#!/bin/sh -- # A comment mentioning perl, indented bash's sake.
eval 'exec perl -S $0 ${1+"$@"}'
        if 0;

chop($Program = `basename $0`);

$Usage = <<"END";

$Program: simple extraction of subroutine call structure.

Usage: $Program <options> <perl_script>

Options:
	-a	Try to add the ampersand to the sub calls...

	-o	Print the calls from one sub only once,
		instead of once per call. In this case
		the calling parameters are not printed.

	-v	Verbose. Print out calls to perl builtin
		functions as well. You will usually want
		to use -o as well since the output gets
		large in this case.

	-nr	Do not follow "requires".

	-s	Only print the subroutines found, not
		the calling structure.

	-t	Trim off '&', ':', and (...) from names and
		do not print out the "calls:" lines.

	-m <list> Match subroutine names in comma separated
		  <list> only. Use -M <list> to still get the
		  &name() calls, or -v to still get the keywords.

	-h	Print this help.

Notes:
	This is not a true perl parser, so can easily
	be fooled or confused.

	Quoting is mostly ignored. Block quotes: <<"END";
	are attempted.
	Nested () are not explored.
	Only one level of "require" is searched.
	Eval-ing a subroutine name or definition wont be noted.

	Requires same indentation for sub line and matching }
		sub foo {
			...
		}

	Requires perl4 style sub calls: &foo(...) not foo(...)
	(perl5 style could be added with a second pass...)

END

$Once = 0;
$Verbose = 0;
$Add_Ampersand = 0;
$Follow_Require = 1;
$Bare_Calls = 0;	# Not done: use `$0 -s` => -m.
$Subs_Only = 0;
$Trim = 0;
$Match = '';
$NoAmpersands = 0;
$Try_C = 0;

@args = @ARGV;

