So glad you asked. I was just thinking about this the other day, and wrote this script called... wait for it...

"subvirgin"

subvirgin finds virgin subroutines. Well, more accurately it lets you find virgin subroutines by a process of elimination, because it logs each subroutine as its used. You still have to do the work of figuring out which subroutines were not used. OK, so there's some room for improvement there, I admit, but still, it's pretty nifty if I do say so myself. One more caveat: it won't do a great job unless you can, through your own ingenuity and luck, get the code you are examining to run through most of its possible execution paths.

All it does is insert some code at the top of each subroutine, using an appropriately-named subroutine, "insert_instrument()" ... cough. This code calls a small SVGN.pm module that logs the name of each subroutine as it runs.

In case it's not obvious, the main value of this tool would be in situations where you are faced with a large, unfamiliar Perl code base and have been told that some of the code is old, orphaned code that is no longer used, and you want to determine which code is still used and which is not (though for the negatives, it won't be with 100% reliability, unfortunately).

You can add your own code to the SVGN module shown at the bottom, so it could do fancier stuff, like, for example, printing the subroutine's caller and arguments. But for now I'll leave that as an exercise for the reader.

Here's the code. Oh, and it doesn't do anonymous or nested subroutines at the moment... sorry about that. Should be easy to fix.

**** WARNING: This has not been extensively tested, and more to the point, IT WILL DO A DESTRUCTIVE UPDATE OF ALL PERL FILES IT FINDS IN THE CURRENT DIRECTORY so use it carefully and work on a copy of your code. ***

#!/usr/bin/perl

#
# subvirgin v0.42
#

use strict;
use warnings;


# TODO: matches, but does not capture, prototypes and attributes
#       determine whether this matters, and, if so, add it


die "\n\nWARNING: this program has not been extensively tested, and it
+ will do a destructive update of any .pl, .pm, and .cgi files it find
+s in the current directory. If you are sure you want to run this prog
+ram, work in a special directory containing an extra copy of the perl
+ files you want to instrument, and remove this line before running th
+e program.\n\n";


opendir(DIR, ".") or die "error: $!";
my @files = grep(!/^(subvirgin\.pl|SVGN\.pm)$/,
                 grep(/\.(?:pl|cgi|pm)$/, readdir(DIR)));
closedir(DIR);

foreach my $file (@files) {
    insert_instrument($file);
}

sub insert_instrument {
    my $file = shift;
    my ($mode,$atime,$mtime) = (stat($file))[2,8,9];
    open(IN, $file) or die "error: $!";
    open(OUT, ">$file.tmp") or die "error: $!";
    my $sub_name = '';
    my $at_start = 1;
    my $package = '';
    while (my $line=<IN>) {
        chomp($line);
        next if ($line =~ /^use SVGN;$/);
        if ($line =~ m{^package\s+(.*);\s*$}) {
            $package = $1 . '::';
            print OUT "$line\n";
        }
        elsif ($line =~ m{^\s*1;\s*$}) {
            $package = '';
            print OUT "$line\n";
        }
        elsif ($line =~ /^\s*(#.*)?$/) {
            print OUT "$line\n";
        }
        elsif ($at_start) {
            print OUT "use SVGN;\n";
            print OUT "$line\n";
            $at_start = 0;
        }
        elsif ($sub_name ne '') {
            next if ($line =~ /^\s*SVGN::doit/);
            my $indent = "";
            if ($line =~ /^(\s*)/) {
                $indent = $1;
            }
            print OUT "${indent}SVGN::doit(\"$package$sub_name\");\n";
            print OUT "$line\n";
            $sub_name = '';
        }
        elsif ($line =~
               m{^
                 (                    # everything up to open curly
                 (\s*)                # optional leading space
                 sub\s+               # sub declaration
                 (\S+)\s*             # name of subroutine
                 (?:\([^)]*?\)\s*)?   # optional prototype
                 (?:\s*:\s*\S+\s*)?   # optional attributes
                 \{                   # open subroutine block
                 )
                 \s*                  # nuke any space before capture
                 (\S.*)?              # catch one-line subroutines
                 $}x
              ) {
            $sub_name = $3;
            if (defined($4) && $4 ne '') { # for one-line subroutines
              my $body = $4;
              $line = "$1 SVGN::doit(\"$package$sub_name\"); $4";
              print OUT "$line\n";
              $sub_name = '';
            }
            else {
              print OUT "$line\n";
            }
        }
        elsif ($line !~ m{^(\s*)SVGN::doit\(\S+\)$}) {
            print OUT "$line\n";
        }
    }
    close(OUT);
    unlink($file);
    rename($file, "$file.old");
    rename("$file.tmp", $file);
    utime $atime, $mtime, $file;
    chmod $mode & 07777, $file;
}
[download]

And here's the skeleton for SVGN.pm

package SVGN;

use strict;

sub doit {
    my $name = shift;
    open(LOG, ">>log.txt") or die "error: $!";
    print LOG "$name\n";
    close(LOG);
}

1;
[download]