#!/usr/bin/perl 
# (change this to invoce your local perl5)

# Modified from for2html (see below) by J. Saroun, saroun@ujf.cas.cz , March 2005
# 1) handles source files in subdirectories
# 2) handles include files *.inc (can have the same base name as another *.f file)
# 3) recognize structures
# 4) add referencess to CSS classes to distinguish coments and strings
# corrected bug: dirparam was not set even when specified
# ================================================================================

#####  ABOUT for2html #####

# for2html: the FORTRAN77 to HTML translator

# Home page http://for2html.sourceforge.net

# Copyright Joachim Wuttke (jwuttke@ph.tum.de) 1999,2002
# Distributed under the Eiffel Forum License

# Version 1    released on 29dec99
# Version 1.1  released on  4jan00  (bug fix: 1.0 ate trailing 0's)
# Version 1.2  released on 26jan00  (line number in error report, TAB's)
# Version 1.3  released on 22mar00  (INCLUDE .h; better handling of col's 2-6)
# Version 1.3+ continuously amended


$for2html = "<a href=\"http://for2html.sourceforge.net\">\n for2html</a>";

##### SUBROUTINES #####

### error messages ### :

sub errc { # call error
   die "res2html aborted while parsing command line :\n@_[0]\n";
   }

sub errf { # file-access error
   die "res2html @_[0]\n";
   }

sub errs { # syntax error
   die "res2html failed in line $lino :\n@_[0]\n";
   }

### analyse command-line parameters :

sub com_lin_pars {

   $argvin = join ' ', @ARGV;

   @ARGLOOP = @ARGV;
   foreach (@ARGLOOP) {
      if ( s/^\-// ) {
         if ( m/^h/i ) {
            die 
"usage: res2html [-s[C][T]] [-d<dir>] [-b<subdir>] [-t<title>] [-u<URL>] <source_file[s]>;\n"
               ."call res2html -s or -d or ... to obtain information "
               ."on command-line options.\n"; }
         elsif ( s/^s// ) {
            if ( ! m/[CT]/ ) { 
               errc "available style options are: -sC C-like comparisons"; }
            if ( m/C/ ) { $c_like_comps = 1; }
            if ( m/T/ ) { $allow_tabs   = 1; }
            }
         elsif ( s/^t// ) {
            if ( $_ ) {
               $prjparam = $_; }
            else {
               errc "use -t<title> to enter a project title"; }
            }
         elsif ( s/^d// ) {
            if ( $_ ) {
               $dirparam = $_; }
            else {
               errc "use -d<directory> to specify the HTML output directory"; }
            }
         elsif ( s/^b// ) {
            if ( $_ ) {
               $SRC = $_; }
            else {
               errc "use -b<subdir> to specify the subdirectory for source files"; }
            }
         elsif ( s/^u// ) {
            if ( $_ ) {
               $urlparam = $_; }
            else {
               errc "use -u<URL> to provide a link to a project home page"; }
            }
         shift @ARGV;
         } # /-/
      } # foreach @ARGLOOP
   if (@ARGV < 1) { errc "no input files given"; }
   } # sub com_lin_pars

### file handling :

sub splitextension { # geht auch einfacher
   $File = @_[0];
   $File =~ m/^(.*)\.(.*)/;
   return ($1, $2)
   }

sub splitfname { # split to path, name, extension
   $_ = @_[0];
   $pa="";$na="";$ex="";$dot=".";
   if ( m/^(.*\/)(.*)/ ) { $pa = $1};
   if ( m/^(.*)\.(.*)/ ) { $ex = $2};
   if (length $ex < 1) {$dot=""}; 
   if ( m/^($pa)(.*)($dot$ex)/ ) { $na = $2};
   return ($pa, $na, $ex);
}

sub open_infile {
#   ($inname,$inext) = splitextension $infile;
   ($indir,$inname,$inext) = splitfname $infile;
   if (length $inname<1) { 
      errc "input file name \"$infile\" has no extension" }
   unless ($inext eq "f" || $inext eq "f77" || $inext eq "inc") { 
      errc "input file is \"$infile\" but should have extension .f .f77 or inc" }
   
   if ( $inext eq "inc" ) {
      $inname="inc_$inname";
   }
   open (INFILE,$infile) || errf "could not open input file $infile";
   $outfile = "$SRC$inname.html"; # put in open IN_file because needed BEFORE pass 3
   $lastept = ""; # in case, ept is called from non-entry-region (include-file) 
   $lino = 0; # line number, for error report
   }

