#!/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 finds in the current directory. If you are sure you want to run this program, work in a special directory containing an extra copy of the perl files you want to instrument, and remove this line before running the 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;
}

##</code><code>##

package SVGN;

use strict;

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

1;