#!/usr/bin/perl -w

#############################
# written by Sergei Steshenko
#############################

#  Copyright 2001 Sergei Steshenko 
#  (
#   sergei_steshenko@pop3.ru
#   sergei_steshenko@softhome.net
#  ).
#
#  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 of the License, 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 this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.


$|=1;

use FileHandle;
use DirHandle;

require File::Basename;
require File::Path;
require Cwd;
# I do not want the above to export names, that's why 'require',
# not 'use'

use vars
(
 '%PerlPreProcessorConfigHash',
 '$__global_input_file',
 '$__global_input_file_fh',
 '$__perl_begin_marker_line_number' # this variable is not used by the script
                                    # itself, but may be used by user provided
                                    # Perl code to understand at what line
                                    # in current input file Perl begin marker
                                    # is located
);

use strict;

my $_tool_name;
my $_tool_path;
($_tool_name, $_tool_path, undef) = &File::Basename::fileparse($0);


my $_prompt="executing => ";
my $_error_marker=': ERROR :';
my $_info_marker=': INFO :';

my %_args_hash;

my $_user_sub_number=0;
$_args_hash{recursion_level}=0;

my $_leading_whitespaces;

my $_spacer;
##########################################
while(defined(my $argv_item=shift(@ARGV)))
##########################################
  {
  # there may be some '-' options, they should be processed first
  if($argv_item=~m/^--?(\w+)/)
    {
    my $option=$1;
    if($option eq 'recursion_level')
      {
      my $value=shift(@ARGV);
      if(!defined($value) || !($value=~m/^\d+$/))
        {
        die "$_tool_name $_error_marker '-recursion_level' should be followed by unsigned integer, died";
        }

      $_args_hash{recursion_level}=$value;
      }
    elsif($option eq 'config_hash_file')
      {
      my $config_hash_file=shift(@ARGV);
      if(!defined $config_hash_file)
        {
        die "$_tool_name $_error_marker '-config_hash_file' should be followed by file name, died";
        }

      $_args_hash{config_hash_file}=$config_hash_file;
      require $_args_hash{config_hash_file};
      }
    elsif($option eq 'cleanup')
      {
      $_args_hash{cleanup}='';
      }
    else
      {
      die "$_tool_name $_error_marker command line syntax error, USAGE:\n\n$0 [-config_hash_file <file_containing_configuration_hash>] [-cleanup] [-recursion_level <recursion_level_to_begin_with>] <files_to_process>\n\ndied";
      }

    next;
    }

  $_spacer='  ' x $_args_hash{recursion_level};

  if(!defined $__global_input_file)
    {
    warn $_spacer,"$_tool_name - Copyright 2001 Sergei Steshenko. This program is free software (GNU General Public License).\n";
    warn $_spacer,"$_tool_name $_info_marker BEGINNING OF processing files from command line\n";

    unless(exists $_args_hash{config_hash_file})
      {
      require "$_tool_path/PerlPreProcessorConfigHash.prl";
      }

    if(
       !(-e $PerlPreProcessorConfigHash{work_subdirectory})
    && &my_system
       (
        $_prompt,                                                     # $_prompt,
        "\\mkdir -p $PerlPreProcessorConfigHash{work_subdirectory}", # $command
       ) != 0
      )
      {
      die "$_tool_name $_error_marker could not create '$PerlPreProcessorConfigHash{work_subdirectory}' directory";
      }
    }

  $__global_input_file=$argv_item;
  $__global_input_file_fh=new FileHandle $__global_input_file=$argv_item, 'r';
  if(!defined $__global_input_file_fh)
    {
    die "cannot open '$__global_input_file' input file for reading, died";
    }

  warn $_spacer,"$_tool_name $_info_marker STARTED  processing '$__global_input_file' file\n";

  &process_one_file();

  close($__global_input_file_fh);

  warn $_spacer,"$_tool_name $_info_marker FINISHED processing '$__global_input_file' file\n";
  } # while(defined(my $argv_item=shift(@ARGV)))

if(defined $__global_input_file)
  {
  warn $_spacer,"$_tool_name $_info_marker END OF       processing files from command line\n";
  }
else
  {
  die "$_tool_name $_error_marker no files to process were specified on command line, try $0 -help\n,died";
  }

