/*****************************************************************************/ /* PerlRTE.c Perl Run-Time Environment. This scripting environment provides a persistent Perl engine using techniques described in the 'perlembed' document. It operates in the CGIplus environment and relies on a Run-Time Environment mechanism available in WASD HTTPd v7.1. Two modes are available (mainly due to experimentation, the first is probably the mode of choice). SUPPORTED VERSIONS ------------------ Developed and tested against Perl v5.18.2 (VMS ports), {v5.10.0}, v5.8.6, v5.8.0 and {v5.6.1}. (Bracketed with {} not longer supported.) CGI.pm and Perl v5.6.0 could not read a POSTed multipart stream satisfactorily. "CGI.pm: Server closed socket during multipart read (client aborted?)." This is apparently a known problem fixed by migrating to the CGI.pm with 5.6.1. PERSISTENT ---------- This approach uses methods and code described in the 'perlembed' document "Maintaining a persistent interpreter" section, to load and keep cached multiple script and module sources. The embedding code maintains the last modification time of each script cached and checks this against the last modification time of the script file before each activiation. If there is a difference in the two time (i.e. the file has changed in some way) the cache is overwritten with a fresh evalation of the script. There is no need to explicitly flush this cache in any way. Measurements using the Apache Bench (AB.EXE) tool indicate for the example Perl script loading the CGI.PM module, an improvement in the order of a factor of *twenty-five*!! I am unsure of exactly how isolated each script loaded really is. Each is treated as an autonomous package and so storage restrictions etc. need to be observed. However apart from that it would seem as if any old (perhaps slightly tweaked) CGI script could be used within this environment. NON-PERSISTENT -------------- Each script gets a brand-new, completely fresh interpreter and so execute completely autonomously. The saving is in script response latency and system impact, both due to the need for loading the Perl shareable image and Perl interpreter only once (a not inconsiderable saving with VMS). Measurements using the Apache Bench (AB.EXE) tool indicate for the example Perl scripts an improvement in the order of a factor of *five* for simple scripts. STANDARD CGI ------------ PerlRTE can even be used to activate a script in lieu of the standard PERL verb. Of course none of the advantages of the persistent environment are available. This is one solution to the requirement for POSTed body contnt to be supplied in binary mode, something quite difficult to organise for standard VMS Perl. $!(an example Perl "wrapper" procedure - wasd_root:[script_local]perlrte.com) $ perlrte = "$ht_exe:perlrte" $ perlrte 'www_script_filename' Change the HTTPD$CONFIG to reflect the procedure, restart ... voila! [DclScriptRuntime] .pl @wasd_root:[script_local]perlrte.com SERVER MAPPING -------------- The persistent Run-Time Environment can be activated in two ways. 1) HTTPD$MAP exec /plrte/* (cgi-bin:[000000]perlrte.exe)/whatever/location/* 2) HTTPD$CONFIG [DclScriptRunTime] .PL (cgi-bin:[000000]perlrte.exe) .CGI (cgi-bin:[000000]perlrte.exe) WRAPPING THE RTE ---------------- To add behaviour qualifiers to PerlRTE create a DCL procedure that activates the executable with the environment required. $!(an example "wrapper" procedure for the PERLRTE engine itself) $ perlrte = "$ht_exe:perlrte" $ perlrte /nopersist When using this technique the mappings would need to be changed to something like the following. exec /plrte/* (@cgi-bin:[000000]perlrte.com)/whatever/location/* CGIPLUS.PM ---------- To use PerlRTE to activate a CGIplus.pm including script some accomodations must be made to prevent interference between the two. The complications arise because both would be attempting to read the CGIPLUSIN stream and synchronise the request processing. Obviously both cannot do this! The compromise has been to allow PERLRTE.C to sync and read the first request's variables, which it places into the main::CGIplusENV associative array used by the CGIplus.pm module (as well as into main::ENV). After that initial request CGIplus.pm takes over the request synchronising and variable reading. As far as PERLRTE.C is concerned the first request it initiates never (or seldom) completes ;^) A script using CGIplus.pm should NEVER BE ACTIVATED using an RTE path (one using the mapping syntax "exec+ (rte_executable)/path/* /path/*"). When an RTE becomes quiescent the server will give it another script. With the CGIplus.pm CGIplus loop is active an unintended and probably incorrect script will become active. Always activate CGIplus.pm enabled scripts via a CGIplus path. CGIplus.pm will detect this mapping mistake and die! So that persistent PerlRTE can use an unmodified CGI.pm it impersonates Active State's PerlEx (http://aspn.activestate.com/). See comments in PERLRTENG.C PERSISTENCE DATA ---------------- Three data are available to perl scripts providing some general information about the persistent environment. $main::perlRTEcache count of script retrieved from cache (0 is first use) $main::perlRTEcount count of PerlRTE engine activations $main::perlRTEversion the version string for PerlRTE CAUTIONS -------- 1) A fair bit of this is "monkey see, monkey do" ... the author, by no means, being even Perl competant ... let alone a Perl internals expert! Hence, this code may be full of bugs, or at the very least, inelegant methods when interfacing with Perl. All suggestions gratefully received. 2) It has been acknowleged by the VMS Perl developers that Perl itself leaks memory with each interpreter construct/destruct (at least up to v5.6). The author has confirmed this, at about 40kB per instance (v5.6 compiled using DECC 6.2 on VMS v7.2-1). It also leaks 4.6kB (a *lot* less) with the persistent approach. The /ENOUGH= puts a limit on the number of scripts the RTE will process before proactively exiting. This is a default of 100 when using /CLEAN or 1000 for persistent engines. QUALIFIERS ---------- /CLEAN with the persistent engine do not cache any eval()ed scripts /ENOUGH= integer (see "cautions" above) /ENV= (for Perl 5.6->) uses PERL_ENV_TABLES to confine %ENV hash to CLISYM_GLOBAL (default), CLISYM_LOCAL, CRTL_ENV, or other /HASH= name of Perl hash into which CGI environment is created /HASHCGIPLUS= name of Perl hash into which CGIplus environment is created /NOPERSIST do not use the persistent engine /PDEBUG turn on debug statements in the persistent Perl engine package /PERL= pass this to the Perl interpreter command line (e.g. "-Dlts") /TYPE= default file type (e.g. ".PL", ".CGI") /NOPERLEX do not use the 'PerlEx' kludge to induce CGI.pm to behave /NOSOCKET do not attempt to load the socket (TCP/IP) extension /WWWPREFIX the persistent engine, by default, creates the Perl CGI variables without the leading "WWW_", this restores this. LOGICAL NAMES ------------- PERLRTE$DBUG turns on all "if (Debug)" statements BUILD DETAILS ------------- $ @BUILD_PERLRTE BUILD !compile+link for local Perl $ @BUILD_PERLRTE LINK !link-only for local Perl And so on for other supported versions. 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 (update PERLRTEV as well!) --------------- 20-MAY-2023 MGD v1.3.0, GATEWAY_SYMBOLS used for standard-CGI variables 21-FEB-2023 MGD v1.2.9, v5.34 (VSI V9.2 x86-64) try to make Perl version agnostic in line with WASD move Apache License 18-MAY-2016 MGD v1.2.8, verified OK against v5.24.0 (VMS ports) 06-JUN-2015 MGD v1.2.7, verified OK against v5.22.0 (VMS ports) 11-JAN-2014 MGD v1.2.6, verified OK against v5.18.2 (VMS ports) 03-JAN-2011 MGD v1.2.5, WASD v10.1 ProctorDetect() 24-JAN-2008 MGD v1.2.4, make STDOUT autoflush (v5.10.0) verified OK against v5.10.0 #WASD# at start of script issues plain-text header bugfix; using non-persistant enough (100) when using persistent engine (should be 1000) bugfix; access P1 as Perl script source file 23-NOV-2005 MGD v1.2.3, verified OK against CPQ AXPVMS PERL V5.8-6 and HP I64VMS PERL V5.8-6 (no modification), minor conditional mods to support IA64 28-JUN-2003 MGD v1.2.2, DEFAULT_PERSIST_ENOUGH back up from 100 to 1000 19-APR-2003 MGD v1.2.1, CgiVarDclSymbolName() in line with WASD v8.2, DEFAULT_PERSIST_ENOUGH down from 1000 to 100 02-JAN-2003 MGD v1.2.0, CgiVar() used to set plain CGI variables (this makes it better conform with CGIplus/RTE), integration with CGIplus.pm to allow a script to use the module without interfering with one another 27-JUL-2002 MGD v1.1.0, significant changes to eliminate CGILIB, PERLRTENG.C changes to support Perl 5.8.0, add 'PerlEx' kludge to PERLRTENG.C to allow CGI.pm to initialize correctly 28-OCT-2000 MGD v1.0.0, initial development */ /*****************************************************************************/ /* PerlRTEng.c gets just these definitions by a #define and #include */ #define SOFTWARECR "Copyright (C) 2000-2023 Mark G.Daniel" #define SOFTWAREVN "1.3.0" #define SOFTWARENM "PERLRTE" #ifdef __ALPHA # define SOFTWAREID SOFTWARENM " AXP-" SOFTWAREVN #endif #ifdef __ia64 # define SOFTWAREID SOFTWARENM " IA64-" SOFTWAREVN #endif #ifdef __x86_64 # define SOFTWAREID SOFTWARENM " X86-" SOFTWAREVN #endif #define SOFTWARELIC \ "Licensed under the Apache License, Version 2.0 (the \"License\");\n\ you may not use this software except in compliance with the License.\n\ A copy is available at ... http://www.apache.org/licenses/LICENSE-2.0\n\ Software distributed under the License is distributed on an \"AS IS\" BASIS,\n\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.\n" #ifndef PERLRTENG_INCLUDE_PERLRTEV /* standard C header files */ #include #include #include #include #include /* VMS related header files */ #include #include #include #include #include #include #include #include /* macros */ #define DEFAULT_CGI_HASH_NAME "main::ENV" #define DEFAULT_CGIPLUS_HASH_NAME "main::CGIplusENV" #define DEFAULT_FILE_TYPE ".PL" #define DEFAULT_PERL_ENV_TABLES "CLISYM_GLOBAL,LNM$PROCESS,LNM$JOB" #define DEFAULT_PERSIST_ENOUGH 1000 #define DEFAULT_NONPERSIST_ENOUGH 100 #define FI_LI __FILE__, __LINE__ #define VMSok(x) ((x) & STS$M_SUCCESS) #define VMSnok(x) !(((x) & STS$M_SUCCESS)) #define boolean int #define true 1 #define false 0 #define MAX_LNM_EQUIV 8 /* global storage */ boolean CgiVarDebug, CliCgiPrefix, CliNoPerlEx, CliNoSocket, CliClean, CliPerlDebug, CliPersistentEngine = true, Debug, IsCgiPlus; int EnoughCount = DEFAULT_PERSIST_ENOUGH, UsageCount; char *CgiPlusEofPtr, *CgiPlusEotPtr, *CgiPlusEscPtr, *CliCgiEnvPtr = DEFAULT_PERL_ENV_TABLES, *CliCgiHashNamePtr = DEFAULT_CGI_HASH_NAME, *CliCgiPlusHashNamePtr = DEFAULT_CGIPLUS_HASH_NAME, *CliFileTypePtr = DEFAULT_FILE_TYPE, *CliPerlSourcePtr, *CliPerlSwitchPtr, *PerlRootPtr, *PerlShrPtr, *PerlVersionPtr; char PerlVersion [16] = "?.??", SoftwareID [] = SOFTWAREID, Utility [] = "PERLRTE"; /* externs */ extern char PackageEmbedPersist[]; /* prototypes */ int sys$crelnm (int, struct dsc$descriptor_s*, struct dsc$descriptor_s*, void*, void*); char* CgiVar (char*); char* DclSymbolNames (); void GetParameters (); void PerlSysInit3 (int*, char***, char***); int PerlNonPersistEngine (char*, char*); int PerlOneShotEngine (char*, char*); int PerlPersistEngine (char*, char*); int ProcessRequest (); int ProctorDetect (); int strsame (char*, char*, int); /*****************************************************************************/ /* */ main ( int argc, char *argv[], char *env[] ) { static $DESCRIPTOR (LogTableDsc, "LNM$PROCESS"); static $DESCRIPTOR (PerlEnvTablesDsc, "PERL_ENV_TABLES"); boolean SwitchHit; int idx, retval, status; char *cptr, *sptr; struct { short int buf_len; short int item; unsigned char *buf_addr; unsigned short *ret_len; } CreLnmItem [MAX_LNM_EQUIV+1]; /*********/ /* begin */ /*********/ if (Debug = (boolean)(getenv ("PERLRTE$DBUG"))) fprintf (stdout, "Content-Type: text/plain\n\n"); /** CgiVarDebug = Debug; **/ if (PerlRootPtr = cptr = getenv ("PERL_ROOT")) { if ((cptr = strstr (PerlRootPtr, "PERL")) || (cptr = strstr (PerlRootPtr, "perl"))) { while (*cptr && !isdigit(*cptr)) cptr++; if (*cptr == '5') { for (cptr++; *cptr && !isdigit(*cptr); cptr++); sprintf (PerlVersion, "5.%d", atoi(cptr)); } } } PerlShrPtr = getenv ("PERLSHR"); IsCgiPlus = (boolean)(CgiPlusEofPtr = getenv("CGIPLUSEOF")); CgiPlusEotPtr = getenv("CGIPLUSEOT"); CgiPlusEscPtr = getenv("CGIPLUSESC"); if (!CliPersistentEngine) EnoughCount = DEFAULT_NONPERSIST_ENOUGH; if (IsCgiPlus) GetParameters (); else if (argc > 1) { /* let's (try and) be all things to all people */ SwitchHit = false; for (idx = 1; idx < argc; idx++) { /* find first non-switch/non-qualifier string on the command line */ if (argv[idx][0] == '-') SwitchHit = true; if (!SwitchHit && argv[idx][0] == '/') { GetParameters (); break; } if (argv[idx][0] != '-') { CliPerlSourcePtr = argv[idx]; break; } } } /* reopen as a binary mode HTTP$INPUT for POSTed requests */ if (CgiPlusEscPtr) if (!(stdin = freopen ("HTTP$INPUT:", "r", stdin, "ctx=bin"))) exit (vaxc$errno); if (CliCgiEnvPtr[0]) { idx = 0; cptr = CliCgiEnvPtr; while (*cptr && idx < MAX_LNM_EQUIV) { for (sptr = cptr; *sptr && *sptr != ','; sptr++); CreLnmItem[idx].item = LNM$_STRING; CreLnmItem[idx].buf_addr = (unsigned char*)cptr; CreLnmItem[idx++].buf_len = sptr - cptr; if (Debug) fprintf (stdout, "|%.*s|\n", sptr-cptr, cptr); if (*(cptr = sptr)) cptr++; } memset (&CreLnmItem[idx], 0, sizeof(CreLnmItem[idx])); status = sys$crelnm (0, &LogTableDsc, &PerlEnvTablesDsc, 0, &CreLnmItem); if (VMSnok (status)) exit (status); } PerlSysInit3 (&argc, &argv, &env); CgiVar (NULL); if (IsCgiPlus) { while (EnoughCount--) { /* block waiting for the first/next request */ CgiVar (""); retval = ProcessRequest (); if (!retval) break; /* provide the CGIplus end-of-output record */ fflush (stdout); fputs (CgiPlusEofPtr, stdout); fflush (stdout); /* ensure is in record mode (Perl expects that!) */ if (!(stdout = freopen ("SYS$OUTPUT:", "w", stdout, "ctx=rec"))) exit (vaxc$errno); } } else ProcessRequest (); if (Debug) fprintf (stdout, "UsageCount: %d\n", UsageCount); exit (SS$_NORMAL); } /*****************************************************************************/ /* */ int ProcessRequest () { int retval; char *cptr, *sptr, *zptr; char PerlSource [256]; /*********/ /* begin */ /*********/ if (Debug) fprintf (stdout, "ProcessRequest() %d\n", IsCgiPlus); if (ProctorDetect ()) return (1); UsageCount++; if (CliPerlSourcePtr) cptr = CliPerlSourcePtr; else cptr = CgiVar ("SCRIPT_FILENAME"); if (!cptr || !*cptr) { fprintf (stdout, "%%%s-E-BUGCHECK, no \"SCRIPT_FILENAME\"\n", Utility); exit (SS$_BUGCHECK | STS$M_INHIB_MSG); } /* ensure the script file name has a default extension */ zptr = (sptr = PerlSource) + sizeof(PerlSource); while (*cptr && sptr < zptr) *sptr++ = *cptr++; if (sptr >= zptr) exit (SS$_BUFFEROVF+1); *(cptr = sptr) = '\0'; while (cptr > PerlSource && *cptr != '.' && *cptr != ']') cptr--; if (*cptr != '.') { for (cptr = CliFileTypePtr; *cptr && sptr < zptr; *sptr++ = *cptr++); if (sptr >= zptr) exit (SS$_BUFFEROVF+1); *sptr = '\0'; } if (IsCgiPlus) if (CliPersistentEngine) retval = PerlPersistEngine (PerlSource, CliPerlSwitchPtr); else retval = PerlNonPersistEngine (PerlSource, CliPerlSwitchPtr); else retval = PerlOneShotEngine (PerlSource, CliPerlSwitchPtr); return (retval); } /*****************************************************************************/ /* Self-contained functionality. Designed to be called if the script is not found. If found the script needs to instantiate whatever resources it is proctored for and then return an HTTP 204 to the server. If not found then call this function and if this is the first call then check if there is a REQUEST_METHOD. If there is then return false. If not assume WASD is proactively starting the RTE. Then respond with an HTTP 204 and return true. If the calling routine receives a false then it continues processing, if a true then it concludes and waits for the next request. */ int ProctorDetect () { static int DetectCount; char *cptr; /*********/ /* begin */ /*********/ if (Debug) fprintf (stdout, "ProctorDetect()\n"); if (DetectCount++) return (0); /* if this CGI variable does not exist then probably not scripting */ cptr = CgiVar ("SERVER_SOFTWARE"); if (!(cptr && *cptr)) return (0); cptr = CgiVar ("REQUEST_METHOD"); if (cptr && *cptr) return (0); fputs ("Status: 204 RTE Proctor Response\r\n\r\n", stdout); return (1); } /*****************************************************************************/ /* Return the value of a CGI variable regardless of whether it is used in a standard CGI environment or a WASD CGIplus (RTE) environment. Also automatically switches WASD V7.2 and later servers into 'struct' mode for significantly improved performance. WASD by default supplies CGI variables prefixed by "WWW_" to differentiate them from any other DCL symbols (or "env"ironment logicals). This is automatically detected if present and ignored. WASD v12.1.1 and later provides the CGI variable (symbol) GATEWAY_SYMBOLS with a comma-separated list of DCL symbol names used for the CGI environment. */ char* CgiVar (char *VarName) { # ifndef CGIVAR_STRUCT_SIZE # define CGIVAR_STRUCT_SIZE 8192 # endif # define SOUS sizeof(unsigned short) static int CalloutDone, DclSymbol, StructLength, WwwLength; static char *NextVarNamePtr; static char NameBuffer [256], StructBuffer [CGIVAR_STRUCT_SIZE], SymbolsBuffer [4096], NameValueBuffer [4096]; static FILE *CgiPlusIn; static $DESCRIPTOR (NameDsc, NameValueBuffer); static $DESCRIPTOR (SymbolsDsc, SymbolsBuffer); static $DESCRIPTOR (NameValueDsc, NameValueBuffer); static $DESCRIPTOR (GatewayInterfaceDsc, "GATEWAY_INTERFACE"); static $DESCRIPTOR (GatewaySymbolsDsc, "GATEWAY_SYMBOLS"); static $DESCRIPTOR (WwwGatewayInterfaceDsc, "WWW_GATEWAY_INTERFACE"); static $DESCRIPTOR (WwwGatewaySymbolsDsc, "WWW_GATEWAY_SYMBOLS"); int status; int Length; unsigned short slen; char *bptr, *cptr, *sptr, *zptr; /*********/ /* begin */ /*********/ if (CgiVarDebug) fprintf (stdout, "CgiVar() |%s|\n", !VarName ? "NULL" : VarName); if (!DclSymbol) { /*************************/ /* check for DCL symbols */ /*************************/ DclSymbol = 1; status = lib$get_symbol (&GatewayInterfaceDsc, &NameValueDsc, 0, 0); if (!(status & 1)) status = lib$get_symbol (&WwwGatewayInterfaceDsc, &NameValueDsc, 0, 0); if (CgiVarDebug) fprintf (stdout, "lib$get_symbol %%X%08.08X\n", status); if (status & 1) { /* CGI symbol detected, therefore CGI request */ IsCgiPlus = 0; status = lib$get_symbol (&GatewaySymbolsDsc, &SymbolsDsc, &slen, 0); if (!(status & 1)) status = lib$get_symbol (&WwwGatewaySymbolsDsc, &SymbolsDsc, &slen, 0); if (status & 1) SymbolsBuffer[slen] = '\0'; else SymbolsBuffer[0] = '\0'; if (CgiVarDebug) fprintf (stdout, "|%s|\n", SymbolsBuffer); if (getenv ("PERLRTE$NOSYMBOLS")) SymbolsBuffer[0] = '\0'; } } if (!VarName || !VarName[0]) { /******************/ /* (re)initialize */ /******************/ StructLength = 0; if (SymbolsBuffer[0]) NextVarNamePtr = SymbolsBuffer; else if (IsCgiPlus) NextVarNamePtr = StructBuffer; else NextVarNamePtr = DclSymbolNames(); if (CgiVarDebug) fprintf (stdout, "NextVarNamePtr |%s|\n", NextVarNamePtr); if (!VarName) return (NULL); } WwwLength = 0; if (!IsCgiPlus) { /************************/ /* standard CGI symbols */ /************************/ if (VarName[0] == '*') { /* return each CGIplus variable in successive calls */ if (!*NextVarNamePtr) { if (SymbolsBuffer[0]) NextVarNamePtr = SymbolsBuffer; else NextVarNamePtr = DclSymbolNames(); if (CgiVarDebug) fprintf (stdout, "CGI |NULL|\n"); return (NULL); } for (cptr = sptr = NextVarNamePtr; *sptr && *sptr != ','; sptr++); while (*sptr && *sptr != ',') sptr++; if (*sptr) sptr++; NextVarNamePtr = sptr; } else cptr = VarName; zptr = (sptr = NameValueBuffer) + sizeof(NameValueBuffer)-1; while (*cptr && *cptr != ',' && sptr < zptr) *sptr++ = *cptr++; *sptr = '\0'; NameDsc.dsc$w_length = sptr - NameValueBuffer; NameValueDsc.dsc$a_pointer = sptr + 1; NameValueDsc.dsc$w_length = sizeof(NameValueBuffer) - NameDsc.dsc$w_length - 2; status = lib$get_symbol (&NameDsc, &NameValueDsc, &slen, 0); if (!(status & 1)) return (NULL); NameValueBuffer[NameDsc.dsc$w_length] = '='; NameValueDsc.dsc$a_pointer[slen] = '\0'; if (*((unsigned long*)NameValueBuffer) == 'WWW_') WwwLength = 4; return (NameValueBuffer + WwwLength); } /***********/ /* CGIplus */ /***********/ if (VarName && VarName[0]) { /***************************/ /* return a variable value */ /***************************/ if (CgiVarDebug) fprintf (stdout, "StructLength %d\n", StructLength); if (!StructLength) return (NULL); if (VarName[0] == '*') { /* return each CGIplus variable in successive calls */ if (!(Length = *(unsigned short*)NextVarNamePtr)) { NextVarNamePtr = StructBuffer; if (CgiVarDebug) fprintf (stdout, "CGIplus |NULL|\n"); return (NULL); } /* by default WASD CGI variable name are prefixed by "WWW_", ignore */ sptr = (NextVarNamePtr += SOUS); NextVarNamePtr += Length; if (*((unsigned long*)sptr) == 'WWW_') WwwLength = 4; if (CgiVarDebug) fprintf (stdout, "CGIplus |%s|\n", sptr + WwwLength); return (sptr + WwwLength); } /* by default WASD CGI variable name are prefixed by "WWW_", ignore */ if (*((unsigned long*)(StructBuffer+SOUS)) == 'WWW_') WwwLength = 4; /* return a pointer to this CGIplus variable's value */ for (bptr = StructBuffer; Length = *(unsigned short*)bptr; bptr += Length) { sptr = (bptr += SOUS) + WwwLength; for (cptr = VarName; *cptr && *sptr && *sptr != '='; cptr++, sptr++) if (toupper(*cptr) != toupper(*sptr)) break; /* if found return a pointer to the value */ if (CgiVarDebug) fprintf (stdout, "VarName |%s|%s|\n", VarName, sptr); if (!*cptr && *sptr == '=') { if (CgiVarDebug) fprintf (stdout, "CGIplus |%s|\n", sptr+1); cptr = malloc (strlen(sptr)); strcpy (cptr, sptr+1); return (cptr); } } /* not found */ if (CgiVarDebug) fprintf (stdout, "CGIplus |NULL|\n"); return (NULL); } /*************************/ /* get CGIplus variables */ /*************************/ if (CgiVarDebug) fprintf (stdout, "CgiPlusIn %u\n", CgiPlusIn); /* cannot "sync" in a non-CGIplus environment */ if (!VarName[0] && !IsCgiPlus) return (NULL); /* the CGIPLUSIN stream can be left open */ if (!CgiPlusIn) if (!(CgiPlusIn = fopen (getenv("CGIPLUSIN"), "r"))) exit (vaxc$errno); /* get the starting record (the essentially discardable one) */ for (;;) { cptr = fgets (StructBuffer, sizeof(StructBuffer), CgiPlusIn); if (!cptr) exit (vaxc$errno); /* if the starting sentinal is detected then break */ if (*(unsigned short*)cptr == '!\0' || *(unsigned short*)cptr == '!\n' || (*(unsigned short*)cptr == '!!' && isdigit(*(cptr+2)))) break; } /* MUST be done after reading the synchronizing starting record */ if (Debug) fprintf (stdout, "Content-Type: text/plain\n\n"); /* detect the CGIplus "force" record-mode environment variable (once) */ if (*(unsigned short*)cptr == '!!') { /********************/ /* CGIplus 'struct' */ /********************/ /* get the size of the binary structure */ StructLength = atoi(cptr+2); if (StructLength <= 0 || StructLength > sizeof(StructBuffer)) exit (SS$_BUGCHECK); if (!fread (StructBuffer, 1, StructLength, CgiPlusIn)) exit (vaxc$errno); } else { /*********************/ /* CGIplus 'records' */ /*********************/ /* reconstructs the original 'struct'ure from the records */ sptr = (bptr = StructBuffer) + sizeof(StructBuffer); while (fgets (bptr+SOUS, sptr-(bptr+SOUS), CgiPlusIn)) { /* first empty record (line) terminates variables */ if (bptr[SOUS] == '\n') break; /* note the location of the length word */ cptr = bptr; for (bptr += SOUS; *bptr && *bptr != '\n'; bptr++); if (*bptr != '\n') exit (SS$_BUGCHECK); *bptr++ = '\0'; if (bptr >= sptr) exit (SS$_BUGCHECK); /* update the length word */ *(unsigned short*)cptr = bptr - (cptr + SOUS); } if (bptr >= sptr) exit (SS$_BUGCHECK); /* terminate with a zero-length entry */ *(unsigned short*)bptr = 0; StructLength = (bptr + SOUS) - StructBuffer; } if (CgiVarDebug) { fprintf (stdout, "StructLength %d\n", StructLength); for (bptr = StructBuffer; Length = *(unsigned short*)bptr; bptr += Length) fprintf (stdout, "|%s|\n", bptr += SOUS); } if (!CalloutDone) { /* provide the CGI callout to set CGIplus into 'struct' mode */ fflush (stdout); fputs (CgiPlusEscPtr, stdout); fflush (stdout); /* the leading '!' indicates we're not going to read the response */ fputs ("!CGIPLUS: struct", stdout); fflush (stdout); fputs (CgiPlusEotPtr, stdout); fflush (stdout); /* don't need to do this again (the '!!' tells us what mode) */ CalloutDone = 1; } return (NULL); # undef SOUS } /*****************************************************************************/ /* Standard CGI environment. Clunky, but what else can we do with DCL symbols? */ char* DclSymbolNames () { static char SymbolNames [] = /* standard CGI variable names */ "AUTH_ACCESS,AUTH_AGENT,AUTH_GROUP,AUTH_PASSWORD,\ AUTH_REALM,AUTH_REALM_DESCRIPTION,AUTH_REMOTE_USER,\ AUTH_TYPE,AUTH_USER,CONTENT_LENGTH,CONTENT_TYPE,\ DOCUMENT_ROOT,GATEWAY_BG,GATEWAY_EOF,GATEWAY_EOT,\ GATEWAY_ESC,GATEWAY_INTERFACE,GATEWAY_MRS,\ HTTP_ACCEPT,HTTP_ACCEPT_CHARSET,HTTP_ACCEPT_ENCODING,\ HTTP_ACCEPT_LANGUAGE,HTTP_AUTHORIZATION,HTTP_CACHE_CONTROL,\ HTTP_COOKIE,HTTP_FORWARDED,HTTP_HOST,HTTP_IF_NOT_MODIFIED,\ HTTP_PRAGMA,HTTP_REFERER,HTTP_USER_AGENT,HTTP_X_FORWARDED_FOR,\ PATH_INFO,PATH_ODS,PATH_TRANSLATED,QUERY_STRING,\ REMOTE_ADDR,REMOTE_HOST,REMOTE_PORT,REMOTE_USER,\ REQUEST_CHARSET,REQUEST_CONTENT_TYPE,REQUEST_METHOD,\ REQUEST_SCHEME,REQUEST_TIME_GMT,REQUEST_TIME_LOCAL,REQUEST_URI,\ SCRIPT_FILENAME,SCRIPT_NAME,SCRIPT_RTE,SERVER_ADMIN,\ SERVER_ADDR,SERVER_CHARSET,SERVER_GMT,SERVER_NAME,\ SERVER_PROTOCOL,SERVER_PORT,SERVER_SOFTWARE,SERVER_SIGNATURE,\ UNIQUE_ID" /* mod_ssl names */ "HTTPS,SSL_PROTOCOL,SSL_SESSION_ID,SSL_CIPHER,SSL_CIPHER_EXPORT,\ SSL_CIPHER_USEKEYSIZE,SSL_CIPHER_ALGKEYSIZE,SSL_CLIENT_M_VERSION,\ SSL_CLIENT_M_SERIAL,SSL_CLIENT_S_DN,SSL_CLIENT_S_DN_x509,\ SSL_CLIENT_I_DN,SSL_CLIENT_I_DN_x509,SSL_CLIENT_V_START,\ SSL_CLIENT_V_END,SSL_CLIENT_A_SIG,SSL_CLIENT_A_KEY,SSL_CLIENT_CERT,\ SSL_SERVER_M_VERSION,SSL_SERVER_M_SERIAL,SSL_SERVER_S_DN,\ SSL_SERVER_S_DN_x509,SSL_SERVER_I_DN,SSL_SERVER_I_DN_x509,\ SSL_SERVER_V_START,SSL_SERVER_V_END,SSL_SERVER_A_SIG,\ SSL_SERVER_A_KEY,SSL_SERVER_CERT,SSL_VERSION_INTERFACE,\ SSL_TLS_SNI,SSL_VERSION_LIBRARY," /* Purveyor SSL names */ "SECURITY_STATUS,SSL_CIPHER,SSL_CIPHER_KEYSIZE,SSL_CLIENT_CA,\ SSL_CLIENT_DN,SSL_SERVER_CA,SSL_SERVER_DN,SSL_VERSION," /* X509 names */ "AUTH_X509_CIPHER,AUTH_X509_FINGERPRINT,AUTH_X509_ISSUER,\ AUTH_X509_KEYSIZE,AUTH_X509_SUBJECT"; /* end of list */ /*********/ /* begin */ /*********/ return (SymbolNames); } /*****************************************************************************/ /* Get "command-line" parameters, whether from the command-line or from a configuration symbol or logical containing the equivalent. */ void GetParameters () { static char CommandLine [256]; static unsigned long Flags = 0; int status; unsigned short Length; char ch; char *aptr, *cptr, *clptr, *sptr; $DESCRIPTOR (CommandLineDsc, CommandLine); /*********/ /* begin */ /*********/ if (Debug) fprintf (stdout, "GetParameters()\n"); if (!(clptr = getenv ("PERLRTE$PARAM"))) { /* get the entire command line following the verb */ if (VMSnok (status = lib$get_foreign (&CommandLineDsc, 0, &Length, &Flags))) exit (status); (clptr = CommandLine)[Length] = '\0'; } aptr = NULL; ch = *clptr; for (;;) { if (aptr && *aptr == '/') *aptr = '\0'; if (!ch || ch == '!') break; *clptr = ch; if (Debug) fprintf (stdout, "clptr |%s|\n", clptr); while (*clptr && isspace(*clptr)) *clptr++ = '\0'; aptr = clptr; if (*clptr == '/') clptr++; while (*clptr && !isspace (*clptr) && *clptr != '/') { if (*clptr != '\"') { clptr++; continue; } cptr = clptr; clptr++; while (*clptr) { if (*clptr == '\"') if (*(clptr+1) == '\"') clptr++; else break; *cptr++ = *clptr++; } *cptr = '\0'; if (*clptr) clptr++; } ch = *clptr; if (*clptr) *clptr = '\0'; if (Debug) fprintf (stdout, "aptr |%s|\n", aptr); if (!*aptr) continue; /***********/ /* process */ /***********/ if (strsame (aptr, "/CLEAN", 4)) { CliClean = true; continue; } if (strsame (aptr, "/DBUG", -1)) { Debug = true; continue; } if (strsame (aptr, "/ENOUGH=", 4)) { for (cptr = aptr; *cptr && *cptr != '='; cptr++); if (*cptr) cptr++; EnoughCount = atoi(cptr); if (EnoughCount) continue; fprintf (stdout, "%%%s-E-IVPARM, invalid parameter\n \\%s\\\n", Utility, aptr+1); exit (STS$K_ERROR | STS$M_INHIB_MSG); } if (strsame (aptr, "/ENV=", 4)) { for (cptr = aptr; *cptr && *cptr != '='; cptr++); if (!*cptr) continue; CliCgiEnvPtr = cptr+1; continue; } if (strsame (aptr, "/HASH=", 6)) { for (cptr = aptr; *cptr && *cptr != '='; cptr++); if (!*cptr) continue; CliCgiHashNamePtr = cptr+1; continue; } if (strsame (aptr, "/HASHCGIPLUS=", 15)) { for (cptr = aptr; *cptr && *cptr != '='; cptr++); if (!*cptr) continue; CliCgiPlusHashNamePtr = cptr+1; continue; } if (strsame (aptr, "/PACKAGE", -1)) { fputs (PackageEmbedPersist, stdout); exit (SS$_NORMAL); } if (strsame (aptr, "/PDEBUG", -1)) { CliPerlDebug = true; continue; } if (strsame (aptr, "/PERL=", 4)) { for (cptr = aptr; *cptr && *cptr != '='; cptr++); if (!*cptr) continue; CliPerlSwitchPtr = cptr+1; continue; } if (strsame (aptr, "/NOPERLEX", 7)) { CliNoPerlEx = true; continue; } if (strsame (aptr, "/NOPERSIST", 7)) { CliPersistentEngine = false; continue; } if (strsame (aptr, "/NOSOCKET", 6)) { CliNoSocket = true; continue; } if (strsame (aptr, "/NOSOCKET", 6)) { CliNoSocket = true; continue; } if (strsame (aptr, "/TYPE=", 4)) { for (cptr = aptr; *cptr && *cptr != '='; cptr++); if (!*cptr) continue; CliFileTypePtr = cptr+1; continue; } if (strsame (aptr, "/VERSION", 4)) { fprintf (stdout, "%%%s-I-VERSION, %s Perl %s\n%s\n%s", Utility, SoftwareID, PerlVersion, SOFTWARECR, SOFTWARELIC); exit (SS$_NORMAL); } if (strsame (aptr, "/WWWPREFIX", 6)) { CliCgiPrefix = true; continue; } if (*aptr == '/') { fprintf (stdout, "%%%s-E-IVQUAL, unrecognized qualifier\n \\%s\\\n", Utility, aptr+1); exit (STS$K_ERROR | STS$M_INHIB_MSG); } CliPerlSourcePtr = aptr; } } /****************************************************************************/ /* Does a case-insensitive, character-by-character string compare and returns true if two strings are the same, or false if not. See comment in strsame_test() below. */ boolean strsame ( char *sptr1, char *sptr2, int count ) { /*********/ /* begin */ /*********/ if (count > 0) return (strncasecmp (sptr1, sptr2, count) == 0); else return (strcasecmp (sptr1, sptr2) == 0); } /*****************************************************************************/ #endif /* PERLRTENG_INCLUDE_PERLRTEV */