#!/usr/bin/perl
# Filename:	eperl.min
# Author:	David Ljung Madison <DaveSource.com>
# See License:	http://MarginalHacks.com/License
  my $VERSION=	"1.17min";
# Description:	Perl version of ePerl, embedded perl, minus many features
# Rewrite of:	http://www.engelschall.com/sw/eperl/
# Differences:	Many.  See the full version of the eperl rewrite

my $PERL = "/usr/bin/perl";	# Should probably match #! on first line

##################################################
# Libraries
##################################################
use strict;		# Cause it's smart
use IO::File;		# For filehandles
use Cwd;

# If you don't want or have Cwd, use this instead:
#sub getcwd { my $c = `pwd`; chomp($c);  $c; }

##################################################
# Setup the variables
##################################################
my $PROGNAME = $0;
$PROGNAME =~ s|.*/||;

# You can support "#include <URL>" if you have a program that can fetch URLs:
my $GET_URL	= "lynx -source";	# Lynx
#my $GET_URL	= "GET";		# LWP GET script

my $MAX_INCLUDES = 50;

##################################################
# Usage
##################################################
sub usage {
  my ($opt_H,$msg) = @_;

  print STDERR "ERROR:  $msg\n";

  print STDERR "\n";

my $usage = <<ENDOFUSAGE;

Usage: $PROGNAME [options] [scriptfile]

Input Options:
  -d, --define=NAME=VALUE   define global Perl variable (\$main::name)
  -D, --setenv=NAME=VALUE   define environment variable (\$ENV{'name'})
  -I, --includedir=PATH     add \@INC/#include directory
  -B, --block-begin=STR     set begin block delimiter
  -E, --block-end=STR       set end block delimiter
  -n, --nocase              force block delimiters to be case insensitive
  -k, --keepcwd             force keeping of current working directory
  -P, --preprocess          enable ePerl Preprocessor
  -L, --line-continue       enable line continuation via backslashes

Output Options:
  -T, --tainting            enable Perl Tainting (note: ePerl is *not* suid)
  -w, --warnings            enable Perl Warnings
  -x, --debug               enable ePerl debugging output on console
  -o, --outputfile=PATH     force the output to be send to this file (default=stdout)
  -c, --check               run syntax check only and exit (no execution)

Giving Feedback:
  -l, --license             display ePerl license files (COPYING and ARTISTIC)
  -v, --version             display ePerl VERSION id
  -h, --help                display ePerl usage list (this one)

New options:
  -X, --heavy_debug         Heavy Debug mode:  Print perl code, don't execute
  -e, --execute             Pre-execute code
  -s, --strict              Strict conformance to orinal ePerl behavior
                            (For features which are inefficient and unlikely
                             to be needed - if you have problems, try this)
ENDOFUSAGE

  print STDERR $usage;
  exit -1;
}

sub set_var {
  my ($opt_H,$str) = @_;
  usage($opt_H,"--define must be of form [NAME=VALUE]")
    unless ($str =~ /(.+)=(.+)/);
  $opt_H->{'vars'}{$1} = $2;
}

sub set_env {
  my ($opt_H,$str) = @_;
  usage($opt_H,"--setenv must be of form [NAME=VALUE]")
    unless ($str =~ /(.+)=(.+)/);
  $ENV{$1} = $2;
}

# Kludgy way to check for "-option=blah" and "-option blah"  (=(.+))?
sub arg { $2 ? $2 : shift(@ARGV); }

