#!/usr/bin/env perl

# ptags: create a tags file for perl scripts

use warnings;
use strict;
use Config;
use File::Find;
use File::Find::Upwards ':all';
use Getopt::Attribute;


our $VERSION = '0.15';


# --use: whether to 'use' the package; might gen more tags. The value is the
# path prefix under which to use() modules.

our $use          : Getopt(use=s);
our $win          : Getopt(win);      # whether to use backslashes in file names
our $verbose      : Getopt(verbose|v+);
our $exclude_file : Getopt(exclude=s); # contains tag name patterns to exclude

$verbose = 0 unless defined $verbose;

my @tag;

sub make_tag (@);

# Go through libs in reverse @INC order. I assume that custom libs will be
# unshif()ed onto @INC so they come first. That means that the main perl libs
# will come last. By going through the libs in reverse order, a local version
# of a module will take precedence over a module that's installed system-wide.
# This is useful if you have a module both under development in your $PROJROOT
# as well as installed system-wide; in this case you most likely want tags to
# point to the locally installed version.
#
# On the other hand, it might not matter anyway because if you sort the ptags
# file, the order of equal tags will depend on the sort order of the path. But
# see the ptags_sort program.

our @lib = grep { !/^\.+$/ } grep { ref ne 'CODE' } reverse @INC;
{
    no warnings 'once';
    unshift @lib => @Devel::SearchINC::PATHS;
}

exit unless @lib;

local $/;

my $use_ptags = '';
my $oldout;
if ($use) {
    no warnings 'once';
    $::PTAGS++;
    open $oldout, ">&STDOUT" or die "can't dup STDOUT: $!\n";
    close STDOUT;
    open STDOUT, '>', \$use_ptags or die "can't redirect STDOUT: $!\n";
}

for (@lib) {
    warn "Indexing $_\n";
    find(\&_find, $_);
}

if ($use) {
    open STDOUT, ">&", $oldout or die "can't dup \$oldout: $!\n";
    make_tag map { "$_\n" } split /\n/ => $use_ptags if $use_ptags;
}

# process exclude patterns
if ($exclude_file && -f $exclude_file) {
    warn "Processing exclude patterns\n";
    open my $fh, $exclude_file or die "can't open $exclude_file: $!\n";
    while (defined(my $pattern = <$fh>)) {
        local $/ = "\n";
        chomp($pattern);
        @tag = grep { $_ !~ qr/$pattern/o } @tag;
    }
    close $fh or die "can't close $exclude_file: $!\n";
}


add_overall_tags();


# sort and filter out anything that doesn't look like a ptag; might have been
# an error message that slipped in when use()ing a package, or from some eval
# block.

print for grep { /^[^\t]+\t[^\t]+\t[^\t]+\n$/ } sort @tag;


sub make_tag (@) {
    for my $def (@_) {
        $verbose >= 2 && warn $def;
        push @tag => $def;
    }
}


