#!/usr/bin/perl
#
# autodocu.pl
#
# (C) Robert Harlander, May 2004. All rights reserved.
#     (robert.harlander<AT>cern.ch)
#
# Version 0.9
#
# Usage:  autodocu.pl <files>
#
# directory $docudir (change below!) must exist.
#
# autodocu.pl is a code browser (hi Zhenny!) 
# (currently only working for FORTRAN-77).
# It parses the <files> and establishes cross references
# for function and subroutine calls.
# The new files are put in $docudir as defined below, and
# get the additional extension "html".
# It also does some code highlighting.
#
# Requirements: Nothing.
#               Well, nothing that you don't have: 
#               * perl
#               * html browser (netscape, mozilla,
#                               Micro$oft Explorer, ...).
#
# Installation: copy this file somewhere to your path as autodocu.pl, 
#               and make it executable.
#
# ----------------------------------------------------------------------
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with GNU Emacs; see the file COPYING.  If not, write to
# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
# ----------------------------------------------------------------------

# CUSTOMIZATION:

# where to put the html files:
$docudir = "/home/rharland/test";

#
# if you want a particular word to be highlighted, put it here.
# format:
#
# %highlightword = ("myword" => "green", "anotherword" => "blue");
#
%highlightword = ();


#
# choose your favorite colors here:
#
$stringcol = "lightgreen";   # strings
$keycol = "blue";            # FORTRAN keywords
$commentcol = "grey";        # comments
$funcallcol = "magenta";     # function calls
$fundefcol  = "orange";      # function definitions
$subcol  = "red";            # subroutine definitions
$entrycol  = "red";          # subroutine entries
$inccol = "green";           # include
$callcol = "magenta";        # subroutine calls
$unknowncol = "cyan";        # calls of external subroutines




# ----------------------------------------------------------------------
# NOTHING SHOULD BE MODIFIED BELOW THIS POINT
# ----------------------------------------------------------------------
	
# FORTRAN keywords:	  
@keywords = ("then","else","if","endif","elseif",
	     "do","enddo","include","while",
	     "return",
	     "implicit","real","complex","integer",
	     "external","dimension","parameter","data",
	     "double precision","open","read","write","print",
	     "common","character","logical",
	     "format",
	     "end");

$stringstart = "<font face=\"Helvetica\" color=\"$stringcol\">";
$stringend = "</font>";
$commentstart = "<font face=\"Helvetica\" color=\"$commentcol\">";
$commentend = "</font>";
$uncallstart = "<font color=\"$unknowncol\">call ";
$uncallend = "</font>";
$callstart = "<font color=\"$callcol\">call ";
$callend = "</font>";
$substart = "<font color=\"$subcol\">subroutine ";
$subend = "</font>";
$entrystart = "<font color=\"$entrycol\">entry ";
$entryend = "</font>";
$incstart = "<font color=\"$inccol\">";
$incend = "</font>";
$funstart = "<font color=\"$funcallcol\">";
$funend = "</font>";
$fundefstart = "<font color=\"$fundefcol\">";
$fundefend = "</font>";

foreach $word (@keywords) {
    %highlightword = (%highlightword,
		      $word => $keycol);
}

%subref = ();
%funref = ();
%entryref = ();

