Perl JAL code analyzer

#!/bin/perl

# analyze jal files and write information to a file

%gotcalls = 0;
%functions = 0;
%fstart = 0;
%fend = 0;
%procedures = 0;
%pstart = 0;
%pend = 0;
%calls = 0;
%getsubs = 0;
%lines = 0;
%var = 0;
%const = 0;
$tlines = 0;
foreach (@ARGV) {
if (/-s(.*)/) {
$libdir = $1;
} elsif (/-e(.*)/) {
$excluded .= "$1, ";
} else {
$infile = $_;
}
}

$infile =~ /(.*)\.jal$/;
$outfile = "$1.htm";
$outstruc = $1. "s.htm";
if (! $infile) {
&help();
}
print "analyze $infile\nexclude $excluded";
print "Report to $outfile, structure to $outstruc\n";
if ($libdir) { print "library $libdir\n"; }

open(M, $infile); # die "could not find $infile\n";

# first collect names of all procedures and functions
@files = ($infile);


&get_subs_and_vars($infile, "");

# ok, noW we have all functions and procedures in the system
# go on evaluating...

$proc = "," . join(",", sort keys %procedures) . ",";
$func = "," . join(",", sort keys %functions) . ",";

# start from scratch to see where they were called from

foreach $file (@files) {
&get_calls($file);
}


foreach (sort keys %calls) {
$lcalled{$calls{$_}} .= $_ . ":";
}

&generate_results;


sub get_calls {
# find get calls to functions and procedures
local($file) = @_;
if ($gotcalls{$file}) {
return;
}
$gotcalls{$file} = 1;
local($linenum);
$linenum = 0;
open(C, $file);
print "get calls $file\n";
while ($line = ) {
$linenum++;
next if ($line =~ /^\-\-/);
# one line at the time
if ($line =~ /(.*)--/) {
# get rid of comments
$line = $1;
}
@mainwords = split(' ',$line);
foreach $word (@mainwords) {
if ($word =~ /[a-zA-Z0-9]+/) {
($word) = split('\(', $word);
($word) = split('\)', $word);
if ($word) {
if ($line =~ /procedure $word/i | $line =~ /function $word/i) {
# this is not a call
next;
}
# print "analyze word $word\n";
$pos = sprintf("$file,%06d", $linenum);

if ( $proc =~ /,$word,/i ) {
$calls{"$pos,p"} = $word;
# print "$pos found call to procedure $word\n";
} elsif ($func =~ /,$word,/i) {
$calls{"$pos,f"} = $word;
# print "$pos found call to function $word\n";
} elsif ($var{$word}) {
# print "$pos found var $word\n";
if ($line =~ /$word = /) {
$var{$word} .= ":=$pos";
} else {
$var{$word} .= ":$pos";
}
} elsif ($const{$word}) {
# print "$pos found const $word\n";
if ($line =~ /$word = /) {
$const{$word} .= ":=$pos";
} else {
$const{$word} .= ":$pos";
}
}
}
}
}
}
}

