#! /usr/bin/perl
#
# This script builds the list of parents subprograms (callers) of subroutines 
# in a single module or, in a collection of modules from a specific
# subdirectory or, from current directory and all Src_* subdirectories.
# Anyway, all Fortran source files will be searched for references 
# in current directory and all Src_* subdirectories.

# Copyright (C) 2001-2005 ABINIT group (LSi)
# This file is distributed under the terms of the
# GNU General Public License, see ~ABINIT/Infos/copyright
# or http://www.gnu.org/copyleft/gpl.txt .
# For the initials of contributors, see ~ABINIT/Infos/contributors .

# NOTE : under Unix, a parents script will be automatically generated by 
# the command  make perl  in the ~ABINIT directory.
#
# USAGE :
# unix shell: parents [-p] [-s] [-v] [-d subdirectory | sourcefile]
# Windows DOS box: [perl] parents.pl [-p] [-s] [-v] [-d subdirectory | sourcefile]
# Options:
# -p	original source files will be preserved; new files with .parent
# suffix will be written into same subdirectory
# -s	suppress suffix like .F90 in parents list
# -v	verbose mode
# -d	handle files in subdirectory instead of all files in Src_*
# By default, all files which type is supported (see %Fsufix array below)
# are handled in Src_* subdirectories.
#
# LIMITATIONS :
#    Only Fortran F90 files are handled at the present time.
#    No preprocessing is done. So, subroutine calls introduced by #include 
# will not be recognized.
#    Since the reference to a function subprogram is very similar to the use
# of an array element in Fortran, function calls detection requires a
# sophisticated algorithm and won't be done by this simple script.
#
$, = ' ';               # set output field separator
$\ = "\n";              # set output record separator

# list of supported file types and corresponding file suffixes:
%Fsufix = ('Fortran','.F90',                       # the first digit after dot is needed only 
#	,'C','.c'							# a future enhancement might include C files
	);		
@Ftypes = keys(%Fsufix);	# list of file types only
#
@Modules = values(%Fsufix);	# modules list defaults to suffixes list
@ALLsourceDir = <. Src_*>;	# source file directories including current one
@SourceDirs = @ALLsourceDir;	# directories list defaults to all source subdirs
#
$debug = 0;			# verbose mode defaults to off
# ?? $debug = 2;	# intensive debugging mode
$preserve = 0;	# default is modify source files
$ParentSuffix = 1;	# default is keep .F90 suffix in parents list
$ParentSeparator = ',';		# separator character in parents list is comma
# analyze options and parameters
$CurARG = 0;
while (1) {
	if ($ARGV[$CurARG] eq '-v') {
		$debug = 1;	# verbose mode on
		$CurARG++;
		next;
		}
	if ($ARGV[$CurARG] eq '-s') {
		$ParentSuffix = 0;	# suppress .F90 suffix in list
		$CurARG++;
		next;
		}
	if ($ARGV[$CurARG] eq '-p') {
		$preserve = 1;	# leave original source files unchanged
		print 'Source files will be kept unchanged' if ($debug > 0);
		$CurARG ++;
		next;
		}
	last;
	}
if ($ARGV[$CurARG] eq '-d') {	# check if -d subdir
	if (! -d $ARGV[$CurARG+1]) {
		print "Error, directory $ARGV[$CurARG+1] not found";
		exit 16;
		}	
	@SourceDirs = ($ARGV[$CurARG+1]);	# sources subdirectory
	$CurARG += 2;
	}
elsif ($ARGV[$CurARG] ne '') {
	$fname = $ARGV[$CurARG];
	if (! -e $fname) {
		print "Error, file $fname not found";
		exit 16;
		}
	$dotx = index($fname,'.');
	$suffix = substr($fname,$dotx);	# get file suffix
	while (($ftyp,$fsfx) = each(%Fsufix)) {
		$filetyp = $ftyp if ($suffix eq $fsfx);
		}
	if ($filetyp eq '') {
		print "Unrecognized suffix for file $fname";
		exit 12;
		}
	@Modules = ($fname);	# single module file
	%ModTypes = ($fname,$filetyp);
	@SourceDirs = ();	# empty directories list
	$CurARG ++;
	}
if ($ARGV[$CurARG] ne '') {
	print "Unexpected argument: $ARGV[$CurARG]";
	exit 8;
	}