sub parse_args {
  my (%opt,@files);

  # Defaults
  $opt{'perl'} = $PERL;
  $opt{'CaseDelimiters'} = 1;

  while ($#ARGV>=0) {
    my $arg=shift(@ARGV);
    if ($arg =~ /^-(h|-help)$/) { usage(\%opt); }
    if ($arg =~ /^-(x|-debug)$/) { $opt{'debug'} = 1; next; }
    if ($arg =~ /^-(X|-heavy_debug)$/) { $opt{'debug'} = 2; next; }
    if ($arg =~ /^-(d|-define=)(.+)?$/) { set_var(\%opt,arg()); next; }
    if ($arg =~ /^-(D|-setenv=)(.+)?$/) { set_env(\%opt,arg()); next; }
    if ($arg =~ /^-(I|-includedir=)(.+)?$/) { push(@{$opt{'INC'}},arg()); next; }
    if ($arg =~ /^-(B|-block[-_]begin=)(.+)?$/) { $opt{'BeginDelimiter'}=arg(); next; }
    if ($arg =~ /^-(E|-block[-_]end=)(.+)?$/) { $opt{'EndDelimiter'}=arg(); next; }
    if ($arg =~ /^-(n|-nocase)$/) { $opt{'CaseDelimiters'}=0; next; }
    if ($arg =~ /^-(k|-keepcwd)$/) { $opt{'keepcwd'}=1; next; }
    if ($arg =~ /^-(L|-line-continue)$/) { $opt{'line-continue'}=1; next; }
    if ($arg =~ /^-(T|-tainting)$/) { $opt{'perl_opts'} .= " -T"; next; }
    if ($arg =~ /^-(w|-warnings)$/) { $opt{'perl_opts'} .= " -w"; next; }
    if ($arg =~ /^-(c|-check)$/) { $opt{'syntax_check'}=1; $opt{'perl_opts'} .= " -c"; next; }
    if ($arg =~ /^-(m|-mode=)(.+)?$/) { $opt{'mode'}=arg(); next; }
    if ($arg =~ /^-(P|-preprocess)$/) { $opt{'preprocess'}=1; next; }
    if ($arg =~ /^-(o|-outputfile=)(.+)?$/) { $opt{'outputfile'}=arg(); next; }

    if ($arg =~ /^-(e|-execute=)(.+)?$/) { push(@{$opt{'init'}},arg()); next; }
    if ($arg =~ /^-(s|-strict)$/) { $opt{'strict'}=1; next; }

    if ($arg =~ /^-(l|-license)$/) { license(); exit(0); }
    if ($arg =~ /^-(v|-version)$/) { version(); exit(0); }
    if ($arg =~ /^-(V|-ingredients)$/) { version(); exit(0); }
    if ($arg =~ /^-./) { usage(\%opt,"Unknown or improperly specified option: $arg"); }
    push(@files,$arg);
  }

  # Mode if not specified
  $opt{'mode'} = "f" unless ($opt{'mode'});
  usage(\%opt,"Unsupported mode: $opt{'mode'}") unless ($opt{'mode'} eq "f");

  usage(\%opt,"No input files defined") unless (@files);

  # Delimiters if not specified
  $opt{'BeginDelimiter'} = $opt{'mode'} eq "f" ? "<:" : "<?"
    unless ($opt{'BeginDelimiter'});
  $opt{'EndDelimiter'} = $opt{'mode'} eq "f" ? ":>" : "!>"
    unless ($opt{'EndDelimiter'});

  (\%opt,@files);
}

##################################################
# Get things ready and start perl
##################################################
sub start {
  my ($opt_H,$first_file) = @_;

  # Handle -nocase
  if (!$opt_H->{'CaseDelimiters'}) {	# Case insensitive
    $opt_H->{'begin_regex'} = "(?i)\Q$opt_H->{'BeginDelimiter'}\E";
    $opt_H->{'end_regex'} = "(?i)\Q$opt_H->{'BeginDelimiter'}\E";
  } else {
    $opt_H->{'begin_regex'} = "\Q$opt_H->{'BeginDelimiter'}\E";
    $opt_H->{'end_regex'} = "\Q$opt_H->{'EndDelimiter'}\E";
  }

  
  # Handle -I INC directories
  if ($opt_H->{'INC'}) {
    my $INC = join(":",@{$opt_H->{'INC'}});
    $ENV{'PERL5LIB'} = $INC;
    $ENV{'PERLLIB'} = $INC;
  }

  # Start perl
  start_perl($opt_H);
}

sub change_dir {
  my ($opt_H) = @_;

  return if $opt_H->{'keepcwd'};
  return unless ($opt_H->{'Cwd'} || get_filename($opt_H) =~ m|/[^/]+$|);

  my $dir = $opt_H->{'Cwd'} || $`;
  my $k = getcwd();
  push(@{$opt_H->{'save_dirs'}}, getcwd());
  chdir($dir) || print STDERR "[$PROGNAME] Warning: Couldn't chdir [$dir]\n";
}

sub restore_dir {
  my ($opt_H) = @_;
  return if $opt_H->{'keepcwd'};
  return unless ($opt_H->{'save_dirs'} && @{$opt_H->{'save_dirs'}});
  my $dir = shift @{$opt_H->{'save_dirs'}};
  chdir($dir) || print STDERR "[$PROGNAME] Warning: Couldn't restore directory [$dir]\n";
}

##################################################
# ePerl filter
##################################################
sub send_perl {
  my ($opt_H,$code) = @_;

  my $line_info = "";
  if ($opt_H->{'line_info'}) {
    my $file = get_filename($opt_H);
    my $line = $opt_H->{'lines'}[0] + $opt_H->{'offset'}[0];
    $line_info = "\n# $line \"$file\"\n";
    $opt_H->{'line_info'} = 0;
  }

  # Debug
  print STDERR $line_info.$code if ($opt_H->{'debug'});

  # Pipe to perl
  print {$opt_H->{'ph'}} $line_info.$code unless ($opt_H->{'debug'} == 2);
}

sub send_perl_code {
  my ($opt_H,$code,$just_entered,$leaving) = @_;

  # Add final ';' unless ending with _
  $code = ($code =~ /_$/) ? $` : "$code;"
    if ($leaving);

  # <:=$var:>
  $code = "print $'"
    if ($just_entered && $code =~ /^=/);

  send_perl($opt_H,$code);
}

