Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

comment on

( [id://3333] : superdoc . print w/replies, xml ) Need Help??
    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: 
    

In reply to Perl tags generator using the Debugger by bikeNomad

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.