1: #!/usr/bin/perl -w 2: # Perl tags generator that uses the debugger hooks 3: # Ned Konz <ned@bike-nomad.com> 4: # $Revision: 1.7 $ 5: # TODO 6: # * figure out a way to avoid running BEGIN blocks 7: 8: use strict; 9: use File::Find; 10: use Getopt::Std; 11: 12: sub usage 13: { 14: print <<EOF; 15: usage: $0 [-R] [-f outfile] [-a] [-L listfile] [file [...]] 16: -R recurse into dirs 17: -f outfile specify output file (default=tags) 18: -a append to output file 19: -L listfile get filenames/options from listfile 20: -h get this help message 21: -v list filenames to stderr 22: EOF 23: exit(shift()); 24: } 25: 26: # process cmdline options 27: my %opts; 28: getopts('Rf:aL:hv', \%opts) || usage(1); 29: usage(0) if defined($opts{'h'}); 30: my $outfile = defined($opts{'f'}) ? $opts{'f'} : 'tags'; 31: if (defined($opts{'L'})) 32: { 33: open(LFILE, $opts{'L'}); 34: map { chomp ; unshift(@ARGV, $_) } <LFILE>; 35: close(LFILE); 36: } 37: 38: # now filenames are in @ARGV 39: push(@ARGV, '.') if ($#ARGV < 0); 40: 41: my @files; 42: my $top; 43: my $nDirs; 44: 45: sub wanted { 46: -f _ && /^.*\.p[lm]\z/si && push(@files, $File::Find::name); 47: $File::Find::prune = !defined($opts{'R'}) && $nDirs > 1; 48: -d _ && $nDirs++; 49: } 50: 51: # process directories 52: foreach $top (@ARGV) 53: { 54: $nDirs = 0; 55: File::Find::find({wanted => \&wanted}, $top); 56: } 57: 58: # Load debugger into environment var $PERL5DB 59: { 60: local $/ = undef; 61: my $debugger = <DATA>; 62: $debugger =~ s/\s*#.*$//gm; # get around bugs in PERL5 debugger code 63: $debugger =~ s/\s+/ /gms; 64: $ENV{PERL5DB} = $debugger; 65: } 66: 67: # Clear outfile if not appending 68: if (!defined($opts{'a'})) 69: { 70: open(OUTFILE,">$outfile") or die "can't open $outfile for write: $!\n"; 71: close(OUTFILE); 72: } 73: 74: # pass output file name in env var 75: $ENV{PLTAGS_OUTFILE} = ">>$outfile"; 76: 77: # Spawn Perl for each file 78: foreach my $fileName (map { $_ =~ s{^\./}{}; $_ } @files) 79: { 80: print STDERR "$fileName\n" if $opts{'v'}; 81: system("$^X -d $fileName"); 82: } 83: 84: # Perl-only sort -u 85: open(OUTFILE, $outfile) or die "can't open $outfile for read: $!\n"; 86: my @lines = <OUTFILE>; 87: close(OUTFILE); 88: @lines = sort @lines; 89: open(OUTFILE, ">$outfile") or die "can't open $outfile for write: $!\n"; 90: my $lastLine = ''; 91: print OUTFILE grep { $_ ne $lastLine and $lastLine = $_ } @lines; 92: close(OUTFILE); 93: 94: # End of main program; debugger text follows 95: 96: __DATA__ 97: 98: # remove those annoying error messages 99: BEGIN { close STDOUT; close STDERR } 100: 101: sub DB::DB 102: { 103: sub DB::keySort 104: { 105: my ($aPackage, $aTag) = $a =~ m{(.*)::(\w+)}; 106: my ($bPackage, $bTag) = $b =~ m{(.*)::(\w+)}; 107: $aPackage cmp $bPackage 108: or $aTag eq 'BEGIN' ? -1 : 0 109: or $bTag eq 'BEGIN' ? 1 : 0 110: or $aTag cmp $bTag; 111: } 112: 113: open(PLTAGS_OUTFILE, $ENV{PLTAGS_OUTFILE}); 114: 115: # from perldebguts: 116: # A hash "%DB::sub" is maintained, whose keys are subroutine names and 117: # whose values have the form "filename:startline-endline". "filename" has 118: # the form "(eval 34)" for subroutines defined inside "eval"s, or 119: # "(re_eval 19)" for those within regex code assertions. 120: 121: foreach my $key (sort DB::keySort keys(%DB::sub)) 122: { 123: my ($fileName, $lineNumber) = $DB::sub{$key} =~ m{(.+):(\d+)-\d+}; 124: my ($package, $tag) = $key =~ m{(.*)::(\w+)}; 125: next if $package eq 'DB' || $tag =~ /^__ANON__/ || $fileName =~ '^\(\D+\d+\)$'; 126: my $lines = \@{'main::_<' . $fileName}; 127: my $line = $$lines[$lineNumber]; 128: # back up to a recognizable line 129: while ($lineNumber > 1 130: and (($tag eq 'BEGIN' and $line !~ m{\bpackage\s+} ) 131: or ($tag ne 'main' and $tag ne 'BEGIN' and $line !~ m{\b$tag\b} ))) 132: { 133: $lineNumber--; 134: $line = $$lines[$lineNumber]; 135: redo if !$line; # pod lines are undef'd 136: } 137: chomp($line); 138: $line =~ s{[\/^\$]}{\\$&}g; 139: $key =~ s/^main:://; # hide main package name 140: $key =~ s/(?:::)?BEGIN$//; 141: next if ! $key; 142: print PLTAGS_OUTFILE "$key\t$fileName\t/^$line\$/\n"; 143: } 144: exit; 145: } 146:
Back to
Craft