Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Perl tags generator using the Debugger

by bikeNomad (Priest)
on May 25, 2001 at 05:27 UTC ( #83204=perlcraft: print w/ replies, xml ) Need Help??

   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: 

Comment on Perl tags generator using the Debugger
Download Code

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others studying the Monastery: (9)
As of 2014-08-22 14:47 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (158 votes), past polls