exit(0);
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------


####################
sub process_one_file
####################
{
my $user_sub_file;
my $user_sub_file_fh;

my $input_file_line_number=0;

my $state=0;
my $print_as_is_state=$state++;
my $in_user_perl_code_state=$state++;

$state=$print_as_is_state;
#######
for(;;)
#######
  {
  my $line = <$__global_input_file_fh>;
  if(!defined $line)
    # end of file
    {
    last;
    }

  $input_file_line_number++;

  ################################
  if($state == $print_as_is_state)
  ################################
    {
    (my $line_with_perl_begin_marker,$_leading_whitespaces)=
    &{$PerlPreProcessorConfigHash{perl_begin_marker_sub}}($line);

    if($line_with_perl_begin_marker)
      {
      $__perl_begin_marker_line_number=$input_file_line_number;

      if(!defined $_leading_whitespaces)
        {
        $_leading_whitespaces='';
        }

      if($PerlPreProcessorConfigHash{keep_perl_markers})
        {
        print $line;
        }

      $user_sub_file=
      $PerlPreProcessorConfigHash{work_subdirectory}.'/'.
      $PerlPreProcessorConfigHash{user_sub_prefix}.
      '.'.
      sprintf("%02x",$_args_hash{recursion_level}).
      '.'.
      sprintf("%04x",$_user_sub_number++).
      '.prl'
      ;
      $user_sub_file_fh=new FileHandle $user_sub_file, 'w';
      if(!defined $user_sub_file_fh)
        {
        die "$_tool_name $_error_marker could not open '$user_sub_file' file for writing, died";
        }
      print $user_sub_file_fh <<EOF;
# the following subroutine was generated by
# $0
# from
# $__global_input_file
# input file, from user Perl code at line number $input_file_line_number
use strict;
EOF
      print $user_sub_file_fh "sub\n{\n";

      $state=$in_user_perl_code_state;
      next;
      }

    (
    my $line_with_perl_one_liner_marker,
    $_leading_whitespaces,
    my $perl_code
    )=&{$PerlPreProcessorConfigHash{perl_one_liner_marker_sub}}($line);

    if($line_with_perl_one_liner_marker)
      {
      $__perl_begin_marker_line_number=$input_file_line_number;
      
      if(!defined $_leading_whitespaces)
        {
        $_leading_whitespaces='';
        }

      if($PerlPreProcessorConfigHash{keep_perl_markers})
        {
        print $line;
        }

      $user_sub_file=
      $PerlPreProcessorConfigHash{work_subdirectory}.'/'.
      $PerlPreProcessorConfigHash{user_sub_prefix}.
      '.'.
      sprintf("%02x",$_args_hash{recursion_level}).
      '.'.
      sprintf("%04x",$_user_sub_number++).
      '.prl'
      ;
      $user_sub_file_fh=new FileHandle $user_sub_file, 'w';
      if(!defined $user_sub_file_fh)
        {
        die "$_tool_name $_error_marker could not open '$user_sub_file' file for writing, died";
        }
      print $user_sub_file_fh <<EOF;
# the following subroutine was generated by
# $0
# from
# $__global_input_file
# input file, from user Perl code at line number $input_file_line_number
use strict;
sub
{
$perl_code
}
EOF
      close($user_sub_file_fh);

      my $code_ref=require $user_sub_file;

      &{$code_ref}; # subroutine which has just been generated from
                    # user code is now called
      use strict;

      if(
         exists $_args_hash{cleanup}
      && unlink($user_sub_file) == 0
        )
        {
        die "$_tool_name $_error_marker could not delete '$user_sub_file' file, died";
        }

      next;
      } # if($line_with_perl_one_liner_marker)

    print $line; # input file line is printed as is
    }
  #########################################
  elsif($state == $in_user_perl_code_state)
  #########################################
    {
    if(&{$PerlPreProcessorConfigHash{perl_end_marker_sub}}($line))
      {
      print $user_sub_file_fh "}\n";

      close($user_sub_file_fh);

      my $code_ref=require $user_sub_file;

      &{$code_ref}; # subroutine which has just been generated from
                    # user code is now called
      use strict;

      if(
         exists $_args_hash{cleanup}
      && unlink($user_sub_file) == 0
        )
        {
        die "$_tool_name $_error_marker could not delete '$user_sub_file' file, died";
        }

      $state=$print_as_is_state;
      undef($_leading_whitespaces);

      if($PerlPreProcessorConfigHash{keep_perl_markers})
        {
        print $line;
        }

      next;
      }
    else
      # perl_end marker not encountered, so user Perl code should be stored
      # as is
      {
      print $user_sub_file_fh $line;
      }
    }
  } # for(;;)
}
#--------------------------------------------


