Vim::Tag - Generate perl tags for vim

    $ ptags --use ~/code/coderepos -o ~/.ptags

    set tags+=~/.ptags

    :ta Foo::Bar
    :ta my_subroutine

    cpanm Bash::Completion::Plugins::VimTag
    alias vit='vi -t'

    $ vit Foo::Bar
    $ vit my_subroutine

    package Foo::Bar;

    $::PTAGS && $::PTAGS->add_tag($tag, $filename, $line);

    #!/usr/bin/env perl
    use warnings;
    use strict;
    use base qw(Vim::Tag);
    main->new->run;

    /.../perl-5.12.2/lib/5.12.2/darwin-2level
    /.../perl-5.12.2/lib/5.12.2

use 5.010;
use strict;
use warnings;

package Vim::Tag;
BEGIN {
  $Vim::Tag::VERSION = '1.110690';
}

# ABSTRACT: Generate perl tags for vim
use File::Find;
use File::Slurp;
use Hash::Rename;
use UNIVERSAL::require;
use Vim::Tag::Null;
use parent qw(Class::Accessor::Constructor Getopt::Inherited);
__PACKAGE__->mk_constructor->mk_scalar_accessors(qw(tags))
  ->mk_array_accessors(qw(libs))
  ->mk_hash_accessors(qw(is_fake_package filename_for has_super_class));
use constant DEFAULTS => (tags => {});
use constant GETOPT => (qw(use=s out|o=s first|f libs|l=s@));
use constant GETOPT_DEFAULTS => (verbose => 0, out => '-');

# --use: whether to 'use' the package; might gen more tags. The value is the
# path prefix under which to use() modules.
#
# --first: if set, tags are only generated the first time each package is
# seen. Seeing a package twice could happen if you have a development version
# but have it installed as well. Use this option if you index the development
# directory first and only want to see that version.
sub run {
    my $self = shift;
    $self->init;
    $self->do_getopt;
    $self->determine_libs;
    exit unless $self->libs;
    $self->generate_tags;
    $self->add_SUPER_tags;
    $self->add_yaml_marshall_tags;
    $self->finalize;
    $self->write_tags;
}
sub init { }

sub finalize {
    my $self = shift;

    # avoid Test::Base doing END{} processing, which, in the absence of real
    # tests, would produce annoying error messages.
    Test::Builder::plan(1) if $Test::Base::VERSION;
}

sub setup_fake_package {
    my ($self, @packages) = @_;
    for my $package (@packages) {
        (my $file = "$package.pm") =~ s!::!/!g;
        $INC{$file} = 'DUMMY';
        no strict 'refs';
        @{ $package . '::ISA' } = qw(Vim::Tag::Null);
        $self->is_fake_package($package, 1);
    }
    $self;
}

sub determine_libs {
    my $self = shift;

    our @libs = grep { !/^\.+$/ } grep { ref ne 'CODE' } @INC;
    {
        no warnings 'once';
        unshift @libs => @Devel::SearchINC::PATHS;
    }
    if (defined $self->opt('libs')) {
        unshift @libs => @{ $self->opt('libs') };
    }

    my @keep_inc;
    for my $candidate (sort { length($a) <=> length($b) } @libs) {
        next if grep { index($candidate, $_) == 0 } @keep_inc;
        push @keep_inc => $candidate;
    }
    $self->libs(@keep_inc);
}

sub generate_tags {
    my $self = shift;
    $::PTAGS = $self;
    for ($self->libs) {
        find(
            {   follow => 1,
                wanted => sub {
                    if (-d && /^(bin|t|blib|inc)$/) {
                        return $File::Find::prune = 1;
                    }
                    return unless -f;
                    if (/\.pm$/o) {
                        $self->process_pm_file;
                    } elsif (/\.pod$/o) {
                        $self->process_pod_file;
                    }
                  }
            },
            $_
        );
    }
}

sub write_tags {
    my $self    = shift;
    my %tags    = %{ $self->tags };
    my $outfile = $self->opt('out');
    ## no critic (ProhibitTwoArgOpen)
    open my $fh, ">$outfile" or die "can't open $outfile for writing: $!\n";
    for my $tag (sort keys %tags) {
        printf $fh "%s\t%s\t%s\n", $tag, @$_ for @{ $tags{$tag} };
    }
    close $fh or die "can't close $outfile: $!\n";
}

sub delete_tags_by_pattern {
    my ($self, $pattern) = @_;
    my %tags = %{ $self->tags };
    for my $key (keys %tags) {
        delete $tags{$key} if $key =~ qr/$pattern/;
    }
    $self->tags(\%tags);
}

sub make_tag_aliases {
    my ($self, @rules) = @_;
    my %tags = %{ $self->tags };
    while (my ($search, $replace) = splice @rules, 0, 2) {
        for my $tag (keys %tags) {
            my $alias_tag = $tag;
            eval "\$alias_tag =~ s/$search/$replace/";
            die $@ if $@;
            next if $tag eq $alias_tag;
            $tags{$alias_tag} = $tags{$tag};
        }
    }
    $self->tags(\%tags);
}

