/*****************************************************************************/
/*
                                PerlRTEng.c

Perl Run-Time Environment - Perl engine.


CGI.PM AND PERLEX
-----------------
CGI.pm contains code to correctly initialize itself with a persistent Perl
engine over multiple requests.  It tests for Apache mod_perl and for Active
State's PerlEx (http://aspn.activestate.com/) environments and performs some
special initialization (amongst other things).  The PerlEx is the simplest of
the two and the one WASD's PerlRTE commanderes.

Code from CGI.pm (delivered with Perl 5.8):

  $CGI::revision = '$Id: CGI.pm,v 1.62 2002/04/10 19:36:01 lstein Exp $';
  $CGI::VERSION='2.81';

The following is the relevant initialization:

  #### Method: new
  # The new routine.  This will check the current environment
  # for an existing query string, and initialize itself, if so.
  ####
  sub new {
      my($class,$initializer) = @_;
      my $self = {};
      bless $self,ref $class || $class || $DefaultClass;
      if ($MOD_PERL && defined Apache->request) {
        Apache->request->register_cleanup(\&CGI::_reset_globals);
        undef $NPH;
      }
      $self->_reset_globals if $PERLEX;
      $self->init($initializer);
      return $self;
  }

The '_reset_globals' is the desired functionality.  This is the only time that
PerlEx is tested for and used and so it seems a fairly innocuous kludge to
make, rather than modify CGI.pm itself to test for WASD!

This is how PerlEx is tested for:

  # Turn on special checking for ActiveState's PerlEx
  $PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) &&
               $ENV{'GATEWAY_INTERFACE'} =~/^CGI-PerlEx/;

So what this module does is massage the GATEWAY_INTERFACE variable to contain
"CGI-PerlEx" instead of it's usual value of "CGI/1.1".  Couldn't be simpler! 
This functionality can be disabled by using the /NOPERLEX command line
qualifier.


COPYRIGHT
---------
Copyright (C) 2000-2013 Mark G.Daniel
This program, comes with ABSOLUTELY NO WARRANTY.
This is free software, and you are welcome to redistribute it under the
conditions of the GNU GENERAL PUBLIC LICENSE, version 3, or any later version.
http://www.gnu.org/licenses/gpl.txt


VERSION HISTORY
---------------
See PERLRTE.C
*/
/*****************************************************************************/

/* just get a small number of definitions from PerlRTE.c */
#define PERLRTENG_INCLUDE_PERLRTEV
#include "perlrte.c"
#undef PERLRTENG_INCLUDE_PERLRTEV

/* Perl headers */

#include <EXTERN.h>
#define PERL_IN_MINIPERLMAIN_C
#include <perl.h>

#ifdef PERL_GLOBAL_STRUCT
#define PERLVAR(var,type) /**/
#define PERLVARA(var,type) /**/
#define PERLVARI(var,type,init) PL_Vars.var = init;
#define PERLVARIC(var,type,init) PL_Vars.var = init;
#include "perlvars.h"
#undef PERLVAR
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
#endif

/* macros */

/* 5.8.0 makes sockets loading dynamic (apparently) */
#ifndef PERLRTENG_56
#define PERLRTENG_56 0
#endif

/* externs */

extern int  CliClean,
            CliCgiPrefix,
            CliNoPerlEx,
            CliNoSocket,
            CliPerlDebug,
            Debug,
            IsCgiPlus,
            UsageCount;

extern char  *CliCgiHashNamePtr,
             *CliCgiPlusHashNamePtr;

extern char  Utility[];

/* prototypes */

char* CgiVar (char*);
void SetCgiEnv (int);
int strsame (char*, char*, int);
int PerlNonPersistEngine (char*, char*);
int PerlOneShotEngine (char*, char*);
int PerlPersistEngine (char*, char*);

void XsInit _((void));
I32 hv_iterinit (HV*);
SV* hv_iternextsv (HV*, char**, I32*);
void boot_DynaLoader _((CV* cv));

#if PERLRTENG_56
void boot_Socket _((CV* cv));
#endif

/*****************************************************************************/
/*
Essentially a Perl package in a null-terminated string.  Done this way so that
it can be evaluated directly as part of the RTE executable, not needing to be
located as a file somewhere.  Lifted (almost) directly from the 'perlembed'
document (thanks to the authors and maintainers).  To view the package
uncluttered by escape characters do "$ PERLRTE /PACKAGE".
*/

char PackageEmbedPersist [] =