#
print "Analyzing modules @Modules in @SourceDirs subdirectories" if ($debug > 0);
# build modules list
foreach $dir (@SourceDirs) {
	foreach $ftyp (@Ftypes) {
		print "Searching $dir for $ftyp modules" if ($debug > 0);
		@Files = (<${dir}/*${Fsufix{$ftyp}}> );
		foreach $fname (@Files) {
			%ModTypes = (%ModTypes,
			$fname,$ftyp);
			}
		}
	}
if ($debug > 0) {	# print modules list
	foreach $filetyp (@Ftypes) {
		@Files = ();
		while (($fname,$ftype) = each (%ModTypes)) {
			@Files = (@Files,$fname) if ($ftype eq $filetyp);
			}
		print "$filetyp modules:",@Files;
		}
	}
# build all sources list
if (@ALLsourceDir eq @SourceDirs) {
	print 'Sources directories same as modules' if ($debug > 0 );
	%SourTypes = %ModTypes;		# this is very much faster
	}
else {
	foreach $dir (@ALLsourceDir) {
		foreach $ftyp (@Ftypes) {
			print "Searching $dir for $ftyp sources" if ($debug > 0);
			@Files = (<${dir}/*${Fsufix{$ftyp}}> );
			foreach $fname (@Files) {
				%SourTypes = (%SourTypes,
				$fname,$ftyp);
				}
			}
		}
	}
if ($debug > 1) {	# print sources list
	foreach $filetyp (@Ftypes) {
		@Files = ();
		while (($fname,$ftype) = each (%SourTypes)) {
			@Files = (@Files,$fname) if ($ftype eq $filetyp);
			}
		print "$filetyp sources:",@Files;
		}
	}
# search all modules for function/subroutine entries and build list.
while (($fname,$ftype) = each (%ModTypes)) {
# skip modules with unsupported file type 
	next if ($ftype ne 'Fortran');
	$rc = open(FILEIN,"<$fname");
	if ($rc eq '') {
		print "Unable to open file $fname, error $rc";
		exit 64;
		}
	$Name = '';
	while ($line = <FILEIN>) {
		($wd1,$wd2,$wd3,$wd4,$wd5,$wd6) = split(' ',$line);
		if ($wd1 eq '!!' && $wd2 eq 'NAME') {
			if ($wd3 ne '') {
				$Name = $wd3;
				next;
				}
			else {
				$line = <FILEIN>;
				($wd1,$wd2,$wd3,$wd4,$wd5,$wd6) = split(' ',$line);
				if ($wd1 eq '!!') {
					$Name = $wd2;
					next;
					}
				}				
			}
		$col1 = substr($line,0,1);
		next if ($col1 eq '!');	# ignore comments
# program modules will be handled like subroutines
		if ($wd1 eq 'subroutine' || $wd1 eq 'program') {
			($subname,$arg1) = split('\(',$wd2);
			print "$wd1 $subname defined in $fname" if ($debug > 1);
			print "$wd1 name $subname differs from NAME $Name in $fname" if ($subname ne $Name && $debug > 0); 
# build list of subprograms
			$subname =~ tr/A-Z/a-z/;	# translate to lower case
			%Subs = (%Subs,
			  $subname,$fname);   
			}
		}
	}
if ($debug > 0) {	# print subprograms list
	print 'Subprograms:',keys(%Subs);
	}
# search all sources for subroutine calls and build parents list.
while (($fname,$ftype) = each (%SourTypes)) {
	next if ($ftype ne 'Fortran');	# ignore non Fortran sources for now
	$rc = open(FILEIN,"<$fname");
	if ($rc eq '') {
		print "Unable to open file $fname, error $rc";
		exit 64;
		}
  $linect = 0;		# line counter
  $progmod = 0;		# assume [sub]program not in modules list
# pick file name in path
	$ix = index($fname,'/');
	$source = $ix >= 0 ? substr($fname,$ix+1) : $fname;
	if ($ParentSuffix == 0) {		# filetype suffix to be suppressed ?
		$dotx = index($source,'.');
		$suffix = substr($source,$dotx);	# get file suffix
		$source = substr($source,0,$dotx) if ($suffix eq $Fsufix{$ftype});	# suppress suffix
             #   print "1. Tested suffix for $source, dotx=$dotx, suffix=$suffix, Fsufix=$Fsufix{$ftype}, source=$source";
		}
	while ($line = <FILEIN>) {
		$linect ++;
    chop $line;
    $xcomnt = index($line,'!');
		next if ($xcomnt == 0);	# ignore entire comments
    $line = substr($line,0,$xcomnt) if ($xcomnt >0);    # drop comment
# TODO: handle multiple call statements on one source line
# handle continued line
    $_ = $line;
    $hit = m/(.*)(&\s*$)/;    # search trailing &
    if ($hit) {
    	$line = $1;     # drop &
     	$line2 = <FILEIN>;
			$linect ++;
     	$_ = $line2;
     	$hit = m/(^\s*&)(.*$)/;    # search leading &
     	$line .= $hit ? $2 : $line2;    # drop &
   		} 
# handle logical if
    $_ = $line;
    $hit = m/(^\s*if\s*\(.*\)\s*)([cC][aA][lL][lL].*$)/;   # search if (..) call
    $line = $2 if ($hit);	# drop if (condition)
		($wd1,$wd2,$wd3,$wd4,$wd5,$wd6) = split(' ',$line);
# save subroutine or program name
		if ($wd1 eq 'subroutine' || $wd1 eq 'program') {
			($progname,$arg1) = split('\(',$wd2);
			$progname =~ tr/A-Z/a-z/;		# translate to lower case
			if ($Subs{$progname} ne '') {		# subroutine or program in modules list ?
# ?? children list reset when more than 1 sub
				$progmod = 1;		# turn on reminder
				$children{$source} = ' ';	# children list empty for now
				}
			}
# handle simple call statements
		$wd1 =~ tr/A-Z/a-z/;		# translate to lower case
		if ($wd1 eq 'call') {
# drop arguments if any
			($subname,$arg1) = split('\(',$wd2);
			$subname =~ tr/A-Z/a-z/;	# translate to lower case
# TODO: ignore intrinsic subroutines as date_and_time, exit, ...
# check subroutine name in %Subs
			if ($Subs{$subname} eq '') {
				print "Undefined subroutine $subname called from $fname line $linect" if ($debug > 0);
				}
			else {

# check for multiple calls to the current source from some parent sub
				$ix = index($Parents{$subname}," $source ");
				print "Subroutine $subname called from $source line $linect" if ($debug > 1 || $debug > 0 && $ix < 0);
				if ($Parents{$subname} eq '') {	# empty list ?
					$Parents{$subname} = " $source ";	# put first element
					}
# add to lists if not already
				elsif ($ix < 0) {
					$Parents{$subname} = $Parents{$subname}.$source.' ';
					}
				} 
# check for multiple calls from the current source to the same child sub
				$ix = index($children{$source}," $subname ");
				$children{$source} = $children{$source}.$subname.' ' if ($progmod == 1 && $ix < 0);
			}
		}
	print "Source file $source children: $children{$source}" if ($progmod == 1 && $debug > 0);
	}
# for each subroutine, read the source file and find the Robodoc section
if ( (keys %Subs) == 0) {
  print 'No subroutine has been found, processing terminated';
	exit 0;		# exit if %Subs EMPTY
	}
while (($subname,$fname) = each (%Subs)) {
	$rc = open(FILEIN,"<$fname");
	if ($rc eq '') {
		print "Unable to open file $fname, error $rc";
		exit 64;
		}
# pick file name in path
	$ix = index($fname,'/');
	$source = $ix >= 0 ? substr($fname,$ix+1) : $fname;
	if ($ParentSuffix == 0) {		# filetype suffix to be suppressed ?
		$dotx = index($source,'.');
		$suffix = substr($source,$dotx);	# get file suffix
		foreach $sfx (values(%Fsufix)) {
			if ($suffix eq $sfx) {
				$source = substr($source,0,$dotx) ;	# suppress suffix
        #  print "2. Tested suffix for $source, dotx=$dotx, suffix=$suffix, sfx=$sfx";
				last;
				}
			}
		}
#
	if ($debug > 0) {
	  print "\nRobodoc-ing sub $subname in module $fname";
		if ($Parents{$subname} eq '') {	# empty list ?
			print "No parents found to sub $subname";
			}
		else {
			print "Sub $subname parents:",$Parents{$subname};
			}
		if ($children{$source} eq ' ') {	# empty list ?
			print "No children found to $source";
			}
		else {
			print "Source file $source children:",$children{$source};
			}
		}
	open(FILEOUT,">$fname.parent") || die "Unable to open FILEOUT";
# read again the source file
	$phase = 1;
	$saveline = '';
  $linect = 0;		# line counter
	while ($line = <FILEIN>) {
		$len = length($line);
		($wd1,$wd2,$wd3,$wd4,$wd5) = split(' ',$line);
# Phase 4: find the Robodoc PARENTS item
		if ($phase == 4) {
			if ($wd1 eq '!!' && $wd2 eq 'PARENTS') {
				print 'PARENTS section encountered' if ($debug > 1);
				$PARaddrep = 'replaced';
				$phase = 5;
				}
# if source section is encountered before parents section, the new one will be inserted ahead
			elsif ($wd1 eq '!!' && $wd2 eq 'SOURCE') {
				print 'No PARENTS section was found before SOURCE' if ($debug > 1);
				$saveline = $line;		# save Robodoc marker for later
				$line = "!! PARENTS\n";		# and substitute header for PARENTS section
				$len = length($line);
				$PARaddrep = 'added';
				$phase = 5;
				}
			}
# Phase 7: find the Robodoc CHILDREN item
		if ($phase == 7) {
			if ($wd1 eq '!!' && $wd2 eq 'CHILDREN') {
				print 'CHILDREN section encountered' if ($debug > 1);
				$CHLaddrep = 'replaced';
				$phase = 8;
				}
# if source section is encountered before CHILDREN section, the new one will be inserted ahead
			elsif ($wd1 eq '!!' && $wd2 eq 'SOURCE') {
				print 'No CHILDREN section was found before SOURCE' if ($debug > 1);
				$saveline = $line;		# save Robodoc marker for later
				$line = "!! CHILDREN\n";		# and substitute header for CHILDREN section
				$len = length($line);
				$CHLaddrep = 'added';
				$phase = 8;
				}
			}# ALL phases except 6 or 9 (skip old PARENTS/CHILDREN section): copy input file to FILEOUT
		&WriteLine($line,$len) if ($phase != 6 && $phase != 9);
# Phase 1: find the Robodoc module header
		if ($phase == 1) {
			next if ($wd1 !~ /\!\!\*\*\*\*[fmp]\*/ );
			print 'Module header encountered' if ($debug > 1);
			$phase = 2;
			next;
			}
# Phase 2: find the Robodoc NAME item
		if ($phase == 2) {
			next if ($wd1 ne '!!' || $wd2 ne 'NAME');
			print 'NAME section encountered' if ($debug > 1);
# While, according to rules_coding, subroutine name should not be specified in the NAME
# directive but in the next line, this shortcut is still widely used in version 3.O.2.
# Hence, the following test:
			$wd3 =~ tr/A-Z/a-z/;	# translate to lower case
			if ($wd3 eq $subname) {
			  print "Subroutine identified as $subname, phase=$phase" if ($debug > 1);
			  $phase = 4;		# subroutine name found in NAME directive, skip phase 3
				}
			else {
				$phase = 3;
				}
			next;
			}
# Phase 3: find the subroutine name
		if ($phase == 3) {
			next if ($wd1 ne '!!');
			$wd2 =~ tr/A-Z/a-z/;	# translate to lower case
			if ($wd2 eq $subname) {
			  print "Subroutine identified as $subname, phase=$phase" if ($debug > 1);
			  $phase = 4;
				}
			else {
# another subroutine, has been found, find next NAME item
				print "Subroutine name \"$wd2\" found while expecting \"$subname\" " if ($debug > 1);
				$phase = 2;
				}
			next;	
			}
# Phase 5: write new PARENTS section
# The header for this section was already written at end of phase 4
		if ($phase == 5) {
# convert Parents list (string) to an array, sort it, then build new list
			@SubsList = split(' ',$Parents{$subname});
			print "Writing PARENTS section after line $linect" if ($debug > 1);
			@SortedList = sort(@SubsList);
			&WriteRows;		# print list of source files in rows
			$phase = 6;		# process end of parents; copy of the source file will be suspended
# if a SOURCE line was saved, restore it to process CHILDREN section
			if ($saveline ne '') {
				$line = $saveline;
				}
			else {
				print 'Skipping old PARENTS section from source file' if ($debug > 1);
				next;				# continue reading the source file
				}
			}
# Phase 6: search end of PARENTS section: CHILDREN, NOTES or SOURCE section
		if ($phase == 6) {
			next if ($wd1 ne '!!' || ($wd2 ne 'CHILDREN' && $wd2 ne 'NOTES' && $wd2 ne 'SOURCE') );
			if ($wd2 eq 'CHILDREN') {
				print 'CHILDREN section encountered' if ($debug > 1);
				$CHLaddrep = 'replaced';
				$phase = 8;
				}
# if SOURCE section is encountered before CHILDREN section, the new one will be inserted ahead
			elsif ($wd2 eq 'SOURCE') {
				print 'No CHILDREN section was found before SOURCE' if ($debug > 1);
				$saveline = $line;		# save Robodoc marker for later
				$line = "!! CHILDREN\n";		# and substitute header for CHILDREN section
				$len = length($line);
				$CHLaddrep = 'added';
				$phase = 8;
				}
			else {
				print 'Searching CHILDREN section' if ($debug > 1);
				$phase = 7;		# find the Robodoc CHILDREN item
				}
# copy the current source line to FILEOUT
			&WriteLine($line,$len);
			}
# phase 8: write new CHILDREN section
# The header for this section was already written at end of phase 5 or 7
		if ($phase == 8) {
# convert Children list (string) to an array, sort it, then build new list
			@SubsList = split(' ',$children{$source});
			print "Writing CHILDREN section after line $linect" if ($debug > 1);
			@SortedList = sort(@SubsList);
			&WriteRows;		# print list of subroutines in rows
# if a SOURCE line was saved, write it here
			if ($saveline ne '') {
				$len = length($saveline);
				&WriteLine($saveline,$len);
				$saveline = '';
				print 'Copying remainder of source file' if ($debug > 1);
				$phase = 10;		# resume copy for the remainder of the source file
				next;				# continue reading/copying with next line
				}
			print 'Skipping old CHILDREN section from source file' if ($debug > 1);
			$phase = 9;		# copy of the source file will be suspended during phase 9
			next;				# continue reading the source file
			}
# Phase 9: search end of CHILDREN section: NOTES or SOURCE section
		if ($phase == 9) {
			next if ($wd1 ne '!!' || ($wd2 ne 'NOTES' && $wd2 ne 'SOURCE') );
# copy the current source line to FILEOUT
			&WriteLine($line,$len);
			print 'Copying remainder of source file' if ($debug > 1);
			$phase = 10;		# resume copy for the remainder of the source file
			next;			# continue reading/copying with next line
			}		
		}
