#!/usr/bin/perl
#
# Make a source code listing.
#
use Getopt::Long;
use File::Basename;
use Cwd;
use Text::Tabs;
#
($progname = $0) =~ s!(.*)/!!;
$outfile = "$progname.list";
&GetOptions(
   "m|model=s"     => \$model,
   "tgcmroot:s"    => \$tgcmroot,
   "usr_srcdirs:s" => \$usr_srcdirs,
   "o|output:s"    => \$outfile,
   "h|help"        => \$help
) or usage();
if ($help) { usage(); } # provide usage if help was requested
# 
# Output file name (default is MkList.list, see above):
#
if (defined $model) { $outfile = "$model.list"; }
#
# Check for args:
#
while (@ARGV) {
  $argfile = shift;
  if ($argfile ne $outfile) { push(@argfiles,$argfile); }
}
#print "argfiles = @argfiles\n";
#
# Order of precedence for determining tgcmroot is: 
#   1: Option to this program (-tgcmroot)
#   2: Environment variable $TGCMROOT
#   3: The default directory on hao or scd systems.
#  
$tgcmroot_default_hao = "/home/tgcm";
$tgcmroot_default_scd = "/fis/hao/tgcm";
if (! defined $tgcmroot or $tgcmroot eq "") {
  if (defined $ENV{TGCMROOT}) { $tgcmroot = $ENV{TGCMROOT}; 
    print "\n$0: Using tgcmroot from TGCMROOT env var: $tgcmroot\n";
  } elsif (-d $tgcmroot_default_hao) { $tgcmroot = $tgcmroot_default_hao;
    print "\n$0: Using default tgcmroot at HAO: $tgcmroot\n";
  } elsif (-d $tgcmroot_default_scd) { $tgcmroot = $tgcmroot_default_scd;
    print "\n$0: Using default tgcmroot at SCD: $tgcmroot\n"; 
  } else { 
    die "\n>>> $0: Could not determine tgcmroot (please use -tgcmroot option)\n\n";
  }
}
#
# @paths: list of directories in which to find source code:
#
if (-d "$tgcmroot/$model/src") { push(@paths,"$tgcmroot/$model/src"); }
if (defined $usr_srcdirs) {
  if ($usr_srcdirs eq '') { 
    print ">>> $progname: empty usr_srcdirs\n";
  } else {
    my @dirs = split(',', $usr_srcdirs);
    while (my $dir = shift @dirs) {
      if (-d $dir) { 
        $path = absolute_path($dir);
        push(@paths,"$path"); 
      } else {
        die "\n>>> $progname: Cannot find user source directory $dir\n";
      }
    }
  }
}
#
# %srcfiles is a hash of arrays of source files found in each directory:
#
%srcfiles = ();
foreach $dir (@paths) {
  $dir =~ s!/?\s*$!!;  # remove / and any whitespace at end of directory name
  ($dir) = glob $dir;  # Expand tildes in path names.
  @filepaths = (glob("$dir/*.[Fch]"), glob("$dir/*.F90"));
  @filenames = '';
  foreach $file (@filepaths) { 
    $filename = basename($file);
    push(@filenames,$filename);
  }
  shift @filenames; 
  $srcfiles{$dir} = [ @filenames ]; # list of files found in $dir
}
#
# Add files given as arguments:
#
if (@argfiles) {
  $srcfiles{'argfiles'} = [ @argfiles ];
}
#
# Print to stdout:
#
foreach $dir (sort keys %srcfiles) {
  $nfiles = $#{ $srcfiles{$dir} } + 1;
  if ($dir ne 'argfiles') {
    print "\nFound $nfiles source files in directory $dir:\n";
  } else {
    print "\n$nfiles files were given as arguments to $progname:\n";
  }
  print "@{ $srcfiles{$dir} }\n";
}
#
# Open output file:
#
open(LIST,"> $outfile") || die "\n$0: Cannot open output file $outfile\n";
print "\nOpened output file $outfile\n";
$date = `date` ; chop $date;
$cwd = getcwd();
$user  = $ENV{"LOGNAME"};
print LIST 
  "\nSource code listing of $model created by $progname $date\n";
print LIST "TGCMROOT = $tgcmroot  MODEL = $model\n";
print LIST "Executed by $user from $cwd\n";
#
foreach $dir (sort keys %srcfiles) {
  $nfiles = $#{ $srcfiles{$dir} } + 1;
  if ($dir ne 'argfiles') {
    print LIST "\nFound $nfiles source files in directory $dir:\n";
  } else {
    print LIST "\nFound $nfiles files given as arguments to $progname:\n";
  }
  foreach $i (0..$nfiles-1) {
    if ($i % 4 == 0) {
      printf LIST "%-20s%-20s%-20s%-20s\n",
       $srcfiles{$dir}[$i],$srcfiles{$dir}[$i+1],
       $srcfiles{$dir}[$i+2],$srcfiles{$dir}[$i+3];
    }
  }
}
select(STDOUT);
$~ = "STDOUT";