"\
package Embed::Persist;\n\
\n\
use strict;\n\
use vars \'%Cache\';\n\
use Symbol qw(delete_package);\n\
$Embed::perlRTEcount = 0;\n\
$Embed::debug = undef;\n\
\n\
sub valid_package_name\n\
{\n\
    my($string) = @_;\n\
    $string =~ s/([^A-Za-z0-9\\/])/sprintf(\"_%2x\",unpack(\"C\",$1))/eg;\n\
    # second pass only for words starting with a digit\n\
    $string =~ s|/(\\d)|sprintf(\"/_%2x\",unpack(\"C\",$1))|eg;\n\
\n\
    # Dress it up as a real package name\n\
    $string =~ s|/|::|g;\n\
    return \"Embed\" . $string;\n\
}\n\
\n\
sub eval_file\n\
{\n\
   $Embed::perlRTEcount++;\n\
   my ($filename, $delete, $debug) = @_;\n\
   my $package = valid_package_name($filename);\n\
   if ($debug) { printf (\"DEBUG: \\$package |$package|\\n\"); }\n\
   my $wasd = 0;\n\
   my $mtime = -M $filename;\n\
   if ($debug) { printf (\"DEBUG: file:$mtime cache:$Cache{$package}{mtime}\\n\"); }\n\
   if (defined $Cache{$package}{mtime} &&\n\
       $Cache{$package}{mtime} == $mtime)\n\
   {\n\
      # we have compiled this subroutine already,\n\
      if ($debug) { printf (\"DEBUG: package cached\\n\"); }\n\
      $main::perlRTEcache++;\n\
      $wasd = $Cache{$package}{wasd};\n\
   }\n\
   else\n\
   {\n\
      local *FH;\n\
      open FH, $filename or die \"open \'$filename\' $!\";\n\
      local($/) = undef;\n\
      my $sub = <FH>;\n\
      close FH;\n\
\n\
      $wasd = substr($sub,0,6) eq \"#WASD#\";\n\
      if ($wasd) {\n\
         $| = 1;\n\
         print \"Content-type: text/plain\\n\\n\";\n\
      }\n\
      # wrap the code into a subroutine inside our unique package\n\
      my $eval = qq{package $package; sub handler { $sub; }};\n\
      {\n\
          # hide our variables within this block\n\
          my($filename,$mtime,$package,$sub);\n\
          eval $eval;\n\
      }\n\
      die $@ if $@;\n\
      if ($debug) { printf (\"DEBUG: eval package\\n\"); }\n\
      $Cache{$package}{mtime} = $mtime;\n\
      $Cache{$package}{wasd} = $wasd;\n\
      $wasd = 0;\n\
      $main::perlRTEcache = 0;\n\
      $main::perlRTEversion = \'" SOFTWAREID "\';\n\
   }\n\
\n\
   # set these global variables for script use/abuse\n\
   $main::perlRTEcount = $Embed::perlRTEcount;\n\
   $main::perlRTEdebug = $debug;\n\
   $main::perlRTEpersist = !$delete;\n\
\n\
   # make STDOUT autoflush (became necessary with v5.10.0)\n\
   $| = 1;\n\
   if ($wasd) { print \"Content-type: text/plain\\n\\n\"; }\n\
   eval {$package->handler;};\n\
   die $@ if $@;\n\
\n\
   $delete = !$main::perlRTEpersist if !$delete;\n\
   if ($delete) {\n\
      if ($debug) { printf (\"DEBUG: delete_package($package)\\n\"); }\n\
      delete_package($package);\n\
      delete $Cache{$package}{mtime};\n\
      delete $Cache{$package}{wasd};\n\
   }\n\
   else {\n\
      if ($debug) { printf (\"DEBUG: package kept\\n\"); }\n\
   }\n\
}\n\
\n\
1;\n\
\n\
__END__\n\
";

/*****************************************************************************/
/*
This function runs the Perl interpreter for a "persistent" Perl Run-Time
Environment.  This uses the "Embed::Persist" package in an attempt to create
a partioned name and execution space for each unique script file passed to it.
*/