sub add_tag {
    my ($self, $tag, $file, $search) = @_;

    # If you derived at the filename via caller(), you might get something
    # like /loader/0x1234567 if the file was loaded via Devel::SearchINC. But
    # it will also have set the correct filename in %INC, so we can find it
    # there. The index() is just an optimization.
    if (   defined($file)
        && index($file, '/loader/0x') == 0
        && $file =~ m!^/loader/0x[0-9a-f]+/(.*)!o) {
        $file = $INC{$1};
    }
    push @{ $self->tags->{$tag} } => [ $file, $search ];
}

sub make_package_tag {
    my ($self, %args) = @_;
    $self->filename_for($args{tag}, $args{filename})
      unless $self->exists_filename_for($args{tag});
    $self->add_tag($args{tag}, $args{filename}, "?^$args{search}\\>");
}

sub process_pm_file {
    my $self     = shift;
    my $text     = read_file($_);
    my $filename = $File::Find::name;
    my $package;
    while ($text =~ /^(package +(\w+(::\w+)*))\s*;/gmo) {
        my ($search, $tag) = ($1, $2);
        our %package_seen;
        return if $package_seen{$tag}++ && $self->opt('first');
        $self->make_package_tag(
            filename => $filename,
            search   => $search,
            tag      => $tag
        );
        $package ||= $tag;    # only remember the first package
    }
    while ($text =~ /^((?:sub|use\s+constant)\s+(\w+(?:::\w+)*))/gmo) {
        $self->add_tag($2, $filename, "?^$1\\>");
    }

    # custom ptags: simple strings
    while ($text =~ /#\s*(ptags:\s*(\w+(::\w+)*))\s*$/gmo) {
        my $tag = do {
            ## no critic (ProhibitNoStrict)
            no strict;
            no warnings;
            eval $2;
        };
        $self->add_tag($tag, $filename, "?^$1\\>");
    }

    # 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
        my @tags = do {
            ## no critic (ProhibitNoStrict)
            no strict;
            no warnings;
            eval $code;
        };
        die $@ if $@;
        $self->add_tag($_, $filename, "?^$search\\>") for @tags;
    }

    # custom ptags: per-file regexes
    my @re;
    while ($text =~ m!#\s*ptags:\s*/(.*)/\s*$!gm) {
        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) {
            $self->add_tag($2, $filename, "?^$1\\>");
        }
    }
    if ($self->opt('use') && index($File::Find::name, $self->opt('use')) == 0) {

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

            # 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;
            local $SIG{__WARN__} = sub {
                my $warning = shift;
                return
                  if index($warning, 'Too late to run INIT block at') != -1;
                return
                  if $warning =~
                      qr/^cannot test anonymous subs .* Test::Class too late/;
                CORE::warn "Warnings during during [${package}->require]:\n";
                CORE::warn($warning);
            };
            $package->require;
            {
                no warnings 'redefine';
                *base::import = $real_base_import;
            }
        }

        # Also determine inheritance and make tags
        no strict 'refs';
        $self->add_tag("subclass--$_", $filename, "?^use base\\>")
          for @{"${package}::ISA"};

        # Remember some data for tags we can't make now; we need the
        # information from all the files.
        $self->has_super_class($package, [ @{"${package}::ISA"} ]);
    }
}

sub process_pod_file {
    my $self     = shift;
    my $text     = read_file($_);
    my $filename = $File::Find::name;
    while ($text =~ /^(=for\s+ptags\s+package +(\w+(::\w+)*))\s*;/gmo) {
        my ($search, $tag) = ($1, $2);
        our %package_seen;
        return if $package_seen{$tag}++ && $self->opt('first');
        $self->make_package_tag(
            filename => $filename,
            search   => $search,
            tag      => $tag
        );
    }
}

# Add those tags that couldn't be added from looking at one file alone.
sub add_SUPER_tags {
    my $self            = shift;
    my %has_super_class = $self->has_super_class;
    while (my ($class, $super_array_ref) = each %has_super_class) {
        for my $super (@{ $super_array_ref || [] }) {
            next if $self->is_fake_package($super);
            unless ($self->exists_filename_for($super)) {
                warn sprintf
                  "class [%s]: can't get filename of superclass [%s]\n",
                  $class, $super;
                next;
            }
            $self->add_tag(
                "superclass--$class",
                $self->filename_for($super),
                "?^package $super\\>"
            );
        }
    }
}

sub add_yaml_marshall_tags {
    my $self = shift;
    return unless defined $YAML::TagClass;
    while (my ($marshall, $package) = each %$YAML::TagClass) {
        $marshall =~ s/\W/-/g;
        my $tag  = "marshall--$marshall";
        my $file = $self->filename_for($package);
        $self->add_tag($tag, $file, 1);
    }
}
1;


__END__