sub get_subs_and_vars {
local($file, $ffile) = @_;
local($proc, $func, $linenum, $line, $nfile, $fhandle, $vars, $type);
$getsubs{$file} = 1;
if ($excluded =~ /$file,/i) {
print "ignore $file\n";
} else {
if (! open($fhandle, $file)) {
if ( open($fhandle,"$libdir/$file") ) {
$file = "$libdir/$file";
} else {
print "file $file not found, called from $ffile\n";
}
}
push(@files, $file);
print "get variables, procedures and functions from $file\n";
$linenum = 0;
$proc = "";
$func = "";
while ($line = <$fhandle>) {
$linenum++;
# get rid of comments
if ($line =~ /^\-\-/) { next; }
if ($line =~ /^(.*) \-\- /) {
$line = $1;
}
if ($line =~ /include (\S+)/) {
# recursive search included files
$nfile = "$1.jal";
if ($getsubs{$nfile} != 1) {
&get_subs_and_vars($nfile, $ffile);
}
} elsif ($line =~ /procedure (\S+)/) {
if ($procedures{$1} ne "" & $procedures{$1} ne $file) {
print "procedure $1 in file $file already defined in";
print " $procedures{$1}\n";
} else {
($proc) = split('\(',$1);
$procedures{$proc} = $file;
$pstart{$proc} = $linenum;
}
} elsif ($line =~ /function (\S+)/) {
if ($functions{$1} ne "" & $functions{$1} ne $file) {
print "function $1 in file $file already defined in";
print " $functions{$1}\n";
} else {
($func) = split('\(',$1);
$functions{$func} = $file;
$fstart{$func} = $linenum;
}
} elsif ($line =~ /end procedure/) {
$pend{$proc} = $linenum;
$proc = "";
} elsif ($line =~ /end function/) {
$fend{$func} = $linenum;
$func = "";
} elsif ($line =~ /var (byte) (.*)/ || $line =~ /var (bit) (.*)/) {
# var byte x, y = 3, z = f( 14 ) -- scratch variables
# var bit l at x : 0
$type = $1;
$vars = $2;
# print $line;
if ($vars =~ /^[\w\d\_]+$/) {
# nothing else on this line
$var{$vars} = "$type $file,$linenum";
} else {
while ($vars) {
if ($vars =~ /([\w\d\_]+)[^w]+(.*)/ ) {
$var{$1} = "$type $file,$linenum";
$vars = $2;
if ($vars =~ /^at [\S]+\s+?:\s+?\d+ (.*)/) {
$vars = $1;
}
} else {
$var{$vars} = "$type: $file,$linenum";
$vars = "";
}
# print $vars ,"\n";
}
}
} elsif ($line =~ /const (byte) (.*)/ || $line =~ /const (bit) (.*)/) {
# const seconds_per_day = 60 * 60 * 24 -- universal integer constant
$type = $1;
$vars = $2;
# print "$linenum found const $type $vars\n";
while ($vars) {
$vars =~ /([\w\d\_]+)[^w]+(.*)/;
$const{$1} = "$type $file,$linenum";
# print "const $1 type $type vars $vars\n";
$vars = $2;
}
}
}
if (undef $lines{$file} ) {
$tlines += $linenum;
}

$lines{$file} = $linenum;
close(F);
}
}
sub show_func {
local($key);
print W qq!<a href="#top">Top</a><a name="func">
<h2>Functions</h2>
<table border="1">
<tr><tr><th>Name</th><th>File</th><th>Start</th><th>End</th>
<th>Called From</th></tr>
!;


foreach $key (sort keys %functions) {
next if (! $key);
print W qq!<tr><td valign="top">$key</td><td valign="top">$functions{$key}</td>
<td valign="top">$fstart{$key}</td><td valign="top">$fend{$key}</td><td valign="top">!;
print W &calls_to($key);
print W "</td></tr>";
}
print W "</table>\n";

}

sub show_proc {
local($key);
print W qq!<a href="#top">Top</a><a name="proc">
<h2>Procedures</h2>
<table border="1">
<tr><tr><th>Name</th><th>File</th><th>Start</th><th>End</th>
<th>Called From</th></tr>
!;


foreach $key (sort keys %procedures) {
next if (! $key);
print W qq!<tr><td valign="top">$key</td><td valign="top">$procedures{$key}</td>
<td valign="top">$pstart{$key}</td><td valign="top">$pend{$key}</td><td valign="top">
!;
print W &calls_to($key);
print W "</td></tr>";
}
print W "</table>\n";
}

sub show_files {
local($key);
print W qq!<a href="#top">Top</a><a name="files">!;
print W qq!<h2>Files</h2>
<table border="1"><tr><th>File</th><th># Lines</th></tr>
!;

foreach $key (sort keys %lines) {
next if (! $key);
print W "<tr><td valign="top">$key</td><td valign="top">$lines{$key}</td></tr>\n";
}

print W "</table>\n";
}

sub generate_results {
local($startnum, $hd, $key);
open(W, ">$outfile");
open(V, ">$outstruc");
print "Generate results\n";
# first find main loop - after all procedures and functions in
# $infile
print "Header\n";
$hd = qq!<html>
<head><title>Analysis $infile</title>
</head>
<body>

<a name="top"><h1>Analysis $infile</h1>
<a href="$outstruc#struc">Structure</a> |
<a href="$outfile#func">Functions</a> | <a href="$outfile#proc">Procedures</a> |
<a href="$outfile#var">Variables</a> | <a href="$outfile#const">Constants</a> |
<a href="$outfile#files">Files</a>
<p>&nbsp;
!;
print W $hd;
print V $hd;
print "Structure\n";
&show_struc;
print "Variables\n";
&show_vars;
print "Constants\n";
&show_const;
print "Procedures\n";
&show_proc;

print "Functions\n";
&show_func;

&show_files;
print "done, see results in $outfile\n";
close(V);
close(W);
}

sub calls_to {
local($key) = @_;
local($file, $line, $type,$ret, $this);
# $key = sprintf("%s,%06i,%s",$fn, $line, $type);
# print "key $key lcalled $lcalled{$key}\n";
$ret = "";
foreach $this (split(":", $lcalled{$key})) {
$line = 0;
($file, $line, $type) = split(",", $this);
$ret .= sprintf("%s %i<br>\n",$file,$line);
}
return($ret);
}