#############
sub my_system
#############
{
my
(
 $_prompt,
 $command
)=@_;

warn $_prompt,$command,"\n";
# ^
# | - it MUST be to STDERR, not STDOUT, since the script output is
# |   printed to STDOUT. Anyway, UNIX(R) traditions should be respected.
system($command);
}
#--------------------------------------------


##########################
sub print_with_indentation
##########################
{
my
(
 $dont_indent_marker,
 $text_to_print,
)=@_;

my $line;
#########################################
foreach $line(split("\n",$text_to_print))
#########################################
  {
  if(defined($dont_indent_marker)  && index($line,$dont_indent_marker) == 0)
    {
    print substr($line,length($dont_indent_marker)),"\n";
    }
  else
    {
    print $_leading_whitespaces,$line,"\n";
    }
  } # foreach $line(split("\n",$text_to_print))
}
#--------------------------------------------


###########
sub include
###########
{
my
(
 $filename,
 $dir_list_array_ref,
 $forget_context,
)=@_;


my @dir_list=
defined $dir_list_array_ref ? @{$dir_list_array_ref} : ('');


my $file_with_path;

my $dir;
#######################
foreach $dir(@dir_list)
#######################
  {
  $file_with_path=$dir eq '' ? $filename : $dir.'/'.$filename;
  if(-e $file_with_path)
    {
    last;
    }
  } # foreach $dir(@dir_list)


if(!defined $file_with_path)
  {
  if(scalar(@dir_list) == 1 && $dir_list[0] eq '')
    {
    die "$_tool_name $_error_marker '$file_with_path' file to be included does not exist, died";
    }
  else
    {
    die
    "$_tool_name $_error_marker '$file_with_path' file to be included does not exist in the search directories:\n",
    join("\n",@dir_list),
    "\ndied";
    }
  }

my $current_file_position=tell($__global_input_file_fh);
close($__global_input_file_fh);
# operating system can have a limit of simultaneously open files, so to avoid
# this current file being processed is closed


my $previous_global_input_file=$__global_input_file;
$__global_input_file=$file_with_path;

$_args_hash{recursion_level}++;

my $_spacer='  ' x $_args_hash{recursion_level};
warn $_spacer,"$_tool_name $_info_marker STARTED  including '$file_with_path' file\n";

if($forget_context)
  {
  my $dash_options_if_any='';
  map {$dash_options_if_any.=" -$_ $_args_hash{$_}";} keys %_args_hash;

  #################################################################
  # recursive call of the script itself, Perl context is forgotten:
  #################################################################

  if(
     &my_system
     (
      $_spacer."$_tool_name $_info_marker executing => ", # $_prompt,
      "$0 $dash_options_if_any $file_with_path",       # $command
     ) != 0
    )
    {
    die "$_tool_name $_error_marker error while executing 'include' sub, see messages above, died";
    }
  }
else
  {
  $__global_input_file_fh=new FileHandle $file_with_path, 'r';
  if(!defined $__global_input_file_fh)
    {
    die "$_tool_name $_error_marker cannot open '$file_with_path' included file for reading, died";
    }

  ##################################################
  # Recursive call of 'process_one_file' subroutine,
  # Perl context is remembered:
  ##################################################
  &process_one_file();

  close($__global_input_file_fh);
  }

warn $_spacer,"$_tool_name $_info_marker FINISHED including '$file_with_path' file\n";

$_args_hash{recursion_level}--;

$__global_input_file=$previous_global_input_file;
$__global_input_file_fh=new FileHandle $__global_input_file, 'r';
if(!defined $__global_input_file_fh)
  {
  die "$_tool_name $_error_marker could not open '$__global_input_file' input file for reading, died";
  }

seek($__global_input_file_fh,$current_file_position,0); # file position restored
}
#--------------------------------------------

