#!/usr/bin/env perl

# ptags: create a tags file for perl scripts

use warnings;
use strict;
use Config;
use File::Find;
use Getopt::Attribute;


our $VERSION = '0.08';


our @lib     : Getopt(lib=s);
our $perllib : Getopt(perllib);  # whether to include perl's installed modules
our $win     : Getopt(win);      # whether to use backslashes in file names
our $use     : Getopt(use);  # whether to 'use' the package; might gen more tags
our $verbose : Getopt(verbose|v);
our $exclude_file : Getopt(exclude=s); # containts tag name patterns to exclude

my @tag;

sub make_tag (@);

push @lib, $Config{sitelibexp}, $Config{privlibexp} if $perllib;
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";
}


# 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;


# Utility function for use with custom ptags. For example,
#    # ptags: combine([qw/get_ set_/], [qw/person domain/], '_object')
# would generate ptags at that location for
#    get_person_object
#    set_person_object
#    get_domain_object
#    set_domain_object

sub combine {
    my @rest = @_;
    my $first = '';
    while (defined(my $part = shift @rest)) {
        if (ref $part eq 'ARRAY') {
            return map { combine($first, $_, @rest) } @$part;
        } else {
            $first .= $part;
        }
    }
    $first;
}


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


sub _find {
    if (-d && (/^(t|blib)$/ || -e '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 = $package = $2;
        $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/:/-/;
    }


    # for autogenerated methods, extract the relevant definitions and use them
    # in a dummy package, then see which methods have been generated. Make
    # ptags for those methods.

    while ($text =~
            /^((use +(?:\w+(?:::\w+)*)::MethodMaker(::\w+)*).*?;)/gsmo) {

        my ($code, $find) = ($1, $2);
        $verbose && warn ">>> eval MethodMaker code\n";
        our $counter;
        my $pkg = sprintf 'methodmaker_test_%s', ++$counter;
        eval "package $pkg; $code";

        if ($@) {
            # This is a very crude extraction of the use() statement.
            #
            # Errors can happen if you use semicolons within your methodmaker
            # definition, or constants that aren't available when we just eval
            # the 'use methodmaker' code.

            $verbose && warn
                "file [$File::Find::name]: can't eval [$code]: [$@]\n";
            next;
        } else {
            no strict 'refs';
            make_tag "$_\t$filename\t?^$find\\>\n" for
                grep { /^(?!(_|isa|stderr|stdin|stdout)$)[a-z]\w*$/ }
                keys %{ $pkg . '::' };
        }
    }

    # 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) {

        # 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;
            eval "use $package";
        }

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


__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

