http://www.perlmonks.org?node_id=83204

   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: