#!/usr/bin/perl -w
# Perl tags generator that uses the debugger hooks
# Ned Konz <ned@bike-nomad.com>
# $Revision: 1.8 $
# TODO
# * figure out a way to avoid running BEGIN blocks

use strict;
use File::Find;
use Getopt::Std;

sub usage
{
    print <<EOF;
usage: $0 [-R] [-f outfile] [-a] [-L listfile] [file [...]]
-R           recurse into dirs
-f outfile   specify output file (default=tags)
-a           append to output file
-L listfile  get filenames/options from listfile
-h           get this help message
-v           list filenames to stderr
EOF
    exit(shift());
}

# process cmdline options
my %opts;
getopts('Rf:aL:hv', \%opts) || usage(1);
usage(0) if defined($opts{'h'});
my $outfile = defined($opts{'f'}) ? $opts{'f'} : 'tags';
if (defined($opts{'L'}))
{
    open(LFILE, $opts{'L'});
    map { chomp ; unshift(@ARGV, $_) } <LFILE>;
    close(LFILE);
}

# now filenames are in @ARGV
push(@ARGV, '.') if ($#ARGV < 0);

my @files;
my $top;
my $nDirs;

sub wanted {
    -f _ && /^.*\.p[lm]\z/si && push(@files, $File::Find::name);
    $File::Find::prune = !defined($opts{'R'}) && $nDirs > 1;
    -d _ && $nDirs++;
}

# process directories
foreach $top (@ARGV)
{
    $nDirs = 0;
    File::Find::find({wanted => \&wanted}, $top);
}

# Load debugger into environment var $PERL5DB
{
    local $/ = undef;
    my $debugger = <DATA>;
    $debugger =~ s/\s*#.*$//gm;    # get around bugs in PERL5 debugger
+ code
    $debugger =~ s/\s+/ /gms;
    $ENV{PERL5DB} = $debugger;
}

# Clear outfile if not appending
if (!defined($opts{'a'}))
{
    open(OUTFILE,">$outfile") or die "can't open $outfile for write: $
+!\n";
    close(OUTFILE);
}

# pass output file name in env var
$ENV{PLTAGS_OUTFILE} = ">>$outfile";

# Spawn Perl for each file
foreach my $fileName (map { $_ =~ s{^\./}{}; $_ } @files)
{
    print STDERR "$fileName\n" if $opts{'v'};
    system("$^X -d $fileName");
}

# Perl-only sort -u
open(OUTFILE, $outfile) or die "can't open $outfile for read: $!\n";
my @lines = <OUTFILE>;
close(OUTFILE);
@lines = sort @lines;
open(OUTFILE, ">$outfile") or die "can't open $outfile for write: $!\n
+";
my $lastLine = '';
print OUTFILE grep { $_ ne $lastLine and $lastLine = $_ } @lines;
close(OUTFILE);

# End of main program; debugger text follows

__DATA__

# remove those annoying error messages
# BEGIN { close STDOUT; close STDERR }

sub DB::DB
{
    sub DB::keySort
    {
        my ($aPackage, $aTag) = $a =~ m{(.*)::(\w+)};
        my ($bPackage, $bTag) = $b =~ m{(.*)::(\w+)};
        $aPackage cmp $bPackage
        or $aTag eq 'BEGIN' ? -1 : 0
        or $bTag eq 'BEGIN' ? 1 : 0
        or $aTag cmp $bTag;
    }

    open(PLTAGS_OUTFILE, $ENV{PLTAGS_OUTFILE});

    # from perldebguts:
    # A hash "%DB::sub" is maintained, whose keys are subroutine names
+ and
    # whose values have the form "filename:startline-endline".  "filen
+ame" has
    # the form "(eval 34)" for subroutines defined inside "eval"s, or
    # "(re_eval 19)" for those within regex code assertions.

    foreach my $key (sort DB::keySort keys(%DB::sub))
    {
        my ($fileName, $lineNumber) = $DB::sub{$key} =~ m{(.+):(\d+)-\
+d+};
        my ($package, $tag) = $key =~ m{(.*)::(\w+)};
        next if $package eq 'DB' || $tag =~ /^__ANON__/ || $fileName =
+~ '^\(\D+\d+\)$';
        next if ($lineNumber <= 0 || $lineNumber == 65535);
        my $lines = \@{'main::_<' . $fileName};
        my $line = $$lines[$lineNumber];
        # back up to a recognizable line
        while ($lineNumber > 1
            and (($tag eq 'BEGIN' and $line !~ m{\bpackage\s+} )
            or ($tag ne 'main' and $tag ne 'BEGIN' and $line !~ m{\b$t
+ag\b} )))
        {
                $lineNumber--;
                $line = $$lines[$lineNumber];
                redo if !$line && $lineNumber > 0; # pod lines are und
+ef'd
        }
        chomp($line);
        $line =~ s{[\/^\$]}{\\$&}g;
        $key =~ s/^main:://;    # hide main package name
        $key =~ s/(?:::)?BEGIN$//;
        next if ! $key;
        print PLTAGS_OUTFILE "$key\t$fileName\t/^$line\$/\n";
        print PLTAGS_OUTFILE "$tag\t$fileName\t/^$line\$/\n";
    }
    exit;
}
[download]