/*###################################################################################
#
# Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de
# Embperl - Copyright (c) 2008-2015 Gerald Richter
# Embperl - Copyright (c) 2015-2023 actevy.io
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the Perl README file.
# For use with Apache httpd and mod_perl, see also Apache copyright.
#
# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
###################################################################################*/
#include "ep.h"
#include "epmacro.h"
/*---------------------------------------------------------------------------
* DoLogError
*/
/*!
*
* \_en
* Logs the occurence of an error to the embperl logfile and the httpd error log
*
* @param r the request object (maybe NULL)
* @param a the application object (maybe NULL)
* @param rc the error code
* @param errdat1 addtional information
* @param errdat2 addtional information
* \endif
*
* \_de
* logged das auftreten eines Fehler in das Embperl Logfile und den httpd
* error log
*
* @param r das Requestobjekt (kann NULL sein)
* @param a das Applikationobjekt (kann NULL sein)
* @param rc Fehlercode
* @param errdat1 Zusätzliche Informationen
* @param errdat2 Zusätzliche Informationen
* \endif
*
* ------------------------------------------------------------------------ */
static char * DoLogError (/*i/o*/ struct tReq * r,
/*i/o*/ struct tApp * a,
/*in*/ int rc,
/*in*/ const char * errdat1,
/*in*/ const char * errdat2)
{
const char * msg ;
char * sText ;
SV * pSV ;
SV * pSVLine = NULL ;
STRLEN l ;
pid_t nPid ;
#ifdef PERL_IMPLICIT_CONTEXT
pTHX ;
if (r)
aTHX = r -> pPerlTHX ;
else if (a)
aTHX = a -> pPerlTHX ;
else
aTHX = PERL_GET_THX ;
#endif
if (r)
{
r -> errdat1 [sizeof (r -> errdat1) - 1] = '\0' ;
r -> errdat2 [sizeof (r -> errdat2) - 1] = '\0' ;
GetLineNo (r) ;
errdat1 = r -> errdat1 ;
errdat2 = r -> errdat2 ;
if (rc != rcPerlWarn)
r -> bError = 1 ;
nPid = r -> pThread -> nPid ;
a = r -> pApp ;
}
else if (a)
{
nPid = a -> pThread -> nPid ;
}
else
nPid = getpid() ;
if (!errdat1)
errdat1 = "" ;
if (!errdat2)
errdat2 = "" ;
switch (rc)
{
case ok: msg ="[%d]ERR: %d: %s ok%s%s" ; break ;
case rcStackOverflow: msg ="[%d]ERR: %d: %s Stack Overflow%s%s" ; break ;
case rcArgStackOverflow: msg ="[%d]ERR: %d: %s Argumnet Stack Overflow (%s)%s" ; break ;
case rcStackUnderflow: msg ="[%d]ERR: %d: %s Stack Underflow%s%s" ; break ;
case rcEndifWithoutIf: msg ="[%d]ERR: %d: %s endif without if%s%s" ; break ;
case rcElseWithoutIf: msg ="[%d]ERR: %d: %s else without if%s%s" ; break ;
case rcEndwhileWithoutWhile: msg ="[%d]ERR: %d: %s endwhile without while%s%s" ; break ;
case rcEndtableWithoutTable: msg ="[%d]ERR: %d: %s blockend <%s> does not match blockstart <%s>" ; break ;
case rcTablerowOutsideOfTable: msg ="[%d]ERR: %d: %s <tr> outside of table%s%s" ; break ;
case rcCmdNotFound: msg ="[%d]ERR: %d: %s Unknown Command %s%s" ; break ;
case rcOutOfMemory: msg ="[%d]ERR: %d: %s Out of memory %s %s" ; break ;
case rcPerlVarError: msg ="[%d]ERR: %d: %s Perl variable error %s%s" ; break ;
case rcHashError: msg ="[%d]ERR: %d: %s Perl hash error, %%%s does not exist%s" ; break ;
case rcArrayError: msg ="[%d]ERR: %d: %s Perl array error , @%s does not exist%s" ; break ;
case rcFileOpenErr: msg ="[%d]ERR: %d: %s File %s open error: %s" ; break ;
case rcLogFileOpenErr: msg ="[%d]ERR: %d: %s Logfile %s open error: %s" ; break ;
case rcMissingRight: msg ="[%d]ERR: %d: %s Missing right %s%s" ; break ;
case rcNoRetFifo: msg ="[%d]ERR: %d: %s No Return Fifo%s%s" ; break ;
case rcMagicError: msg ="[%d]ERR: %d: %s Perl Magic Error%s%s" ; break ;
case rcWriteErr: msg ="[%d]ERR: %d: %s File write Error%s%s" ; break ;
case rcUnknownNameSpace: msg ="[%d]ERR: %d: %s Namespace %s unknown%s" ; break ;
case rcInputNotSupported: msg ="[%d]ERR: %d: %s Input not supported in mod_perl mode%s%s" ; break ;
case rcCannotUsedRecursive: msg ="[%d]ERR: %d: %s Cannot be called recursively in mod_perl mode%s%s" ; break ;
case rcEndtableWithoutTablerow: msg ="[%d]ERR: %d: %s </tr> without <tr>%s%s" ; break ;
case rcEndtextareaWithoutTextarea: msg ="[%d]ERR: %d: %s </textarea> without <textarea>%s%s" ; break ;
case rcEvalErr: msg ="[%d]ERR: %d: %s Error in Perl code: %s%s" ; break ;
case rcNotCompiledForModPerl: msg ="[%d]ERR: %d: %s Embperl is not compiled for mod_perl. Rerun Makefile.PL and give the correct Apache source tree location %s%s" ; break ;
case rcExecCGIMissing: msg ="[%d]ERR: %d: %s Forbidden %s: Options ExecCGI not set in your Apache configs%s" ; break ;
case rcIsDir: msg ="[%d]ERR: %d: %s Forbidden %s is a directory%s" ; break ;
case rcXNotSet: msg ="[%d]ERR: %d: %s Forbidden %s X Bit not set%s" ; break ;
case rcNotFound: msg ="[%d]ERR: %d: %s Not found '%s', searched: %s" ; break ;
case rcTokenNotFound: msg ="[%d]ERR: %d: %s Token not found '%s', %s" ; break ;
case rcUnknownVarType: msg ="[%d]ERR: %d: %s Type for Variable %s is unknown %s" ; break ;
case rcPerlWarn: msg ="[%d]ERR: %d: %s Warning in Perl code: %s%s" ; break ;
case rcVirtLogNotSet: msg ="[%d]ERR: %d: %s EMBPERL_VIRTLOG must be set, when dbgLogLink is set %s%s" ; break ;
case rcMissingInput: msg ="[%d]ERR: %d: %s Sourcedata/-file missing %s%s" ; break ;
case rcUntilWithoutDo: msg ="[%d]ERR: %d: %s until without do%s%s" ; break ;
case rcEndforeachWithoutForeach:msg ="[%d]ERR: %d: %s endforeach without foreach%s%s" ; break ;
case rcMissingArgs: msg ="[%d]ERR: %d: %s Too few arguments%s%s" ; break ;
case rcNotAnArray: msg ="[%d]ERR: %d: %s Second Argument must be array/list%s%s" ; break ;
case rcCallInputFuncFailed: msg ="[%d]ERR: %d: %s Call to Input Function failed: %s%s" ; break ;
case rcCallOutputFuncFailed: msg ="[%d]ERR: %d: %s Call to Output Function failed: %s%s" ; break ;
case rcSubNotFound: msg ="[%d]ERR: %d: %s Call to unknown Embperl macro %s%s" ; break ;
case rcImportStashErr: msg ="[%d]ERR: %d: %s Package %s for import unknown%s" ; break ;
case rcCGIError: msg ="[%d]ERR: %d: %s Setup of CGI.pm failed: %s%s" ; break ;
case rcUnclosedHtml: msg ="[%d]ERR: %d: %s Unclosed HTML tag <%s> at end of file %s" ; break ;
case rcUnclosedCmd: msg ="[%d]ERR: %d: %s Unclosed command [$ %s $] at end of file %s" ; break ;
case rcNotAllowed: msg ="[%d]ERR: %d: %s Forbidden %s: Does not match EMBPERL_ALLOW %s" ; break ;
case rcNotHashRef: msg ="[%d]ERR: %d: %s %s need hashref in '%s'" ; break ;
case rcTagMismatch: msg ="[%d]ERR: %d: %s Endtag '%s' doesn't match starttag '%s'" ; break ;
case rcCleanupErr: msg ="[%d]ERR: %d: %s Error in cleanup %s%s" ; break ;
case rcCryptoWrongHeader: msg ="[%d]ERR: %d: %s Decrypt-error: Not encrypted (%s)%s" ; break ;
case rcCryptoWrongSyntax: msg ="[%d]ERR: %d: %s Decrypt-error: Wrong syntax (%s)%s" ; break ;
case rcCryptoNotSupported: msg ="[%d]ERR: %d: %s Decrypt-error: Not supported (%s)%s" ; break ;
case rcCryptoBufferOverflow: msg ="[%d]ERR: %d: %s Decrypt-error: Buffer overflow (%s)%s" ; break ;
case rcCryptoErr: msg ="[%d]ERR: %d: %s Decrypt-error: OpenSSL error (%s)%s" ; break ;
case rcUnknownProvider: msg ="[%d]ERR: %d: %s Unknown Provider %s %s" ; break ;
case rcXalanError: msg ="[%d]ERR: %d: %s Xalan Error: %s: %s" ; break ;
case rcLibXSLTError: msg ="[%d]ERR: %d: %s LibXSLT Error: %s: %s" ; break ;
case rcMissingParam: msg ="[%d]ERR: %d: %s Missing Parameter %s %s" ; break ;
case rcNotCodeRef: msg ="[%d]ERR: %d: %s %s need coderef in '%s'" ; break ;
case rcUnknownRecipe: msg ="[%d]ERR: %d: %s Unknown recipe '%s'" ; break ;
case rcTypeMismatch: msg ="[%d]ERR: %d: %s Unsupported Outputformat %s of %s" ; break ;
case rcChdirError: msg ="[%d]ERR: %d: %s Cannot change to directory %s %s" ; break ;
case rcUnknownSyntax: msg ="[%d]ERR: %d: %s Unknown syntax '%s'" ; break ;
case rcForbidden: msg ="[%d]ERR: %d: %s Access Forbidden for '%s'" ; break ;
case rcDecline: msg ="[%d]ERR: %d: %s Decline for '%s'" ; break ;
case rcCannotCheckUri: msg ="[%d]ERR: %d: %s Cannot check URI against ALLOW and/or URIMATCH because URI is unknown" ; break ;
case rcSetupSessionErr: msg ="[%d]ERR: %d: %s Embperl Session handling DISABLED because of the following error: %s\nSet EMBPERL_SESSION_HANDLER_CLASS to 'no' to avoid this message. %s" ; break ;
case rcRefcntNotOne: msg ="[%d]ERR: %d: %s There is still %s reference(s) to the %s object, while there shouldn't be any." ; break ;
case rcApacheErr: msg ="[%d]ERR: %d: %s Apache returns Error: %s %s" ; break ;
case rcTooDeepNested: msg ="[%d]ERR: %d: %s Source data is too deep nested %s %s" ; break ;
case rcUnknownOption: msg ="[%d]ERR: %d: %s Unknown option '%s' in configuration directive '%s'" ; break ;
case rcTimeFormatErr: msg ="[%d]ERR: %d: %s Format error in %s = %s" ; break ;
case rcSubCallNotRequest: msg ="[%d]ERR: %d: %s A Embperl sub is called and no Embperl request is running %s %s" ; break ;
case rcNotScalarRef: msg ="[%d]ERR: %d: %s %s need scalar in '%s'" ; break ;
case rcFormDataTruncated: msg ="[%d]ERR: %d: %s Formdata exceeded length of %s bytes, truncated" ; break ;
default: msg ="[%d]ERR: %d: %s Error (no description) %s %s" ; break ;
}
if (r && ((rc != rcPerlWarn && rc != rcEvalErr) || r -> errdat1[0] == '\0'))
{
char * p = NULL ;
char buf[20] = "" ;
char * f ;
tComponent * c = &r -> Component ;
if (!(f = c -> sSourcefile))
{
c = r -> Component.pPrev ;
if (c && !(f = c -> sSourcefile))
f = "", p = "" ;
}
if (f)
{
if (!p)
p = strrchr (f, '/') ;
if (p)
p++ ;
else
{
p = strrchr (f, '\\') ;
if (!p)
p = f ;
else
p++ ;
}
}
else
if (!p)
p = "" ;
if (c && c -> nSourceline)
sprintf (buf, "(%d)", c -> nSourceline) ;
pSVLine = newSVpvf ("%s%s:", p, buf) ;
newSVpvf2(pSVLine) ;
}
pSV = newSVpvf (msg, nPid , rc, pSVLine?SvPV(pSVLine, l):"", errdat1, errdat2) ;
newSVpvf2(pSV) ;
if (r && r -> Component.Config.bOptions & optShowBacktrace)
{
tComponent * c = &r -> Component ;
while (c)
{
sv_catpvf(pSV, "\n * %s", (!c -> sSourcefile)?"<no filename available>":c -> sSourcefile) ;
c = c -> pPrev ;
}
}
if (pSVLine)
SvREFCNT_dec(pSVLine) ;
sText = SvPV (pSV, l) ;
if (a)
lprintf (a, "%s\n", sText) ;
#ifdef APACHE
if (r && r -> pApacheReq)
{
#ifdef APLOG_ERR
if (rc != rcPerlWarn)
ap_log_error (APLOG_MARK, APLOG_ERR | APLOG_NOERRNO, APLOG_STATUSCODE r -> pApacheReq -> server, "%s", sText) ;
else
ap_log_error (APLOG_MARK, APLOG_WARNING | APLOG_NOERRNO, APLOG_STATUSCODE r -> pApacheReq -> server, "%s", sText) ;
#else
log_error (sText, r -> pApacheReq -> server) ;
#endif
}
else
#endif
{
#ifdef WIN32
PerlIO_printf (PerlIO_stderr(), "%s\n", sText) ;
PerlIO_flush (PerlIO_stderr()) ;
#else
#undef fprintf
#undef fflush
fprintf (stderr, "%s\n", sText) ;
fflush (stderr) ;
#endif
}
if (r)
{
if (rc == rcPerlWarn)
strncpy (r -> lastwarn, r -> errdat1, sizeof (r -> lastwarn) - 1) ;
if (r -> pErrArray)
{
av_push (r -> pErrArray, r -> pErrSV?SvREFCNT_inc(r -> pErrSV):pSV) ;
}
else
SvREFCNT_dec (pSV) ;
r -> errdat1[0] = '\0' ;
r -> errdat2[0] = '\0' ;
}
else
SvREFCNT_dec (pSV) ;
return sText ;
}
/*---------------------------------------------------------------------------
* LogErrorParam
*/
/*!
*
* \_en
* Logs the occurence of an error to the embperl logfile and the httpd error log
*
* @param a the application object
* @param rc the error code
* @param errdat1 addtional information
* @param errdat2 addtional information
* \endif
*
* \_de
* logged das auftreten eines Fehler in das Embperl Logfile und den httpd
* error log
*
* @param a das Applikationobjekt
* @param rc Fehlercode
* @param errdat1 Zusätzliche Informationen
* @param errdat2 Zusätzliche Informationen
* \endif
*
* ------------------------------------------------------------------------ */
char * LogErrorParam (/*i/o*/ struct tApp * a,
/*in*/ int rc,
/*in*/ const char * errdat1,
/*in*/ const char * errdat2)
{
return DoLogError (NULL, a, rc, errdat1, errdat2) ;
}
/*---------------------------------------------------------------------------
* LogError
*/
/*!
*
* \_en
* Logs the occurence of an error to the embperl logfile and the httpd error log
* Addtional information, like stack backtrace, is taken from the request object
*
* @param r the request object
* @param rc the error code
* \endif
*
* \_de
* Logged das auftreten eines Fehler in das Embperl Logfile und den httpd
* error log. Zusätzlich Informationen, wie z.B. ein Stackbacktrace, werden
* dem Requestobjket entnommen
*
* @param a das Requestobjekt
* @param rc Fehlercode
* \endif
*
* ------------------------------------------------------------------------ */
char * LogError (/*i/o*/ register req * r,
/*in*/ int rc)
{
return DoLogError (r, NULL, rc, NULL, NULL) ;
}
#if defined (_MDEBUG) && defined (WIN32)
static int EmbperlCRTDebugOutput( int reportType, char *userMessage, int *retVal )
{
lprintf (CurrReq, "[%d]CRTDBG: %s\n", pCurrReq -> nPid, userMessage) ;
return TRUE ;
}
#endif
/* */
/* Magic */
/* */
void NewEscMode (/*i/o*/ register req * r,
SV * pSV)
{
if (r -> Component.Config.nEscMode & escXML && !r -> Component.bEscInUrl)
r -> Component.pNextEscape = Char2XML ;
else if (r -> Component.Config.nEscMode & escHtml && !r -> Component.bEscInUrl)
{
struct tCharTrans * pChar2Html ;
if (r -> Config.nOutputEscCharset == ocharsetLatin1)
pChar2Html = Char2Html ;
else if (r -> Config.nOutputEscCharset == ocharsetLatin2)
pChar2Html = Char2HtmlLatin2 ;
else
pChar2Html = Char2HtmlMin ;
r -> Component.pNextEscape = pChar2Html ;
}
else if (r -> Component.Config.nEscMode & escUrl)
r -> Component.pNextEscape = Char2Url ;
else
r -> Component.pNextEscape = NULL ;
if (r -> Component.bEscModeSet < 1)
{
r -> Component.pCurrEscape = r -> Component.pNextEscape ;
r -> Component.nCurrEscMode = r -> Component.Config.nEscMode ;
}
if (r -> Component.bEscModeSet < 0 && pSV && SvOK (pSV))
r -> Component.bEscModeSet = 1 ;
}
#ifdef UNUSED
/* ---------------------------------------------------------------------------- */
/* */
/* Localise op_mask then opmask_add() */
/* */
/* Just copied from Opcode.xs */
/* */
/* ---------------------------------------------------------------------------- */
static void
opmask_addlocal(pTHX_
SV * opset,
char * op_mask_buf)
{
char *orig_op_mask = op_mask;
int i,j;
char *bitmask;
STRLEN len;
int myopcode = 0;
int opset_len = (maxo + 7) / 8 ;
SAVEPPTR(op_mask);
op_mask = &op_mask_buf[0];
if (orig_op_mask)
Copy(orig_op_mask, op_mask, maxo, char);
else
Zero(op_mask, maxo, char);
/* OPCODES ALREADY MASKED ARE NEVER UNMASKED. See opmask_addlocal() */
bitmask = SvPV(opset, len);
for (i=0; i < opset_len; i++)
{
U16 bits = bitmask[i];
if (!bits)
{ /* optimise for sparse masks */
myopcode += 8;
continue;
}
for (j=0; j < 8 && myopcode < maxo; )
op_mask[myopcode++] |= bits & (1 << j++);
}
}
#endif
/* ---------------------------------------------------------------------------- */
/* */
/* Create Session cookie */
/* */
/* ---------------------------------------------------------------------------- */
static char * CreateSessionCookie (/*i/o*/ register req * r,
/*in*/ SV * pSessionObj,
/*in*/ char type,
/*in*/ int bReturnCookie)
{
SV * pSVID = NULL ;
SV * pSVUID = NULL ;
char * pUID = NULL ;
char * pInitialUID = NULL ;
STRLEN ulen = 0 ;
STRLEN ilen = 0 ;
IV bModified = 0 ;
char * pCookie = NULL ;
STRLEN ldummy ;
tAppConfig * pCfg = &r -> pApp -> Config ;
epTHX ;
if (r -> nSessionMgnt)
{
dSP; /* initialize stack pointer */
int n ;
PUSHMARK(sp); /* remember the stack pointer */
XPUSHs(pSessionObj) ; /* push pointer to obeject */
XPUSHs(sv_2mortal(newSViv(bReturnCookie?0:1))) ; /* init session if not for cookie */
PUTBACK;
n = perl_call_method ("getids", G_ARRAY) ; /* call the function */
SPAGAIN;
if (n > 2)
{
int savewarn = dowarn ;
dowarn = 0 ; /* no warnings here */
bModified = POPi ;
pSVUID = POPs;
pUID = SvPV (pSVUID, ulen) ;
pSVID = POPs;
pInitialUID = SvPV (pSVID, ilen) ;
dowarn = savewarn ;
}
PUTBACK;
if (r -> Config.bDebug & dbgSession)
lprintf (r -> pApp, "[%d]SES: Received Cookie ID: %s New Cookie ID: %s %s data is%s modified\n", r -> pThread -> nPid, pInitialUID, pUID, type == 's'?"State":"User", bModified?"":" NOT") ;
if (ilen > 0 && (ulen == 0 || (!bModified && strcmp ("!DELETE", pInitialUID) == 0)))
{ /* delete cookie */
if (bReturnCookie)
{
pCookie = ep_pstrcat (r -> pPool, pCfg -> sCookieName, type == 's'?"s=":"=", "; expires=Thu, 1-Jan-1970 00:00:01 GMT", NULL) ;
if (pCfg -> sCookieDomain)
pCookie = ep_pstrcat (r -> pPool, pCookie, "; domain=", pCfg -> sCookieDomain, NULL) ;
if (pCfg -> sCookiePath)
pCookie = ep_pstrcat (r -> pPool, pCookie, "; path=", pCfg -> sCookiePath, NULL) ;
if (pCfg -> bCookieSecure)
pCookie = ep_pstrcat (r -> pPool, pCookie, "; secure", NULL) ;
}
if (r -> Config.bDebug & dbgSession)
lprintf (r -> pApp, "[%d]SES: Delete Cookie -> %s\n", r -> pThread -> nPid, pCookie) ;
}
else if (ulen > 0 &&
((bModified && (ilen == 0 || strcmp (pInitialUID, pUID) !=0)) ||
(r -> nSessionMgnt & 4) || !bReturnCookie))
{
if (bReturnCookie)
{
pCookie = ep_pstrcat (r -> pPool, pCfg -> sCookieName, type == 's'?"s=":"=", pUID, NULL) ;
if (pCfg -> sCookieDomain)
pCookie = ep_pstrcat (r -> pPool, pCookie, "; domain=", pCfg -> sCookieDomain, NULL) ;
if (pCfg -> sCookiePath)
pCookie = ep_pstrcat (r -> pPool, pCookie, "; path=", pCfg -> sCookiePath, NULL) ;
if (r -> sCookieExpires)
pCookie = ep_pstrcat (r -> pPool, pCookie, "; expires=", r -> sCookieExpires, NULL) ;
if (pCfg -> bCookieSecure)
pCookie = ep_pstrcat (r -> pPool, pCookie, "; secure", NULL) ;
if (r -> Config.bDebug & dbgSession)
lprintf (r -> pApp, "[%d]SES: Send Cookie -> %s\n", r -> pThread -> nPid, pCookie) ;
}
else
{
pCookie = ep_pstrdup (r -> pPool, SvPV(pSVUID, ldummy)) ;
if (r -> Config.bDebug & dbgSession)
lprintf (r -> pApp, "[%d]SES: Add ID to URL type=%c id=%s\n", r -> pThread -> nPid, type, pCookie) ;
}
}
}
return pCookie ;
}
#ifdef UNUSED
/* ---------------------------------------------------------------------------- */
/* */
/* Setup Safe Namespace */
/* */
/* ---------------------------------------------------------------------------- */
static void SetupSafeNamespace (/*i/o*/ register req * r)
{
GV * gv;
dTHR ;
epTHX ;
/* The following is borrowed from Opcode.xs */
if (r -> Component.Config.bOptions & optOpcodeMask)
opmask_addlocal(aTHX_ r -> Component.Config.pOpcodeMask, r -> Component.op_mask_buf);
if (r -> Component.Config.bOptions & optSafeNamespace)
{
save_aptr(&endav);
endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */
save_hptr(&defstash); /* save current default stack */
/* the assignment to global defstash changes our sense of 'main' */
defstash = gv_stashpv(r -> Component.sCurrPackage, GV_ADDWARN); /* should exist already */
if (r -> Component.Config.bDebug)
lprintf (r -> pApp, "[%d]REQ: switch to safe namespace %s\n", r -> pThread -> nPid, r -> Component.sCurrPackage) ;
/* defstash must itself contain a main:: so we'll add that now */
/* take care with the ref counts (was cause of long standing bug) */
/* XXX I'm still not sure if this is right, GV_ADDWARN should warn! */
gv = gv_fetchpv("main::", GV_ADDWARN, SVt_PVHV);
sv_free((SV*)GvHV(gv));
GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
}
}
#endif
/* ---------------------------------------------------------------------------- */
/* */
/* Reset Request */
/* */
/* ---------------------------------------------------------------------------- */
static int ResetRequest (/*i/o*/ register req * r,
/*in*/ char * sInputfile)
{
epTHX ;
if (r -> Component.Config.bDebug)
{
clock_t cl = clock () ;
time_t t ;
struct tm * tm ;
time (&t) ;
tm =localtime (&t) ;
lprintf (r -> pApp, "[%d]PERF: input = %s\n", r -> pThread -> nPid, sInputfile?sInputfile:"???") ;
#ifdef CLOCKS_PER_SEC
lprintf (r -> pApp, "[%d]PERF: Time: %d ms ", r -> pThread -> nPid, ((cl - r -> startclock) * 1000 / CLOCKS_PER_SEC)) ;
#else
lprintf (r -> pApp, "[%d]PERF: ", r -> pThread -> nPid) ;
#endif
lprintf (r -> pApp, "\n") ;
lprintf (r -> pApp, "[%d]%sRequest finished. %s. Entry-SVs: %d Exit-SVs: %d \n", r -> pThread -> nPid,
(r -> Component.pPrev?"Sub-":""), asctime(tm), r -> stsv_count, sv_count) ;
#ifdef DMALLOC
dmalloc_message ( "[%d]%sRequest finished. Entry-SVs: %d Exit-SVs: %d \n", r -> pThread -> nPid,
(r -> Component.pPrev?"Sub-":""), r -> stsv_count, sv_count) ;
#endif
}
r -> Component.pCurrPos = NULL ;
FlushLog (r -> pApp) ;
r -> Component.nSourceline = 1 ;
r -> Component.pSourcelinePos = NULL ;
r -> Component.pLineNoCurrPos = NULL ;
r -> Component.bReqRunning = 0 ;
/*
av_clear (r -> pErrFill) ;
av_clear (r -> pErrState) ;
*/
return ok ;
}
/* ---------------------------------------------------------------------------- */
/* */
/* Start the output stream */
/* */
/* ---------------------------------------------------------------------------- */
static int StartOutput (/*i/o*/ register req * r)
{
int bOutToMem = r -> Component.Param.pOutput && SvROK (r -> Component.Param.pOutput) ;
epTHX_
#ifdef APACHE
if (r -> pApacheReq && r -> pApacheReq -> main)
r -> Config.bOptions |= optEarlyHttpHeader ; /* do not direct output to memory on internal redirect */
#endif
if (bOutToMem)
r -> Config.bOptions &= ~optEarlyHttpHeader ;
if (r -> Component.pPrev || r -> Component.pImportStash)
r -> Config.bOptions &= ~optSendHttpHeader ;
if (r -> Config.bOptions & optEarlyHttpHeader)
{
#ifdef APACHE
if (r -> pApacheReq == NULL)
{
#endif
if (r -> Config.bOptions & optSendHttpHeader)
oputs (r, "Content-type: text/html\n\n") ;
#ifdef APACHE
}
else
{
#ifndef APACHE2
if (r -> pApacheReq -> main == NULL && (r -> Config.bOptions & optSendHttpHeader))
send_http_header (r -> pApacheReq) ;
#endif
#ifndef WIN32
/* shouldn't be necessary for newer mod_perl versions !? */
/* mod_perl_sent_header(r -> pApacheReq, 1) ; */
#endif
if (r -> pApacheReq -> header_only)
return ok ;
}
#endif
}
else
{
/*
if (r -> nIOType == epIOCGI && (r -> Config.bOptions & optSendHttpHeader))
oputs (r, "Content-type: text/html\n\n") ;
*/
oBegin (r) ;
}
if ((r -> Config.nSessionMode & smodeSDatParam) && !r -> Component.pPrev)
{
char * pCookie = CreateSessionCookie (r, r -> pApp -> pStateObj, 's', 0) ;
/* lprintf (r -> pApp, "opt %x optadd %x options %x cookie %s\n", optAddStateSessionToLinks, r -> Component.Config.bOptions & optAddStateSessionToLinks, r -> Component.Config.bOptions, SvPV(pCookie, l)) ; */
if (pCookie)
r -> sSessionID = ep_pstrcat (r -> pPool, r -> pApp -> Config.sCookieName, "=", pCookie, NULL) ;
}
if ((r -> Config.nSessionMode & smodeUDatParam) && !r -> Component.pPrev)
{
char * pCookie = CreateSessionCookie (r, r -> pApp -> pUserObj, 'u', 0) ;
if (pCookie)
{
if (r -> sSessionID)
r -> sSessionID = ep_pstrcat (r -> pPool, r -> sSessionID, ":", pCookie, NULL) ;
else
r -> sSessionID = ep_pstrcat (r -> pPool, r -> pApp -> Config.sCookieName, "=:", pCookie, NULL) ;
}
}
return ok ;
}
/* ---------------------------------------------------------------------------- */
/* */
/* GenerateErrorPage */
/* */
/* ---------------------------------------------------------------------------- */
static int GenerateErrorPage (/*i/o*/ register req * r,
/*in*/ int rc)
{
epTHX_
dSP; /* initialize stack pointer */
if (r -> pApp -> Config.sMailErrorsTo)
{
/* --- check if error should be mailed --- */
tApp * a = r -> pApp ;
time_t nTime = time(NULL) ;
if (a -> nErrorsLastTime < nTime - a -> Config.nMailErrorsResetTime)
a -> nErrorsCount = 0 ;
else if (a -> nErrorsLastSendTime < nTime - a -> Config.nMailErrorsResendTime)
a -> nErrorsCount = 0 ;
a -> nErrorsLastTime = nTime ;
if (a -> Config.nMailErrorsLimit == 0 || a -> nErrorsCount < a -> Config.nMailErrorsLimit)
{
a -> nErrorsCount++ ;
a -> nErrorsLastSendTime = nTime ;
PUSHMARK(sp);
XPUSHs(r -> pApp -> _perlsv) ;
XPUSHs(r -> _perlsv) ;
PUTBACK;
perl_call_method ("mail_errors", G_DISCARD) ;
SPAGAIN ;
}
}
if (r -> Component.Config.bOptions & optReturnError)
{
oRollbackOutput (r, NULL) ;
if (r -> Component.Param.pOutput && SvROK (r -> Component.Param.pOutput))
{
sv_setsv (SvRV (r -> Component.Param.pOutput), &sv_undef) ;
}
r -> bExit = 1 ;
return ok ; /* No further output or header, this should be handle by the server */
}
else if (r -> Component.pOutput && !(r -> Component.Config.bOptions & optDisableEmbperlErrorPage))
{
oRollbackOutput (r, NULL) ; /* forget everything outputed so far */
oBegin (r) ;
SPAGAIN ;
PUSHMARK(sp);
XPUSHs(r -> pApp -> _perlsv) ;
XPUSHs(r -> _perlsv) ;
PUTBACK;
perl_call_method ("send_error_page", G_DISCARD) ;
SPAGAIN ;
#ifdef APACHE
if (r -> pApacheReq)
{
if (rc >= 400)
r -> pApacheReq -> status = rc ;
else
r -> pApacheReq -> status = 500 ;
}
#endif
SetHashValueInt (r, r -> pThread -> pHeaderHash, "Content-Length", GetContentLength (r) ) ;
}
r -> bError = 1 ;
return ok ;
}
/* ---------------------------------------------------------------------------- */
/* */
/* SendHttpHeader */
/* */
/* ---------------------------------------------------------------------------- */
int embperl_SendHttpHeader (/*i/o*/ register req * r)
{
epTHX_
char * pCookie = NULL ;
if (r -> Config.nSessionMode & smodeUDatCookie)
pCookie = CreateSessionCookie (r, r -> pApp -> pUserObj, 'u', 1) ;
#ifdef APACHE
if (r -> pApacheReq)
{
SV * pHeader ;
char * p ;
HE * pEntry ;
char * pKey ;
I32 l ;
STRLEN ldummy ;
I32 i;
I32 len;
AV *arr;
SV **svp;
/* loc = 0 => no location header found
* loc = 1 => location header found
* loc = 2 => location header + value found
* loc = 3 => location header + value + status found
*/
I32 loc;
I32 loc_status = 301;
hv_iterinit (r -> pThread -> pHeaderHash) ;
while ((pEntry = hv_iternext (r -> pThread -> pHeaderHash)))
{
pKey = hv_iterkey (pEntry, &l) ;
pHeader = hv_iterval (r -> pThread -> pHeaderHash, pEntry) ;
loc = 0;
if (pHeader && pKey)
{
if (stricmp (pKey, "location") == 0)
loc = 1;
if (stricmp (pKey, "content-type") == 0)
{
p = NULL;
if ( SvROK(pHeader) && SvTYPE(SvRV(pHeader)) == SVt_PVAV )
{
arr = (AV *)SvRV(pHeader);
if (av_len(arr) >= 0)
{
svp = av_fetch(arr, 0, 0);
p = SvPV(*svp, ldummy);
}
}
else
{
p = SvPV(pHeader, ldummy);
}
if (p)
r->pApacheReq->content_type = apr_pstrdup(r->pApacheReq->pool, p);
}
else if (SvROK(pHeader) && SvTYPE(SvRV(pHeader)) == SVt_PVAV )
{
arr = (AV *)SvRV(pHeader);
len = av_len(arr);
for (i = 0; i <= len; i++)
{
svp = av_fetch(arr, i, 0);
if (loc == 2)
{
loc = 3;
loc_status = SvIV(*svp);
break;
}
p = SvPV(*svp, ldummy);
apr_table_add( r->pApacheReq->headers_out, apr_pstrdup(r->pApacheReq->pool, pKey),
apr_pstrdup(r->pApacheReq->pool, p ) );
if (loc == 1)
loc = 2;
}
}
else
{
p = SvPV(pHeader, ldummy);
apr_table_set(r -> pApacheReq->headers_out, apr_pstrdup(r -> pApacheReq->pool, pKey), apr_pstrdup(r -> pApacheReq->pool, p)) ;
if (loc == 1) loc = 2;
}
if (loc >= 2) r->pApacheReq->status = loc_status;
}
}
if (pCookie)
apr_table_add(r -> pApacheReq->headers_out, "Set-Cookie", pCookie) ;
#if 0
if (r -> Component.Config.bEP1Compat) /* Embperl 2 currently cannot calc Content Length */
set_content_length (r -> pApacheReq, GetContentLength (r) + (r -> Component.pCurrEscape?2:0)) ;
#endif
#ifndef APACHE2
send_http_header (r -> pApacheReq) ;
#endif
if (r -> Component.Config.bDebug & dbgHeadersIn)
{
int i;
const apr_array_header_t *hdrs_arr;
apr_table_entry_t *hdrs;
hdrs_arr = apr_table_elts (r -> pApacheReq->headers_out);
hdrs = (apr_table_entry_t *)hdrs_arr->elts;
lprintf (r -> pApp, "[%d]HDR: %d\n", r -> pThread -> nPid, hdrs_arr->nelts) ;
for (i = 0; i < hdrs_arr->nelts; ++i)
if (hdrs[i].key)
lprintf (r -> pApp, "[%d]HDR: %s=%s\n", r -> pThread -> nPid, hdrs[i].key, hdrs[i].val) ;
}
}
else
#endif
{
/*char txt[100] ;*/
int save = r -> Component.pOutput -> nMarker ;
SV * pHeader ;
char * p ;
HE * pEntry ;
char * pKey ;
I32 l ;
char * pContentType = "text/html";
STRLEN ldummy ;
/* loc = 0 => no location header found
* loc = 1 => location header found
*/
I32 loc;
r -> Component.pOutput -> nMarker = 0 ; /* output directly */
hv_iterinit (r -> pThread -> pHeaderHash) ;
while ((pEntry = hv_iternext (r -> pThread -> pHeaderHash)))
{
pKey = hv_iterkey (pEntry, &l) ;
pHeader = hv_iterval (r -> pThread -> pHeaderHash, pEntry) ;
loc = 0;
if (pHeader && pKey)
{
if (stricmp (pKey, "location") == 0)
loc = 1;
if (SvROK(pHeader) && SvTYPE(SvRV(pHeader)) == SVt_PVAV )
{
AV * arr = (AV *)SvRV(pHeader);
I32 len = av_len(arr);
int i ;
for (i = 0; i <= len; i++)
{
SV ** svp = av_fetch(arr, i, 0);
p = SvPV(*svp, ldummy);
oputs (r, pKey) ;
oputs (r, ": ") ;
oputs (r, p) ;
oputs (r, "\n") ;
if (r -> Component.Config.bDebug & dbgHeadersIn)
lprintf (r -> pApp, "[%d]HDR: %s: %s\n", r -> pThread -> nPid, pKey, p) ;
if (loc == 1)
break;
}
}
else
{
p = SvPV (pHeader, na) ;
if (stricmp (pKey, "content-type") == 0)
pContentType = p ;
else
{
oputs (r, pKey) ;
oputs (r, ": ") ;
oputs (r, p) ;
oputs (r, "\n") ;
}
if (r -> Component.Config.bDebug & dbgHeadersIn)
lprintf (r -> pApp, "[%d]HDR: %s: %s\n", r -> pThread -> nPid, pKey, p) ;
}
}
}
oputs (r, "Content-Type: ") ;
oputs (r, pContentType) ;
oputs (r, "\n") ;
if (pCookie)
{
oputs (r, "Set-Cookie") ;
oputs (r, ": ") ;
oputs (r, pCookie) ;
oputs (r, "\n") ;
}
oputs (r, "\n") ;
r -> Component.pOutput -> nMarker = save ;
}
return ok ;
}
/* ---------------------------------------------------------------------------- */
/* */
/* End the output stream to memory */
/* */
/* ---------------------------------------------------------------------------- */
static int OutputToMem (/*i/o*/ register req * r)
{
epTHX_
SV * pOut ;
char * pData ;
STRLEN l ;
if (!SvROK (r -> Component.Param.pOutput))
{
strcpy (r -> errdat1, "OutputToMem") ;
strcpy (r -> errdat2, "parameter output") ;
return rcNotScalarRef ;
}
pOut = SvRV (r -> Component.Param.pOutput) ;
if (!r -> bError && r -> Component.pOutputSV && !r -> Component.pImportStash)
{
sv_setsv (pOut, r -> Component.pOutputSV) ;
}
else
{
if (!r -> bError && !r -> Component.pImportStash)
{
tDomTree * pDomTree = DomTree_self (r -> Component.xCurrDomTree) ;
Node_toString (r, pDomTree, pDomTree -> xDocument, 0) ;
}
l = GetContentLength (r) + 1 ;
sv_setpv (pOut, "") ;
SvGROW (pOut, l) ;
pData = SvPVX (pOut) ;
oCommitToMem (r, NULL, pData) ;
SvCUR_set (pOut, l - 1) ;
}
return ok ;
}
/* ---------------------------------------------------------------------------- */
/* */
/* End the output stream to file */
/* */
/* ---------------------------------------------------------------------------- */
static int OutputToFile (/*i/o*/ register req * r)
{
epTHX_
oCommit (r, NULL) ;
if (!r -> bError && !r -> Component.pImportStash)
{
if (r -> Component.pOutputSV)
{
STRLEN l ;
char * p = SvPV (r -> Component.pOutputSV, l) ;
owrite (r, p, l) ;
}
else
{
tDomTree * pDomTree = DomTree_self (r -> Component.xCurrDomTree) ;
Node_toString (r, pDomTree, pDomTree -> xDocument, 0) ;
}
}
return ok ;
}
/* ---------------------------------------------------------------------------- */
/* */
/* Append tree to upper tree */
/* */
/* ---------------------------------------------------------------------------- */
static int AppendToUpperTree (/*i/o*/ register req * r)
{
epTHX_
tDomTree * pDomTree = DomTree_self (r -> Component.xCurrDomTree) ;
tComponent * lc = r -> Component.pPrev ;
if (lc -> xCurrNode)
{
if (r -> Component.pOutputSV)
{
STRLEN len ;
char * p = SvPV (r -> Component.pOutputSV, len) ;
lc -> xCurrNode = Node_insertAfter_CDATA (r -> pApp, p, len, 0, DomTree_self (lc -> xCurrDomTree), lc -> xCurrNode, lc -> nCurrRepeatLevel) ;
}
else if (pDomTree -> xDocument)
{
lc -> xCurrNode = Node_insertAfter (r -> pApp, pDomTree, pDomTree -> xDocument, 0, DomTree_self (lc -> xCurrDomTree), lc -> xCurrNode, lc -> nCurrRepeatLevel) ;
}
}
return ok ;
}
/* ---------------------------------------------------------------------------- */
/* */
/* End the output stream */
/* */
/* ---------------------------------------------------------------------------- */
static int EndOutput (/*i/o*/ register req * r,
/*in*/ int rc,
/*in*/ SV * pOutData)
{
epTHX_
r -> Component.bEscModeSet = 0 ;
if (rc != ok || r -> bError)
{ /* --- generate error page if necessary --- */
GenerateErrorPage (r, rc) ;
if (r -> bExit)
return ok ;
}
if (!(r -> Config.bOptions & optEarlyHttpHeader) &&
(r -> Config.bOptions & optSendHttpHeader) && !r -> Component.Param.pOutput)
embperl_SendHttpHeader (r) ;
if (r -> Component.Param.pOutput)
return OutputToMem (r) ;
rc = OutputToFile (r) ;
#ifdef APACHE
if (r -> pApacheReq)
ap_finalize_request_protocol (r -> pApacheReq) ;
#endif
oflush (r) ;
return rc ;
}
/* ---------------------------------------------------------------------------- */
/* */
/* export symbols into caller package */
/* */
/* ---------------------------------------------------------------------------- */
static int export (/*in*/ tReq * r)
{
epTHX_
SV * sCaller = sv_2mortal(newSVpv (HvNAME (r -> Component.pImportStash), 0)) ;
dSP ;
PUSHMARK(sp);
XPUSHs(r -> _perlsv);
XPUSHs(sCaller) ;
PUTBACK;
perl_call_method ("export", G_SCALAR | G_EVAL) ;
SPAGAIN ;
if (SvTRUE (ERRSV))
{
STRLEN l ;
strncpy (r -> errdat1, SvPV (ERRSV, l), sizeof (r -> errdat1) - 1) ;
LogError (r, rcEvalErr) ;
POPs ;
sv_setpv(ERRSV,"");
}
tainted = 0 ;
return ok ;
}
/* ---------------------------------------------------------------------------- */
/* */
/* Process the file */
/* */
/* ---------------------------------------------------------------------------- */
static int ProcessFile (/*i/o*/ register req * r,
/*in*/ int nFileSize)
{
epTHX_
int rc ;
SV * pParam ;
SV * pParamRV = NULL ;
SV * pRecipe = r -> Component.Config.pRecipe ;
STRLEN l ;
int num ;
dSP ;
tainted = 0 ;
if (!pRecipe || !SvOK(pRecipe))
pRecipe = sv_2mortal(newSVpv("Embperl", 7)) ;
if (SvPOK(pRecipe))
{
PUSHMARK(sp);
XPUSHs(r -> pApp -> _perlsv);
XPUSHs(r -> _perlsv);
XPUSHs(pRecipe);
PUTBACK;
num = perl_call_method ("get_recipe", G_SCALAR | G_EVAL) ;
tainted = 0 ;
SPAGAIN;
if (num == 1)
pParamRV = POPs ;
PUTBACK;
if (SvTRUE (ERRSV))
{
STRLEN l ;
strncpy (r -> errdat1, SvPV (ERRSV, l), sizeof (r -> errdat1) - 1) ;
LogError (r, rcEvalErr) ;
sv_setpv(ERRSV,"");
num = 0 ;
}
if (num != 1 || !SvROK (pParamRV) || !(pParam = SvRV(pParamRV)) ||
(SvTYPE((SV *)pParam) != SVt_PVHV && SvTYPE(pParam) != SVt_PVAV))
{
strncpy (r -> errdat1, SvPV(pRecipe, l), sizeof (r -> errdat1) - 1) ;
return rcUnknownRecipe ;
}
}
else if (SvROK(pRecipe))
pParam = SvRV(pRecipe) ;
else
pParam = pRecipe ;
if ((rc = Cache_New (r, pParam, -1, 1, &r -> Component.pOutputCache)) != ok)
return rc ;
if (strncmp (r -> Component.pOutputCache -> pProvider -> sOutputType, "text/", 5) == 0)
{
if ((rc = Cache_GetContentSV (r, r -> Component.pOutputCache, &r -> Component.pOutputSV, FALSE)) != ok)
return rc ;
}
else if (strcmp (r -> Component.pOutputCache -> pProvider -> sOutputType, "X-Embperl/DomTree") == 0)
{
if ((rc = Cache_GetContentIndex (r, r -> Component.pOutputCache, &r -> Component.xCurrDomTree, FALSE)) != ok)
return rc ;
}
else
{
sprintf (r -> errdat1, "'%s' (accpetable are 'text/*', 'X-Embperl/DomTree')", r -> Component.pOutputCache -> pProvider -> sOutputType) ;
strncpy (r -> errdat2, r -> Component.pOutputCache -> sKey, sizeof (r -> errdat2) - 1) ;
return rcTypeMismatch ;
}
return ok ;
}
/* ---------------------------------------------------------------------------- */
/* */
/* Request handler */
/* */
/* ---------------------------------------------------------------------------- */
int embperl_RunRequest (/*i/o*/ register req * r)
{
int rc = ok ;
tComponent * c = &r -> Component ;
char * sInputfile = c -> sSourcefile ;
dTHR ;
epTHX ;
EPENTRY (ExecuteReq) ;
if (!r -> Component.pExportHash)
r -> Component.pExportHash = newHV () ;
ENTER;
SAVETMPS ;
/* SetupSafeNamespace (r) ; */
if (c -> Param.pErrArray)
{
SvREFCNT_inc(c -> Param.pErrArray) ;
SvREFCNT_dec(r -> pErrArray) ;
r -> pErrArray = c -> Param.pErrArray ;
}
/* --- open output and send http header if EarlyHttpHeaders --- */
if (rc == ok)
rc = StartOutput (r) ;
/* --- ok so far? if not exit ---- */
#ifdef APACHE
if (rc != ok || (r -> pApacheReq && r -> pApacheReq -> header_only && (r -> Config.bOptions & optEarlyHttpHeader)))
#else
if (rc != ok)
#endif
{
if (rc != ok)
LogError (r, rc);
#ifdef APACHE
r -> pApacheReq = NULL ;
#endif
r -> Component.bReqRunning = 0 ;
FREETMPS ;
LEAVE;
return rc ;
}
r -> Component.bReqRunning = 1 ;
if (!r -> bError)
{
if ((rc = ProcessFile (r, 0 /*r -> Buf.pFile -> nFilesize*/)) != ok)
{
if (rc == rcExit)
rc = ok ;
else
LogError (r, rc) ;
}
if (r -> Component.Param.nImport > 0)
export (r) ;
}
/* --- Restore Operatormask and Package, destroy temp perl sv's --- */
FREETMPS ;
LEAVE;
r -> Component.bReqRunning = 0 ;
/* --- send http header and data to the browser if not already done --- */
if ((rc = EndOutput (r, rc, r -> Component.Param.pOutput)) != ok)
LogError (r, rc) ;
#ifdef EP2
if (r -> Component.pOutputCache)
Cache_ReleaseContent (r, r -> Component.pOutputCache) ;
#endif
/* --- reset variables and log end of request --- */
if ((rc = ResetRequest (r, sInputfile)) != ok)
LogError (r, rc) ;
#if defined (_MDEBUG) && defined (WIN32)
_ASSERTE( _CrtCheckMemory( ) );
#endif
if ((c -> Config.bOptions & optReturnError) && r -> bError)
{
#ifdef APACHE
if (r -> pApacheReq && r -> pApacheReqSV)
{
dSP ;
PUSHMARK(sp);
XPUSHs(r -> pApacheReqSV);
XPUSHs(sv_2mortal(newSVpv("EMBPERL_ERRORS", 14)));
XPUSHs(sv_2mortal(newRV((SV*)r -> pErrArray)));
PUTBACK;
perl_call_method ("pnotes", G_DISCARD) ;
}
#endif
#ifdef APACHE
/* This must be the very very very last !!!!! */
r -> pApacheReq = NULL ;
#endif
return 500 ;
}
#ifdef APACHE
/* This must be the very very very last !!!!! */
r -> pApacheReq = NULL ;
#endif
return ok ;
}
/* ---------------------------------------------------------------------------- */
/* */
/* Run Request */
/* */
/* ---------------------------------------------------------------------------- */
int embperl_ExecuteRequest (/*in*/ pTHX_
/*in*/ SV * pApacheReqSV,
/*in*/ SV * pPerlParam)
{
int rc ;
tReq * r = NULL ;
#ifdef DMALLOC
time_t t = time(NULL) ;
static unsigned long nMemCheckpoint ;
static unsigned long nMemCheckpoint2 ;
dmalloc_message ("[%d]REQ: Start Request at %s\n", getpid(), ctime (&t)) ;
#endif
#if defined (_MDEBUG) && defined (WIN32)
_CrtMemCheckpoint(&r -> MemCheckpoint);
#endif
#ifdef DMALLOC
nMemCheckpoint2 = nMemCheckpoint ;
nMemCheckpoint = dmalloc_mark () ;
#endif
ENTER;
SAVETMPS ;
rc = embperl_InitRequestComponent (aTHX_ pApacheReqSV, pPerlParam, &r) ;
#ifdef DMALLOC
r -> MemCheckpoint = nMemCheckpoint;
#endif
if (rc == ok)
rc = embperl_RunRequest (r) ;
#ifdef DMALLOC
dmalloc_message ( "[%d]%sRequest will be freed. Entry-SVs: %d: %%d\n", r -> pThread -> nPid,
(r -> Component.pPrev?"Sub-":""), r -> stsv_count) ;
#endif
if (r)
embperl_CleanupRequest (r) ;
FREETMPS ;
LEAVE;
#if defined (_MDEBUG) && defined (WIN32)
_CrtMemDumpAllObjectsSince(&r -> MemCheckpoint);
#endif
#ifdef DMALLOC
/* unsigned long mark, int not_freed_b, int freed_b, int details_b */
dmalloc_log_changed (nMemCheckpoint, 1, 0, 1) ;
dmalloc_message ( "[%d]Request freed. Exit-SVs: %d\n", getpid(),
sv_count) ;
if (nMemCheckpoint2)
{
dmalloc_message ( "***TO PREVIOUS REQUEST***\n") ;
dmalloc_log_changed (nMemCheckpoint2, 1, 0, 1) ;
}
#endif
return rc ;
}
/* ---------------------------------------------------------------------------- */
/* */
/* Run Component */
/* */
/* ---------------------------------------------------------------------------- */
int embperl_RunComponent (/*in*/ tComponent * c)
{
tReq * r = c -> pReq ;
epTHX_
int rc ;
ENTER;
SAVETMPS ;
c -> bReqRunning = 1 ;
if ((c -> Config.bOptions & optReturnError) )
save_int(&r -> bError) ;
if (c -> Param.pErrArray)
{
save_int(&r -> bError) ;
save_aptr(&r -> pErrArray) ;
r -> pErrArray = c -> Param.pErrArray ;
}
if ((c -> Config.bOptions & optEarlyHttpHeader) == 0)
oBegin (r) ;
if ((rc = ProcessFile (r, 0 /*r -> Buf.pFile -> nFilesize*/)) != ok)
{
if (rc == rcExit)
rc = ok ;
else
LogError (r, rc) ;
}
if (rc == ok && (c -> Config.bOptions & optReturnError) && r -> bError)
rc = 500 ;
if (!r -> bError)
{
if (c -> Param.nImport > 0)
export (r) ;
else if (c -> pOutput && !c -> pOutput -> bDisableOutput)
{
if (c -> Param.pOutput)
OutputToMem (r) ;
else if (r -> Component.pPrev && c -> pOutput == r -> Component.pPrev -> pOutput)
AppendToUpperTree (r) ;
else
OutputToFile (r) ;
}
}
/* --- Restore Operatormask and Package, destroy temp perl sv's --- */
FREETMPS ;
LEAVE;
c -> bReqRunning = 0 ;
return rc ;
}
/* ---------------------------------------------------------------------------- */
/* */
/* Execute Component */
/* */
/* ---------------------------------------------------------------------------- */
int embperl_ExecuteComponent(/*in*/ tReq * r,
/*in*/ SV * pPerlParam)
{
epTHX_
int rc ;
tComponent * pComponent ;
rc = embperl_SetupComponent (r, pPerlParam, &pComponent) ;
if (rc == ok)
{
rc = embperl_RunComponent (pComponent) ;
embperl_CleanupComponent (pComponent) ;
}
return rc ;
}