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