You are viewing a plain text version of this content. The canonical link for it is here.
Posted to embperl-cvs@perl.apache.org by ri...@locus.apache.org on 2000/11/15 08:21:55 UTC
cvs commit: embperl/test/cmp binary.htm
richter 00/11/14 23:21:54
Modified: . Tag: Embperl2c Changes.pod Embperl.pm README.v2
ep.h ep2.h epcomp.c epdat.h epeval.c epmain.c
test.pl
test/cmp Tag: Embperl2c binary.htm
Log:
Embperl2 -
- Added cacheing of output. There are serveral parameters that
controls the caching. They can be either given as configuration
directives in httpd.conf, as parameters to Execute or as
Perl vars/subs inside a [! !] of the page itself.
Revision Changes Path
No revision
No revision
1.129.4.5 +4 -0 embperl/Changes.pod
Index: Changes.pod
===================================================================
RCS file: /home/cvs/embperl/Changes.pod,v
retrieving revision 1.129.4.4
retrieving revision 1.129.4.5
diff -u -r1.129.4.4 -r1.129.4.5
--- Changes.pod 2000/11/13 18:38:42 1.129.4.4
+++ Changes.pod 2000/11/15 07:21:52 1.129.4.5
@@ -41,6 +41,10 @@
<option value="foo"> and <option>foo</option> are the same
- Execute ('file.htm#subname') works now without a previous
import
+ - Added cacheing of output. There are serveral parameters that
+ controls the caching. They can be either given as configuration
+ directives in httpd.conf, as parameters to Execute or as
+ Perl vars/subs inside a [! !] of the page itself.
=head1 1.3b7_dev
1.118.4.12 +16 -8 embperl/Embperl.pm
Index: Embperl.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl.pm,v
retrieving revision 1.118.4.11
retrieving revision 1.118.4.12
diff -u -r1.118.4.11 -r1.118.4.12
--- Embperl.pm 2000/11/10 08:52:26 1.118.4.11
+++ Embperl.pm 2000/11/15 07:21:52 1.118.4.12
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: Embperl.pm,v 1.118.4.11 2000/11/10 08:52:26 richter Exp $
+# $Id: Embperl.pm,v 1.118.4.12 2000/11/15 07:21:52 richter Exp $
#
###################################################################################
@@ -420,12 +420,13 @@
if ($Apache::Session::VERSION =~ /^0\.17/)
{
# Apache::Session = 0.17
- $SessionMgnt = 1 ;
- tie %udat, 'Apache::Session', $ENV{EMBPERL_SESSION_CLASS} || 'Win32',
- undef, {not_lazy=>0, autocommit=>0, lifetime=>&Apache::Session::LIFETIME} ;
- tie %mdat, 'Apache::Session', $ENV{EMBPERL_SESSION_CLASS} || 'Win32',
- undef, {not_lazy=>0, autocommit=>0, lifetime=>&Apache::Session::LIFETIME} ;
- warn "[$$]SES: Embperl Session management enabled (0.17)\n" ;
+ ##$SessionMgnt = 1 ;
+ ##tie %udat, 'Apache::Session', $ENV{EMBPERL_SESSION_CLASS} || 'Win32',
+ ## undef, {not_lazy=>0, autocommit=>0, lifetime=>&Apache::Session::LIFETIME} ;
+ ##tie %mdat, 'Apache::Session', $ENV{EMBPERL_SESSION_CLASS} || 'Win32',
+ ## undef, {not_lazy=>0, autocommit=>0, lifetime=>&Apache::Session::LIFETIME} ;
+ warn "[$$]SES: Apache::Session 0.17 not supported by Embperl Session management anymore\n" ;
+ $SessionMgnt = 0 ;
}
}
@@ -672,7 +673,12 @@
$$req{'cookie_expires'} = $ENV{EMBPERL_COOKIE_EXPIRES} if (exists ($ENV{EMBPERL_COOKIE_EXPIRES})) ;
##ep2##
- $$req{'ep1compat'} = $ENV{EMBPERL_EP1COMPAT} || 0 ;
+ $$req{'ep1compat'} = $ENV{EMBPERL_EP1COMPAT} || 0 ;
+ $$req{'cache_key'} = $ENV{EMBPERL_CACHE_KEY} if (exists ($ENV{EMBPERL_CACHE_KEY})) ; ;
+ $$req{'cache_key_options'} = $ENV{EMBPERL_CACHE_KEY_OPTIONS} if (exists ($ENV{EMBPERL_CACHE_KEY_OPTIONS})) ; ;
+ $$req{'expired_func'} = $ENV{EMBPERL_EXPIRES_FUNC} if (exists ($ENV{EMBPERL_EXPIRES_FUNC})) ; ;
+ $$req{'cache_key_func'} = $ENV{EMBPERL_CACHE_KEY_FUNC} if (exists ($ENV{EMBPERL_CACHE_KEY_FUNC})) ; ;
+ $$req{'expires_in'} = $ENV{EMBPERL_EXPIRES_IN} if (exists ($ENV{EMBPERL_EXPIRES_IN})) ; ;
##/ep2##
@@ -1251,6 +1257,8 @@
$packfile = '-> No Perl in Source <-' if ($packfile eq ('_<' . __FILE__) || $packfile eq __FILE__) ;
$addcleanup = \%{"$package\:\:CLEANUP"} ;
$addcleanup -> {'CLEANUP'} = 0 ;
+ $addcleanup -> {'EXPIRES'} = 0 ;
+ $addcleanup -> {'CACHE_KEY'} = 0 ;
if ($Debugflags & dbgShowCleanup)
{
print LOG "[$$]CUP: ***** Cleanup package: $package *****\n" ;
1.1.4.3 +47 -0 embperl/Attic/README.v2
Index: README.v2
===================================================================
RCS file: /home/cvs/embperl/Attic/README.v2,v
retrieving revision 1.1.4.2
retrieving revision 1.1.4.3
diff -u -r1.1.4.2 -r1.1.4.3
--- README.v2 2000/11/08 21:40:27 1.1.4.2
+++ README.v2 2000/11/15 07:21:52 1.1.4.3
@@ -94,6 +94,53 @@
itself!
+Addtional Config directives
+---------------------------
+
+execute parameter / httpd.conf environment variable / name inside page (must set inside [! !])
+
+
+cache_key / EMBPERL_CACHE_KEY / $CACHE_KEY
+
+literal string that is appended to the cache key
+
+
+cache_key_options / EMBPERL_CACHE_KEY_OPTIONS / $CACHE_KEY_OPTIONS
+
+ ckoptCarryOver = 1, use result from CacheKeyFunc of preivious step if any
+ ckoptPathInfo = 2, include the PathInfo into CacheKey
+ ckoptQueryInfo = 4, include the QueryInfo into CacheKey
+ ckoptDontCachePost = 8, don't cache POST requests (not yet implemented)
+
+ Default: all options set
+
+
+expired_func / EMBPERL_EXPIRES_FUNC / &EXPIRES
+
+function that should be called when build a cache key. The result is
+appended to the cache key.
+
+
+cache_key_func / EMBPERL_CACHE_KEY_FUNC / &CACHE_KEY
+
+function that is called everytime before data is taken from the cache.
+If this funtion returns true, the data from the cache isn't used anymore,
+but rebuild.
+
+
+Function could be either a coderef (when passed to Execute), a name of a
+subroutine or a string starting with "sub " in which case it is compiled
+as anoymous subroutine.
+
+
+expires_in / EMBPERL_EXPIRES_IN / $EXPIRES
+
+Time in seconds that the output schould be cached. (0 = never, -1 = forever)
+
+
+-------------------
+
+
Enjoy
Gerald
1.27.4.6 +6 -0 embperl/ep.h
Index: ep.h
===================================================================
RCS file: /home/cvs/embperl/ep.h,v
retrieving revision 1.27.4.5
retrieving revision 1.27.4.6
diff -u -r1.27.4.5 -r1.27.4.6
--- ep.h 2000/10/18 13:28:52 1.27.4.5
+++ ep.h 2000/11/15 07:21:52 1.27.4.6
@@ -526,6 +526,12 @@
int EvalMain (/*i/o*/ register req * r) ;
+int EvalConfig (/*i/o*/ register req * r,
+ /*in*/ SV * pSV,
+ /*in*/ int numArgs,
+ /*in*/ SV ** pArgs,
+ /*out*/ CV ** pCV) ;
+
#ifdef EP2
int CallStoredCV (/*i/o*/ register req * r,
1.1.2.6 +6 -0 embperl/Attic/ep2.h
Index: ep2.h
===================================================================
RCS file: /home/cvs/embperl/Attic/ep2.h,v
retrieving revision 1.1.2.5
retrieving revision 1.1.2.6
diff -u -r1.1.2.5 -r1.1.2.6
--- ep2.h 2000/11/02 08:45:20 1.1.2.5
+++ ep2.h 2000/11/15 07:21:52 1.1.2.6
@@ -69,6 +69,12 @@
int embperl_CompileDocument (/*i/o*/ register req * r,
/*in*/ tProcessor * pFirstProcessor) ;
+int embperl_PreExecuteProcessor (/*in*/ tReq * r,
+ /*in*/ tProcessor * pProcessor,
+ /*in*/ tDomTree ** pDomTree,
+ /*in*/ SV ** ppPreCompResult,
+ /*in*/ SV ** ppCompResult) ;
+
int embperl_ExecuteProcessor (/*in*/ tReq * r,
/*in*/ tProcessor * pProcessor,
/*in*/ tDomTree ** pDomTree,
1.4.2.15 +127 -17 embperl/Attic/epcomp.c
Index: epcomp.c
===================================================================
RCS file: /home/cvs/embperl/Attic/epcomp.c,v
retrieving revision 1.4.2.14
retrieving revision 1.4.2.15
diff -u -r1.4.2.14 -r1.4.2.15
--- epcomp.c 2000/11/02 08:45:21 1.4.2.14
+++ epcomp.c 2000/11/15 07:21:52 1.4.2.15
@@ -1230,6 +1230,77 @@
/* ------------------------------------------------------------------------ */
/* */
+/* embperl_CompileProcessorSetupVar */
+/* */
+/* Looks for vars/subs inside compiled document */
+/* */
+/* in pProcessor Processor data */
+/* */
+/* ------------------------------------------------------------------------ */
+
+int embperl_PreExecuteProcessor (/*in*/ tReq * r,
+ /*in*/ tProcessor * pProcessor,
+ /*in*/ tDomTree ** pDomTree,
+ /*in*/ SV ** ppPreCompResult,
+ /*in*/ SV ** ppCompResult)
+
+
+ {
+ STRLEN l ;
+ SV * pSV ;
+ CV * pCV ;
+ SV * pSVVar ;
+
+ pSV = newSVpvf("%s::EXPIRES", r -> Buf.sEvalPackage) ;
+ pCV = perl_get_cv (SvPV(pSV, l), 0) ;
+ if (pCV)
+ {
+ SvREFCNT_dec (pProcessor -> pOutputExpiresCV) ;
+ pProcessor -> pOutputExpiresCV = pCV ;
+ SvREFCNT_inc (pCV) ;
+ }
+ SvREFCNT_dec(pSV);
+
+ pSV = newSVpvf("%s::EXPIRES", r -> Buf.sEvalPackage) ;
+ pSVVar = perl_get_sv (SvPV(pSV, l), 0) ;
+ if (pSVVar)
+ {
+ pProcessor -> nOutputExpiresIn = SvNV (pSVVar) ;
+ }
+ SvREFCNT_dec(pSV);
+
+ pSV = newSVpvf("%s::CACHE_KEY", r -> Buf.sEvalPackage) ;
+ pCV = perl_get_cv (SvPV(pSV, l), 0) ;
+ if (pCV)
+ {
+ SvREFCNT_dec (pProcessor -> pCacheKeyCV) ;
+ pProcessor -> pCacheKeyCV = pCV ;
+ SvREFCNT_inc (pCV) ;
+ }
+ SvREFCNT_dec(pSV);
+
+ pSV = newSVpvf("%s::CACHE_KEY", r -> Buf.sEvalPackage) ;
+ pSVVar = perl_get_sv (SvPV(pSV, l), 0) ;
+ if (pSVVar)
+ {
+ pProcessor -> sCacheKey = SvPV (pSVVar, l) ;
+ }
+ SvREFCNT_dec(pSV);
+
+ pSV = newSVpvf("%s::CACHE_KEY_OPTIONS", r -> Buf.sEvalPackage) ;
+ pSVVar = perl_get_sv (SvPV(pSV, l), 0) ;
+ if (pSVVar)
+ {
+ pProcessor -> bCacheKeyOptions = SvIV (pSVVar) ;
+ }
+ SvREFCNT_dec(pSV);
+
+ return ok ;
+ }
+
+
+/* ------------------------------------------------------------------------ */
+/* */
/* embperl_CompileProcessor */
/* */
/* Compile the whole document */
@@ -1381,6 +1452,11 @@
pDomTree = DomTree_self (r -> xCurrDomTree) ;
AssignSVPtr (ppCompResult,SV_DomTree_self (pDomTree)) ;
SvREFCNT_inc (*ppCompResult) ;
+ /* add timestamp */
+ SvUPGRADE (*ppCompResult, SVt_PVNV) ;
+ SvNVX (*ppCompResult) = time (NULL) ;
+ SvNOK_on (*ppCompResult) ;
+
cl2 = clock () ;
#ifdef CLOCKS_PER_SEC
@@ -1611,6 +1687,10 @@
*pDomTree = pCurrDomTree ;
AssignSVPtr (ppExecResult, SV_DomTree_self (pCurrDomTree)) ;
SvREFCNT_inc (*ppExecResult) ;
+ /* add timestamp */
+ SvUPGRADE (*ppExecResult, SVt_PVNV) ;
+ SvNVX (*ppExecResult) = time (NULL) ;
+ SvNOK_on (*ppExecResult) ;
}
r -> nPhase = phTerm ;
@@ -1643,18 +1723,22 @@
/*in*/ double nExpiresIn,
/*in*/ CV * pExpiresCV,
/*in*/ int * bForceExpire,
- /*out*/ SV * * * pppSV)
+ /*i/o*/ char * * ppCVKey,
+ /*out*/ SV * * * pppSV)
{
int rc ;
- char sKey[255] ;
+ char sKey[512] ;
int nKey ;
+ char * pCVKey = "";
+ char * pPathInfoKey ;
+ char * pQueryInfoKey ;
SV * * ppSV ;
STRLEN l ;
-
+ int bOpt = cType == 'P'?0:pProcessor -> bCacheKeyOptions ;
- if (nExpiresIn == 0)
+ if (nExpiresIn == 0 && !pExpiresCV)
{
*pppSV = (SV**)_malloc (r, sizeof (SV *)) ;
**pppSV = NULL ;
@@ -1662,8 +1746,36 @@
lprintf (r, "[%d]CACHE: File: '%s' Processor: '%s' Step: '%s' Type: '%c' not cached\n", r -> nPid, r -> Buf.pFile -> sSourcefile, pProcessor -> sName, sStepName, cType) ;
return ok ;
}
+
+ if ((bOpt & ckoptCarryOver) && *ppCVKey)
+ {
+ pCVKey = *ppCVKey ;
+ }
+ else
+ {
+ if (pProcessor -> pCacheKeyCV)
+ {
+ SV * pRet ;
- nKey = sprintf (sKey, "%c-%d-%0.200s", cType, pProcessor -> nProcessorNo, pProcessor -> sCacheKey) ;
+ if ((rc = CallCV (r, "CacheKey", pProcessor -> pCacheKeyCV, 0, &pRet)) != ok)
+ return rc ;
+
+ if (pRet && SvOK(pRet))
+ *ppCVKey = pCVKey = SvPV (pRet, l) ;
+ }
+ }
+
+ if ((bOpt & ckoptPathInfo) && r -> sPathInfo)
+ pPathInfoKey = r -> sPathInfo ;
+ else
+ pPathInfoKey = "" ;
+
+ if ((bOpt & ckoptQueryInfo) && r -> sQueryInfo)
+ pQueryInfoKey = r -> sQueryInfo ;
+ else
+ pQueryInfoKey = "" ;
+
+ nKey = _snprintf (sKey, sizeof (sKey) - 1, "%c-%d-%s-%s-%s-%s", cType, pProcessor -> nProcessorNo, pProcessor -> sCacheKey, pCVKey, pPathInfoKey, pQueryInfoKey) ;
if (r -> bDebug & dbgCache)
lprintf (r, "[%d]CACHE: File: '%s' Processor: '%s' Step: '%s' gives Key: '%s'\n", r -> nPid, r -> Buf.pFile -> sSourcefile, pProcessor -> sName, sStepName, sKey) ;
*pppSV = ppSV = hv_fetch(r -> Buf.pFile -> pCacheHash, sKey, nKey, 1) ;
@@ -1725,7 +1837,7 @@
if ((rc = CallCV (r, "Expired?", pExpiresCV, 0, &pRet)) != ok)
return rc ;
- if (pRet && SvOK(pRet))
+ if (pRet && SvTRUE(pRet))
{ // Expire the entry
sv_setsv (*ppSV, &sv_undef) ;
*bForceExpire = 1 ;
@@ -1733,12 +1845,6 @@
lprintf (r, "[%d]CACHE: Expired because Expirey sub returned TRUE\n", r -> nPid) ;
}
}
- else if (nExpiresIn > 0)
- { /* add timestamp */
- SvUPGRADE (*ppSV, SVt_PVNV) ;
- SvNVX (*ppSV) = time (NULL) ;
- SvNOK_on (*ppSV) ;
- }
return ok ;
}
@@ -1773,7 +1879,7 @@
tProcessor * pProcessor = NULL ;
int bForceExpire ;
int bForceExpirePre ;
-
+ char * pCVKey = NULL ;
tainted = 0 ;
cl2 = clock () ;
@@ -1785,7 +1891,7 @@
{
if (pProcessor -> pPreCompiler)
{
- if ((rc = embperl_GetFromCache (r, pProcessor, 'P', "Precompiler", -1, NULL, &bForceExpirePre, &ppSV)) != ok)
+ if ((rc = embperl_GetFromCache (r, pProcessor, 'P', "Precompiler", -1, NULL, &bForceExpirePre, &pCVKey, &ppSV)) != ok)
return rc ;
if ((rc = (*pProcessor -> pPreCompiler)(r, pProcessor, &pDomTree, NULL, ppSV)) != ok)
@@ -1821,13 +1927,13 @@
if (pProcessor -> pPreCompiler)
{
- if ((rc = embperl_GetFromCache (r, pProcessor, 'P', "Precompiler", -1, NULL, &bForceExpirePre, &ppPreCompResult)) != ok)
+ if ((rc = embperl_GetFromCache (r, pProcessor, 'P', "Precompiler", -1, NULL, &bForceExpirePre, &pCVKey, &ppPreCompResult)) != ok)
return rc ;
}
if (pProcessor -> pCompiler)
{
- if ((rc = embperl_GetFromCache (r, pProcessor, 'C', "Compiler", -1, NULL, &bForceExpire, &ppCompResult)) != ok)
+ if ((rc = embperl_GetFromCache (r, pProcessor, 'C', "Compiler", -1, NULL, &bForceExpire, &pCVKey, &ppCompResult)) != ok)
return rc ;
if ((rc = (*pProcessor -> pCompiler)(r, pProcessor, &pDomTree, ppPreCompResult, ppCompResult)) != ok)
@@ -1836,7 +1942,11 @@
if (!r -> bError && pProcessor -> pExecuter)
{
- if ((rc = embperl_GetFromCache (r, pProcessor, 'E', "Executer", pProcessor -> nOutputExpiresIn, pProcessor -> pOutputExpiresCV, &bForceExpire, &ppExecResult)) != ok)
+ if (pProcessor -> pPreExecuter)
+ if ((rc = (*pProcessor -> pPreExecuter)(r, pProcessor, &pDomTree, ppPreCompResult, ppCompResult)) != ok)
+ return rc ;
+
+ if ((rc = embperl_GetFromCache (r, pProcessor, 'E', "Executer", pProcessor -> nOutputExpiresIn, pProcessor -> pOutputExpiresCV, &bForceExpire, &pCVKey, &ppExecResult)) != ok)
return rc ;
if ((rc = (*pProcessor -> pExecuter)(r, pProcessor, &pDomTree, ppPreCompResult, ppCompResult, ppExecResult)) != ok)
1.20.4.9 +32 -4 embperl/epdat.h
Index: epdat.h
===================================================================
RCS file: /home/cvs/embperl/epdat.h,v
retrieving revision 1.20.4.8
retrieving revision 1.20.4.9
diff -u -r1.20.4.8 -r1.20.4.9
--- epdat.h 2000/10/31 08:02:48 1.20.4.8
+++ epdat.h 2000/11/15 07:21:52 1.20.4.9
@@ -17,6 +17,22 @@
#ifdef EP2
/*-----------------------------------------------------------------*/
/* */
+/* cache Options */
+/* */
+/*-----------------------------------------------------------------*/
+
+typedef enum tCacheOptions
+ {
+ ckoptCarryOver = 1, /* use result from CacheKeyCV of preivious step if any */
+ ckoptPathInfo = 2, /* include the PathInfo into CacheKey */
+ ckoptQueryInfo = 4, /* include the QueryInfo into CacheKey */
+ ckoptDontCachePost = 8, /* don't cache POST requests */
+ ckoptDefault = 15, /* default is all options set */
+ } tCacheOptions ;
+
+
+/*-----------------------------------------------------------------*/
+/* */
/* Processor */
/* */
/*-----------------------------------------------------------------*/
@@ -36,6 +52,11 @@
/*in*/ tDomTree ** ppDomTree,
/*in*/ SV ** ppPreCompResult,
/*out*/ SV ** ppCompResult) ;
+ int (* pPreExecuter) (/*in*/ tReq * r,
+ /*in*/ struct tProcessor * pProcessor,
+ /*in*/ tDomTree ** pDomTree,
+ /*in*/ SV ** ppPreCompResult,
+ /*in*/ SV ** ppCompResult) ;
int (* pExecuter) (/*in*/ tReq * r,
/*in*/ struct tProcessor * pProcessor,
/*in*/ tDomTree ** pDomTree,
@@ -43,7 +64,9 @@
/*in*/ SV ** ppCompResult,
/*out*/ SV ** ppExecResult) ;
- const char * sCacheKey ;
+ const char * sCacheKey ; /* literal to add to key for cache */
+ CV * pCacheKeyCV ; /* CV to call and add result to key for cache */
+ tCacheOptions bCacheKeyOptions ;
double nOutputExpiresIn ;
CV * pOutputExpiresCV ;
@@ -99,9 +122,11 @@
#ifdef EP2
bool bEP1Compat ; /* run in Embperl 1.x compatible mode */
tProcessor ** pProcessor ; /* [array] processors used to process the file */
- char ** sExpiresKey ; /* [array] Key used to store expires setting */
- double * nExpiresAt ; /* [array] Data expiers at */
- SV ** pExpiresCV ; /* [array] sub that is called to determinate expiration */
+ char * sCacheKey ; /* Key used to store expires setting */
+ CV * pCacheKeyCV ; /* CV to call and add result to key for cache */
+ tCacheOptions bCacheKeyOptions ;
+ double nExpiresIn ; /* Data expiers at */
+ CV * pExpiresCV ; /* sub that is called to determinate expiration */
#endif
char * sPath ; /* file search path */
char * sReqFilename ; /* filename of original request */
@@ -330,6 +355,9 @@
bool bEP1Compat ; /* run in Embperl 1.x compatible mode */
tPhase nPhase ; /* which phase of the request we are in */
+ char * sPathInfo ;
+ char * sQueryInfo ;
+
/* --- DomTree ---*/
tNode xDocument ;
1.23.4.6 +89 -0 embperl/epeval.c
Index: epeval.c
===================================================================
RCS file: /home/cvs/embperl/epeval.c,v
retrieving revision 1.23.4.5
retrieving revision 1.23.4.6
diff -u -r1.23.4.5 -r1.23.4.6
--- epeval.c 2000/11/08 21:40:30 1.23.4.5
+++ epeval.c 2000/11/15 07:21:52 1.23.4.6
@@ -71,6 +71,95 @@
}
+/* -------------------------------------------------------------------------------
+*
+* Eval Config Statements
+*
+* in pSV pointer to string or CV
+* out pCV pointer to SV contains an CV to the evaled code
+*
+------------------------------------------------------------------------------- */
+
+int EvalConfig (/*i/o*/ register req * r,
+ /*in*/ SV * pSV,
+ /*in*/ int numArgs,
+ /*in*/ SV ** pArgs,
+ /*out*/ CV ** pCV)
+ {
+ dTHXsem
+ dSP;
+ SV * pSVErr ;
+ int num ;
+ char * s = "Needs CodeRef" ;
+
+ EPENTRY (EvalDirect) ;
+
+ tainted = 0 ;
+ pCurrReq = r ;
+
+ *pCV = NULL ;
+ if (SvPOK (pSV))
+ {
+ STRLEN l ;
+ s = SvPV (pSV, l) ;
+ if (strncmp (s, "sub ", 4) == 0)
+ {
+ SV * pSVErr ;
+ SV * pRV ;
+
+ pRV = perl_eval_pv (s, 0) ;
+ if (SvROK (pRV))
+ {
+ *pCV = (CV *)SvRV (pRV) ;
+ SvREFCNT_inc (*pCV) ;
+ }
+
+ pSVErr = ERRSV ;
+ if (SvTRUE (pSVErr))
+ {
+ STRLEN l ;
+ char * p = SvPV (pSVErr, l) ;
+ if (l > sizeof (r -> errdat1) - 1)
+ l = sizeof (r -> errdat1) - 1 ;
+ strncpy (r -> errdat1, p, l) ;
+ if (l > 0 && r -> errdat1[l-1] == '\n')
+ l-- ;
+ r -> errdat1[l] = '\0' ;
+
+ LogError (r, rcEvalErr) ;
+
+ sv_setpv(pSVErr,"");
+ *pCV = NULL ;
+ return rcEvalErr ;
+ }
+ }
+ else
+ {
+ *pCV = perl_get_cv (s, 0) ;
+ SvREFCNT_inc (*pCV) ;
+ }
+ }
+ else
+ {
+ if (SvROK (pSV))
+ {
+ *pCV = (CV *)SvRV (pSV) ;
+ }
+ }
+
+ if (!*pCV || SvTYPE (*pCV) != SVt_PVCV)
+ {
+ *pCV = NULL ;
+ strcpy (r -> errdat1 ,"Config: ") ;
+ strncpy (r -> errdat2, s, sizeof (r -> errdat2) - 1) ;
+ return rcEvalErr ;
+ }
+
+ return ok ;
+ }
+
+
+
/* -------------------------------------------------------------------------------
*
1.75.4.14 +73 -21 embperl/epmain.c
Index: epmain.c
===================================================================
RCS file: /home/cvs/embperl/epmain.c,v
retrieving revision 1.75.4.13
retrieving revision 1.75.4.14
diff -u -r1.75.4.13 -r1.75.4.14
--- epmain.c 2000/11/11 19:39:26 1.75.4.13
+++ epmain.c 2000/11/15 07:21:52 1.75.4.14
@@ -692,9 +692,24 @@
rc = GetFormData (r, p, len) ;
+#ifdef EP2
+ if (!f && len > 0)
+ {
+ if ((f = _malloc (r, len + 1)) == NULL)
+ return rcOutOfMemory ;
+
+ memcpy (f, p, len) ;
+ p[len] = '\0' ;
+ }
+ if (len > 0)
+ {
+ r -> sQueryInfo = f ;
+ f[len] = '\0' ;
+ }
+#else
if (f)
_free (r, f) ;
-
+#endif
return rc ;
}
@@ -1675,6 +1690,8 @@
#ifdef EP2
SV * * ppSV ;
SV * pSV ;
+ SV * * ppCV ;
+ int rc ;
#endif
tConf * pConf = malloc (sizeof (tConf)) ;
@@ -1700,22 +1717,31 @@
#ifdef EP2
- pConf -> bEP1Compat = GetHashValueInt (pReqInfo, "ep1compat", pCurrReq -> pConf?pCurrReq -> pConf -> bEP1Compat:pCurrReq -> bEP1Compat) ; /* EP1Compat */
- /* ##ep2##
- pConf -> sExpiresKey = sstrdup (GetHashValueStr (pReqInfo, "expires_key", pCurrReq -> pConf?pCurrReq -> pConf -> sExpiresKey:NULL)) ; ;
-
- pConf -> nExpiresAt = 0 ;
- pConf -> pExpiresCV = NULL ;
- ppSV = hv_fetch (pReqInfo, "expires_at", 10, 0) ;
- if (ppSV && *ppSV && SvTYPE (*ppSV) == SVt_RV &&
- SvTYPE (pSV = SvRV (*ppSV)) == SVt_PVCV)
- pConf -> pExpiresCV = pSV ;
- else if (ppSV && *ppSV)
- pConf -> nExpiresAt = SvNV (*ppSV) ;
- */
- pConf -> sExpiresKey = NULL ;
- pConf -> nExpiresAt = 0 ;
- pConf -> pExpiresCV = NULL ;
+ pConf -> bEP1Compat = GetHashValueInt (pReqInfo, "ep1compat", pCurrReq -> pConf?pCurrReq -> pConf -> bEP1Compat:pCurrReq -> bEP1Compat) ; /* EP1Compat */
+
+ pConf -> sCacheKey = sstrdup (GetHashValueStr (pReqInfo, "cache_key", pCurrReq -> pConf?pCurrReq -> pConf -> sCacheKey:NULL)) ; ;
+ pConf -> bCacheKeyOptions = GetHashValueInt (pReqInfo, "cache_key_options", pCurrReq -> pConf?pCurrReq -> pConf -> bCacheKeyOptions:ckoptDefault) ;
+
+ ppCV = hv_fetch(pReqInfo, "expires_func", sizeof ("expires_func") - 1, 0) ;
+ if (ppCV && *ppCV && SvOK (*ppCV))
+ {
+ if ((rc = EvalConfig (pCurrReq, *ppCV, 0, NULL, &pConf -> pExpiresCV)) != ok)
+ LogError (pCurrReq, rc) ;
+ }
+ else
+ pConf -> pExpiresCV = pCurrReq -> pConf?pCurrReq -> pConf -> pExpiresCV:NULL ;
+
+
+ ppCV = hv_fetch(pReqInfo, "cache_key_func", sizeof ("cache_key_func") - 1, 0) ;
+ if (ppCV && *ppCV && SvOK (*ppCV))
+ {
+ if ((rc = EvalConfig (pCurrReq, *ppCV, 0, NULL, &pConf -> pCacheKeyCV)) != ok)
+ LogError (pCurrReq, rc) ;
+ }
+ else
+ pConf -> pCacheKeyCV = pCurrReq -> pConf?pCurrReq -> pConf -> pCacheKeyCV:NULL ;
+
+ pConf -> nExpiresIn = GetHashValueInt (pReqInfo, "expires_in", pCurrReq -> pConf?pCurrReq -> pConf -> nExpiresIn:0) ;
#endif
@@ -1763,9 +1789,12 @@
free (pConf -> sReqFilename) ;
#ifdef EP2
- if (pConf -> sExpiresKey)
- free (pConf -> sExpiresKey) ;
+ if (pConf -> sCacheKey)
+ free (pConf -> sCacheKey) ;
+ if (pConf -> pCacheKeyCV)
+ SvREFCNT_dec (pConf -> pCacheKeyCV) ;
+
if (pConf -> pExpiresCV)
SvREFCNT_dec (pConf -> pExpiresCV) ;
#endif
@@ -2049,6 +2078,10 @@
char * sMode ;
tFile * pFile ;
HV * pReqHV ;
+#ifdef EP2
+ SV * * ppSV ;
+ STRLEN len ;
+#endif
dTHR ;
@@ -2119,6 +2152,9 @@
r -> bDebug = pConf -> bDebug ;
#ifdef EP2
r -> bEP1Compat = pConf -> bEP1Compat ;
+ ppSV = hv_fetch(r -> pEnvHash, "PATH_INFO", sizeof ("PATH_INFO") - 1, 0) ;
+ if (ppSV)
+ r -> sPathInfo = SvPV (*ppSV ,len) ;
#endif
if (rc != ok)
r -> bDebug = 0 ; /* Turn debbuging off, only errors will go to stderr if logfile not open */
@@ -2910,10 +2946,26 @@
#ifdef EP2
if (!r -> bEP1Compat)
{
- tProcessor p2 = {2, "Embperl", embperl_CompileProcessor, NULL, embperl_ExecuteProcessor, "", 0, NULL, NULL } ;
- tProcessor p1 = {1, "Parser", embperl_ParseProcessor, NULL, NULL, "", 0, NULL, &p2 } ;
+ tConf * pConf = r -> pConf ;
+
+ tProcessor p2 = {2, "Embperl", embperl_CompileProcessor, NULL, embperl_PreExecuteProcessor, embperl_ExecuteProcessor, "",
+ pConf -> pCacheKeyCV, pConf -> bCacheKeyOptions, pConf -> nExpiresIn, pConf -> pExpiresCV, NULL } ;
+ tProcessor p1 = {1, "Parser", embperl_ParseProcessor, NULL, NULL, NULL, "", NULL, 0, 0, NULL, &p2 } ;
+
+ if (p2.pCacheKeyCV)
+ SvREFCNT_inc (p2.pCacheKeyCV) ;
+ if (p2.pOutputExpiresCV)
+ SvREFCNT_inc (p2.pOutputExpiresCV) ;
+
rc = embperl_CompileDocument (r, &p1) ;
+
+ if (p2.pCacheKeyCV)
+ SvREFCNT_dec (p2.pCacheKeyCV) ;
+
+ if (p2.pOutputExpiresCV)
+ SvREFCNT_dec (p2.pOutputExpiresCV) ;
+
}
else
{
1.70.4.20 +262 -20 embperl/test.pl
Index: test.pl
===================================================================
RCS file: /home/cvs/embperl/test.pl,v
retrieving revision 1.70.4.19
retrieving revision 1.70.4.20
diff -u -r1.70.4.19 -r1.70.4.20
--- test.pl 2000/11/10 08:52:29 1.70.4.19
+++ test.pl 2000/11/15 07:21:52 1.70.4.20
@@ -465,7 +465,7 @@
$opt_offline $opt_ep1 $opt_cgi $opt_modperl $opt_execute $opt_nokill $opt_loop
$opt_multchild $opt_memcheck $opt_exitonmem $opt_exitonsv $opt_config $opt_nostart $opt_uniquefn
$opt_quite $opt_ignoreerror $opt_tests $opt_blib $opt_help $opt_dbgbreak $opt_finderr
- $opt_ddd $opt_gdb $opt_ab $opt_start $opt_kill $opt_showcookie) ;
+ $opt_ddd $opt_gdb $opt_ab $opt_start $opt_kill $opt_showcookie $opt_cache) ;
{
local $^W = 0 ;
@@ -537,7 +537,7 @@
eval { Getopt::Long::Configure ('bundling') } ;
$@ = "" ;
-$ret = GetOptions ("offline|o", "ep1|1", "cgi|c", "modperl|httpd|h", "execute|e", "nokill|r", "loop|l:i",
+$ret = GetOptions ("offline|o", "ep1|1", "cgi|c", "cache|a", "modperl|httpd|h", "execute|e", "nokill|r", "loop|l:i",
"multchild|m", "memcheck|v", "exitonmem|g", "exitonsv", "config|f=s", "nostart|x", "uniquefn|u",
"quite|q", "ignoreerror|i", "tests|t", "blib|b", "help", "dbgbreak", "finderr",
"ddd", "gdb", "ab:s", "start", "kill", "showcookie") ;
@@ -591,6 +591,7 @@
print "-c test cgi\n" ;
print "-h test mod_perl\n" ;
print "-e test execute\n" ;
+ print "-a test output cache\n" ;
print "-r don't kill httpd at end of test\n" ;
print "-l loop forever\n" ;
print "-m start httpd with mulitple childs\n" ;
@@ -643,6 +644,10 @@
$vmhttpdsize = 0 ;
$vmhttpdinitsize = 0 ;
+#####################################################
+
+sub s1 { 1 } ;
+sub s0 { 0 } ;
#####################################################
@@ -666,6 +671,30 @@
#####################################################
+sub CmpInMem
+
+ {
+
+ my ($out, $cmp, $parm) = @_ ;
+
+ local $p = $parm ;
+
+ $out =~ s/\r//g ;
+ chomp ($out) ;
+
+ if ($out ne eval ($cmp))
+ {
+ print "\nError\nIs:\t>$out<\nShould:\t>" . eval ($cmp) . "<\n" ;
+ return 1 ;
+ }
+
+ return 0 ;
+ }
+
+
+
+#####################################################
+
sub CmpFiles
{
my ($f1, $f2, $errin) = @_ ;
@@ -980,16 +1009,16 @@
#### check commandline options #####
-if (!$opt_modperl && !$opt_cgi && !$opt_offline && !$opt_execute)
+if (!$opt_modperl && !$opt_cgi && !$opt_offline && !$opt_execute && !$opt_cache)
{
if (defined ($opt_ab))
{
$opt_modperl = 1 ;
}
elsif ($EPHTTPD ne '')
- { $opt_modperl = $opt_cgi = $opt_offline = $opt_execute = 1 }
+ { $opt_cache = $opt_modperl = $opt_cgi = $opt_offline = $opt_execute = 1 }
else
- { $opt_offline = $opt_execute = 1 }
+ { $opt_cache = $opt_offline = $opt_execute = 1 }
$opt_ep1 = 1 ;
}
@@ -1066,6 +1095,7 @@
%seen = () ;
$max_sv = 0 ;
$version = $EP2?2:1 ;
+$frommem = 0 ;
$cp = HTML::Embperl::AddCompartment ('TEST') ;
@@ -1075,6 +1105,13 @@
do
{
+ if ($opt_offline || $opt_execute || $opt_cache)
+ {
+ open (SAVEERR, ">&STDERR") || die "Cannot save stderr" ;
+ open (STDERR, ">$offlineerr") || die "Cannot redirect stderr" ;
+ open (ERR, "$offlineerr") || die "Cannot open redirected stderr ($offlineerr)" ; ;
+ }
+
#############
#
# OFFLINE
@@ -1085,13 +1122,6 @@
{
print "\nTesting offline mode...\n\n" ;
- if ($loopcnt == 0)
- {
- open (SAVEERR, ">&STDERR") || die "Cannot save stderr" ;
- open (STDERR, ">$offlineerr") || die "Cannot redirect stderr" ;
- open (ERR, "$offlineerr") || die "Cannot open redirected stderr ($offlineerr)" ; ;
- }
-
$n = 0 ;
$t_offline = 0 ;
$n_offline = 0 ;
@@ -1391,8 +1421,217 @@
}
}
- if ((($opt_execute) || ($opt_offline)) && $looptest == 0)
+ if ($EP2)
{
+ #############
+ #
+ # Cache tests
+ #
+ #############
+
+ $frommem = 1 ;
+ if ($err == 0)
+ {
+ print "\nTesting Ouput Caching...\n\n" ;
+
+ HTML::Embperl::Init ($logfile, $defaultdebug) ;
+
+ my $src = '* [+ $param[0] +] *' ;
+ my $cmp = '"* $p *"' ;
+ my $out ;
+
+ @cachetests = (
+ {
+ text => 'No cache 1',
+ param => { param => [1], },
+ cmp => 1,
+ },
+ {
+ text => 'No cache 2',
+ param => { param => [2], },
+ cmp => 2,
+ },
+ {
+ text => 'Expires in 1 sec',
+ param => { param => [3], expires_in => 1, },
+ cmp => 3,
+ },
+ {
+ text => 'Expires in 1 sec (cached)',
+ param => { param => ['not cached'], expires_in => 1, },
+ cmp => 3,
+ },
+ {
+ text => 'Wait for expire',
+ sleep => 2,
+ },
+ {
+ text => 'Expires in 1 sec (reexec)',
+ param => { param => ['reexec'], expires_in => 1, },
+ cmp => 'reexec',
+ },
+ {
+ text => 'Expires function',
+ param => { param => [4], expires_func => sub { 1 } },
+ cmp => 4,
+ },
+ {
+ text => 'Expires function (cached)',
+ param => { param => ['not cached func'], expires_func => sub { 0 } },
+ cmp => 4,
+ },
+ {
+ text => 'Expires function (reexec)',
+ param => { param => ['reexec func'], expires_func => sub { 1 }, },
+ cmp => 'reexec func',
+ },
+ {
+ text => 'Expires string function (cached)',
+ param => { param => ['not cached string func'], expires_func => 'sub { 0 }' },
+ cmp => 'reexec func',
+ },
+ {
+ text => 'Expires string function (reexec)',
+ param => { param => ['reexec string func'], expires_func => 'sub { 1 }', },
+ cmp => 'reexec string func',
+ },
+ {
+ text => 'Expires named function (cached)',
+ param => { param => ['not cached named func'], expires_func => 'main::s0' },
+ cmp => 'reexec string func',
+ },
+ {
+ text => 'Expires named function (reexec)',
+ param => { param => ['reexec named func'], expires_func => 'main::s1', },
+ cmp => 'reexec named func',
+ },
+ {
+ text => 'Change query_info',
+ param => { param => ['query_info'], expires_func => 'main::s0' },
+ query_info => 'qi',
+ cmp => 'query_info',
+ },
+ {
+ text => 'Change query_info (cached)',
+ param => { param => ['not cached query_info'], expires_func => 'main::s0' },
+ query_info => 'qi',
+ cmp => 'query_info',
+ },
+ {
+ text => 'Expires named function (cached)',
+ param => { param => ['not cached named func query_info'], expires_func => 'main::s0' },
+ cmp => 'reexec named func',
+ },
+ {
+ text => 'Change query_info (reexec)',
+ param => { param => ['reexec query_info'], expires_func => 'main::s1' },
+ query_info => 'qi',
+ cmp => 'reexec query_info',
+ },
+ {
+ text => 'Expires named function (cached)',
+ param => { param => ['not cached named func query_info'], expires_func => 'main::s0' },
+ cmp => 'reexec named func',
+ },
+ {
+ text => 'Change query_info (cached)',
+ param => { param => ['not cached reexec query_info 2'], expires_func => 'main::s0' },
+ query_info => 'qi',
+ cmp => 'reexec query_info',
+ },
+ {
+ text => 'Modify source',
+ param => { param => ['mod'], expires_func => 'main::s0' },
+ mtime => 2,
+ cmp => 'mod',
+ },
+
+ {
+ text => 'Modify source query_info',
+ param => { param => ['mod query_info'], expires_func => 'main::s0' },
+ query_info => 'qi',
+ mtime => 2,
+ cmp => 'mod query_info',
+ },
+
+ {
+ text => '$EXPIRES in source',
+ name => 'c2',
+ src => \('[! $EXPIRES = 1 !]' . $src),
+ param => { param => ['expires in src'] },
+ cmp => 'expires in src',
+ },
+ {
+ text => '$EXPIRES in source (cached)',
+ name => 'c2',
+ src => \('[! $EXPIRES = 1 !]' . $src),
+ param => { param => ['not cached expires in src'] },
+ cmp => 'expires in src',
+ },
+ {
+ text => 'Wait for expire',
+ sleep => 2,
+ },
+ {
+ text => '$EXPIRES in source (reexc)',
+ name => 'c2',
+ src => \('[! $EXPIRES = 1 !]' . $src),
+ param => { param => ['reexec expires in src'] },
+ cmp => 'reexec expires in src',
+ },
+ {
+ text => 'sub EXPIRES in source',
+ name => 'c3',
+ src => \('[! sub EXPIRES { 0 } !]' . $src),
+ param => { param => ['expires_func in src'] },
+ cmp => 'expires_func in src',
+ },
+ {
+ text => 'sub EXPIRES in source (cached)',
+ name => 'c3',
+ src => \('[! sub EXPIRES { 0 } !]' . $src),
+ param => { param => ['not cached expires_func in src'] },
+ cmp => 'expires_func in src',
+ },
+ ) ;
+
+ foreach $cachetest (@cachetests)
+ {
+ if ($err == 0)
+ {
+ printf ("%-30s", "$cachetest->{text}...") ;
+ if ($cachetest->{'sleep'})
+ {
+ sleep $cachetest->{'sleep'} ;
+ }
+ else
+ {
+ $ENV{QUERY_STRING} = $cachetest->{'query_info'} if ($cachetest->{'query_info'}) ;
+ delete $ENV{QUERY_STRING} if (!$cachetest->{'query_info'}) ;
+
+ $err = HTML::Embperl::Execute ({inputfile => $cachetest->{'name'} || 'c1',
+ input => $cachetest->{'src'} || \$src,
+ output => \$out,
+ mtime => $cachetest->{'mtime'} || 1,
+ %{$cachetest->{param}}}) ;
+ $err = CheckError (0) if ($err == 0) ;
+ $err = CmpInMem ($out, $cmp, $cachetest->{'cmp'}) if ($err == 0) ;
+ }
+ print "ok\n" if ($err == 0) ;
+ }
+ }
+
+
+
+ }
+ $frommem = 0 if ($err == 0) ;
+ }
+
+
+
+
+ if ((($opt_execute) || ($opt_offline) || ($opt_cache)) && $looptest == 0)
+ {
close STDERR ;
open (STDERR, ">&SAVEERR") ;
}
@@ -1703,13 +1942,16 @@
if ($err)
{
- $page ||= '???' ;
- print "Input:\t\t$page\n" ;
- print "Output:\t\t$outfile\n" ;
- print "Compared to:\t$org\n" if ($org) ;
- print "Log:\t\t$logfile\n" ;
- @p = map { " $_ = $test->{$_}\n" } keys %$test if (ref ($test) eq 'HASH') ;
- print "Testparameter:\n @p" if (@p) ;
+ if (!$frommem)
+ {
+ $page ||= '???' ;
+ print "Input:\t\t$page\n" ;
+ print "Output:\t\t$outfile\n" ;
+ print "Compared to:\t$org\n" if ($org) ;
+ print "Log:\t\t$logfile\n" ;
+ @p = map { " $_ = $test->{$_}\n" } keys %$test if (ref ($test) eq 'HASH') ;
+ print "Testparameter:\n @p" if (@p) ;
+ }
print "\n ERRORS detected! NOT all test have been passed successfully\n\n" ;
}
else
No revision
No revision
1.1.2.4 +1 -2 embperl/test/cmp/binary.htm
<<Binary file>>