#............................................................................
# Precompiler.pl
#
#   This file is only useful when loaded with PerlEx.dll
#   Any command line use would be useful only for testing
#
#   This script will override the one that is built into
#   PerlEx.dll as a resource, if it resides in the same
#   directory as the DLL.
#
#   Init() - called once on load
#       no return code
#   Execute(<file_name>,@_) -
#       returns:
#           0 if successful
#           1 if host should load script
#           2 if eval error and host should try to load script
#          -1 if file or script error
#
# Authors: Dick Hardt <dickh@ActiveState.com>
#        : Jay Thorne <jayt@ActiveState.com>
#   with lots of help from the Apache\Registry.pm module written by:
#       Andreas Koenig <andreas.koenig@franz.ww.tu-berlin.de> and
#       Doug MacEachern <dougm@osf.org>
#
#   Copyright (C) 1997,1998 ActiveState Tool Corp. All rights reserved
#.............................................................................

package PerlEx::Precompiler;
use FileHandle ();
use File::Basename ();
use File::DosGlob;
use Cwd ();

my (%script_time);      # time since a loaded script was last modified
my (%script_eval);      # eval error from an attempt at loading a script
my (@noload_dirs);      # directories that we will not load from
my (@preload_files);    # files that we preload
my (%OrigENV);
my ($package);
my ($fPreLoading);

# hashes to hold values we need to save on a script-by-script basis
my (%saved_vars, %saved_INC);       # $?, $^W, et al.

# to hold values for restoring global variables
my (@precompiler_saved_vars, @precompiler_saved_INC);

BEGIN {
    # avoid that ugly nt.ph require with some uglier defines
    $fPreLoading = 1;
    #
    # hand coded since subroutines are not available in the begin block
    #
    $_trace=PerlEx::Trace();
    # $_trace = 4;    # debug level is set in Registry, but can be overridden here
    print STDERR "Precompiler: Trace Level is set to $_trace\n";
    print STDERR "Precompiler: BEGIN block called in $0\n" if ($_trace>=4);
}

sub _GetPaths {
    my $subkey = shift;
    my (@paths);
    if(!PerlEx::GetPaths($subkey, \@paths)) {
        print STDERR "Precompiler: Unable to get paths for key $subkey\n"  if ($_trace>=1);
        return undef;
    }
    return @paths;
}

sub _GetKeys {
    my $subkey = shift;
    my (@keys);
    if(!PerlEx::GetKeys($subkey, \@keys)) {
        print STDERR "Precompiler: Unable to get keys for key $subkey\n"  if ($_trace>=1);
        return undef;
    }
    return @keys;
}

sub _GetVal {
    my $subkey = shift;
    my (%values);
    if(!PerlEx::GetValues($subkey, \%values)) {
        print STDERR "Precompiler: Unable to get values for key $subkey\n"  if ($_trace>=1);
        return undef;
    }
    return %values;
}

sub _PreLoad {
    print STDERR "Precompiler: Preload Called \n" if ($_trace >= 4);
    my ($script);
    foreach $script (@preload_files) {
        Execute($script);
        }
    $fPreLoading = 0;   # done preloading
}

sub _MakeScriptName {
    my $script_name = shift;
    $script_name = "\L$script_name";    # smash case
    $script_name =~ s/\\/\//g;      # make all the slashes the same

    $script_name =~ s[^\/\/]{};     # get rid of leading slash pairs if we have a UNC ( \\machine\share )
    $script_name =~ s/([^a-z0-9:\.\/])/sprintf("_%2x",unpack("C",$1))/eg;
    $script_name =~ s/[:.]/_/g;     # this makes the script name more readable

    # last pass cares for slashes and words starting with a digit
    $script_name =~ s{
                       ([\/])        # directory
                       (\d?)         # package's first character
                      }[
                       "::" . ($2 ? "_$2" : "")
                       ]egx;
    return $script_name;
}

