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: