#!/bin/perl
#
# file:         yaep
# purpose:      "yet another embedded perl" (aka "poor man embedded perl")
# created:      pasha oct 21 2000
# modified:     pasha mar 11 2011
# modification: /home/www -> /www
# synopsis:     yaep [--parse] [--preclude=file] [--conclude=file] 
#               <input_perl_script>
# pending:      on error, produce error pointing not to /tmp/yaep$$,
#               but to original script file (with a correct line number)
# bug:          -- options of <inout_perl_script> are not allowed
#               (they are processed as -- options for yaep)
#

use strict;
use warnings;
use File::Basename;
use Getopt::Long;
use pasha::dieonwarn;
use pasha::common;

sub print_text ($);


########### settings ##################################
my $OPEN_TAG      = '<?perl';
my $CLOSE_TAG     = '?perl>';
my $OPEN_EQ_TAG   = '<?=';         # used to display var of one statement
my $CLOSE_EQ_TAG  = $CLOSE_TAG;    # like <?= $var ?perl>
my $PERL_OPTS     = '-I/www/pasha-src/build';   # options for generated script 
#######################################################

########### process command line ######################
my ($PARSE_ONLY, $PRECLUDE, $CONCLUDE, $HELP);
GetOptions (
	    'parse'      => \$PARSE_ONLY,
	    'preclude:s' => \$PRECLUDE,
	    'conclude:s' => \$CONCLUDE,
	    'help:s'     => \$HELP
	    );
if ((defined ($HELP)) || (scalar @ARGV == 0))
{
    select (STDERR);
    print ('Usage: ' . ME . " [--parse] [--preclude=file] [--conclude=file]\n");
    print ("       <input_perl_script> [<input_perl_script_arguments>]\n");
    print ("--parse - parse <input_perl_script> and print output to stdout,\n");
    print ("          without executing it;\n"); 
    print ("--preclude=file - preclude script with file's content;\n");
    print ("--conclude=file - conclude script with file's content.\n");
    print ("--help          - print this message.\n");
    exit (1);
}
#######################################################

########## read the input file and replace ############
########## text areas by print statements #############
(my $ESC_OPEN_TAG     = $OPEN_TAG)     =~ s/\?/\\\?/o;
(my $ESC_CLOSE_TAG    = $CLOSE_TAG)    =~ s/\?/\\\?/o;
(my $ESC_OPEN_EQ_TAG  = $OPEN_EQ_TAG)  =~ s/\?/\\\?/o;
(my $ESC_CLOSE_EQ_TAG = $CLOSE_EQ_TAG) =~ s/\?/\\\?/o;
my $PERL_SCRIPT = $ARGV[0];
my $script = file2string ($PERL_SCRIPT);
shift;    # so on this stage the remaining arguments (if any) 
          # are arguments to processed perl script
for ($script)
{
    # replace <?= ... ?perl> by generic open-close tags
    s/$ESC_OPEN_EQ_TAG\s+(.*?)\s+$ESC_CLOSE_EQ_TAG/$OPEN_TAG print($1); $CLOSE_TAG/go;

    # from the beginning till the first open tag
    s/^(.*?)$ESC_OPEN_TAG/print_text($1)/mseo;
    
    s/$ESC_CLOSE_TAG(.*?)$ESC_OPEN_TAG/print_text($1)/msego;
    
    # from the last (remaining) close tag till the end
    s/$ESC_CLOSE_TAG(.*)$/print_text($1)/mseo;

    # replace __FILE__ by name of the processed file
    s/__FILE__/'$PERL_SCRIPT'/msgo;
}
#######################################################

########## add preclude/conclude ######################
if (defined $PRECLUDE)
{
    $script = file2string ($PRECLUDE) . $script;
}
if (defined $CONCLUDE)
{
    $script .= file2string ($CONCLUDE);
}
#######################################################

if (defined ($PARSE_ONLY))
{
    print ($script); 
    exit (0);
}

########## write script to tmp file and execute it ################
my $tmpdir = '/tmp/' . ME . $$;
system ("rm -r $tmpdir >/dev/null 2>&1");     # just to be sure...
mkdir ($tmpdir) || me_die ("unable mkdir $tmpdir");
my $tmpfile = $tmpdir . '/' . basename ($PERL_SCRIPT);
open (F, ">$tmpfile") || me_die ("unable open $tmpfile");
print (F $script);
close (F) || me_die ("unable close $tmpfile");
my $rc = system ('perl', '-w', $PERL_OPTS, $tmpfile, @ARGV) >> 8;
system ("rm -r $tmpdir") && me_print ("unable remove $tmpdir: leaving garbage");
###################################################################

exit ($rc);



sub print_text ($)
{
  my $s = $_[0];
  if ($s !~ /[^\s]/ms)
    {
	  return (';');
    }
  for ($s)
    {
	  s/^\n//mso;      # strip the starting newline
	  s/\n$//mso;      # strip the final newline
	  s/\$/\\\$/msgo;  # escape $
    }
  if (length ($s) == 0)
    {
	  return (';');
	}
  return ("print <<EOT\n$s\nEOT\n;");
}

__END__