sub _ParseEmbed
{
    my (%Params)=@_;
    my ($ReturnData,@filecontents,$currenthunk)="";
    print STDERR "Precompiler: Embed called\n" if ($_trace>=4);
     
    # defaults (if necessary)
    (@filecontents)=split /$Params{'begin'}|$Params{'end'}/mo,$Params{'content'};
    # split the contents of the "active server perl file" at the begin and end
    # registry entries.
    # giving us an array of n length of the file contents.
    # 
    foreach $i (0..$#filecontents)
       {
       $currenthunk=$filecontents[$i];
       if ( ( $i % 2 ) == 0) # Odd numbered elements are the perl code, by definition
           {                 # even elements are html
           $currenthunk=~s/\'/\\\'/gm;  # escape single quotes
           $ReturnData.="print '".$currenthunk."';\n";
           }
       else
           {
           $currenthunk=&_unescape($currenthunk) if $Params{'decode'};
           # decode allows the perl code to be produced by ugly editors that
           # escape all the language bits into %xx encoded entities.
           if ( $currenthunk =~s/^=//gs) { # if the first character of the code seg
                                           # is an = sign, then delete the = and
              $ReturnData.="print ".$currenthunk.";\n"; # evaluate perl variable
              }
           else {
              $ReturnData.=$currenthunk;              # include code segments as is
              }
           }
       }
    #  Need to supply a content-type for Embed files
    return 'print "Content-type: text/html\n\n";'."\n".$ReturnData;
}

my (%_shebang_switches) = (
    'T' => sub {
               print STDERR "Precompiler: T switch ignored, must set tainting on in Registry.\n"
               unless ($PerlEx::__T || $_trace < 3);
               '';
           },
    'w' => sub {
               'BEGIN { $^W = 1; }'
           },
    'd' => sub {
               $PerlEx::Precompiler::_debug = 1;
               '';
           }
);

sub _ParseShebangLine {
    my $sub = shift;
    print STDERR "Precompiler: ParseShebangLine called\n" if ($_trace >= 4);

    # Turn off remote debugging from the last script we ran
    $PerlEX::Precompiler::_debug = 0;

    # Get the shebang line out of script that we were given
    my ($line) = $sub =~ /^(.*)$/mo;
    my @shebang = split( /\s+/, $line );

    # Return back if we didn't find a shebang line at the beginning of the
    # script.
    return $sub unless @shebang;
    return $sub unless shift( @shebang ) =~ /^\#!/o;

    # Parse out any switches we found on the shebang line
    my ($arg, @s, $prepend);
    $prepend = '';
    foreach $arg (@shebang) {
        next unless ($arg =~ s/^-//);
        last if substr( $arg, 0, 1 ) eq '-';

        for (split( //, $arg )) {
            next unless $_shebang_switches{ $_ };
            print STDERR "Precompiler: Parsed shebang switch $_\n" if ($_trace >= 4);
            $prepend .= &{ $_shebang_switches{ $_ } };
        }
    }

    # If we parsed any switches, add stuff to the beginning of the script
    $sub =~ s/^/$prepend/ if $prepend;

    return $sub;
}

# unescape URL-encoded data stolen from cgi.pm (like where else?)
sub _unescape {
    print STDERR "Precompiler: Unescape called\n" if ($_trace>=4);
    my($todecode) = @_;
    $todecode =~ tr/+/ /;       # pluses become spaces
    $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
    return $todecode;
}

sub Init {
    print STDERR "Precompiler: Init called\n" if ($_trace>=4);
    my ($dir);
    my (@glob_files);
    my (@preload_dirs);
    %OrigENV = %ENV;
    # get all the scripts to be preloaded
    @preload_dirs = _GetPaths('Preload');
    if ($_trace>=4) {
        foreach $dir (@preload_dirs) {
            print STDERR "\tPreload Dirs: $dir\n";
            }
        }
    foreach $dir (@preload_dirs) {
        @glob_files = &File::DosGlob::glob($dir);
        @preload_files = (@preload_files, @glob_files);
        }
    if ($_trace>=4) {
        foreach $dir (@preload_files) {
            print STDERR "\tPreload Files: $dir\n";
            }
        }
    @noload_dirs = _GetPaths('Noload');
    for ($i=0;$i<@noload_dirs;$i++) {
        $noload_dirs[$i] = _MakeScriptName($noload_dirs[$i]);
        }
    if ($_trace>=4) {
        foreach $dir (@noload_dirs) {
            print STDERR "\tnoload_dirs Files: $dir\n";
            }
        }        

    $PerlEx::__T = PerlEx::GetTaint();

    # Debugging output
    my %values = &_GetVal();
    $EnableDebugOutput=$values{"EnableDebugOutput"};
    print STDERR "Precompiler: EnableDebugOutput is set to $EnableDebugOutput\n" if $_trace>=4;


    # Embedding Code
    # build hash of hash of "Embed" enabled file extension
    # example '.aspl' => begin =>"<%", end=> "%>" , decode=> 0
    # read Registry
    @EmbedKeys = &_GetKeys("Embed");
    # keys
    foreach $key (@EmbedKeys) {
        my (%Value) =&_GetVal("Embed\\$key");
        # now the values
        foreach $name (keys(%Value)) {
           $Embed{$key}{$name}=$Value{$name};
           # put them in global $Embed
           }
        }

    if ($_trace>=4) {
       # to list the contents of the registry
        print STDERR "Precompiler: Registry Entries for Embed:\n";
        foreach $key ( sort (keys %Embed) ) {
            print STDERR "\n\tKey:$key: ";
            foreach $subkey (sort(keys %{ $Embed{$key} } )) {
                print STDERR "\t$subkey => $Embed{$key}{$subkey}\n";
                }
            }
        }
    # preload all scripts after the registry entries are read

    _PreLoad ();
}

sub catch_exit {
    my ($arg) = @_ ? @_ : "0";
    print STDERR "Precompiler: exit() called with exit value $arg\n" if ($_trace>=1);
    # force a reload of the script next time on non-zero exit
    delete $script_time{$package} if ($arg ne "0");
    goto EXITTED;
}

#..........................................................
#
# This routine is the entry point for executing scripts
#
#.........................................................
sub Execute {
    my $file_name = shift;
    print STDERR "Precompiler: Execute called with [$file_name]\n" if ($_trace>=3);
# Create package name from filename
    my $script_name = _MakeScriptName($file_name);
    $package = "PerlEx::Precompiler::$script_name";
# let's see if file is not to be loaded
    {
    my($dir);
    foreach $dir (@noload_dirs) {
        if ($script_name =~ /^$dir/i) {
            print STDERR "Precompiler: NoLoad: Not loading [$script_name] from [$dir]\n" if ($_trace>=3);
            return 1;   # let host process script in seperate interpretor
            }
        }
    }
# Let's get the file info
    if (!(-e $file_name)) {
        print STDERR "Precompiler: Script $file_name does not exist\n";
        print STDERR "Precompiler: Returning -1 at ",__LINE__,"\n";
        return -1;
       }  
    if (!(-r $file_name)) {
        print STDERR "Precompiler: Script $file_name is not readable by Precompiler\n";
        print STDERR "Precompiler: Returning -1 at ",__LINE__,"\n";
        return -1;
        }   # $> (Effective UID) does not do anything right now
    if (-d _) {
        print STDERR "Precompiler: Script $file_name is a directory - not allowed.\n";
        print STDERR "Precompiler: Returning -1 at ",__LINE__,"\n";
        return -1;
        }
    my $mtime = -M _;

# Let's get the file

    my $fLoadScript = 1;
    
    *0 = \$file_name;   # make perl think that we are the file we are going to execute
    print STDERR "Precompiler: Checking for existence of $file_name in Cache\n" if ( $_trace >= 4 );
    if ( exists $script_time{$package}) {
        $age = int ($mtime*24*60);
        if ($script_time{$package} > $mtime ) {
#   TBD
#   ? need to execute any END blocks since we are reloading
            print STDERR "Precompiler: Script $file_name changed $age minutes ago, recompiling.\n" if ($_trace>=3);
        } else {
            $fLoadScript = 0;
            print STDERR "Precompiler: Script $file_name is compiled and $age minutes old.\n" if ($_trace>=3);
            }
        } 
        
    if ($fLoadScript) {
        # package does not exist yet on the $script_time hash. Therefore its not loaded yet.
        if ($_trace>=3) {
            my $loadtype = $fPreLoading ? '--PreLoading--' : 'Demand Loading';
            print STDERR "Precompiler: $loadtype [$file_name]\n";
            print STDERR "\tinto [$package]\n" ;
            }
        $script_time{$package} = $mtime;
        my($sub);
           {
            my $fh = FileHandle->new($file_name);
            local $/;
            $sub = <$fh>;
            # XXX - TBD
            #       $sub = parse_cmdline($sub);
            $sub = _ParseShebangLine($sub);
            # TBD  file should be closed?
           }
    # compile this subroutine into the uniq package name
    undef &{"$package\::handler"} unless ($_trace>=4); #avoid warnings
           {
            &File::Basename::fileparse_set_fstype("MSDOS");
            my ($name,$path,$suffix) = &File::Basename::fileparse($file_name,'\..*');
            print STDERR "Precompiler: Check for Embed parse of $file_name\n" if ($_trace>=4);
            foreach $extension (@EmbedKeys) {
                print STDERR "Precompiler: Checking $extension\n" if ($_trace >=4 );
                if ($extension eq $suffix) {
                    # this filename ends with one of the keys
                    print STDERR "Precompiler: Parsing Embed File:$file_name\n" if ($_trace>=4);
                    $sub=&_ParseEmbed( %{ $Embed{$extension} }, 'content' => $sub);
                    print STDERR "Precompiler: Embed Finished Parsing $file_name\n" if ($_trace>=4);
                    }
                }
            }
        print STDERR "Precompiler: Precompiling $file_name\n" if ($_trace>=4);
        my $eval = join(
                       ' ',
                       'package ', $package, ";\n",
                       "sub handler {\n",
                       ($PerlEx::Precompiler::_debug ? "$DB::single=1;\n" : ''),
                       "#line 1 $file_name\n" ,
                       $sub,
                       ($PerlEx::Precompiler::_debug ? "$DB::single=0;\n" : ''),
                       "\n}",
                   );
        print STDERR "Precompiler: Evaluating [$package].\n" if ($_trace>=4);
 # debug code: 
 #      print STDERR "Precompiler: contents of package to eval:\n$eval\n" if ($_trace>=4);
        # if we had a problem eval() the script before
  
        if (exists $script_eval{$package}) {
            delete $script_eval{$package};
            }

        *CORE::GLOBAL::exit = \&catch_exit;

        @precompiler_saved_vars = ($@, $!, $,, $/, $\, $^W, $?);
        @precompiler_saved_INC = @INC;
        $ENV{'GATEWAY_INTERFACE'} ="CGI-PerlEx";
        eval $eval;
        my $eval_err = $@;
        # save the values of some global special variables
        @{$saved_vars{$package}} = ($@, $!, $,, $/, $\, $^W, $?);
        @{$saved_INC{$package}} = @INC;
        # Temporary: bug in Perl core gives a warning about $, in the
        # next statement, if the script we just ran set $^W;
        $^W=0;
        # restore our vars
        ($@, $!, $,, $/, $\, $^W, $?) = @precompiler_saved_vars;
        @INC = @precompiler_saved_INC;
       
        # do we need to worry about untainting on Win32?
        if ($eval_err) {
            $script_eval{$package} = $eval_err;    # save for later
            print STDERR "Precompiler: Eval Error: \n\tPackage:[$package]\n\tFile:[$file_name]\n\tError:[$script_eval{$package}]\n" if ($_trace>=1);
            print STDERR "Precompiler: Returning -1 at ",__LINE__,"\n";
            return -1;                      # get out of here since we failed parse
            }
       }
    if (exists $script_eval{$package}) {
        print STDERR "Precompiler: Eval Error: \n\tPackage:[$package]\n\tFile:[$file_name]\n\tError:[$script_eval{$package}]\n" if ($_trace>=1);
        print STDERR "Precompiler: Returning -1 at ",__LINE__,"\n";
        return -1;  # we failed parse last time, so keep sending error
        }
        
    if (!$fPreLoading) {
        # my $cwd = Cwd::fastcwd(); # Don't think we need to save this
        # chdir File::Basename::dirname($file_name);  # PerlEx does this
        my $cv = \&{"$package\::handler"};
        print STDERR "Precompiler: Executing\n\tPackage:[$package]\n\tFilename:[$file_name]\n\tParams:[@_].\n" if ($_trace>=3);
        # Reset the special variables
        @precompiler_saved_vars = ($@, $!, $,, $/, $\, $^W, $?);
        @precompiler_saved_INC = @INC;
        # Temporary: bug in Perl core gives a warning about $, in the
        # next statement, if the script we just ran set $^W;
        $^W=0;
        ($@, $!, $,, $/, $\, $^W, $?) = @{$saved_vars{$package}};
        @INC = @{$saved_INC{$package}};
        $ENV{'GATEWAY_INTERFACE'} ="CGI-PerlEx"; # for compatibility with the mod_perl extensions.
        eval { &{ $cv }( @_ ) };
EXITTED:
        my $eval_err = $@;
        # Temporary: bug in Perl core gives a warning about $, in the
        # next statement, if the script we just ran set $^W;
        $^W=0;
        # restore our global vars and %ENV
        ($@, $!, $,, $/, $\, $^W, $?) = @precompiler_saved_vars;
        @INC = @precompiler_saved_INC;
        foreach (keys %ENV) {
            delete $ENV{$_};
        }
        foreach (keys %OrigENV) {
            $ENV{$_} = $OrigENV{$_};
        }
        if ( $eval_err ) {
            print STDERR "Precompiler Execute Error:\n\tFilename:[$file_name]\n\tPackage:[$package]\nParams[@_]\n$eval_err\n";
            return -1;     # Tell host we failed 
            }
        print STDERR "Precompiler: finished Exec" if ($_trace>=3);
        }

    print STDERR "Precompiler done and everything is ok\n" if ($_trace>=3);
    return 0;   # everything OK
    }
END {
    print STDERR "Precompiler: END block called\n" if ($_trace>=4);
}

__END__

# The following lines will not get called when this file is loaded
# by PerlEx.dll, but are useful for testing to make sure that everything
# compiles ok       
# set parameter to Execute() to be a valid filename for command line testing
#test code

    Init();
    my $cwd = Cwd::fastcwd();
    @test_files = (glob('D:\Testsuite\aspl\*.aspl')); # aspl files on drive D:
    foreach $test_file (@test_files) {
        Execute($test_file) && print STDERR "Execute ERROR with $test_file\n";
        }