sub foo { print STDERR "Entering sub foo(@_)\n"; # Do something print STDERR "Exiting sub foo: return value $bar\n"; return $bar; } #### #!/usr/bin/perl -w # usage: $0 filename [optional output file] # If the output file is not specified, it will print to STDOUT use strict; my $outp; open FILE, $ARGV[0] or die "A grim and horrible death: $!"; if ( defined( $ARGV[1] ) ) { open OUTP, ">$ARGV[1]" or die "Couldn't write: $!"; $outp = \*OUTP; } else { $outp = \*STDOUT; } my ( %calls, $name, @context ); #--- # First parsing phase is to try to gather all the return codes together, # keyed by the function name #--- while ( ) { next if /^\s*#/; next if /^\s*$/; last if /__END__/; $name = $1 if /^sub (\w+)/; #--- # Push the context and get next line if possible #--- if ( /^\s*return (\$?[\w->:]+) (if .+)[;{]$/ || /^\s*return (\$?[\w->:]+) (unless .+)[;{]$/ ) { my ( $code, $context ) = ( $1, $2 ); chomp $context; $context =~ s/^\s+//; push @{$calls{$name}{$code}}, $context; next; } if ( /(.+){$/ ) { chomp; s/^\s+//; push @context, $_ } pop @context if ( /}$/ ); push(@{$calls{$name}{$1}}, $context[-1]),next if ( /\s*return (\$?[\w->:{}]+ )/ ); } close FILE; for my $name ( sort keys %calls ) { for my $rc ( sort keys %{$calls{$name}} ) { print $outp "$rc when:\n\t"; local $" = "\n\t"; print $outp "@{$calls{$name}{$rc}}\n"; } } #### #!/usr/bin/perl -w use strict; die "$0 ..." unless @ARGV > 1; my %keyword = (); my ( $source, @targets ) = @ARGV; my $package = ''; #--- # Try to extract the keywords, precompile the regex and store #--- open SRC, $source or die "Couldn't open $source : $!"; while( ) { $package = $1 if ( ! $package && /^package\s+(.+);/ ); next unless ( /^sub\s+(.+){\s*$/ ); my $name; $name = $1; next if ( substr($name,0,1) eq "_" ); $name =~ s/\s+$//; $keyword{$name} = qr/([\w:{}]+)->$name/; } close SRC; for my $file ( @targets ) { my ( $line ); open FILE, $file or die "Couldn't open $file : $!"; LINE: while( $line = ) { next LINE if ( $line =~ /^\s*#/ || $line =~ /^\s*$/ ); last LINE if $line =~ /__END__/; for ( keys %keyword ) { my $regex = $keyword{$_}; if ( $line =~ /$regex/ ) { my $starts_at = $.; my $lpack = $1 || ''; next LINE if ( $file eq $source ) && ( $line =~ /^sub/ ); next LINE if ( $line =~ /Usage/ ); next LINE if ( $lpack =~ /::/ && $lpack ne $package ); while( $line !~ /;/ && ! eof(FILE) ) { $line .= ; next LINE if $line =~ /^EOF/m; } $line =~ s/^\s*//; printf "%s (%d) %s", uc $file, $starts_at, $line; next LINE; } } } #LINE close FILE; }