# end of file has been hit
	close (FILEOUT);
	close (FILEIN);
# was PARENTS section encountered ?
  if ($phase < 10) {
		print "Error: Robodoc module header missing in $fname" if ($phase == 1);
		print "Error: Robodoc subroutine NAME missing in $fname" if ($phase == 2 || $phase == 3);
		print "Error: no Robodoc PARENTS or SOURCE section found in $fname" if ($phase == 4);
		print "Error: end of file hit while skipping PARENTS section from $fname" if ($phase == 6);
		print "Error: no Robodoc CHILDREN or SOURCE section found in $fname" if ($phase == 7);
		print "Error: end of file hit while skipping CHILDREN section from $fname" if ($phase == 9);
		unlink ("$fname.parent");		# remove work file
    next;		# process next subroutine
    }
# rename files if preserve option (-p) has not been specified
	if ($preserve == 0) {
		unlink ("$fname.old");	# suppress .old file
		$rc = rename($fname,"$fname.old");
		if ($rc != 1) {
			print "Error $! renaming $fname to $fname.old";
			exit 120;
			}
		$rc = rename("$fname.parent","$fname");
		if ($rc != 1) {
			print "Error $! renaming $fname.parent to $fname";
			exit 140;
			}
		}
	print "Parents section $PARaddrep" if ($debug == 1);
	print "Children section $CHLaddrep" if ($debug == 1);
	print "Processing of subroutine $subname in module $fname completed";
	}
