#!/bin/sh
#  -*-Perl-*-  (for Emacs)    vim:set filetype=perl:  (for vim)
#======================================================================#
# Run the right perl version:
if [ -x /usr/local/bin/perl ]; then
  perl=/usr/local/bin/perl
elif [ -x /usr/bin/perl ]; then
  perl=/usr/bin/perl
else
  perl=`which perl| sed 's/.*aliased to *//'`
fi
#
exec $perl -x -S $0 "$@";     # -x: start from the following line
#======================================================================#
#! /Good_Path/perl -w 
# line 17
#
# Name:   mkdummyinc
# Author: Antony Mee (A.J.Mee@ncl.ac.uk)
# Started:   18-Jul-2006
# CVS: $Id$
# Usage:
#   mkdummy [-o outfile] -d dummyfile < source_file \n
# Description:
#
#   Output is written as a Fortran program and supposed to end up in the
#   local file src/$(XXXXXX_MODULE)_dummies.inc .
# Example:
#     mkdummy -d nospecial.f90 -s special/neutron_star.f90 > special_dummies.inc
#
# History:
#   17-jul-06/tony: Created
#   08-may-09/wlad: Commented and fixed problem with last dummy 
#                   subroutine carrying the include line with it
#
# ---------------------------------------------------------------------- #
my $fortran_routine  = '^\s*(subroutine|function)\s*([^\s(])\s*\(.*?\).*end $1 $2\s*$';
# ---------------------------------------------------------------------- #
#
use strict;
use Getopt::Long;
#
my @implemented;
#
(my $cmdname = $0) =~ s{.*/}{};
#
## Process command line
#
my (%opts);	# Variables written by GetOptions
GetOptions(\%opts,
	   qw( -h   --help
	       -o=s --output=s
	       -d=s --dummy=s
	       -s=s --src=s
                               ));
#
die usage() if ($opts{h} || $opts{help});
#
my $srcfile = ($opts{s} || $opts{src} || "-");
#
my $dummyfile = ($opts{d} || $opts{dummyfile} || die "no dummy specified");
#
my $outfile = ($opts{o} || $opts{output} || "-");
open(OUT, "> $outfile") or die "Can't open $outfile for writing";
#
find_implemented_routines($srcfile);
write_dummies($dummyfile);
#
# ---------------------------------------------------------------------- #
#
sub usage {
# Extract description and usage information from this file's header.
    my $thisfile = __FILE__;
    local $/ = '';              # Read paragraphs
    open(FILE, "<$thisfile") or die "Cannot open $thisfile\n";
    while (<FILE>) {
	# Paragraph _must_ contain `Description:' or `Usage:'
        next unless /^\s*\#\s*(Description|Usage):/m;
        # Drop `Author:', etc. (anything before `Description:' or `Usage:')
        s/.*?\n(\s*\#\s*(Description|Usage):\s*\n.*)/$1/s;
        # Don't print comment sign:
        s/^\s*# ?//mg;
        last;                        # ignore body
    }
    $_ or "<No usage information found>\n";
}
# ---------------------------------------------------------------------- #
sub is_implemented {
    my $subname = shift;
#
    foreach my $name (@implemented) {
      return 1 if ($subname =~ /^\s*$name\s*$/i);
    }
    return 0;
}
# ---------------------------------------------------------------------- #
sub find_implemented_routines {
    my $file = shift;
    open(SRC,"<$file") || die "cannot open $file";
#
    while( my $line = <SRC> ) {
	  chop($line);
	  my $lout = $line;
	  if(  $line =~ /^\s*subroutine/i || $line =~ /^\s*function/i ||
          	 $line =~ /^\s*integer\s*function/i ) {
	      my $subname;
	      my @words = split " ", $line;
	      if( $words[1] =~ /^\s*function/i ) {
	          ( $subname = $words[2] ) =~ tr/A-Z/a-z/;	#lower case
	      } else {
	          ( $subname = $words[1] ) =~ tr/A-Z/a-z/;	#lower case
	      }
	      $subname =~ s/\s//g;			#remove whitespace
	      $subname =~ s/\(.*$//;
          push @implemented, $subname
	  }
    }
#
    close(SRC);
}
# ---------------------------------------------------------------------- #
sub write_dummies {
    my $file = shift;
    my $write_line=0;
    open(SRC,"< $file") || die "cannot open $file";
    print OUT 
"!***********************************************************************
!
!                 AUTOMATICALLY GENERATED FILE 
!            ALL CHANGES TO THIS FILE WILL BE LOST
!
! File created by $cmdname from:
!   Source file:  $srcfile
! and
!   Dummy file:   $dummyfile
!
!***********************************************************************
";
#
# Get the input file, each line is read into $line
#
    while ( my $line = <SRC> ) {
#
# Chop the last character, which is "\n", the new line carrier command. 
# This effectively turns the input into a serial file. The same would 
# happen using chomp($line), which is actually a more transparent usage. 
# The difference between chop() and chomp() is that chomp only deletes the
# "\n" character, while chop deletes the last character whatever it may be.  
#
	  chop($line);
#
# Define lout
#
	  my $lout = $line;
#
# Test the line. If is starts with subroutine, function, or integer followed 
# by function (why this last thing?). The "^\s*" stuff means 
#   ^: beggining of line, 
#   *: zero or more of the last character 
# So, "/^\s*subroutine/i" in english means "search for a line that starts 
# with subroutine, ignoring whatever blank spaces between the start of the 
# line and 'subroutine'" 
#
	  if(  $line =~ /^\s*subroutine/i || $line =~ /^\s*function/i ||
          	 $line =~ /^\s*integer\s*function/i ) {
#
# Define subname
#
	      my $subname;
#
# Split line using the null string as separators. Put the pieces into 
# a "word" array ($ is for scalars, @ for arrays). This means that 
# for $line="subroutine register_special", we have array[0]="subroutine", 
# and array[1]="register_special".
# 
	      my @words = split " ", $line;
#
# Get the name of the subroutine
#
	      if( $words[1] =~ /^\s*function/i ) {
	          ( $subname = $words[2] ) =~ tr/A-Z/a-z/;	#lower case
	      } else {
	          ( $subname = $words[1] ) =~ tr/A-Z/a-z/;	#lower case
	      }
	      $subname =~ s/\s//g;			#remove whitespace
	      $subname =~ s/\(.*$//;
#
# Flag the line for writing if the subroutine is not implemented in
# the input file. This flag will follow all further lines until another
# another line starting with "subroutine" or "function" is flagged and 
# tested....
#
          $write_line = ! is_implemented($subname);
	  }# endif
#
# Go printing...
#
      print OUT "$lout\n" if ($write_line);
#	  
# Stop printing if it reaches endsubroutine or endfunction. This fix is needed because 
# the last subroutine of the dummy file, if flagged (i.e., if not implemented on the 
# input file), would continue printing until the end of the file. It would then print 
# the line containing "input XXX_dummies.inc" and "endmodule XXX" onto the XXX_dummies.inc. 
# This, in turn, causes an infinite loop. 
#
	  if ($write_line && ($line =~ /^\s*endsubroutine/i || $line =~ /^s\*function/i)) {
#
	      print OUT 
"!*********************************************************************** \n";
	      $write_line = 0;
	  }      # End of if
    }            # End of while
#
    close(SRC);
}                # End of sub
# End of file mkdummyinc