int PerlPersistEngine
(
char *PerlSource,
char *PerlSwitch
)
{
   static PerlInterpreter  *PerlIntPtr;

   int  idx, status;
   char  *PerlArgs [10];

   /*********/
   /* begin */
   /*********/

   if (Debug)
      fprintf (stdout, "PerlPersistEngine() %d |%s|%s|\n",
               UsageCount, PerlSource, PerlSwitch ? PerlSwitch : "(null)");

   if (!PerlIntPtr)
   {
      if (Debug) fprintf (stdout, "perl_alloc()\n");
      PerlIntPtr = perl_alloc();

      if (Debug) fprintf (stdout, "perl_contruct()\n");
      perl_construct (PerlIntPtr);
      PL_perl_destruct_level = 0;

      /* load the "Embed::Persist" package (string) above */
      idx = 0;
      PerlArgs[idx++] = "PERLRTENG";
      if (PerlSwitch && PerlSwitch[0]) PerlArgs[idx++] = PerlSwitch;
      PerlArgs[idx++] = "-e";
      PerlArgs[idx++] = PackageEmbedPersist;
      PerlArgs[idx] = NULL;
      PL_origalen = 1;
      if (Debug) fprintf (stdout, "perl_parse()\n");
      status = perl_parse (PerlIntPtr, XsInit, idx, PerlArgs, (char**)NULL);
      if (Debug) fprintf (stdout, "status: %d\n", status);
      if (status) exit (status);

      if (Debug) fprintf (stdout, "perl_run()\n");
      status = perl_run (PerlIntPtr);
      if (Debug) fprintf (stdout, "status: %d\n", status);
      if (!(status & 1)) exit (status);
   }

   SetCgiEnv (1);

   idx = 0;
   PerlArgs[idx++] = PerlSource;
   PerlArgs[idx++] = CliClean ? "1" : "0";
   PerlArgs[idx++] = (Debug || CliPerlDebug) ? "1" : "0";
   PerlArgs[idx] = NULL;
   if (Debug) fprintf (stdout, "perl_call_argv()\n");
   perl_call_argv ("Embed::Persist::eval_file",
                   G_DISCARD | G_EVAL, PerlArgs);

   if (SvTRUE(ERRSV))
   {
      fprintf (stdout, "%%%s-E-CALLARGV, %s-CALLARGV-E-ARGS,",
               Utility, SvPV(ERRSV,PL_na));
      for (idx = 0; PerlArgs[idx]; idx++)
         fprintf(stdout," [%d]%s",idx,PerlArgs[idx]);
      fputs ("\n", stdout);
      return (0);
   }

   SetCgiEnv (0);

   return (1);
}

/*****************************************************************************/
/*
This function runs a Perl interpreter for a "clean" Perl Run-Time Environment. 
Allows the Perl interpreter to continue between requests, just contructing and
destructing it.  The function also attempts to improve latency by proactively
creating a new Perl environment at the conclusion of a request.  At the start
of the next it only has to parse and run the script.
*/

int PerlNonPersistEngine
(
char *PerlSource,
char *PerlSwitch
)
{
   static PerlInterpreter  *PerlIntPtr = NULL;

   int  idx;
   I32  status;
   char  *PerlArgs [4];

   /*********/
   /* begin */
   /*********/

   if (Debug)
      fprintf (stdout, "PerlNonPersistEngine() %d |%s|%s|\n",
               UsageCount, PerlSource, PerlSwitch ? PerlSwitch : "(null)");

   if (UsageCount == 1 || !PerlIntPtr || PerlSource[0] == '.')
   {
      if (Debug) fprintf (stdout, "perl_alloc()\n");
      PerlIntPtr = perl_alloc();
   }
   if (UsageCount == 1)
   {
      if (Debug) fprintf (stdout, "perl_contruct()\n");
      perl_construct (PerlIntPtr);
      PL_perl_destruct_level = 0;
   }

   idx = 0;
   PerlArgs[idx++] = "PERLRTENG";
   if (PerlSwitch && PerlSwitch[0]) PerlArgs[idx++] = PerlSwitch;
   PerlArgs[idx++] = PerlSource;
   PerlArgs[idx] = NULL;
   if (Debug) fprintf (stdout, "perl_parse()\n");
   status = perl_parse (PerlIntPtr, XsInit, idx, PerlArgs, (char **)NULL);
   if (Debug) fprintf (stdout, "status: %d\n", status);

   if (!status)
   {
      SetCgiEnv (1);
      if (Debug) fprintf (stdout, "perl_run()\n");
      perl_run (PerlIntPtr);
   }

   if (Debug) fprintf (stdout, "perl_destruct()\n");
   perl_destruct (PerlIntPtr);

   /* proactively create a new Perl environment ready for the next request */
   if (Debug) fprintf (stdout, "perl_alloc()\n");
   PerlIntPtr = perl_alloc();

   if (Debug) fprintf (stdout, "perl_contruct()\n");
   perl_construct (PerlIntPtr);
   PL_perl_destruct_level = 0;

   return (1);
}

/*****************************************************************************/
/*
This function runs a Perl interpreter in "one-shot" mode.
That is PERLRTE being used in a standard CGI (non-plus/RTE) environment.
*/