LOOP:	
while (@ARGV) {
    $_ = shift;
    CASE: {
	/^-d$/ && ($Debug = 1, last CASE);
	/^-o$/ && ($Once = 1, last CASE);
	/^-a$/ && ($Add_Ampersand = 1, last CASE);
	/^-v$/ && ($Verbose = 1, last CASE);
	/^-b$/ && ($Bare_Calls = 1, last CASE);
	/^-s$/ && ($Subs_Only = 1, last CASE);
	/^-t$/ && ($Trim = 1, last CASE);
	/^-C$/ && ($Try_C = 1, $Add_Ampersand = 1, last CASE);
	/^-m$/ && ($Match .= shift, $NoAmpersands = 1, last CASE);
	/^-M$/ && ($Match .= shift, $NoAmpersands = 0, last CASE);
	/^-nr$/ && ($Follow_Require = 0, last CASE);
	/^--$/ && (last LOOP);	# -- means end of switches
	/^-(-.*)$/ && (unshift(@ARGV, $1), last CASE);
	/^(-h|-help)$/ && ((print $Usage), exit 0, last CASE);
	if ( /^-(..+)$/ ) {	# split bundled switches:
		local($y, $x) = ($1, '');
		foreach $x (reverse(split(//, $y))) { unshift(@ARGV,"-$x") };
		last CASE;
	}
	/^-/ && ((print "Invalid arg: $_\n$Usage"), exit 1, last CASE);
	unshift(@ARGV,$_);
	last LOOP;
    }
}

if ( $Bare_Calls && @ARGV && $ENV{PERLCALLS_BARE_CALLS} eq '' ) {
	local($files, @list, $match);
	if ( ! @ARGV ) {
		print STDERR "$Program: Sorry cannot use -b flag on STDIN\n";
		exit 1;
	}
	$ENV{PERLCALLS_BARE_CALLS} = 1;
	$files = join(' ', @ARGV);
	@list = `$0 -st $files`;
	$Match .= ',' . join(',', @list); 
	$Match =~ s/^,+//;
}

&set_keywords();

if ( $Match ) {
	$tmp = '';
	foreach $m (split(/\s*,\s*/, $Match) ) {
		$tmp .= '\b' . $m . '|';
	}
	$tmp =~ s/\|+$//;
	$Match = $tmp;
	print STDERR "MATCH\n$Match\n" if $Debug;
}

$Sub = 'main';

@Stack = ($Sub);
$Subs{$Sub} = 1;

$Indent = '';
@Indent = ($Indent);

while (<>) {
	chop();
	last if /^__END__/;

	if ($Add_Ampersand) {
		$o = $_;
		$_ =~ s/([^\$\@\%])(\b[_A-z]\w*\s*\()/$1\&$2/g;
		$_ =~ s/^(\b[_A-z]\w*\s*\()/\&$1/g;
		$_ =~ s/\&(($OpMatch|$KeyMatch)\s*\()/$1/og;
		#print "B: $o\nA: $_\n" if $o ne $_;
	}
	
	push(@Code, $_);

	# Do one level of require:
	if ( $_ =~ /^\s*require\s+(\S+)/ && $Follow_Require ) {
		$file = $1;
		$file =~ s/^[\s"';]*//;
		$file =~ s/[\s"';]*$//;
		$gotit = 0;
		foreach $dir ('.', @INC) {
			$rfile = "$dir/$file";
			next if ! -f $rfile;
			next unless open(REQ, "$rfile");

			$gotit = 1;
			while ($rline = <REQ>) {
				chop($rline);
				push(@Code, $rline); 
				if ( $rline =~ /^\s*require\b/ ) {
					print STDERR "Skipping nested require: $'\n";
				}
				last if $rline =~ /^__END__/;
			}
			close(REQ);
			last;
		}
		warn "Could not require: $file\n" unless $gotit;
	}
}

if ($Try_C) {
	my $all = '';
print "OpMatch: $OpMatch\n";
	foreach $line (@Code) {
		$line =~ s,//.*$,,;
		if ( $line =~ /^[^()]*\b(\w+)(\s*\(.*)\{\s*$/ ) {
			my $ident = $1;
			my $rest = $2;
			if ( $ident !~ /($OpMatch)/o ) {
				my $line0 = $line;
				$line = "sub $ident {\n";
				$line .= "\t my $rest = \@_;";
				print "OLD: $line0\n";
				print "NEW: $line\n";
			}
		}
		$all .= $line . "\n";
	}
	$all =~ s,/\*(.|\n)*?\*/,,g;
	@Code = split(/\n/, $all);
}

$sep = ' %%% ';

$Quote = '';

foreach $line (@Code) {
	
	# These are Not perfect. Quoting inside a line is not checked.

	next if $line =~ /^\s*#/;		
	$line =~ s/([^\$])#.*$/$1/;		

	if ( $Quote eq '' && $line =~ /<<(.*)\s*;/ ) {
		$Quote = $1;
		$Quote =~ s/['"]//g;
		if ( $Quote =~ /^[\w:-]+$/ ) {
			print STDERR "QUOTE_ON: $Quote\n" if $Debug;
			eval "sub match_quote {
				local(\$x) = \@_;
				if ( \$x =~ /^$Quote/ ) {
					return 1;
				}
				return 0;
			}";
		} else {
			$Quote = '';
		}

	}

	if ( $Quote ne '' && &match_quote($line) ) {
		print STDERR "QUOTE_OFF: $line\n" if $Debug;
		$Quote = '';
	}
	next if $Quote;

	if ( $line =~ /^(\s*)sub\s+([\w':]+)\s*[\{]*\s*$/ ) {
		# Found a sub.

		$Indent = $1;
		$Sub = '&' . $2;
		$Subs{$Sub} = 1;

		push(@Stack,  $Sub);
		push(@Indent, $Indent);

		next;

	} elsif ( $Sub ne 'main' && $line =~ /^$Indent\}\s*$/ ) {
		# End of sub, we guess.
		pop(@Stack);
		pop(@Indent);

		$Sub = $Stack[$#Stack];
		$Indent = $Indent[$#Indent];

	} elsif ( $line =~ /^\s*(local|my)(.*)=\s*[\@\$]_[\[\d\]]*\s*;/ ) {
		# Look for subroutine "signature"
		$tmp = $2;
		$tmp =~ s/^\s*//;
		$tmp =~ s/\s*$//;

		$Args{$Sub} .= $tmp . ', ';
		print STDERR "ARGS: $Sub: $Args{$Sub}\n" if $Debug;
	}

	
	$match = '(';

	$match .= '|\&[A-z_]\w+'	unless $Match && $NoAmpersands;
	$match .= '|' . $KeyMatch	if $Verbose;
	$match .= '|' . $Match		if $Match;

	$match .= ')\b';

	$match =~ s/^\(\|/(/;

	while ( $line =~ /$match/o ) {
		$sub  = $1;
		$rest = $';
		$args = '';
		if ( $sub !~ /^\&/ ) {
			$sub = " $sub";
		}
		if ( $rest =~ /\s*\([^\)]*\)/ ) {
			$args = $&;
			$rest = $';
			$args =~ s/^\s*//;
		}
		$args = '()' unless $args;

		if ( ! $Call{$Sub} ) {
			push(@Order, $Sub);
		}
		$Call{$Sub} .= $sub . $args . $sep; 

		$line = $rest;
	}
}

if ( $Quote ) {
	print STDERR "$Program: Warning: code ended in quote: $Quote\n"; 
}

$sep =~ s/(\W)/\\$1/g;

$Nothing = '';
foreach $sub (@Order, '__NOT__', (sort keys(%Subs)) ) {

	if ($sub eq '__NOT__' ) {
		$Nothing = '*nothing*';
		next;
	}

	next if $DidSub{$sub};
	$DidSub{$sub} = 1;

	$args = $Args{$sub};
	$args =~ s/,\s*$//;
	$args = '()' unless $args;

	$tmp = "$sub$args:";
	$tmp =~ s/\&//g if $Trim;
	$tmp =~ s/\(.*://g if $Trim;

	print "$tmp\n";
	print "    calls:\n" unless $Subs_Only || $Trim;


	undef %did;

	if ( $Nothing && $Call{$sub} eq '' ) {
		$Call{$sub} = $Nothing;
	}
	foreach $call ( split(/$sep/, $Call{$sub}) ) {

		next if $call =~ /^[&]*main\b/;
		$call =~ s/\(.*\)/()/g if $Once;
		next if $did{$call} && $Once;
		$did{$call} = 1;

		if ( $Trim ) {
			$call =~ s/^\s*//g;
			$call =~ s/\&//g;
			$call =~ s/\(.*$//g;
		}

		print "\t$call\n" unless $Subs_Only;
	}
	print "\n" unless $Subs_Only;
}

#------------------------------------------------------
sub set_keywords {
	$KeyMatch = '';
	$OpMatch = '';
	open(THIS_FILE, "$0") || die "$!";

	local($on) = 0;
	while (<THIS_FILE>) {
		chop;
		next if /^\s*#/;
		next if /^\s*$/;

		if ( $on ) {
			if ( $_ =~ /OP:/ ) {
				
				$OpMatch  .= '\b' . $' . '|';
			} else {
				$KeyMatch .= '\b' . $_ . '|';
			}
		}
		$on = 1 if /^__END__/;
	}
	close(THIS_FILE);
	$KeyMatch =~ s/\|+$//;
	$OpMatch =~ s/\|+$//;
	print STDERR "KEYMATCH\n$KeyMatch\n" if $Debug;
	print STDERR "OP-MATCH\n$OpMatch\n" if $Debug;
}

__END__
# List all perl keywords here:
OP:if
OP:elsif
OP:if
OP:elsif
OP:unless
OP:else
OP:switch
OP:eq
OP:ne
OP:gt
OP:lt
OP:ge
OP:le
OP:cmp
OP:not
OP:and
OP:or
OP:xor
OP:while
OP:for
OP:foreach
OP:do
OP:until
OP:defined
OP:undef
OP:and
OP:or
OP:not
OP:bless
OP:ref
#
chomp
chop
chr
crypt
hex
index
lc
lcfirst
length
oct
ord
pack
reverse
rindex
sprintf
substr
uc
ucfirst
quotemeta
split
study
abs
atan2
cos
exp
hex
int
log
oct
rand
sin
sqrt
srand
pop
push
shift
splice
unshift
grep
join
map
reverse
sort
unpack
delete
each
exists
keys
values
binmode
close
closedir
dbmclose
dbmopen
die
eof
fileno
flock
format
getc
print
printf
read
readdir
rewinddir
seek
seekdir
select
syscall
sysread
syswrite
tell
telldir
truncate
warn
write
pack
read
syscall
sysread
syswrite
unpack
vec
chdir
chmod
chown
chroot
fcntl
glob
ioctl
link
lstat
mkdir
open
opendir
readlink
rename
rmdir
stat
symlink
umask
unlink
utime
caller
continue
die
do
dump
eval
exit
goto
last
next
redo
return
#sub
wantarray
caller
import
local
my
package
use
defined
dump
eval
formline
local
my
reset
scalar
undef
wantarray
alarm
exec
fork
getpgrp
getppid
getpriority
kill
pipe
setpgrp
setpriority
sleep
system
times
wait
waitpid
do
import
no
package
require
use
bless
dbmclose
dbmopen
package
ref
tie
tied
untie
use
accept
bind
connect
getpeername
getsockname
getsockopt
listen
recv
send
setsockopt
shutdown
socket
socketpair
msgctl
msgget
msgrcv
msgsnd
semctl
semget
semop
shmctl
shmget
shmread
shmwrite
endgrent
endhostent
endnetent
endpwent
getgrent
getgrgid
getgrnam
getlogin
getpwent
getpwnam
getpwuid
setgrent
setpwent
endprotoent
endservent
gethostbyaddr
gethostbyname
gethostent
getnetbyaddr
getnetbyname
getnetent
getprotobyname
getprotobynumber
getprotoent
getservbyname
getservbyport
getservent
sethostent
setnetent
setprotoent
setservent
gmtime
localtime
time
times
abs
bless
chomp
chr
exists
formline
glob
import
lc
lcfirst
map
my
no
qx
qw
ref
sysopen
tie
tied
uc
ucfirst
untie
use