# ***************************
sub WriteLine {
	local ($line,$llen) = @_;
  local ($rc);
# Purpose: write one line to FILEOUT and check return code
# Arguments:  $line, $llen = line to be written and length
# Common variables: $linect,$fname.parent
	$rc = syswrite(FILEOUT,$line,$llen);
	if ($rc != $llen) {
		print "Error $rc writing to $fname.parent";
		exit 100;
		}
		$linect ++;
	return;
	}
# ***************************
sub WriteRows {
	local ($lenh,$line1,$len1,$len2,$sub);
# Purpose: print a list in (max) 80-characters rows.
# Common variables: @SortedList, $ParentSeparator
	$line1 = '!!      ';
	$lenh = length($line1);
	$len1 = $lenh;
	foreach $sub(@SortedList) {
		$len2 = $len1+length($sub)+1;	# estimate length of output line, NL-terminated
		if ($len2 > 80) {
			substr($line1,-1,1)="\n";	# replace separator by NL
			&WriteLine($line1,$len1);
			$line1 = '!!      '.$sub.$ParentSeparator;
			$len1 = $lenh+length($sub)+1;
		}
		else {
				$line1 = $line1.$sub.$ParentSeparator;
				$len1 = $len2;
			}
		}
	if ($len1 > $lenh) {			# non empty line left ?
		substr($line1,-1,1)="\n";	# replace separator by NL
		&WriteLine($line1,$len1);	# write last row
		}
	&WriteLine("!!\n",3);			# finish list with null Robodoc line
	return;
	}