int PerlOneShotEngine
(
char *PerlSource,
char *PerlSwitch
)       
{
   int  idx;
   I32  status;
   char  *PerlArgs [4];
   PerlInterpreter  *PerlIntPtr;

   /*********/
   /* begin */
   /*********/

   if (Debug)
      fprintf (stdout, "PerlOneShotEngine() |%s|%s|\n",
               PerlSource, PerlSwitch ? PerlSwitch : "(null)");

   PerlIntPtr = NULL;

   if (Debug) fprintf (stdout, "perl_alloc()\n");
   PerlIntPtr = perl_alloc();

   if (Debug) fprintf (stdout, "perl_contruct()\n");
   perl_construct (PerlIntPtr);
   PL_perl_destruct_level = 0;

   idx = 0;
   PerlArgs[idx++] = "PERLRTENG";
   if (PerlSwitch && PerlSwitch[0]) PerlArgs[idx++] = PerlSwitch;
   PerlArgs[idx++] = PerlSource;
   PerlArgs[idx] = NULL;
   if (Debug) fprintf (stdout, "perl_parse()\n");
   status = perl_parse (PerlIntPtr, XsInit, idx, PerlArgs, (char**)NULL);
   if (Debug) fprintf (stdout, "status: %d\n", status);

   if (!status)
   {
      SetCgiEnv (1);
      if (Debug) fprintf (stdout, "perl_run()\n");
      perl_run (PerlIntPtr);
   }

   if (Debug) fprintf (stdout, "perl_destruct()\n");
   perl_destruct (PerlIntPtr);

   return (1);
}

/*****************************************************************************/
/*
Monkey see, monkey do ...
*/

void PerlSysInit3
(
int *argcp,
char ***argvp,
char ***envp
)
{
   /*********/
   /* begin */
   /*********/

   if (Debug) fprintf (stdout, "PerlSysInit3()\n");

   PERL_SYS_INIT3 (argcp, argvp, envp);
}

/*****************************************************************************/
/*
Generate the CGI variables.  If 'SetEnv' is true scan through the CGI(plus)
variable list adding each of the variables to main::ENV, if false delete each
of them.  With a persistent environment it is necessary to clean up variables
created, lest they interfere with the next script processed.  To allow PERLRTE
to run scripts using the CGIplus.pm module this creates and populates an
associative array main::CGIplusENV with the same data.  See description
in PERLRTE.C for further detail on this arrangement.
*/

void SetCgiEnv (int SetEnv)
       
{
   static HV  *myEnvCgiHV,
              *myEnvCgiPlusHV;

   char  *cptr, *sptr;
   char  String [256];
   I32  klen;
   SV  *svptr;

   /*********/
   /* begin */
   /*********/

   if (Debug)
      fprintf (stdout, "SetCgiEnv() %d %d |%s|%s|\n",
               SetEnv, CliCgiPrefix, CliCgiHashNamePtr,
               CliCgiPlusHashNamePtr);

   if (SetEnv)
   {
      myEnvCgiHV = perl_get_hv (CliCgiHashNamePtr, TRUE);
      myEnvCgiPlusHV = perl_get_hv (CliCgiPlusHashNamePtr, TRUE);
   }

   while ((cptr = CgiVar("*")))
   {
      if (Debug) fprintf (stdout, "|%s|\n", cptr);
      for (sptr = cptr; *sptr && *sptr != '='; sptr++);
      klen = sptr - cptr;
      /* induce CGI.pm to behave persistently (see description in prologue) */
      if (!CliNoPerlEx && IsCgiPlus)
         if (strsame (cptr, "GATEWAY_INTERFACE", klen))
            sptr = "=CGI-PerlEx";
      if (*sptr) sptr++;
      if (SetEnv)
      {
         hv_store (myEnvCgiHV, cptr, klen, newSVpv(sptr,0), FALSE);
         hv_store (myEnvCgiPlusHV, cptr, klen, newSVpv(sptr,0), FALSE);
      }
      else
      {
         hv_delete (myEnvCgiHV, cptr, klen, FALSE);
         hv_delete (myEnvCgiPlusHV, cptr, klen, FALSE);
      }
   }
}

/*****************************************************************************/
/*
*/

void XsInit ()
       
{
   char *file = __FILE__;

   /*********/
   /* begin */
   /*********/

   if (Debug) fprintf (stdout, "XsInit()\n");

   /* DynaLoader is a special case */
   newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);

   /* Perl 5.6 uses static loading, 5.8 uses dynamic loading */
#if PERLRTENG_56
   if (!CliNoSocket) newXS("Socket::bootstrap", boot_Socket, file);
#endif
}

/*****************************************************************************/