Beefy Boxes and Bandwidth Generously Provided by pair Networks DiBona
The stupid question is the question not asked
 
PerlMonks  

Perl Tags generator

by bikeNomad (Priest)
on May 25, 2001 at 23:19 UTC ( #83388=sourcecode: print w/ replies, xml ) Need Help??

Category: Utility Scripts
Author/Contact Info bikeNomad Ned Konz <ned@bike-nomad.com>
Description: Perl editor tags generator (like ctags) that uses the debugger hooks to avoid parsing Perl itself.

update: avoid getting into long loops when the line number happens to be 65535 because of (apparently) a Perl bug

#!/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;
}

Comment on Perl Tags generator
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://83388]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (6)
As of 2014-04-19 00:44 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (474 votes), past polls