sub show_vars {
local($key, $this, @where, $file, $ln);
print W qq!<a href="#top">Top</a><a name="var"><h2>Variables</h2>
<table border="1"><tr><th>Variable</th><th>defined</th><th>used</th></tr>!;
foreach $key (sort keys %var) {
next if (! $key);
($this, @where) = split(":", $var{$key});
print W qq!<tr><td valign="top">$key</td><td valign="top">$this</td><td valign="top">!;
foreach (@where) {
($file, $ln) = split(",");
if ($file =~ /^=(.*)/) {
$file = "<b>$1</b>";
}
printf W "%s %i<br>", $file, $ln;
}
print W "</td></tr>\n";

}
print W "</table>\n";
}

sub show_const {
local($key, $this, @where, $file, $ln, %ret, $t);
print W qq!<a href="#top">Top</a><a name="const"><h2>Constants</h2>
<table border="1"><tr><th>Constants</th><th>defined</th><th>used</th></tr>!;
foreach $key (sort keys %const) {
next if (! $key);
$rets = ();
($this, @where) = split(":", $const{$key});
print W qq!<tr><td valign="top">$key</td><td valign="top">$this</td><td valign="top">!;
foreach (@where) {
($file, $ln) = split(",");
if ($file =~ /^=(.*)/ ) {
$file = "<b>$1</b>";
}
$rets{"$file $ln"} = sprintf("%s %i<br>", $file, $ln);
}
foreach (sort keys %rets) {
print W $rets{$_};
}
print W "</td></tr>\n";

}
print W "</table>\n";
}

sub show_struc {

print V qq!<a href="#top">Top</a><a name="struc"><h2>Structure</h2>
<table border="1"><tr><th>Stack</th>!;
for (1..10) { print V "<th></th>"; }
print V qq!<th>called</th><th>in</th></tr>!;

foreach ( sort keys %procedures) {
if ($procedures{$_} =~ /$infile/) {
# print "$_ $procedures{$_} $pstart{$_} $pend{$_}\n";
if ($pend{$_} > $startnum) { $startnum = $pend{$_}; }
}
}
foreach ( sort keys %functions) {
if ($functions{$_} =~ /$infile/) {
# print "$_ $functions{$_} $fstart{$_} $fend{$_}\n";
if ($fend{$_} > $startnum) { $startnum = $fend{$_}; }
}
}
$startnum++;
print V "<tr><td colspan="12">$infile main loop starts at $startnum</td></tr>\n";
print V &show_calls(0, $infile, $startnum, 999999);
print V "</table>";
}

sub show_calls {
local($level, $file, $start, $end) = @_;
local($tfile, $tstart, $ttype, $ret);
$ret = "";

# print "checking $file from $start to $end\n";
if ($start) {
foreach ( sort keys %calls) {
if (! /$file/) { next; }
($tfile, $tstart, $ttype) = split(',',$_);
# print "$tfile, $tstart, $ttype $calls{$_}\n";
if ($tstart < $start) {
# correct file, but not at the right position
next;
}
if ($tstart > $end) {
next;
}
$called = $calls{$_};
$ret .= "<tr><td valign="top">$level</td>";
for (1..$level) { $ret .= "<td>&nbsp;</td> "; }
# this is going to be biiiiiig :-)
$ret .= "<td valign="top">$called</td>";
# for (0..70 - length($called) - 2 * $level) { print W " "; }
# print "$level\t$tfile\t$tstart\t$ttype\t$calls{$_}\n";
if ($ttype eq "p") {
$ret .= "<td valign="top">$procedures{$called}\t$pstart{$called}</td></tr>\n";
$ret .= &show_calls($level + 1, $procedures{$called}, $pstart{$called}, $pend{$called});
} elsif ($ttype eq "f") {
$ret .= "<td valign="top">$functions{$called}\t$fstart{$called}</td></tr>\n";
$ret .= &show_calls($level + 1, $functions{$called}, $fstart{$called}, $fend{$called});
}
}
}
return($ret);
}

sub help {
print qq!$0
this script documents your jal source. All constants, variables,
procedures, functions and calls will be listed in a HTM file.

Usage:
$0 -slib [-ejpic.jal] mysource.jal
-s just like jal, put your library directory here
-e excluded files, wont go into analysis
to exclude several files use more than one -e eg.
-ejpic.jal -ejstepper.jal
mysource.jal main source file

you can use and modify this file as you please :-)

Stefan Seiz sse at seiz.ch March 2002

!;
exit;
}