#!/usr/bin/env perl
package Ptags::Null;
our $null = bless {}, __PACKAGE__;
sub AUTOLOAD { $null }

package main;

# ptags: create a tags file for perl scripts
use warnings;
use strict;
use Config;
use File::Find;
use File::Find::Upwards;
use File::Slurp;
use Getopt::Attribute;
use UNIVERSAL::require;
our $VERSION = '0.03';

# --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 (@);

# call this subroutine in ~/.ptags_rc.pl to create fake packages that you
# don't want to install - maybe they're needed only on another platform, on
# the production system, need libraries that are impossible or difficult to
# install etc.
our %is_fake_package;

sub setup_fake_package {
    my @packages = @_;
    for my $package (@packages) {
        (my $file = "$package.pm") =~ s!::!/!g;
        $INC{$file} = 'DUMMY';
        no strict 'refs';
        @{ $package . '::ISA' } = qw(Ptags::Null);
        $is_fake_package{$package}++;
    }
}

BEGIN {
    my $rc_file = "$ENV{HOME}/.ptags_rc.pl";
    if (-e $rc_file && -r _) {
        unless (my $return = do $rc_file) {
            die "couldn't parse $rc_file: $@" if $@;
            die "couldn't do $rc_file: $!" unless defined $return;
            die "couldn't run $rc_file" unless $return;
        }
    }
}

# 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 && (/^(bin|t|blib|inc)$/ || file_find_upwards('PTAGS.SKIP'))) {
        $verbose && warn "Skipping directory [$File::Find::name]\n";
        return $File::Find::prune = 1;
    }

    return unless -f;

    if (/\.pm$/) {
        process_pm_file();
    } elsif (/\.pod$/) {
        process_pod_file();
    }
}

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

sub process_pm_file {
    my $text = read_file($_);
    my $filename = get_filename();
    my $package;
    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/:/-/;
        }
    }
    if ($use && index($File::Find::name, $use) == 0) {

        # give modules a chance to output their custom ptags using $::PTAGS
        $verbose && warn ">>> use [$package]\n";
        {

            # localise global variables so that no matter what the module does
            # with them, they will be restored at the end of the block
            #
            # Spiffy messes up base::import(), so we save it here and restore
            # it later.
            local @INC = @INC;

            # %SIG values are undef first time around?
            no warnings 'uninitialized';
            local %SIG = %SIG;
            require base unless defined $INC{'base.pm'};
            my $real_base_import = \&base::import;

            # To suppress certain warnings, we capture STDERR, then filter
            use IO::Capture::Stderr;
            my $capture = IO::Capture::Stderr->new;
            $capture->start;
            $package->require;
            my $error = $@;
            $capture->stop;

            # now print only non-suppressed warnings
            my @warnings =
              grep { !/^cannot test anonymous subs .* Test::Class too late/ }
              grep { !/Too late to run INIT block at/ } $capture->read;
            if (@warnings) {
                warn "Warnings during during [${package}->require]:\n";
                warn $_ for @warnings;
            }
            if ($error) {
                my $msg = "Error during [${package}->require]:";

                # Make some common error messages more legible
                if ($@ =~ /can't open (.*?): No such file or directory/) {
                    warn "$msg Can't find $1\n";
                } else {

                    # fallback error message
                    warn "$msg $@";
                }
            }
            {
                no warnings 'redefine';
                *base::import = $real_base_import;
            }
        }

        # 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"} ];
    }
}

sub process_pod_file {
    my $text = read_file($_);
    my $filename = get_filename();
    my $package;
    while ($text =~ /^(=for\s+ptags\s+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/:/-/;
    }
}

# 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 || [] }) {
            next if $is_fake_package{$super};
            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);
        }
    }
}