foreach $file (@ARGV) {
    open(FILE,$file);
    
    # this loop collects the
    # * function names into %funref
    # * subroutine names into %subref
    while (<FILE>) {
	$line = $_;
	chop($line);

	# skip comments:
	if ($line =~ /^[c]/i) {next}
	
	if (length($line) >= 6) {
	    $linehead = substr("$line",0,6);
	    $line = substr("$line",6);
	}
	else {next}

	# translate tabs to whitespace:
	$line =~ s/^(\s*)(.*)/$2/;
	$blanks = $1;

	# cut off the leading white space:
	$line =~ s/^(\s*)(.*)/$2/;

	# translate tabs to whitespace:
	$line =~ s/\t/ /g;

	# collect subroutine names defined in FILE:
	if ($line =~ /^subroutine +([^ \(]+)/i) {
	    %subref = (%subref,
			  $1 => "$docudir/$file.html");
	}

	# collect subroutine names defined in FILE:
	if ($line =~ /^entry +([^ \(]+)/i) {
	    %entryref = (%entryref,
			  $1 => "$docudir/$file.html");
	}

	# collect function names defined in FILE:
	elsif ($line =~ /^((complex|real)?(\*\d+ )?function) +([^ \*\(]+)/i) {
	    %funref = (%funref,
		       $4 => "$docudir/$file.html");
	}
    }
    close(FILE);
}

# Now we have a list of all subroutine names, together with
# the information where these subroutines are defined.
# Let's check the code again for subroutine and function calls.

foreach $file (@ARGV) {

    # source file:
    open(FILE,$file);

    print("$file...\n");
    if ($file =~ /(.*)\//) {
	$dir = $1;
	unless (-d "$docudir/$dir") {
	    print("Creating directory $docudir/$dir...\n");
	    mkdir("$docudir/$dir",0755);
	}
    }

    # html file (it's called "program.f.html", for example):
    open(OUT,">$docudir/$file.html") || die;

    print {OUT} ("<html>\n");
    print {OUT} ("<hr>\n");
    print {OUT} ("<tt>c&nbsp;&nbsp; file: $file </tt><br>\n");
    print {OUT} ("<tt>c&nbsp;&nbsp; generated with ",
		 "<a href=\"http://www.robert-harlander.de/software/\">".
		 "autodocu.pl</a> on ",`date +%d/%b/%Y`,"</tt><br>\n");
    print {OUT} ("<hr>\n");
    print {OUT} ("<font size=+1>\n");
    print {OUT} ("<pre>\n");

    $strc = 0;

    while (<FILE>) {

	$line = $_;

	# chop off the newline character at the end:
	chop($line);

	# comment lines:
	if ($line =~ /^[c]/i) {
	    print {OUT} ($commentstart.$line,$commentend."\n");
	    next;
	}

	# translate tabs to whitespace:
	$line =~ s/\t/ /g;

	if (length($line) >= 6) {
	    $linehead = substr("$line",0,6);
	    $line = substr("$line",6);
	}
	else {$linehead = ''}

	# cut off comments at the end of a line to put them back later:
	if ($line =~ s/(\!.*)//) {
	    $linetail = $commentstart.$1.$commentend;
	} else {
	    $linetail = '';
	}

	# remove leading whitespace and save it in $blanks to put them
	# back later:
	$line =~ s/^(\s*)(.*)/$2/;
	$blanks = $1;

	# this is not to get confused by different string delimiters:
	# we just replace them by single quotes everywhere:
	$line =~ s/\"/\'/g;

	# treat all strings, except when they follow an include statement:
	unless ($line =~ /^include/) {
	    dostrings();
	}

	# subroutine calls:
	if ($line =~ s/^call +([^ \(]+)/$callstart $1$callend/i) {
	    # it's either a subroutine call...
	    if ($subref{$1}) {
		$ref = $subref{$1}."#".$1;
		$line = "<a href=\"".$ref."\">".$line."</a>";
	    }
	    # ...or the call of a particular entry point:
	    elsif ($entryref{$1}) {
		$ref = $entryref{$1}."#".$1;
		$line = "<a href=\"".$ref."\">".$line."</a>";
	    }
	    # do this if we cannot find the subroutine definition
	    # (it's an external subroutine then):
	    else {
		$line =~ s/^call +([^ \(]+)/$uncallstart $1$uncallend/i;
	    }
	}
	# treat include statements:
	elsif ($line =~ /^include \'(.*)\'/)
	{
	    $line = "<a href=\"$1\.html\">".$incstart.$line.$incend."</a>";
	}
	# subroutine definition:
	elsif ($line =~ s/^subroutine +([^ \(]+)/$substart $1$subend/i) {
	    $line = "<a NAME=\"$1\">".$line."</a>";
	}
	# subroutine entry:
	elsif ($line =~ s/^entry +([^ \(]+)/$entrystart $1$entryend/i) {
	    $line = "<a NAME=\"$1\">".$line."</a>";
	}
	# function definition:
	elsif ($line =~ /^((complex|real)?(\*\d+ )?function) +([^ \*\(]+)/i) 
	{
	    $line = "<a NAME=\"$4\">".$fundefstart.$line.$fundefend."</a>";
	}
	# keyword:
	else {
	    foreach $key (keys(%funref)) {
		$ref = $funref{$key}."#".$key;
		$head = "<a href=\"".$ref."\">".$funstart;
		$tail = $funend."</a>";
		if ($line =~ /(^|[^a-zA-Z])$key\(/i) {
		    $line =~ s/(^|[^a-zA-Z])$key\(/$1$head$key$tail\(/ig;
		}
	    }
	    foreach $key (keys(%highlightword)) {
		$head = "<font color=\"".$highlightword{$key}."\">";
		$tail = "</font>";
		if ($line =~ /(^|[^a-z])$key([^a-z]|$)/i) {
 		    $line =~ s/(^|[^a-z])$key([^a-z]|$)/$1$head$key$tail$2/ig;
		}
		}
    }
		foreach $match (@match) {
		    $line =~ s/$dummy/$stringstart$match$stringend/;
		}
	print {OUT} ($linehead.$blanks.$line.$linetail,"\n");
    }
    print {OUT} ("</font>\n");
    print {OUT} ("</pre>\n");
    print {OUT} ("</html>\n");
    close(OUT);
    close(FILE);
}
    
	print("Wrote output to $docudir.\n");

	sub dostrings {

	$dummy = "xxSTRINGPLACEHOLDERxx";
	$strcold = $strc;
	@str = $line =~ m/\'/g;
	$strc = ($#str+1 + $strcold) % 2;
	$linea = '';
	$lineb = '';

	if ($strcold == 0) {
	    if ($strc == 0) {
		@match = $line =~ m/(\'[^\']*\')/g;
		$line =~ s/(\'[^\']*\')/$dummy/g;
	    } else {
		$line =~ s/(\'[^\']*)$//;
		$lineb = $1;
		@match = $line =~ m/(\'[^\']*\')/g;
		$line =~ s/(\'[^\']*\')/$dummy/g;
		$line = $line.$dummy;
	    }
	} else {
	    if ($line =~ s/^([^\']*\')//) {$linea = $1}
	    elsif ($line !~ /\'/) {$linea = $line; $line = ''}
	    if ($strc == 0) {
		@match = $line =~ m/(\'[^\']*\')/g;
		$line =~ s/(\'[^\']*\')/$dummy/g;
		$line = $dummy.$line;
	    } else {
		$line =~ s/(\'[^\']*)$//;
		$lineb = $1;
		@match = $line =~ m/(\'[^\']*\')/g;
		$line =~ s/(\'[^\']*\')/$dummy/g;
		$line = $dummy.$line.$dummy;
	    }
	}
	$" = ",";
	if ($linea) {
            @match = ($linea,@match);
	}
	if ($lineb) {
            @match = (@match,$lineb);
	}

    }
