/*****************************************************************************/ /* 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 - ht_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 @ht_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 $ @BUILD_PERLRTE BUILD 56 !compile+link for Perl 5.6 or later $ @BUILD_PERLRTE LINK 56 !link-only for Perl 5.6 or later And so on for other supported versions. COPYRIGHT --------- Copyright (C) 2000-2016 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 (update PERLRTEV as well!) --------------- 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-2016 Mark G.Daniel" #define SOFTWAREVN "1.2.8" #define SOFTWARENM "PERLRTE" #if PERLRTENG_58 # define PERLRTEP "/5.8" #endif #if PERLRTENG_518 # define PERLRTEP "/5.18" #endif #if PERLRTENG_520 # define PERLRTEP "/5.20" #endif #if PERLRTENG_522 # define PERLRTEP "/5.22" #endif #if PERLRTENG_524 # define PERLRTEP "/5.24" #endif #ifndef PERLRTEP # define PERLRTEP "/???" #endif #ifdef __ALPHA # define SOFTWAREID SOFTWARENM " AXP-" SOFTWAREVN PERLRTEP #endif #ifdef __ia64 # define SOFTWAREID SOFTWARENM " IA64-" SOFTWAREVN PERLRTEP #endif #ifdef __VAX # define SOFTWAREID SOFTWARENM " VAX-" SOFTWAREVN PERLRTEP #endif #define SOFTWAREGPL \ "This program, comes with ABSOLUTELY NO WARRANTY.\n\ This is free software, and you are welcome to redistribute it the under the\n\ conditions of the GNU GENERAL PUBLIC LICENSE, version 3 or any later version.\n\ http://www.gnu.org/licenses/gpl.txt\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 /* 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; char 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* CgiVarDclSymbolName (char*); 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; **/ 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); 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()\n"); 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). */ char* CgiVar (char *VarName) { # ifndef CGIVAR_STRUCT_SIZE # define CGIVAR_STRUCT_SIZE 8192 # endif # define SOUS sizeof(unsigned short) static int CalloutDone, StructLength; static char *NextVarNamePtr; static char StructBuffer [CGIVAR_STRUCT_SIZE]; static FILE *CgiPlusIn; int status; int Length; char *bptr, *cptr, *sptr, *zptr; /*********/ /* begin */ /*********/ if (CgiVarDebug) fprintf (stdout, "CgiVar() |%s|\n", !VarName ? "NULL" : VarName); if (!VarName || !VarName[0]) { /* initialize */ StructLength = 0; NextVarNamePtr = StructBuffer; if (!VarName) return (NULL); } if (VarName[0]) { /***************************/ /* return a variable value */ /***************************/ if (!IsCgiPlus) { /* standard CGI environment */ static int CheckWWW, PrefixWWW; static char NameValue [256+1024]; static $DESCRIPTOR (NameDsc, ""); static $DESCRIPTOR (ValueDsc, NameValue); static $DESCRIPTOR (WwwGatewayInterfaceDsc, "WWW_GATEWAY_INTERFACE"); unsigned short ShortLength; if (!CheckWWW) { CheckWWW = 1; status = lib$get_symbol (&WwwGatewayInterfaceDsc, &ValueDsc, &ShortLength, NULL); if (status & 1) PrefixWWW = 1; if (CgiVarDebug) fprintf (stdout, "PrefixWWW: %d\n", PrefixWWW); } if (VarName[0] == '*') if (!(VarName = CgiVarDclSymbolName ("*"))) return (NULL); zptr = (sptr = NameValue) + sizeof(NameValue)-1; if (CliCgiPrefix || PrefixWWW) { /* by default WASD CGI variable names are prefixed by "WWW_" */ for (cptr = "WWW_"; *cptr; *sptr++ = *cptr++); for (cptr = VarName; *cptr && sptr < zptr; *sptr++ = *cptr++); } else for (cptr = VarName; *cptr && sptr < zptr; *sptr++ = *cptr++); NameDsc.dsc$a_pointer = NameValue; NameDsc.dsc$w_length = sptr - NameValue; NameValue[NameDsc.dsc$w_length] = '='; ValueDsc.dsc$a_pointer = NameValue + NameDsc.dsc$w_length + 1; ValueDsc.dsc$w_length = sizeof(NameValue) - (NameDsc.dsc$w_length + 1); status = lib$get_symbol (&NameDsc, &ValueDsc, &ShortLength, NULL); if (CgiVarDebug) fprintf (stdout, "lib$get_symbol() %%X%08.08X\n", status); if (status & 1) ValueDsc.dsc$a_pointer[ShortLength] = '\0'; else NameDsc.dsc$a_pointer[NameDsc.dsc$w_length+1] = '\0'; if (CgiVarDebug) fprintf (stdout, "CGI |%s|\n", NameValue); if (CliCgiPrefix || PrefixWWW) return (NameValue + 4); return (NameValue); } /* hmmm, CGIplus not initialized */ if (IsCgiPlus && !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); } sptr = (NextVarNamePtr += SOUS); NextVarNamePtr += Length; if (CgiVarDebug) fprintf (stdout, "CGIplus |%s|\n", sptr); /* by default WASD CGI variable name are prefixed by "WWW_", ignore */ if (!CliCgiPrefix) return (sptr + 4); return (sptr + 4); } /* return a pointer to this CGIplus variable's value */ for (bptr = StructBuffer; Length = *(unsigned short*)bptr; bptr += Length) { /* by default WASD CGI variable name are prefixed by "WWW_", ignore */ sptr = (bptr += SOUS) + 4; for (cptr = VarName; *cptr && *sptr && *sptr != '='; cptr++, sptr++) if (toupper(*cptr) != toupper(*sptr)) break; /* if found return a pointer to the value */ 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 the CGIplus variables */ /*****************************/ /* 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, "%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* CgiVarDclSymbolName (char *VarName) { static char *CgiVarSymbolNames [] = { /* 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", "HTML_BODYTAG", "HTML_FOOTER", "HTML_FOOTERTAG", "HTML_HEADER", "HTML_HEADERTAG", "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 */ "#mod_ssl", "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 */ "#purveyor", "SECURITY_STATUS", "SSL_CIPHER", "SSL_CIPHER_KEYSIZE", "SSL_CLIENT_CA", "SSL_CLIENT_DN", "SSL_SERVER_CA", "SSL_SERVER_DN", "SSL_VERSION", /* X509 names */ "#X509", "AUTH_X509_CIPHER", "AUTH_X509_FINGERPRINT", "AUTH_X509_ISSUER", "AUTH_X509_KEYSIZE", "AUTH_X509_SUBJECT", /* end of list */ NULL }; static int idx; char *cptr, *sptr; /*********/ /* begin */ /*********/ if (CgiVarDebug) fprintf (stdout, "CgiVarDclSymbolName() %d |%s|\n", idx, !VarName ? "NULL" : VarName); if (!VarName) { idx = 0; return (NULL); } for (;;) { cptr = CgiVarSymbolNames[idx++]; if (CgiVarDebug) fprintf (stdout, "|%s|\n", !cptr ? "NULL" : cptr); if (!cptr) break; if (*cptr != '#') return (cptr); for (;;) { if (*(unsigned long*)cptr == '#mod') { /* Apache mod_ssl-like SSL CGI variables */ idx++; if (CgiVar ("SSL_VERSION_INTERFACE")) break; } if (*(unsigned long*)cptr == '#pur') { /* Purveyor-like SSL CGI variables */ idx++; if (CgiVar ("SECURITY_STATUS")) break; } if (*(unsigned long*)cptr == '#X50') { /* X.509 client certificate authentication CGI variables */ idx++; if (CgiVar ("AUTH_X509_CIPHER")) break; } while (cptr = CgiVarSymbolNames[idx]) { if (*cptr == '#') break; idx++; } if (!cptr) break; if (CgiVarDebug) fprintf (stdout, "|%s|\n", cptr); } if (!cptr) break; } idx = 0; return (NULL); } /*****************************************************************************/ /* 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\n%s\n%s", Utility, SoftwareID, SOFTWARECR, SOFTWAREGPL); 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. If a maximum number of characters are specified only those will be compared, if the entire strings should be compared then specify the number of characters as 0. */ boolean strsame ( char *sptr1, char *sptr2, int count ) { while (*sptr1 && *sptr2) { if (toupper (*sptr1++) != toupper (*sptr2++)) return (false); if (count) if (!--count) return (true); } if (*sptr1 || *sptr2) return (false); else return (true); } /*****************************************************************************/ #endif /* PERLRTENG_INCLUDE_PERLRTEV */