sub _find {
    # if (-d && (/^(t|blib)$/ || -e 'PTAGS.SKIP')) {
    if (-d && (/^(t|blib)$/ || file_find_upwards('PTAGS.SKIP') )) {
        $verbose && warn "Skipping directory [$File::Find::name]\n";
        return $File::Find::prune = 1;
    }

    return unless -f && /\.pm$/;
    open FH, $_ or die "can't open $_: $!\n";
    my $text = <FH>;

    my $package;

    my $filename = $File::Find::name;
    $filename =~ y!/!\\! if $win;
    $verbose && warn ">>> processing file [$filename]\n";

    while ($text =~ /^(package +(\w+(::\w+)*))\s*;/gmo) {
        my $search = $1;
        my $tag = $2;
        $package ||= $tag;  # only remember the first package

        our %filename_for;
        $filename_for{$tag} = $filename;

        $verbose && warn ">>> package [$package]\n";
        do { make_tag "$tag\t$filename\t?^$search\\>\n" }
            while $tag =~ y/:/-/;
    }

    # only include __TEST__ tags if we could determine the package name
    if ($package) {
        # support vimrc definitions to switch between Foo.pm and Foo_TEST.pm.
        #
        # __TEST__Foo.pm      -> Foo_TEST.pm
        # __TEST__Foo_TEST.pm -> Foo.pm

        my $other_filename;
        if ($filename =~ /_TEST\.pm$/) {
            ($other_filename = $filename) =~ s/_TEST\.pm$/.pm/;
        } else {
            ($other_filename = $filename) =~ s/\.pm$/_TEST.pm/;
        }

        make_tag "__TEST__$package\t$other_filename\t1\n";
    }

    while ($text =~ /^(sub +(\w+(::\w+)*))\s*[:{\(#]/gmo) {
        my $tag = $2;
        $verbose && warn ">>> sub [$tag]\n";
        do { make_tag "$tag\t$filename\t?^$1\\>\n" }
            while $tag =~ y/:/-/;
    }

    while ($text =~ /^(use +constant\s+(\w+(::\w+)*))\s*=>/gmo) {
        my $tag = $2;
        $verbose && warn ">>> constant [$tag]\n";
        do { make_tag "$tag\t$filename\t?^$1\\>\n" }
            while $tag =~ y/:/-/;
    }


    # custom ptags: simple strings
    while ($text =~ /#\s*(ptags:\s*(\w+(::\w+)*))\s*$/gmo) {
        $verbose && warn ">>> custom ptag [$2]\n";
        my $tag = do { no strict; no warnings; eval $2 };
        do { make_tag "$tag\t$filename\t?$1\\>\n" }
            while $tag =~ y/:/-/;
    }


    # Custom ptags with code. The search name must be unique within file the
    # code ptag is defined in. Can't use the code as the ptags search pattern,
    # as it probably contains characters the vim regex engine considers
    # meta-characters ('[]$' etc).

    while ($text =~ /#\s*ptags-code:\s*([\w:]+)\s*(.*)/gmo) {
        my ($search, $code) = ($1, $2);  # assign in case the code uses regexes

        $verbose && warn ">>> ptags-code [$code]\n";
        my @tags = do { no strict; no warnings; eval $code };
        die $@ if $@;
        for my $tag (@tags) {
            do { make_tag "$tag\t$filename\t?$search\\>\n" }
                while $tag =~ y/:/-/;
        }
    }


    # custom ptags: per-file regexes
    my @re;
    while ($text =~ m!#\s*ptags:\s*/(.*)/\s*$!gm) {
        $verbose && warn ">>> ptags-regex [$1]\n";
        push @re => qr/$1/;
    }
    for my $re (@re) {

        # in theory we could nest this loop below the loop given above but
        # because they're iterating over the same string, funny things happen
        # when the regexes interfere with each other.

        while ($text =~ /$re/gm) { 
            my $tag = $2;
            do { make_tag "$tag\t$filename\t?$1\\>\n" }
                while $tag =~ y/:/-/;
        }
        close FH;
    }

    if ($use && index($File::Find::name, $use) == 0) {

        # give modules a chance to output their custom ptags using $::PTAGS

        $verbose && warn ">>> use [$package]\n";
        {
            local $SIG{__WARN__} = sub {
                my $warning = shift;
                return if $warning =~ /Too late to run INIT block at/;
                CORE::warn($warning);
            };

            no warnings;
            
            # localise global variables so that no matter what the module does
            # with them, they will be restored at the end of the block

            local @INC = @INC;

            my $eval = "use $package";
            eval $eval;
            warn "can't eval [$eval]: $@" if $@;
        }

        # Also determine inheritance and make tags
        $verbose && warn ">>> inheritance for [$package]\n";
        no strict 'refs';
        make_tag "__SUBCLASS__$_\t$filename\t?^use base\\>\n"
            for @{"${package}::ISA"};

        # Remember some data for tags we can't make now; we need the 
        # information from all the files.

        our %has_super_class;
        $has_super_class{$package} = [ @{"${package}::ISA"} ];
    }
}


# Add those tags that couldn't be added from looking at one file alone.

sub add_overall_tags {
    our (%has_super_class, %filename_for);
    while (my ($class, $super_array_ref) = each %has_super_class) {

        for my $super (@{ $super_array_ref || [] }) {
            unless (defined $filename_for{$super}) {
                warn sprintf
                    "class [%s]: can't get filename of superclass [%s]\n",
                    $class, $super;
                next;
            }
            make_tag 
                sprintf("__SUPER__%s\t%s\t?^package %s\\>\n",
                    $class, $filename_for{$super}, $super);
        }
    }
}



__END__

=head1 NAME

Dist::Joseki - tools for the prolific module author

=head1 SYNOPSIS

None yet (see below).

=head1 DESCRIPTION

None yet. This is an early release; fully functional, but undocumented. The
next release will have more documentation.

=cut