sub quote {
  my ($str) = @_;

  # Fix quoting/slashes
  $str =~ s/\\/\\\\/g;
  $str =~ s/'/\\'/g;

  "'$str'";
}

# Convert plaintext to perl code (print statement)
sub send_perl_text {
  my ($opt_H,$str,$entering,$just_left) = @_;

  my $nl = 1 if (chomp($str));
  my $line_continue = 0;

  return $nl ? send_perl($opt_H,"\n") : 0 if ($opt_H->{'syntax_check'});

  # <: perl :>//  Text here is ignored
  return send_perl($opt_H,"\n") if ($just_left && $str =~ m|^//|);

  if ($opt_H->{'line-continue'} && $str =~ /\\$/) {
    $line_continue = 1;
    $str = $`;
  }

  if ($str ne "") {
    $str=quote($str);
    $str.=',"\n"' if ($nl && !$line_continue);
  } else {
    return unless $nl;
    $str = '"\n"';
  }
  
  $str = "print $str;";
  $str.="\n" if $nl;
  send_perl($opt_H,$str);
}

sub eperl {
  my ($opt_H) = (@_);

  my $in_perl = 0;
  my ($just_entered,$just_left) = (0,0);

  get_line($opt_H);
  $opt_H->{'line'}[0] = $.;
  while (defined $_) {
    if (!$in_perl && /$opt_H->{'begin_regex'}/) {
      $in_perl = 1;
      my ($out,$rest) = ($`,$');
      send_perl_text($opt_H,$out,1,$just_left);
      $just_entered = 1; $just_left = 0;
      $_ = $rest;
    } elsif ($in_perl && /$opt_H->{'end_regex'}/) {
      $in_perl = 0;
      my ($in,$rest) = ($`,$');
      send_perl_code($opt_H,$in,$just_entered,1);
      $just_entered = 0; $just_left = 1;
      $_ = $rest;
    } elsif ($in_perl) {
      send_perl_code($opt_H,$_,$just_entered,0);
      $just_entered = 0; $just_left = 0;
      undef $_;
    } else {
      send_perl_text($opt_H,$_,1,$just_left);
      $just_entered = 0; $just_left = 0;
      undef $_;
    }
    get_line($opt_H) unless defined $_;
    $opt_H->{'line'}[0] = $.;
  }
  print STDERR "[$PROGNAME] Warning: Never left perl code [",
               get_filename($opt_H),", $.]\n"
    if ($in_perl);
}

##################################################
# Perl process
##################################################
sub init_perl {
  my ($opt_H) = @_;

  # Init perl
  foreach my $k ( keys %{$opt_H->{'vars'}} ) {
    my $val = quote($opt_H->{'vars'}{$k});
    my $str = "\$main::$k = $val;";
    set_filename($opt_H,"{INIT CODE}: $str");
    send_perl($opt_H,"$str\n");
  }

  foreach my $i ( @{$opt_H->{'init'}} ) {
    my $iq = quote($i);
    set_filename($opt_H,"{INIT CODE}: $iq");
    send_perl($opt_H,"$i\n");
  }
}

# Just open a normal pipe to a perl process, redirect STDOUT
sub start_perl_pipe {
  my ($opt_H) = @_;

  # Setup out/err
  if ($opt_H->{'outputfile'} && $opt_H->{'outputfile'} ne "-") {
    open(OLDOUT,">&STDOUT") || die("[$PROGNAME]  Couldn't dup STDOUT\n");
    close(STDOUT);
    die("Couldn't write [$opt_H->{'outputfile'}]\n")
      unless open(STDOUT,">$opt_H->{'outputfile'}");
  }

  # Open the pipe to perl
  $opt_H->{'ph'} = new IO::File;
  usage($opt_H,"Couldn't start perl: $opt_H->{'perl'}",1)
    unless $opt_H->{'ph'}->open("|$opt_H->{'perl'} $opt_H->{'perl_opts'}");

  # Restore STDOUT
  if ($opt_H->{'outputfile'} && $opt_H->{'outputfile'} ne "-") {
    close(STDOUT);
    open(STDOUT,">&OLDOUT");
  }
}

sub start_perl {
  my ($opt_H) = @_;

  if ($opt_H->{'debug'} != 2) {
    start_perl_pipe($opt_H);
  }

  init_perl($opt_H);
}

sub end_perl {
  my ($opt_H) = @_;
  return 0 unless $opt_H->{'ph'};

  # Perl script done - close perl input
  $opt_H->{'ph'}->close;
  my $ret = $?;

  my $exit = $ret >> 8;
  my $int  = $ret & 127;
  my $core = $ret & 128;
  $exit|=0xffffff00 if $exit>>7;
  $exit = sprintf("%d",$exit);
  print STDERR "[$PROGNAME] Interpretor returned error [$exit]\n" if ($exit);
#    if ($exit && $exit != 255);	# Exit 255 is perl's runtime error
  print STDERR "[$PROGNAME] **INTERRUPT**\n" if $int;
  print STDERR "[$PROGNAME] (Core dump)\n" if $core;
  print STDERR "$opt_H->{'start_file'} syntax OK\n" if ($opt_H->{'syntax_check'} && !$ret);
  $exit;
}

##################################################
# Input files/preprocessor
##################################################
sub set_filename {
  my ($opt_H,$file) = @_;

  my $stdin = ($file eq "-") ? 1 : 0;

  my $filename = $stdin ? "<STDIN>" : $file;

  unshift(@{$opt_H->{'files'}}, $filename);
  unshift(@{$opt_H->{'lines'}}, 1);
  unshift(@{$opt_H->{'offset'}}, 0);	# For special case STDIN with line_info
  unshift(@{$opt_H->{'stdin'}}, $stdin);

  $opt_H->{'line_info'} = 1;
}

sub get_filename {
  my ($opt_H) = @_;
  return unless $opt_H->{'files'} && @{$opt_H->{'files'}};
  $opt_H->{'files'}[0];
}

sub open_file {
  my ($opt_H,$file,$sinclude) = @_;

  set_filename($opt_H,$file);
  unshift(@{$opt_H->{'sinclude'}}, $sinclude ? 1 : 0);

  my $start=1 unless ($opt_H->{'fhs'} && @{$opt_H->{'fhs'}});

  my $fh = new IO::File;

  if ($file !~ m|http://|) {
    usage($opt_H,"Couldn't open [$file]: $!",1)
      unless $fh->open("<$file");
  } else {
    # URL - Kludge!  Is there a package that will give me a filehandle to a URL?
    usage($opt_H,"[$PROGNAME] Error: URL includes only supported with $GET_URL",1)
      unless $fh->open("$GET_URL $file|");
  }
  unshift(@{$opt_H->{'fhs'}}, $fh);

  change_dir($opt_H) if ($start);
  $opt_H->{'start_file'} = $file if ($start);
}

sub close_file {
  my ($opt_H) = @_;

  return unless $opt_H->{'fhs'} || @{$opt_H->{'fhs'}};
  my $fh = shift @{$opt_H->{'fhs'}};
  $fh->close;

  # Restore file state
  if (get_filename($opt_H)) {
    shift @{$opt_H->{'files'}};
    shift @{$opt_H->{'lines'}};
    shift @{$opt_H->{'sinclude'}};
    shift @{$opt_H->{'offset'}};
    shift @{$opt_H->{'stdin'}};
  }

  $opt_H->{'line_info'} = 1;

  my $last=1 unless ($opt_H->{'fhs'} && @{$opt_H->{'fhs'}});
  restore_dir($opt_H) if ($last);
}

sub get_line {
  my ($opt_H) = (@_);

  return unless $opt_H->{'fhs'} && @{$opt_H->{'fhs'}};

  undef $_;
  while (!defined $_ && @{$opt_H->{'fhs'}}) {
    my $fh = $opt_H->{'fhs'}[0];
    close_file($opt_H) unless ($_ = <$fh>);
  }

  # For shebang support, eperl ignores the first line if it starts with #!
  return get_line($opt_H) if ($. == 1 && /^#!/);

  return unless ($opt_H->{'preprocess'});

  #########################
  # Preprocessor
  #########################

  # Line info can be specified in STDIN streams in non-strict mode
  # Allow for optional "change file:" directive, which is happily
  # ignored as a comment by the original eperl.
  if (!$opt_H->{'strict'} && $opt_H->{'stdin'}[0] &&
      /^#(change file:)? (\d+) "([^"]+)"$/) {
    $opt_H->{'files'}[0] = $3;
    $opt_H->{'offset'}[0] = $2-$.-1;
    $opt_H->{'lines'}[0] = $.+1;
    $opt_H->{'line_info'} = 1;
    return get_line($opt_H);
  }   

  # Comments
  if (/^#c/) {
    # Allow comments to disappear completely (no newlines) if they contain //
    if (!$opt_H->{'strict'} && m|//|) {
      send_perl($opt_H,"\n");
      return get_line($opt_H);
    }
    $_ = "\n";
  } 

  # if-elsif-else-endif
  s/^\s*#if\s+(\S.*)$/$opt_H->{'BeginDelimiter'} if ($1) { _$opt_H->{'EndDelimiter'}\/\//g;
  s/^\s*#elsif\s+(\S.*)$/$opt_H->{'BeginDelimiter'} } elsif ($1) { _$opt_H->{'EndDelimiter'}\/\//g;
  s/^\s*#else\s*/$opt_H->{'BeginDelimiter'} } else { _$opt_H->{'EndDelimiter'}\/\//g;
  s/^\s*#endif\s*/$opt_H->{'BeginDelimiter'} } _$opt_H->{'EndDelimiter'}\/\//g;

  # sinclude needs to replace delimiters
  if ($opt_H->{'sinclude'} && $opt_H->{'sinclude'}[0]) {
    s/$opt_H->{'BeginDelimiter'}//g;
    s/$opt_H->{'EndDelimiter'}//g;
  }

  # include/sinclude
  if (/^\s*#(s)?include\s+"([^"]+)"\s*$/ ||
      /^\s*#(s)?include\s+'([^']+)'\s*$/ ||
      /^\s*#(s)?include\s+<([^>]+)>\s*$/ ||
      /^\s*#(s)?include\s+(\S+)\s*$/) {
    my ($sinclude,$inc) = ($1,$2);

    # SECURITY FIX!  This is broken in the real ePerl v2.2.14!
    # Otherwise: We can do "#include" inside "#sinclude" to turn off security
    $sinclude = 1 if ($opt_H->{'sinclude'} && $opt_H->{'sinclude'}[0]);

    return print STDERR "[$PROGNAME] Error:  Too many includes [>$MAX_INCLUDES]\n"
      if (@{$opt_H->{'fhs'}}+1 > $MAX_INCLUDES);

    $opt_H->{'lines'}[0] = $.+1;	# Come back to next line

    # Find include file
    my $file = $inc;
    if ($file =~ m|^/|) {		# Absolute path
    } elsif ($file =~ m|^http://|) {	# URL
    } else {				# Non-absolute path
      my @path = @{$opt_H->{'INC'}} if $opt_H->{'INC'};
      while (!-r $file && @path) { $file = shift(@path)."/$inc"; }
      unless (-r $file) {
        my $msg = "[$PROGNAME] Error:  Couldn't find include [$inc]\n";
        print STDERR $msg;		# Send to STDERR
        send_perl_text($opt_H,$msg,0,0);	# And to the perl output
        return get_line($opt_H);
      }
    }

    # Open it
    open_file($opt_H,$file,$sinclude);
    # And return first line
    return get_line($opt_H);
  }
}

##################################################
# Main
##################################################
sub main {
  my ($opt_H,@files) = parse_args();

  # Common module/main setup code
  start($opt_H,$files[0]);

  foreach my $file ( @files ) {
    # Open eperl input
    open_file($opt_H,$file);

    # Run eperl
    eperl($opt_H);
  }

  my $exit = end_perl($opt_H);
  exit($exit);
}

main();

sub license {
  print "\n";
  print "This software is licensed under the MarginalHacks license:\n";
  print "\n";
  print "  http://MarginalHacks.com/License\n";
  print "\n";
  print "The documentation in this code was taken from the original ePerl\n";
  print "and lies under the Artistic License or GNU General Public License\n";
  print "\n";
}

sub version {
  print "\n";
  print "This is $PROGNAME Version $VERSION\n";
  print "\n";
  print "Copyright (c) 2000 David Ljung Madison <MarginalHacks.com>\n";
  print "\n";
  print "This is a perl copy of the original ePerl program:\n";
  print "Copyright (c) 1996,1997,1998 Ralf S. Engelschall <rse\@engelschall.com>\n";
  print "\n";
}