sub open_outfile {
   open (OUTFILE,">$dirname$outfile") || 
      errf "could not open output module file $dirname$outfile";
   }

sub open_prjfile {
   if (opendir OUTDIR,$dirname) {
      chmod 0755, $dirname; }
   elsif (! mkdir $dirname, 0755) {
      errf "could not create HTML output directory $dirname"; }
   if (opendir SRCDIR,"$dirname$SRC") {
      chmod 0755, "$dirname$SRC";}
   elsif (! mkdir "$dirname$SRC", 0755) {
      errf "could not create HTML output directory $dirname$SRC"; }
   $prjfile = "$prjname"."_OVERVIEW.html";
   open (PRJFILE,">$dirname$prjfile") || 
      errf "could not open output project file $dirname$prjfile";
   }

### cross reference handling :

sub new_ept {
   # learn new entry_point
   $ept=@_[0];
   $fref{$ept} = "$inname";
   }

sub new_call {
   # learn new call 
   $called=@_[0];
   if ($lastept && $called ne $lastept && $lref{$called} ne $lastept) { 
      $cref{$called} = 
        "$cref{$called} <a href=\"#$lastept\">$LastEpt</a>"; 
      $lref{$called} = $lastept; # do not learn two calls from the same ept
      }
   }

### convert fragments of FORTRAN code to HTML :

sub printif {
   if ( $pass == 3 ) { print OUTFILE "@_[0]"; }
   } 

sub printeol {
   printif "<br>\n";
   } 

sub printtriv { # print anything, just substitute blank_character by &nbsp;
   $_=@_[0];
   s/\ /&nbsp;/g;    # preserve whitespace
   printif $_;
   }

sub printchar { # print any character occuring in a normal Fortran statement
   $_=@_[0];
   if ( m/(<|>)/ ) { 
      print "\"$_\"\n";
      errs "encountered $1 outside comment or string" }
   printtriv $_;
   }

sub printnum { # print any character allowed in columns 2-5
   $_=@_[0];
   if ( m/!/ ) {
      errs "sorry: inline-comment starting in columns 2-5 cannot be handled by for2html" }
   if ( m/[^0-9\s]/ ) { 
      print "\"$_\"\n";
      errs "invalid character in columns 2-5" }
   printif "<SPAN class=\"label\">"; printtriv $_; printif "</SPAN>" ;
   }

sub printtext { # print quoted text (comment or string)
   $_=@_[0];
   # substitute characters that have a special meaning in HTML
   s/&/&amp;/g; # of course this substitution must be done first
   s/</&lt;/g; 
   s/>/&gt;/g; 
   printchar $_;
   }

sub printept { # print entry point to project_overview and outfile
   # write entry-point to project-overview :
   print PRJFILE "<li><b><a name=\"$lastept\" href=\"$outfile#$lastept\">$Key  $LastEpt</a></b><br>\n";
   # write back-references to project-overview :
   if ( $Key eq "PROGRAM" ) {
      print PRJFILE "<i>main entry</i>\n"; }
   else {
      if ( $ctxt = $cref{$lastept} ) {
         print PRJFILE "<i>called by </i>$ctxt\n"; }
      else {
         print PRJFILE "<i>never called</i>\n"; }
   }     
    
   # write entry point to outfile: provide named anchor and href
   printif "<a name=\"$lastept\" href=\"../$prjfile#$lastept\">";
   printchar "$Key $LastEpt"; printif "</a>";	    
}

