InfoMagic Source Code 1993 July/THE_SOURCE_CODE_CD_ROM.iso/languages/perl/scripts-convex/profiling/perlpf.pl

Perl Script | 1993-07-14 | 4.9 KB | 209 lines

#! /HOME/waynet/bin/perl
#
#    @(#)perlpf    1.0 (waynet@sun) 12/14/88
#
# Author:
#     Wayne Thompson
#
# Description:
#     Perlpf is a profiler for perl scripts. The profile is sent to stdout.
#     Perlpf is blatantly based on perldb.
#
# Options:
#     -o filename - put generated script in filename.
#
# Files:
#     /tmp/ppf$$     i/o>    default file for temporary generated script.
#
# Diagnostics:
#
# Dependencies:
#
# Bugs:
#

$tmp = "/tmp/ppf$$";        # default temporary file, -o overrides.

# parse any switches

while ($ARGV[0] =~ /^-/) {
    $_ = shift;
    /^-o$/ && ($tmp = shift,next);
    die "Unrecognized switch: $_";
}

$filename = shift;
die "Usage: perlpf [-o output] scriptname arguments" unless $filename;

open(script,$filename) || die "Can't find $filename";

open(tmp, ">$tmp") || die "Can't make temp script";

$perl = '/usr/bin/perl';
$init = 1;
$state = 'statement';

# now translate script to contain PF calls at the appropriate places

while (<script>) {
    chop;
    if ($. == 1) {
    if (/^#! *([^ \t]*) (-[^ \t]*)/) {
        $perl = $1;
        $switch = $2;
    }
    elsif (/^#! *([^ \t]*)/) {
        $perl = $1;
    }
    }
    s/ *$//;
    push(@script,$_);        # remember line for PFinit
    $line = $_;
    next if /^$/;        # blank lines are uninteresting
    next if /^[ \t]*#/;        # likewise comment lines
    if ($init) {
    print tmp "do PFinit($.);"; $init = '';
    }
    if ($inform) {        # skip formats
    if (/^\.$/) {
        $inform = '';
        $state = 'statement';
    }
    next;
    }
    if (/^[ \t]*format /) {
    $inform++;
    next;
    }
    if ($state eq 'statement' &&
      !/^[ \t]*}|^[ \t]*else|^[ \t]*continue|^[ \t]*elsif/) {
    if (s/^([ \t]*[A-Za-z_0-9]+:)//) {
        $label = $1;
    }
    else {
        $label = '';
    }
    $line = $label . "do PF($.); " . $_;    # all that work for this line
    }
    else {
    $script[$#script - 1] .= ' ';    # mark line as having continuation
    }
    do parse();                # set $state to correct eol value
}
continue {
    print tmp $line,"\n";
}

# now put out our profiling subroutines.  First the one that's called all over.

print tmp '
do PFend ();

sub PF {
    $PFline=pop(@_);
    $PFcnt[$PFline]++;
}

sub PFinit {
';
print tmp "    \$0 = '$script';\n";
print tmp "    \$PFmax = $.;\n";
print tmp "    unlink '/tmp/ppf$$';\n";        # expected to fail on -o.
for ($i = 1; $#script >= 0; $i++) {
    $_ = shift(@script);
    s/'/\\'/g;
    print tmp "    \$PFline[$i] = '$_';\n";
}
print tmp '}

sub PFend {
    for ($PFi = 1; $PFi <= $PFmax; $PFi++) {
    printf ("%6s\t%s\n", $PFcnt[$PFi], $PFline[$PFi]);
    }
}
';

close tmp;

# prepare to run the new script

unshift(@ARGV,$tmp);
unshift(@ARGV,$switch) if $switch;
unshift(@ARGV,$perl);
exec @ARGV;

# This routine tokenizes one perl line good enough to tell what state we are
# in by the end of the line, so we can tell if the next line should contain
# a call to PF or not.

sub parse {
    until ($_ eq '') {
    $ord = ord($_);
    if ($quoting) {
        if ($quote == $ord) {
        $quoting--;
        }
        s/^.//            if /^[\\]/;
        s/^.//;
        last if $_ eq "\n";
        $state = 'term'        unless $quoting;
        next;
    }
    if ($ord > 64) {
        do quote(ord($1),1), next    if s/^m\b(.)//;
        do quote(ord($1),2), next    if s/^s\b(.)//;
        do quote(ord($1),2), next    if s/^y\b(.)//;
        do quote(ord($1),2), next    if s/^tr\b(.)//;
        do quote($ord,1), next    if s/^`//;
        next            if s/^[A-Za-z_][A-Za-z_0-9]*://;
        $state = 'term', next    if s/^eof\b//;
        $state = 'term', next    if s/^shift\b//;
        $state = 'term', next    if s/^split\b//;
        $state = 'term', next    if s/^tell\b//;
        $state = 'term', next    if s/^write\b//;
        $state = 'operator', next    if s/^[A-Za-z_][A-Za-z_0-9]*//;
        $state = 'operator', next    if s/^[~^|]+//;
        $state = 'statement', next    if s/^{//;
        $state = 'statement', next    if s/^}[ \t]*$//;
        $state = 'statement', next    if s/^}[ \t]*#/#/;
        $state = 'term', next    if s/^}//;
        $state = 'operator', next    if s/^\[//;
        $state = 'term', next    if s/^]//;
        die "Illegal character $_";
    }
    elsif ($ord < 33) {
        next if s/[ \t\n\f]+//;
        die "Illegal character $_";
    }
    else {
        $state = 'statement', next    if s/^;//;
        $state = 'term', next    if s/^\.[0-9eE]+//;
        $state = 'term', next    if s/^[0-9][0-9xaAbBcCddeEfF.]*//;
        $state = 'term', next    if s/^\$[A-Za-z_][A-Za-z_0-9]*//;
        $state = 'term', next    if s/^\$.//;
        $state = 'term', next    if s/^@[A-Za-z_][A-Za-z_0-9]*//;
        $state = 'term', next    if s/^@.//;
        $state = 'term', next    if s/^<[A-Za-z_0-9]*>//;
        next            if s/^\+\+//;
        next            if s/^--//;
        $state = 'operator', next    if s/^[-(!%&*=+:,.<>]//;
        $state = 'term', next    if s/^\)+//;
        do quote($ord,1), next    if s/^'//;
        do quote($ord,1), next    if s/^"//;
        if (s|^[/?]||) {
        if ($state =~ /stat|oper/) {
            $state = 'term';
            do quote($ord,1), next;
        }
        $state = 'operator', next;
        }
        next            if s/^#.*//;
    }
    }
}

sub quote {
    ($quote,$quoting) = @_;
    $state = 'quote';
}