/*****************************************************************************/
/*
                                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-2023 Mark G.Daniel

Licensed under the Apache License, Version 2.0 (the "License"); you may not use
this file except in compliance with the License.  You may obtain a copy of the
License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software distributed
under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR
CONDITIONS OF ANY KIND, either express or implied.  See the License for the
specific language governing permissions and limitations under the License.


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

/* externs */

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

extern char  *CliCgiHashNamePtr,
             *CliCgiPlusHashNamePtr;

extern char  PerlVersion[],
             SoftwareID[],
             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));

/*****************************************************************************/
/*
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 = \"%s %s\";\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  *sptr;
   char  *PerlArgs [10];

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

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

   if (!PerlIntPtr)
   {
      sptr = malloc (sizeof(PackageEmbedPersist) + 128);
      sprintf (sptr, PackageEmbedPersist, SoftwareID, PerlVersion);

      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++] = sptr;
      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);
}

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