sub parse_line {
   $lino = $lino + 1;

   # new_line already treated by splitting input into lines :
   s/\n//g; s/\r//g;

   # I do not like tab's in source code :
   if ( ! $allow_tabs && m/\t/ ) {
      errs "found TAB" }

   # full comment lines are handled once and for all :
   if ( m/^[Cc*!](.*)/ ) { 
      printif "<SPAN class=\"comment\"> #<i>";
      s/\t/   /g;
      printtext $1;
      printif "</i></SPAN>";
      printeol; 
      return;
      }

   # TAB's in columns 1-6 always mean: next char is in column 7 :
   if ( $allow_tabs ) {
      if (! s/^\t/      / )        {
      if (! s/^(.{1})\t/$1     /) {
      if (! s/^(.{2})\t/$1    /) {
      if (! s/^(.{3})\t/$1   /) {
      if (! s/^(.{4})\t/$1  /) {
      if (! s/^(.{5})\t/$1 /) {}}}}}}
      s/\t/   /g; # in columns 7pp: TAB replaced by three blanks
      }

   # statement label in columns 1-5
   $l = $_;
   $f = substr $l,0,5; 
   printnum $f;
           
   # continuation indicator in column 6
   $f = substr $l,5,1; 
   printtriv $f; # corrected for bug reported by Liam.Healy@nrl.navy.mil

   # statement field (..72 or ..132: would need command-line switch)
   $_ = substr $l,6;
   $Line=$_;
   while ( m/./ ) { # scan line by characters
      if ( s/^\ // ) { printif "&nbsp;" } # whitespace -> HTML escape
      elsif ( m/^([A-Za-z]\w*)(.*)/ ) {
	 # an identifier or a reserved word
	 if ( m/^(PROGRAM|SUBROUTINE|FUNCTION|ENTRY|BLOCK\ *DATA)(\ *)(\w*)(.*)/i ) {
            # a block name -> save in hash table
	    $Key=uc($1);	    
 	    $LastEpt = $3;     # original spelling
	    $lastept = lc($LastEpt); # canonical miniscules
	    my $rest=$4;           # rest of the line (possibly arguments)
	       if ( $Key eq "FUNCTION" ) {     # recognize function type
	          if  ( $Line =~ m/(\S*)(\ *)($Key)(.*)/ ) {
	             $fnctyp=$1;
	          } 
	       }
	       	       	       	       
	       if ( $rest =~ m/\((.*)\)/ ) {   # recognize arguments
	          $arg=$1;
	          $arg =~ s/\s+//g;
	       }	    

	    if ( $pass == 1 ) { 	    
               new_ept $lastept; 
               if ( ! $prjparam && $Key eq "PROGRAM" ) { # take project name from PROGRAM statement
                  if ( ! $prjname ) { $prjname = $LastEpt; } 
                  else {
                     errs "There are several PROGRAM statements - "
                  ."use the -t parameter to set the project title"; }
                  } 
               }
            elsif ( $pass == 3 ) { printept;}
	    $_ = $rest; 
	 }
         
	 elsif ( m/^(STRUCTURE)(\ *)\/(.*)\/(.*)/i ) {
            # recognize structure definition
	    $Key=uc($1);	    
 	    $LastEpt = "/$3/";     # original spelling
	    $lastept = lc($3);     # canonical miniscules without //
	    if ( $pass == 1 ) { new_ept $lastept; } elsif ( $pass == 3 ) { printept;}
	    $_ = $4; } 
	 
	 elsif ( m/^(INCLUDE)(\ *)'(.*)'(.*)/i ) {
            # definition file -> provide link
            printchar "$1$2";
#            ($fnam,$fext) = splitextension $3;
            ($fdir,$fnam,$fext) = splitfname $3;
            unless ($fext eq "f" || $fext eq "f77" || $fext eq "h" || $fext eq "inc") {
               warn "unexpected file name extension in included file $3\n" }
	    if ( $fext eq "inc" ) {$fnam="inc_$fnam"}; # prepend inc files with inc_
	    printif "\'<a href=\"$fnam.html\">$3</a>\'"; 
	    $_ = $4; } 
         else {
            # a known identifier ? -> provide link to where it was defined
	    my $key = $1;
	    $key =~ tr/A-Z/a-z/;
	    if ($fnam=$fref{$key}) { # Zuweisung, kein Test auf Gleichheit !
	       printif "<a href=\"$fnam.html#$key\">$1</a>"; 
               if ( $pass == 2 ) { new_call $key; }
               }
            else {
               printif $key; }
            $_ = $2; } 
	 }
      elsif ( s/^!// ) {
         # comment from here to end-of-line
         printif "<SPAN class=\"comment\"> !<i>";
         printtext $_;
         printif "</i></SPAN>"; 
         $_ = ""; }
      elsif ( s/^\'// ) {
         # a string
         unless ( m/^(.*?)'(.*)/ ) {
            errs "unmatched apostrophe in \`$2\'" }
         printif "<SPAN class=\"string\"> '";
         printtext $1;
         printif "'</SPAN>";
         $_ = $2; }
      elsif ( m/^\.(.*)/ && $c_like_comps ) {
         # nice symbols for comparison operators (C-like)
         if    ( s/^\.eq\.//i )  { printif "==" }
         elsif ( s/^\.ne\.//i )  { printif "!=" }
         elsif ( s/^\.gt\.//i )  { printif "&gt;" }
         elsif ( s/^\.lt\.//i )  { printif "&lt;" }
         elsif ( s/^\.ge\.//i )  { printif "&gt;=" }
         elsif ( s/^\.le\.//i )  { printif "&lt;=" }
         elsif ( s/^\.or\.//i )  { printif "||" }
         elsif ( s/^\.and\.//i ) { printif "&amp;&amp;" }
         elsif ( s/^\.not\.//i ) { printif "! " }
         else  { s/\.//;          printif "." } 
         }
      elsif ( m/^(<|>|&)/ ) {
         # at this place, special characters should never occur
         print "$_\n";
         errs "found $1 outside string or comment"; }
      else {
         # any other character : print out literally
         m /^(.)(.*)/;
         printif $1;
         $_ = $2; }
      }

      printeol; "<br>\n";
   }

### write HTML trivia :

sub print_HTML_header {
   @fstat = stat INFILE;
   $mdate = nicetime ($fstat[9]);
   printif "<html><head><title>$infile</title>\n";  
   printif "<LINK rel=\"StyleSheet\" href=\"../restraxsrc.css\" type=\"text/css\" title=\"restraxsrcstyle\">\n";
   printif "</head><body>\n";
   printif "<center><h2>$infile</h2></center>\n";
   printif "<i>Fortran project <a href=\"../$prjfile\">$prjname</a>, source module $infile</i>.<p>\n";
   printif "<i>Source module last modified on $mdate;</i><br>\n";
   $thistime = nicetime(time);
   printif "<i>HTML image of Fortran source automatically generated by $for2html on $thistime.</i>\n";
   printif "<p><hr><p><code>\n";
   }

sub print_HTML_epilogue {
   printif "<p><hr><p></body></html>\n";
   }

sub print_HTML_head_prj {
   print PRJFILE "<html><head><title>$prjname</title>\n";
   print PRJFILE "<LINK rel=\"StyleSheet\" href=\"restrax.css\" type=\"text/css\" title=\"restraxstyle\">\n";
   
   print PRJFILE "</head><body>\n";
   print PRJFILE "<center><h1>$prjname source overview</h1></center>\n";
   if ($urlparam) {
      print PRJFILE 
        "<i>Up: <a href=\"$urlparam\">$prjname home page</a>.</i><p>\n"; }
   $thistime = nicetime(time);
   print PRJFILE "<i>Fortran project overview automatically generated"
         ." by $for2html on $thistime,</i><br>\n";
#   print PRJFILE "<i>called as for2html $argvin.</i><br>\n";
   print PRJFILE "<p><hr><p><code>\n";
   }

sub print_HTML_epi_prj {
   print PRJFILE "</code></center><p><hr><p></body></html>\n";
   }

### PERL trivia :

sub nicetime {
   ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime (@_[0]);
   $wdname = (Sun,Mon,Tue,Wed,Thu,Fri,Sat)[$wday];
   $moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec)[$mon];
   $year = 1900 + $year;
   return "$wdname, $mday $moname $year, ".(sprintf "%2u",$hour)
      .":".(sprintf "%02u",$min);
   }

##### MAIN PROGRAM #####

$SRC="src/"; # default subdirectory for source files in html

com_lin_pars;

print "first pass\n"; # learn entry points
$pass = 1; 
foreach $infile (@ARGV) {
   print "$infile\n";
   open_infile;
   while (<INFILE>) { parse_line }
   close INFILE;
   };

#print "references: \n";
#print "$fref{\"reclat\"} \n";
#exit;

if ($prjparam) { $prjname = $prjparam; } elsif ( ! $prjname) { $prjname = "PROJECT"; }
if ($dirparam) { $dirname = "$dirparam/"; } else { $dirname = "$prjname/" ; }

#print "$prjname $prjparam \n";
#print "$dirname $dirparam \n";
#exit;

if (! ( $prjname || $prjparam )) {
   die "for2html found no PROGRAM statement - "
     ."use -t to set the project title\n"; }

print "second pass\n"; # learn calls to entry points
$pass = 2; 
foreach $infile (@ARGV) {
   print "$infile\n";
   open_infile;
   while (<INFILE>) { parse_line }
   close INFILE;
   }

print "third pass \n"; # write out
$pass = 3;
open_prjfile;

print_HTML_head_prj;
foreach $infile (@ARGV) {
   print "$infile\n";
   open_infile;
   open_outfile;
   print PRJFILE 
     "<li><b>Source Module <a href=\"$outfile\">$infile</a></b><br><ul>\n";

   print_HTML_header;
   while (<INFILE>) { parse_line }
   print_HTML_epilogue;

   close INFILE;
   close OUTFILE;
   print PRJFILE "</ul>\n";
   }
print_HTML_epi_prj;
close PRJFILE;

##### EOF #####