# getlib.pl
#
# Copyright (c) 1993, 1994, 1995, 1996, 1997, 1998, 1999 by RIPE NCC
#
# All Rights Reserved
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted,
# provided that the above copyright notice appear in all copies and that
# both that copyright notice and this permission notice appear in
# supporting documentation, and that the name of the author not be
# used in advertising or publicity pertaining to distribution of the
# software without specific, written prior permission.
#
# THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS; IN NO EVENT SHALL
# AUTHOR BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY
# DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
# AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
#
# $Id: getlib.pl,v 2.3 1999/10/06 16:41:10 marek Exp $
#
#	$RCSfile: getlib.pl,v $
#	$Revision: 2.3 $
#	$Author: marek $
#	$Date: 1999/10/06 16:41:10 $

# Usage: 
#
# getlib [ FileName ] [ var1=1 [ var2=2 ] ... ]
#
# - program reads data from a file (or STDIN if no filename is specified)
#   and substitutes lines of the form:
#
#   GETLIB FileName [ SubRoutine ]
#
#   by the "SubRoutine" in file "FileName" or
#   with the complete file if no "SubRoutine" is specified
#
# - The program substitutes variables when they are specified
#   on the commandline. One may use variabels in the "GETLIB" lines.
#
# Output is printed to STDOUT
#
#
# *** Important notes ***:
#
# Perl5:
#
# - It will substitute 'my' function calls by 'local' if we are not 
#   running perl5 or higher
#
# - The variable $PERL5OPTIONS will be substituted by empty space 
#   with perl4 and when not defined or the variable value with perl5
#   and higher 
#
#
# Finding subroutines:
#
# Program can only extract the subroutine if it contains an equal number 
# of '{' and '}' braces!!!!
#
#
# Solaris patch:
#
# The program will also patch:
# 'open(FILEHANDLE, "<...' ->  'open(FILEHANDLE, "+<...' 
# 
# when SOCK_STREAMVALUE==2 (only solaris has this value defined as 2 and
#                           it will not really hurt if some other obscure 
#                           system has it the same since the code is 
#                           compatible!)
#
# this is done to get the 'fcntl' -> 'flock' emulated locks properly working 
#


# special variable
#
# it is only substituted when running perl5 or higher

$PERL5OPTIONS="PERL5OPTIONS";


# match patterns with \n's

local($*)=1;