print LIST "\n";
foreach $dir (sort keys %srcfiles) {
  if ($dir eq 'argfiles') {
    print LIST 
      "\n>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n";
    print LIST "Begin listing of source files given as arguments to $progname\n";
    print LIST 
      "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n\n";
  } else {
    print LIST 
      "\n>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n";
    print LIST "Begin listing of source files in directory $dir\n";
    print LIST 
      "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n\n";
  }
  foreach $file (@{ $srcfiles{$dir} }) {
    if ($file) {
      if ($dir eq 'argfiles') {
        $filepath = $file;
      } else {
        $filepath = "$dir/$file";
      }
      &addfile($filepath);
    }
  }
}

#-------------------------------------------------------------------------
sub usage {
  die <<EOF;

DESCIPTION
  $0 makes a listing of source code for the requested model.

SYNOPSIS
  $0 [options] [file1,file2,...]

OPTIONS
  -model	Name of requested model. If not provided, listing will
                be made of files given as arguments, plus any source
                code in -usr_srcdirs, if provided. 

  -tgcmroot  	TGCM root distribution containing \$model subdirectory.
                If tgcmroot is not provided, program will use env var 
                TGCMROOT. If env var is not set, program will use default 
                HAO or SCD tgcmroot directories. 

                Note \$tgcmroot/\$model dir should contain src/ and scripts/ 
                subdirectories containing source code and utility scripts
                respectively.

  -usr_srcdirs  List of comma-separated directories to be included in the
                listing (e.g., dirs containing new or modified source).
                (no whitespace, please)

  -output       Output file name. Default is $model.list, if -model was given,
                otherwise default is MkList.list.

  -help		Print usage message and quit.

ARGUMENTS
  Optional list of additional files to be included in the listing.

EXAMPLES:
  MkList -model=tiegcm                      # make listing of source code for model tiegcm 
  MkList -model=tiegcm -usr_srcdirs=modsrc  # make listing of tiegcm, plus files in modsrc
  MkList -output=mylisting *.h *.F  # make listing of *.h and *.F files in current directory
  MkList -usr_srcdirs=modsrc        # make listing of files in modsrc

EOF
}
#-------------------------------------------------------------------------
sub addfile {
  my ($file) = @_;
  my $lineref = 1;
  my $neq = int((90-length($file))/2);
  my $filename = basename($file);
  print LIST "=" x $neq, $file, "=" x $neq, "\n";
#
# Write code with line references:
#
  open(FILE,"< $file") ||
    die "\n$0: Cannot open file $file\nWARNING: output file $outfile ",
      "may be incomplete\n\n";
  $~ = "LIST";                          # for formats
  select(LIST);
  format LIST =
@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<
    $code, $lineref
.
  if ($lineref) {                       # add line refs
    while (<FILE>) {
      $code = expand($_);               # expand tabs to spaces
      chop $code;
      $lineref = ($filename . ".") . $.;    # line reference
      write;
    }
  } else {                              # no line refs
    while (<FILE>) {
      $code = expand($_);
      print $code;
    }
  }  
  close FILE;
  select(STDOUT);
  $~ = "STDOUT";

} # end sub addfile
#-----------------------------------------------------------------------
sub absolute_path {
#
# Convert a pathname into an absolute pathname, expanding any . or .. characters.
# Assumes pathnames refer to a local filesystem.
# Assumes the directory separator is "/".
#
  my $path = shift;
  my $cwd = getcwd();  # current working directory
  my $abspath;         # resulting absolute pathname
#
# Strip off any leading or trailing whitespace.  
# (This pattern won't match if there's embedded whitespace.
#
  $path =~ s!^\s*(\S*)\s*$!$1!;
#
# Convert relative to absolute path.
#
  if ($path =~ m!^\.$!) {          # path is "."
      return $cwd;
  } elsif ($path =~ m!^\./!) {     # path starts with "./"
      $path =~ s!^\.!$cwd!;
  } elsif ($path =~ m!^\.\.$!) {   # path is ".."
      $path = "$cwd/..";
  } elsif ($path =~ m!^\.\./!) {   # path starts with "../"
      $path = "$cwd/$path";
  } elsif ($path =~ m!^[^/]!) {    # path starts with non-slash character
      $path = "$cwd/$path";
  }
  my ($dir, @dirs2);
#
# The -1 prevents split from stripping trailing nulls
# This enables correct processing of the input "/".
#
  my @dirs = split "/", $path, -1;   

  my $i;
  # Remove any "" that are not leading.
  for ($i=0; $i<=$#dirs; ++$i) {
      if ($i == 0 or $dirs[$i] ne "") {
          push @dirs2, $dirs[$i];
      }  
  }
  @dirs = ();

  # Remove any "."
  foreach $dir (@dirs2) {
      unless ($dir eq ".") {
          push @dirs, $dir;
      }  
  }
  @dirs2 = ();

  # Remove the "subdir/.." parts.
  foreach $dir (@dirs) {
    if ( $dir !~ /^\.\.$/ ) {
        push @dirs2, $dir;
    } else {
        pop @dirs2;   # remove previous dir when current dir is ..
    }
  }  
  if ($#dirs2 == 0 and $dirs2[0] eq "") { return "/"; }
  $abspath = join '/', @dirs2;
  return( $abspath );
}