sub readfile {
   local($filename)=@_;
   
   local($filedata)="";
   
   if ($filename) {
      open(FILEDATA, "<".$filename);
      $filedata=join("", <FILEDATA>);
      close(FILEDATA);
   }
   else {
      $filedata=join("", <STDIN>);
   }
   
   # print STDERR $filedata;
   
   # substitute the vars

   local($tmp);
   
   foreach $var (keys(%var)) {
      
      next if ($var eq $PERL5OPTIONS);
      
      $tmp=$var;
   
      $tmp=~ s/([^\w\s])/\\$1/g;
   
      # print STDERR "-$var-$tmp-$var{$var}-\n";
   
      $filedata=~ s/$tmp/$var{$var}/g;
   
   }

   # do the solaris patch

   if ($var{"SOCK_STREAMVALUE"}==2) {
      $filedata=~ s/(open\s*\(\s*[^\s\,]+\s*\,\s*)(\"|\')(\s*)\</$1$2$3\+\</g;  
   }
   
   # do the perl5 patch
   
   local($version)= ($] =~ /(^|[^\d\.])(\d+)\.\d/)[1];
   
   if ($version<5) {
      
      $filedata=~ s/(^|\s)my(\s|\s*\()/$1local$2/g;
      
      $filedata=~ s/$PERL5OPTIONS//g;
      
   }
   else {
      
      $filedata=~ s/$PERL5OPTIONS/$var{$PERL5OPTIONS}/g;
      
   }
   
   return $filedata;

}

# here starts the main program

local($var,
      $data,
      $filedata,
      $rcsdata,
      $commentdata,
      $libfile,$libfiledata,
      $routine,$routinedata);


local(%alreadyincluded)=();

local(%vars)=();

local($file)="";


foreach $var (@ARGV) {
   if (! -f $var) {
      if ($var=~ /^\s*([^\s\=]+)\s*\=(.*)$/) {
         $var{$1}=$2;
         # print STDERR "-$1-$2-\n";
      }
      else {
         print STDERR "input file (\'$var\') couldn\'t be found\nor is not a valid variable";
         exit 1;
      }
   }
   else {
      if ($file) {
         print STDERR "More then one input file (\'$file\' \& \'$var\') specified\non command line";
         exit 1;
      }
      else {
         $file=$var;
      }
   }
}

# read the datafile & substitute the vars & do the Solaris patch

$filedata=&readfile($file);


# substitute the subroutines

while ($filedata=~ s/(^|\s)GETLIB\s+([^\s\;]+)\s*([^\s\;]*)\s*\;/\%GETLIBISHERE\%/) {
    
    $libfile=$2;
    $routine=$3;
    
    # read the libfile & substitute the vars & do the Solaris patch
    
    if (-f $libfile) {
       
       # don't include files twice
       #
       # note: this is not completely safe
       #
       #       it allows us to include a 'routine' from 'file'
       #       and still include the whole 'file' later again
       #       so that 'routine' is defined twice
       #
       #       it would take too much time to sort this out now.
       
       if (($alreadyincluded{$libfile}) ||
           (($routine) && ($alreadyincluded{$libfile." ".$routine}))) {
           
          $filedata=~ s/\%GETLIBISHERE\%//;
          
          next;
          
       }
       
       if ($routine) {
          
          $alreadyincluded{$libfile." ".$routine}=1;
       
       }
       else {
          
          $alreadyincluded{$libfile}=1;
       
       }
       
       $libfiledata=&readfile($libfile);

    }
    else {
       
       print STDERR "Cannot find file \'$libfile\' as requested in \'$ARGV[0]\':\n\'GETLIB $libfile $routine\'\n";
       
       exit 1;
       
    }
    
    if ($routine) {
    
       # check if we can find comment before the routine
       
       $commentdata="";
       
       while ($libfiledata=~ s/(\n|^)([^\n\S]*\#.*\n)(\s*sub\s+$routine\s)/\n$3/) { 
                
          $commentdata=$2.$commentdata;    
             
       }  
       
       # get the RCS header but make sure that the comment was not
       # the RCS header already...
       
       if ($commentdata!=~ /(\n|^)[^\n\S]*\#\s*\$RCSfile\:.*\n/) {
       
          $rcsdata="";
          
          while ($libfiledata=~ s/(\n|^)([^\n\S]*\#.*\n)([^\n\S]*\#\s*\$RCSfile\:.*\n)/\n$3/) { 
                
              $rcsdata=$2.$rcsdata;    
          
          }
             
          $libfiledata=~ /(\n|^)([^\n\S]*\#\s*\$RCSfile\:.*\n)/;
             
          $rcsdata.=$2;
             
          while ($libfiledata=~ s/\n([^\n\S]*\#\s*\$RCSfile\:.*\n)([^\n\S]*\#.*\n)/\n$1/) { 
                
             $rcsdata.=$2;    
             
          }
               
       }
       
       # get the routine
       
       # the following is a kludge to extract the routine but I really
       # don't see any other way to do it (or to lazy to find one ;-)
    
       if ($libfiledata=~ s/^(.*\n)*\s*(sub\s+$routine\s+\{[^\}]*\})//) {
       
          $routinedata=$2;
          
          while (scalar($routinedata=~ s/\{/\{/g) != scalar($routinedata=~ s/\}/\}/g)) {
            
             if ($libfiledata=~ s/^([^\}]*\n)*([^\}]*\})//) {
          
                $routinedata.=$1.$2;
             
             }
             else {
                
                print STDERR "Found \'$routine\' in \'$libfile\', but couldn\'t extract it\n";
       
                exit 1;
             
             }
          
          }
       
        }
        else {
    
           print STDERR "Couldn't find \'$routine\' in \'$libfile\'\n";
       
           exit 1;
    
       }
       
       $data="\n#\n#\t\'$routine\' is included from the file \'$libfile\'\n#\n\n\n";
       
    }
    else {
       
       $data="\n#\n#\tThe file \'$libfile\' is included here\n#\n\n\n";
       
    }
    
    $data.=$rcsdata."\n\n" if ($rcsdata);
    
    $data.=$commentdata."\n\n" if ($commentdata);
    
    if ($routine) {
       $data.=$routinedata."\n\n";
    }
    else {   
       $data.=$libfiledata."\n\n";
    }
    
    $data.="#\n#\tEnd of included \'$libfile\' data is here\n#\n";
    
    $filedata=~ s/\%GETLIBISHERE\%/$data/;
    
    # print "*", $rcsdata, "*", $commentdata, "*", $routinedata, "*";
}

print $filedata;
