/*###################################################################################
#
#   Embperl - Copyright (c) 1997-2005 Gerald Richter / ECOS
#
#   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.
#
#   $Id$
#
###################################################################################*/


#include "ep.h"
#include "epmacro.h"


/*---------------------------------------------------------------------------
* EvalDirect
*/
/*!
*
* \_en									   
* Compile and execute Perl code 
*                                                                          
* @param   pArg             Perl code to eval as SV. Can be either
*                           a string (PV) or code (CV)
* @param   numArgs          Number of arguments
* @param   pArgs            Arguments
* \endif                                                                       
*
* \_de									   
* Compiliert Perlcode und f?hrt ihn dann direkt aus.
*                                                                          
* @param   pArg             Perlcode der compiliert werden soll als SV. 
*                           Kann entweder eine Zeichenkette (SV) oder
*                           Code (CV) sein
* @param   numArgs          Anzahl der Argumente
* @param   pArgs            Argumente
* \endif                                                                       
*                                                                          
* ------------------------------------------------------------------------ */

int EvalDirect (/*i/o*/ register req *  r,
		/*in*/  SV *            pArg, 
                /*in*/  int		numArgs,
                /*in*/  SV **		pArgs)
    {
    epTHX_ /* dTHXsem */ 
    dSP;
    SV *  pSVErr  ;
    int   num ;         

    tainted = 0 ;

    PUSHMARK(sp);
    for (num = 0; num < numArgs; num++)
	XPUSHs(pArgs [num]) ;            /* push pointer to argument */
    PUTBACK;

    perl_eval_sv(pArg, G_SCALAR | G_KEEPERR);


    tainted = 0 ;
    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) ; */

        if (SvROK (pSVErr))
            {
            if (r -> pErrSV)
                SvREFCNT_dec(r -> pErrSV) ;
            r -> pErrSV = newRV (SvRV(pSVErr)) ;
            }
        
        sv_setpv(pSVErr,"");
        return rcEvalErr ;
        }

    return ok ;
    }


/*---------------------------------------------------------------------------
* EvalConfig
*/
/*!
*
* \_en									   
* Returns a CV for the given config expresseion. Can be either
* a CV, a name of a Perl sub or a string which starts with "sub "
* in which case it is compiled.
*                                                                          
* @param   pSV              Config code
* @param   numArgs          Number of arguments
* @param   pArgs            Arguments
* @param   sContext         give some context information for the error message
* @param   ppCV             Returns the CV
* \endif                                                                       
*
* \_de									   
* Liefert f?r einen gegeben Konfigurationsausdruck ein CV zur?ck.
* Der Ausdruck kann entweder schon ein CV sein, der Name einer
* Perlfunktion oder eine Zeichenkette die mit "sub " anf?ngt sein,
* in welchem Fall der Code kompiliert wird.
*                                                                          
* @param   pSV              Konfigurationsausdruck
* @param   numArgs          Anzahl der Argumente
* @param   pArgs            Argumente
* @param   sContext         Gibt Information ?ber das Umfeld f?r die Fehlermeldung
* @param   ppCV             Liefert die CV zur?ck
* \endif                                                                       
*                                                                          
* ------------------------------------------------------------------------ */

int EvalConfig (/*i/o*/ tApp *          a,
		/*in*/  SV *            pSV, 
                /*in*/  int		numArgs,
                /*in*/  SV **		pArgs,
		/*in*/  const char *    sContext, 
		/*out*/ CV **           pCV)
    {
    char * s = "Needs CodeRef" ;
    #ifdef PERL_IMPLICIT_CONTEXT
    pTHX = a?a -> pPerlTHX:PERL_GET_THX;
    #endif
    dSP;

    EPENTRY (EvalConfig) ;

    tainted = 0 ;

    *pCV = NULL ;
    if (SvPOK (pSV))
	{
	STRLEN l ;
	s = SvPV (pSV, l) ;
	if (strncmp (s, "sub ", 4) == 0)
	    {
	    SV * pSVErr ;
	    SV * pRV = NULL ;
            int  n ;

            n = perl_eval_sv (pSV, G_EVAL | G_SCALAR) ;
            tainted = 0 ;

            SPAGAIN;
            if (n > 0)
                pRV = POPs;
            PUTBACK;
    
            tainted = 0 ;
	    if (n > 0 && SvROK (pRV))
		{
		*pCV = (CV *)SvRV (pRV) ;
		SvREFCNT_inc (*pCV) ;
		}

	    pSVErr = ERRSV ;
	    if (SvTRUE (pSVErr))
		{
		STRLEN l ;
		char * p = SvPV (pSVErr, l) ;
        
		LogErrorParam (a, rcEvalErr, p, sContext) ;

		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 ;
        LogErrorParam (a, rcEvalErr, s, sContext) ;
	return rcEvalErr ;
	}
#ifdef DMALLOC
        AddDMallocMagic (*pCV, s?s:"EvalConfig", __FILE__, __LINE__) ;
#endif

    return ok ;
    }


/*---------------------------------------------------------------------------
* EvalRegEx
*/
/*!
*
* \_en									   
* Returns a CV for the given regular expression.
*                                                                          
* @param   sRegex           regular expression as string
* @param   sContext         give some context information for the error message
* @param   ppCV             Returns the CV
* \endif                                                                       
*
* \_de									   
* Liefert f?r eine gegebenen Regul?ren Ausdruck ein CV zur?ck.
*                                                                          
* @param   sRegex           Regul?rer Ausdruck als Zeichenkette
* @param   sContext         Gibt Information ?ber das Umfeld f?r die Fehlermeldung
* @param   ppCV             Liefert die CV zur?ck
* \endif                                                                       
*                                                                          
* ------------------------------------------------------------------------ */

int EvalRegEx  (/*i/o*/ tApp *          a,
		/*in*/  char *          sRegex, 
		/*in*/  const char *    sContext, 
		/*out*/ CV **           ppCV)
    {
    epaTHX_
    SV * pSV ;
    char * p ;
    STRLEN l ;
    SV * pRV = NULL ;
    SV * pSVErr ;
    char c ;
    int  n ;
    dSP ;

    if (sRegex[0] == '!')
        {
        c = '!' ;
        while (isspace(*sRegex))
            sRegex++ ;
        }
    else
        c = '=' ;
    
    tainted = 0 ;
    pSV = newSVpvf ("package Embperl::Regex ; sub { $_[0] %c~ m{%s} }", c, sRegex) ;
    newSVpvf2(pSV) ;

    /* perl_eval_pv seems to be broken in 5.005_03!! */
    /* p = SvPV(pSV, l) ; */
    /* pRV = perl_eval_pv (p, 0) ; */

    n = perl_eval_sv (pSV, G_EVAL | G_SCALAR) ;
    SvREFCNT_dec(pSV);
    tainted = 0 ;

    SPAGAIN;
    if (n > 0)
        pRV = POPs;
    PUTBACK;
    
    pSVErr = ERRSV ;
    if (SvTRUE (pSVErr))
	{
	p = SvPV (pSVErr, l) ;

	LogErrorParam (a, rcEvalErr, p, sContext) ;

	sv_setpv(pSVErr,"");
	*ppCV = NULL ;
	return rcEvalErr ;
	}

    if (n > 0 && SvROK (pRV))
	{
	*ppCV = (CV *)SvRV (pRV) ;
	SvREFCNT_inc (*ppCV) ;
#ifdef DMALLOC
        AddDMallocMagic (*ppCV, sRegex?sRegex:"EvalRegEx", __FILE__, __LINE__) ;
#endif
	}
    else
      	*ppCV = NULL ;

    

    return ok ;
    }


    
    

/* -------------------------------------------------------------------------------
*
* Eval PERL Statements into a sub 
* 
* in  sArg   Statement to eval
* out pRet   pointer to SV contains an CV to the evaled code
*
------------------------------------------------------------------------------- */

static int EvalAll (/*i/o*/ register req * r,
		    /*in*/  const char *  sArg,
                    /*in*/  int           flags,
                    /*in*/  const char *  sName,
		    /*out*/ SV **         pRet)             
    {
    epTHX_ /* dTHXsem */ 
    static char sFormat []       = "package %s ; sub %s { \n#line %d \"%s\"\n%s\n} %s%s" ;
    static char sFormatStrict [] = "package %s ; use strict ; sub %s {\n#line %d \"%s\"\n%s\n} %s%s" ; 
    static char sFormatArray []       = "package %s ; sub %s { \n#line %d \"%s\"\n[%s]\n} %s%s" ;
    static char sFormatStrictArray [] = "package %s ; use strict ; sub %s {\n#line %d \"%s\"\n[%s]\n} %s%s" ; 
    SV *   pSVCmd ;
    SV *   pSVErr ;
    int    n ;
    char * sRef = "" ;

    dSP;
    
    EPENTRY (EvalAll) ;

    GetLineNo (r) ;

    if (r -> Component.Config.bDebug & dbgDefEval)
        lprintf (r -> pApp,  "[%d]DEF:  Line %d: %s\n", r -> pThread -> nPid, r -> Component.nSourceline, sArg?sArg:"<unknown>") ;

    tainted = 0 ;

    if (!sName)
        sName = "" ;
    
    if (*sName)
	sRef = "; \\&" ;
    
    if (r -> Component.bStrict)
        if (flags & G_ARRAY)
            pSVCmd = newSVpvf(sFormatStrictArray, r -> Component.sEvalPackage, sName, r -> Component.nSourceline, r -> Component.sSourcefile, sArg, sRef, sName) ;
        else
            pSVCmd = newSVpvf(sFormatStrict, r -> Component.sEvalPackage, sName, r -> Component.nSourceline, r -> Component.sSourcefile, sArg, sRef, sName) ;
    else
        if (flags & G_ARRAY)
            pSVCmd = newSVpvf(sFormatArray, r -> Component.sEvalPackage, sName, r -> Component.nSourceline, r -> Component.sSourcefile, sArg, sRef, sName) ;
        else
            pSVCmd = newSVpvf(sFormat, r -> Component.sEvalPackage, sName, r -> Component.nSourceline, r -> Component.sSourcefile, sArg, sRef, sName) ;
    newSVpvf2(pSVCmd) ;

    PUSHMARK(sp);
    n = perl_eval_sv(pSVCmd, G_SCALAR | G_KEEPERR);
    SvREFCNT_dec(pSVCmd);
    tainted = 0 ;

    SPAGAIN;
    if (n > 0)
        *pRet = POPs;
    else
	*pRet = NULL ;
    PUTBACK;

    if (r -> Component.Config.bDebug & dbgMem)
        lprintf (r -> pApp,  "[%d]SVs:  %d\n", r -> pThread -> nPid, sv_count) ;
    
    pSVErr = ERRSV ;
    if (SvTRUE (pSVErr) || (n == 0 && (flags & G_DISCARD) == 0))
        {
        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' ;
         
        if (pRet && *pRet)
	     SvREFCNT_dec (*pRet) ;
	
	*pRet = newSVpv (r -> errdat1, 0) ;
         
        /* LogError (r, rcEvalErr) ; */
	sv_setpv(pSVErr, "");
        return rcEvalErr ;
        }

    return ok ;
    }



/* -------------------------------------------------------------------------------
*
* Call an already evaled PERL Statement
* 
* in  sArg   Statement to eval (only used for logging)
* in  pSub   CV which should be called
* out pRet   pointer to SV contains the eval return
*
------------------------------------------------------------------------------- */


int CallCV  (/*i/o*/ register req * r,
		    /*in*/  const char *  sArg,
                    /*in*/  CV *          pSub,
                    /*in*/  int           flags,
                    /*out*/ SV **         pRet)             
    {
    epTHX_ /* dTHXsem */ 
    int   num ;         
#ifdef TABUSED
    int   nCountUsed = r -> TableStack.State.nCountUsed ;
    int   nRowUsed   = r -> TableStack.State.nRowUsed ;
    int   nColUsed   = r -> TableStack.State.nColUsed ;
#endif
    SV *  pSVErr ;
    dSP;                            /* initialize stack pointer      */


    if (r -> Component.pImportStash)
	{ /* do not execute any code on import */
	*pRet = NULL ;
	return ok ;
	}
    

    EPENTRY (CallCV) ;

    if (r -> Component.Config.bDebug & dbgEval)
        lprintf (r -> pApp,  "[%d]EVAL< %s\n", r -> pThread -> nPid, sArg?sArg:"<unknown>") ;

    tainted = 0 ;

    ENTER ;
    SAVETMPS ;
    PUSHMARK(sp);                   /* remember the stack pointer    */

    num = perl_call_sv ((SV *)pSub, flags | G_EVAL | G_NOARGS) ; /* call the function             */
    tainted = 0 ;

    SPAGAIN;                        /* refresh stack pointer         */
    
    if (r -> Component.Config.bDebug & dbgMem)
        lprintf (r -> pApp,  "[%d]SVs:  %d\n", r -> pThread -> nPid, sv_count) ;
    /* pop the return value from stack */
    if (num == 1)   
        {
        *pRet = POPs ;
        if (SvTYPE (*pRet) == SVt_PVMG)
            { /* variable is magicaly -> fetch value now */
            SV * pSV = newSVsv (*pRet) ;
            *pRet = pSV ;
            }
        else        
            SvREFCNT_inc (*pRet) ;

        if (r -> Component.Config.bDebug & dbgEval)
            {
            if (SvOK (*pRet))
                lprintf (r -> pApp,  "[%d]EVAL> %s\n", r -> pThread -> nPid, SvPV (*pRet, na)) ;
            else
                lprintf (r -> pApp,  "[%d]EVAL> <undefined>\n", r -> pThread -> nPid) ;
            }                
            
#ifdef TABUSED
        if ((nCountUsed != r -> TableStack.State.nCountUsed ||
             nColUsed != r -> TableStack.State.nColUsed ||
             nRowUsed != r -> TableStack.State.nRowUsed) &&
              !SvOK (*pRet))
            {
            r -> TableStack.State.nResult = 0 ;
            SvREFCNT_dec (*pRet) ;
            *pRet = newSVpv("", 0) ;
            } 

        if ((r -> Component.Config.bDebug & dbgTab) &&
            (r -> TableStack.State.nCountUsed ||
             r -> TableStack.State.nColUsed ||
             r -> TableStack.State.nRowUsed))
            lprintf (r -> pApp,  "[%d]TAB:  nResult = %d\n", r -> pThread -> nPid, r -> TableStack.State.nResult) ;
#ifdef DMALLOC
        AddDMallocMagic (*pRet, sArg?sArg:"CallCV", __FILE__, __LINE__) ;
#endif
#endif
        }
     else if (num == 0)
        {
        *pRet = NULL ;
        if (r -> Component.Config.bDebug & dbgEval)
            lprintf (r -> pApp,  "[%d]EVAL> <NULL>\n", r -> pThread -> nPid) ;
        }
     else
        {
        *pRet = &sv_undef ;
        if (r -> Component.Config.bDebug & dbgEval)
            lprintf (r -> pApp,  "[%d]EVAL> returns %d args instead of one\n", r -> pThread -> nPid, num) ;
        }

     /*if (SvREFCNT(*pRet) != 2)
            lprintf (r -> pApp,  "[%d]EVAL refcnt != 2 !!= %d !!!!!\n", r -> pThread -> nPid, SvREFCNT(*pRet)) ;*/

     PUTBACK;
     FREETMPS ;
     LEAVE ;

     if (r -> bExit || r -> Component.bExit)
	 {
	 if (*pRet)
	     SvREFCNT_dec (*pRet) ;
	 *pRet = NULL ;
         if (r -> Component.Config.bDebug & dbgEval)
            lprintf (r -> pApp,  "[%d]EVAL> exit passed through\n", r -> pThread -> nPid) ;
	 return rcExit ;
	 }
     
     pSVErr = ERRSV ;
     if (SvTRUE (pSVErr))
        {
        STRLEN l ;
        char * p ;

        if (SvMAGICAL (pSVErr) && mg_find (pSVErr, 'U'))
            {
 	    /* On an Apache::exit call, the function croaks with error having 'U' magic.
 	     * When we get this return, we'll just give up and quit this file completely,
 	     * without error. */
             
	    /*struct magic * m = SvMAGIC (pSVErr) ;*/

            tDomTree * pDomTree = DomTree_self (r -> Component.xCurrDomTree) ;
            tIndex n = ArrayGetSize (r -> pApp, pDomTree -> pCheckpoints) ;
            if (n > 2)
                DomTree_checkpoint (r, n-1)  ;

            if (r -> Component.Config.bDebug & dbgEval)
                lprintf (r -> pApp,  "[%d]EVAL> exit called\n", r -> pThread -> nPid) ;
            
            sv_unmagic(pSVErr,'U');
	    sv_setpv(pSVErr,"");

	    r -> Component.Config.bOptions |= optNoUncloseWarn ;
	    r -> bExit = 1 ;

            return rcExit ;
            }

        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' ;

        if (SvROK (pSVErr))
            {
            if (r -> pErrSV)
                SvREFCNT_dec(r -> pErrSV) ;
            r -> pErrSV = newRV (SvRV(pSVErr)) ;
            }
        
         
	LogError (r, rcEvalErr) ;

	sv_setpv(pSVErr,"");

	return rcEvalErr ;
        }

     
    return ok ;
    }

/* -------------------------------------------------------------------------------
*
* Eval PERL Statements and setup the correct return value/error message
* 
* in  sArg   Statement to eval
* out ppSV   pointer to an SV with should be set to CV of the evaled code
*
------------------------------------------------------------------------------- */


int EvalOnly           (/*i/o*/ register req * r,
			/*in*/  const char *  sArg,
                        /*in*/  SV **         ppSV,
                        /*in*/  int           flags,
  		        /*in*/  const char *  sName)



    {
    int     rc ;
    SV *   pSub ;
    epTHX_    
    
    EPENTRY (EvalOnly) ;

    r -> lastwarn[0] = '\0' ;
    
    rc = EvalAll (r, sArg, flags, sName, &pSub) ;

    if (rc == ok && (flags & G_DISCARD))
	{
	if (pSub)
	    SvREFCNT_dec (pSub) ;
	return ok ;
	}

    if (ppSV && *ppSV)
	 SvREFCNT_dec (*ppSV) ;

    if (rc == ok && pSub != NULL && SvTYPE (pSub) == SVt_RV)
        {
        /*sv_setsv (*ppSV, pSub) ;*/
        *ppSV = SvRV(pSub) ;
        SvREFCNT_inc (*ppSV) ;  
        }
    else
        {
        if (pSub != NULL && SvTYPE (pSub) == SVt_PV)
            {
	    *ppSV = pSub ; /* save error message */
	    pSub = NULL ;
	    }
        else if (r -> lastwarn[0] != '\0')
	    {
    	    *ppSV = newSVpv (r -> lastwarn, 0) ;
	    }
        else
	    {
    	    *ppSV = newSVpv ("Compile Error", 0) ;
	    }
        
        if (pSub)
	     SvREFCNT_dec (pSub) ;

	r -> bError = 1 ;
        return rc ;
        }

    return ok ;
    }

#if 0
/* -------------------------------------------------------------------------------
*
* Eval PERL Statements and execute the evaled code
* 
* in  sArg   Statement to eval
* out ppSV   pointer to an SV with should be set to CV of the evaled code
* out pRet   pointer to SV contains the eval return
*
------------------------------------------------------------------------------- */


static int EvalAndCall (/*i/o*/ register req * r,
			/*in*/  const char *  sArg,
                        /*in*/  SV **         ppSV,
                        /*in*/  int           flags,
                        /*out*/ SV **         pRet)             


    {
    int     rc ;
    epTHX_    
    
    
    EPENTRY (EvalAndCall) ;

    if ((rc = EvalOnly (r, sArg, ppSV, flags, "")) != ok)
	{
	*pRet = NULL ;
	return rc ;
	}


    if (*ppSV && SvTYPE (*ppSV) == SVt_PVCV)
        { /* Call the compiled eval */
        return CallCV (r, sArg, (CV *)*ppSV, flags, pRet) ;
        }
    
    *pRet = NULL ;
    r -> bError = 1 ;
    
    if (ppSV && *ppSV)
	 SvREFCNT_dec (*ppSV) ;

    if (r -> lastwarn[0] != '\0')
    	{
 	*ppSV = newSVpv (r -> lastwarn, 0) ;
	}
    else
	{
    	*ppSV = newSVpv ("Compile Error", 0) ;
	}

    return rcEvalErr ;
    }

#endif


/* -------------------------------------------------------------------------------
*
* Call an already evaled PERL Statement
* 
* in  sArg   Statement to eval (only used for logging)
* in  pSub   CV which should be called
* in  numArgs number of arguments
* in  pArgs   args for subroutine
* out pRet   pointer to SV contains the eval return
*
------------------------------------------------------------------------------- */


int CallStoredCV  (/*i/o*/ register req * r,
		    /*in*/  const char *  sArg,
                    /*in*/  CV *          pSub,
                    /*in*/  int           numArgs,
                    /*in*/  SV **         pArgs,
                    /*in*/  int           flags,
                    /*out*/ SV **         pRet)             
    {
    epTHX_ /* dTHXsem */
    int   num ;         
    SV *  pSVErr ;

    dSP;                            /* initialize stack pointer      */

    EPENTRY (CallCV) ;

    if (r -> Component.Config.bDebug & dbgEval)
        lprintf (r -> pApp,  "[%d]EVAL< %s\n", r -> pThread -> nPid, sArg?sArg:"<unknown>") ;

    tainted = 0 ;

    ENTER ;
    SAVETMPS ;
    PUSHMARK(sp);                   /* remember the stack pointer    */
    for (num = 0; num < numArgs; num++)
	XPUSHs(pArgs [num]) ;            /* push pointer to argument */
    PUTBACK;

    num = perl_call_sv ((SV *)pSub, flags | G_EVAL | (numArgs?0:G_NOARGS)) ; /* call the function             */
    tainted = 0 ;
    
    SPAGAIN;                        /* refresh stack pointer         */
    
    if (r -> Component.Config.bDebug & dbgMem)
        lprintf (r -> pApp,  "[%d]SVs:  %d\n", r -> pThread -> nPid, sv_count) ;
    /* pop the return value from stack */
    if (num == 1)   
        {
        *pRet = POPs ;
        if (SvTYPE (*pRet) == SVt_PVMG)
            { /* variable is magicaly -> fetch value now */
            SV * pSV = newSVsv (*pRet) ;
            *pRet = pSV ;
            }
        else        
            SvREFCNT_inc (*pRet) ;

        if (r -> Component.Config.bDebug & dbgEval)
            {
            if (SvOK (*pRet))
                lprintf (r -> pApp,  "[%d]EVAL> %s\n", r -> pThread -> nPid, SvPV (*pRet, na)) ;
            else
                lprintf (r -> pApp,  "[%d]EVAL> <undefined>\n", r -> pThread -> nPid) ;
            }                
#ifdef DMALLOC
        AddDMallocMagic (*pRet, sArg?sArg:"CallStoredCV", __FILE__, __LINE__) ;
#endif
        }
     else if (num == 0)
        {
        *pRet = NULL ;
        if (r -> Component.Config.bDebug & dbgEval)
            lprintf (r -> pApp,  "[%d]EVAL> <NULL>\n", r -> pThread -> nPid) ;
        }
     else
        {
        *pRet = &sv_undef ;
        if (r -> Component.Config.bDebug & dbgEval)
            lprintf (r -> pApp,  "[%d]EVAL> returns %d args instead of one\n", r -> pThread -> nPid, num) ;
        }

     PUTBACK;
     FREETMPS ;
     LEAVE ;

    /*
     if (r -> bExit || r -> Component.bExit)
	 {
	 if (*pRet)
	     SvREFCNT_dec (*pRet) ;
	 *pRet = NULL ;
         if (r -> Component.Config.bDebug & dbgEval)
            lprintf (r -> pApp,  "[%d]EVAL> exit passed through\n", r -> pThread -> nPid) ;
	 return rcExit ;
	 }
     */

     pSVErr = ERRSV ;
     if (SvTRUE (pSVErr))
        {
        STRLEN l ;
        char * p ;

        if (SvMAGICAL (pSVErr) && mg_find (pSVErr, 'U'))
            {
 	    /* On an Apache::exit call, the function croaks with error having 'U' magic.
 	     * When we get this return, we'll just give up and quit this file completely,
 	     * without error. */
             
	    /*struct magic * m = SvMAGIC (pSVErr) ;*/

            tDomTree * pDomTree = DomTree_self (r -> Component.xCurrDomTree) ;
            tIndex n = ArrayGetSize (r -> pApp, pDomTree -> pCheckpoints) ;
            if (n > 2)
                DomTree_checkpoint (r, n-1) ;

            p = SvPV(ERRSV, l) ;
            if (l > 0 && strncmp (p, "request ",8) == 0)
                r -> bExit = 1 ;
            
            if (r -> Component.Config.bDebug & dbgEval)
                lprintf (r -> pApp,  "[%d]EVAL> %s exit called (%s)\n", r -> pThread -> nPid, r -> bExit?"request":"component", p?p:"") ;
            
	    sv_unmagic(pSVErr,'U');
	    sv_setpv(pSVErr,"");

	    r -> Component.Config.bOptions |= optNoUncloseWarn ;
	    r -> Component.bExit = 1 ;

            return rcExit ;
            }

        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' ;

        if (SvROK (pSVErr))
            {
            if (r -> pErrSV)
                SvREFCNT_dec(r -> pErrSV) ;
            r -> pErrSV = newRV (SvRV(pSVErr)) ;
            }
        
         
	LogError (r, rcEvalErr) ;

	sv_setpv(pSVErr,"");

	return rcEvalErr ;
        }

     
    return ok ;
    }

#if 0
#ifdef EP2

/* -------------------------------------------------------------------------------
*
* Eval PERL Statements check if it's already compiled
* 
* in  sArg      Statement to eval
* in  nFilepos  position von eval in file (is used to build an unique key)
* out pRet      pointer to SV contains the eval return
*
------------------------------------------------------------------------------- */

int EvalStore (/*i/o*/ register req * r,
	      /*in*/  const char *  sArg,
	      /*in*/  int           nFilepos,
	      /*out*/ SV **         pRet)             


    {
    int     rc ;
    SV **   ppSV ;
    epTHX_    
    
    
    EPENTRY (Eval) ;

    *pRet = NULL ;

    /*if (r -> Component.Config.bDebug & dbgCacheDisable)
        return EvalAllNoCache (r, sArg, pRet) ;
    */
    /* Already compiled ? */

    ppSV = hv_fetch(r -> Buf.pFile -> pCacheHash, (char *)&nFilepos, sizeof (nFilepos), 1) ;  
    if (ppSV == NULL)
        {
        strcpy (r -> errdat1, "CacheHash in EvalStore") ;
        return rcHashError ;
        }

    if (*ppSV != NULL && SvTYPE (*ppSV) == SVt_PV)
        {
        strncpy (r -> errdat1, SvPV(*ppSV, na), sizeof (r -> errdat1) - 1) ; 
        LogError (r, rcEvalErr) ;
        return rcEvalErr ;
        }

    lprintf (r -> pApp,  "CV ppSV=%s type=%d\n", *ppSV?"ok":"NULL", *ppSV?SvTYPE (*ppSV):0) ;               
    if (*ppSV == NULL || SvTYPE (*ppSV) != SVt_PVCV)
	{
	if ((rc = EvalOnly (r, sArg, ppSV, G_SCALAR, "")) != ok)
	    {
	    *pRet = NULL ;
	    return rc ;
	    }
        *pRet = *ppSV  ;
	return ok ;
	}

    *pRet = *ppSV  ;
    r -> numCacheHits++ ;
    return ok ;
    }



#endif /* EP2 */

/* -------------------------------------------------------------------------------
*
* Eval PERL Statements and execute the evaled code, check if it's already compiled
* 
* in  sArg      Statement to eval
* in  nFilepos  position von eval in file (is used to build an unique key)
* out pRet      pointer to SV contains the eval return
*
------------------------------------------------------------------------------- */

int Eval (/*i/o*/ register req * r,
			/*in*/  const char *  sArg,
          /*in*/  int           nFilepos,
          /*out*/ SV **         pRet)             


    {
    SV **   ppSV ;
    epTHX_    
    
    
    EPENTRY (Eval) ;

    *pRet = NULL ;

    /*if (r -> Component.Config.bDebug & dbgCacheDisable)
        return EvalAllNoCache (r, sArg, pRet) ;
    */
    /* Already compiled ? */

    ppSV = hv_fetch(r -> Buf.pFile -> pCacheHash, (char *)&nFilepos, sizeof (nFilepos), 1) ;  
    if (ppSV == NULL)
        {
        strcpy (r -> errdat1, "CacheHash in Eval") ;
        return rcHashError ;
        }

    if (*ppSV != NULL && SvTYPE (*ppSV) == SVt_PV)
        {
        strncpy (r -> errdat1, SvPV(*ppSV, na), sizeof (r -> errdat1) - 1) ; 
        LogError (r, rcEvalErr) ;
        return rcEvalErr ;
        }

    if (*ppSV == NULL || SvTYPE (*ppSV) != SVt_PVCV)
        return EvalAndCall (r, sArg, ppSV, G_SCALAR, pRet) ;

    r -> numCacheHits++ ;
    return CallCV (r, sArg, (CV *)*ppSV, G_SCALAR, pRet) ;
    }


/* -------------------------------------------------------------------------------
*
* Eval PERL Statements and execute the evaled code, check if it's already compiled
* strip off all <HTML> Tags before 
* 
* in  sArg      Statement to eval
* in  nFilepos  position von eval in file (is used to build an unique key)
* out pRet      pointer to SV contains the eval return value
*
------------------------------------------------------------------------------- */


int EvalTransFlags (/*i/o*/ register req * r,
			/*in*/  char *   sArg,
                    /*in*/  int      nFilepos,
                    /*in*/  int      flags,
                    /*out*/ SV **    pRet)             


    {
    SV **   ppSV ;
    epTHX_    
    
    EPENTRY (EvalTrans) ;


    *pRet = NULL ;

    /*
    if (r -> Component.Config.bDebug & dbgCacheDisable)
        {
        /  * strip off all <HTML> Tags *  /
        TransHtml (r, sArg, 0) ;
        
        return EvalAllNoCache (r, sArg, pRet) ;
        }
    */
    /* Already compiled ? */

    ppSV = hv_fetch(r -> Buf.pFile -> pCacheHash, (char *)&nFilepos, sizeof (nFilepos), 1) ;  
    if (ppSV == NULL)
        {
        strcpy (r -> errdat1, "CacheHash in EvalTransFlags") ;
        return rcHashError ;
        }

    if (*ppSV != NULL && SvTYPE (*ppSV) == SVt_PV)
        {
        strncpy (r -> errdat1, SvPV(*ppSV, na), sizeof (r -> errdat1) - 1) ; 
        LogError (r, rcEvalErr) ;
        return rcEvalErr ;
        }

    if (*ppSV == NULL || SvTYPE (*ppSV) != SVt_PVCV)
        {
        /* strip off all <HTML> Tags */
        TransHtml (r, sArg, 0) ;

        return EvalAndCall (r, sArg, ppSV, flags, pRet) ;
        }

    r -> numCacheHits++ ;
    
    return CallCV (r, sArg, (CV *)*ppSV, flags, pRet) ;
    }


int EvalTrans (/*i/o*/ register req * r,
			/*in*/  char *   sArg,
                    /*in*/  int      nFilepos,
                    /*out*/ SV **    pRet)             
    
    {
    return EvalTransFlags (r, sArg, nFilepos, G_SCALAR, pRet) ;
    }
    
    
/* -------------------------------------------------------------------------------
*
* Eval PERL Statements and execute the evaled code, check if it's already compiled
* if yes do not call the code a second time
* strip off all <HTML> Tags before 
* 
* in  sArg      Statement to eval
* in  nFilepos  position von eval in file (is used to build an unique key)
* out pRet      pointer to SV contains the eval return value
*
------------------------------------------------------------------------------- */


int EvalTransOnFirstCall (/*i/o*/ register req * r,
			/*in*/  char *   sArg,
                          /*in*/  int      nFilepos,
                          /*out*/ SV **    pRet)             


    {
    SV **   ppSV ;
    epTHX_    
    
    EPENTRY (EvalTrans) ;


    *pRet = NULL ;

    /* Already compiled ? */

    ppSV = hv_fetch(r -> Buf.pFile -> pCacheHash, (char *)&nFilepos, sizeof (nFilepos), 1) ;  
    if (ppSV == NULL)
        {
        strcpy (r -> errdat1, "CacheHash in EvalTransOnFirstCall") ;
        return rcHashError ;
        }

    if (*ppSV != NULL && SvTYPE (*ppSV) == SVt_PV)
        {
        strncpy (r -> errdat1, SvPV(*ppSV, na), sizeof (r -> errdat1) - 1) ; 
        LogError (r, rcEvalErr) ;
        return rcEvalErr ;
        }

    if (*ppSV == NULL || SvTYPE (*ppSV) != SVt_PVCV)
        {
        int	rc ;
	HV *  pImportStash = r -> Component.pImportStash ;
	r -> Component.pImportStash = NULL ; /* temporarely disable import */

	/* strip off all <HTML> Tags */
        TransHtml (r, sArg, 0) ;

	rc = EvalAndCall (r, sArg, ppSV, G_SCALAR, pRet) ;

       	r -> Component.pImportStash = pImportStash ; 

	return rc ;	    
	}

    r -> numCacheHits++ ;
    
    return ok ; /* Do not call this a second time */
    }


/* -------------------------------------------------------------------------------
*
* Eval PERL Statements into a sub, check if it's already compiled
* 
* in  sArg      Statement to eval wrap into a sub
* in  nFilepos  position von eval in file (is used to build an unique key)
* in  sName     sub name
*
------------------------------------------------------------------------------- */

int EvalSub (/*i/o*/ register req * r,
	    /*in*/  const char *  sArg,
	    /*in*/  int           nFilepos,
	    /*in*/  const char *  sName)


    {
    int     rc ;
    SV **   ppSV ;
    epTHX_    
    
    
    EPENTRY (EvalSub) ;



    /* Already compiled ? */

    ppSV = hv_fetch(r -> Buf.pFile -> pCacheHash, (char *)&nFilepos, sizeof (nFilepos), 1) ;  
    if (ppSV == NULL)
        {
        strcpy (r -> errdat1, "CacheHash in EvalSub") ;
        return rcHashError ;
        }

    if (*ppSV != NULL && SvTYPE (*ppSV) == SVt_PV)
        {
        strncpy (r -> errdat1, SvPV(*ppSV, na), sizeof (r -> errdat1) - 1) ; 
        LogError (r, rcEvalErr) ;
        return rcEvalErr ;
        }

    if (*ppSV == NULL || SvTYPE (*ppSV) != SVt_PVCV)
        {
	char endc ;
	int  len = strlen (sName) ;
	
	while (len > 0 && isspace(sName[len-1]))
	    len-- ;
	endc = sName[len] ;
	((char *)sName)[len] = '\0' ;
	
	if ((rc =  EvalOnly (r, sArg, ppSV, 0, sName)) != ok)
	    {
	    ((char *)sName)[len] = endc ;
	    return rc ;
	    }

        if (r -> Component.pImportStash && *ppSV && SvTYPE (*ppSV) == SVt_PVCV)
	    {
	    hv_store (r -> Component.pExportHash, (char *)sName, len, newRV_inc(*ppSV), 0) ;
	    
	    if (r -> Component.Config.bDebug & dbgImport)
		lprintf (r -> pApp,  "[%d]IMP:  %s -> %s (%x)\n", r -> pThread -> nPid, sName, HvNAME (r -> Component.pImportStash), *ppSV) ;

	    /* 
	    gvp = (GV**)hv_fetch(r -> Component.pImportStash, (char *)sName, len, 1);
	    
	    if (!gvp || *gvp == (GV*)&PL_sv_undef)
		{
		((char *)sName)[len] = endc ;
		return rcHashError ;
		}

	    gv = *gvp;
	    if (SvTYPE(gv) != SVt_PVGV) 
		gv_init(gv, r -> Component.pImportStash, (char *)sName, len, 0);
	    
	    lprintf (r -> pApp,  "sv_any=%x\n", gv -> sv_any) ;
	    
	    SvREFCNT_dec (GvCV (gv)) ;  
	    GvCV (gv) = (CV *)*ppSV ; 
	    SvREFCNT_inc (*ppSV) ;  
	    */
	    }

	((char *)sName)[len] = endc ;
	return ok ;
	}

    r -> numCacheHits++ ;
    return ok ;
    }


/* -------------------------------------------------------------------------------
*
* Eval PERL Statements and execute the evaled code, check if it's already compiled
* 
* in  sArg      Statement to eval
* in  nFilepos  position von eval in file (is used to build an unique key)
* out pNum      pointer to int, contains the eval return value
*
------------------------------------------------------------------------------- */



int EvalNum (/*i/o*/ register req * r,
			/*in*/  char *        sArg,
             /*in*/  int           nFilepos,
             /*out*/ int *         pNum)             
    {
    SV * pRet ;
    int  n ;
    epTHX_    

    EPENTRY (EvalNum) ;


    n = Eval (r, sArg, nFilepos, &pRet) ;
    
    if (pRet)
        {
        *pNum = SvIV (pRet) ;
        SvREFCNT_dec (pRet) ;
        }
    else
        *pNum = 0 ;

    return ok ;
    }
    

/* -------------------------------------------------------------------------------
*
* EvalBool PERL Statements and execute the evaled code, check if it's already compiled
* 
* in  sArg      Statement to eval
* in  nFilepos  position von eval in file (is used to build an unique key)
* out pTrue     return 1 if evaled expression is true
*
------------------------------------------------------------------------------- */



int EvalBool (/*i/o*/ register req * r,
	      /*in*/  char *        sArg,
              /*in*/  int           nFilepos,
              /*out*/ int *         pTrue)             
    {
    SV * pRet ;
    int  rc ;
    epTHX_    

    EPENTRY (EvalNum) ;


    rc = Eval (r, sArg, nFilepos, &pRet) ;
    
    if (pRet)
        {
        *pTrue = SvTRUE (pRet) ;
        SvREFCNT_dec (pRet) ;
        }
    else
        *pTrue = 0 ;

    return rc ;
    }
    

/* -------------------------------------------------------------------------------
*
* EvalMain Scan file for [* ... *] and convert it to a perl program
* 
*
------------------------------------------------------------------------------- */


int EvalMain (/*i/o*/ register req *  r)

    {
    int     rc ;
    long    nFilepos = -1 ;
    char *  sProg = "" ;
    SV **   ppSV ;
    SV *    pRet ;
    int     flags = G_SCALAR ;
    epTHX_    

    /* Already compiled ? */

    ppSV = hv_fetch(r -> Buf.pFile -> pCacheHash, (char *)&nFilepos, sizeof (nFilepos), 1) ;  
    if (ppSV == NULL)
        {
        strcpy (r -> errdat1, "CacheHash in EvalMain") ;
        return rcHashError ;
        }

    if (*ppSV != NULL && SvTYPE (*ppSV) == SVt_PV)
        {
        strncpy (r -> errdat1, SvPV(*ppSV, na), sizeof (r -> errdat1) - 1) ; 
        LogError (r, rcEvalErr) ;
        return rcEvalErr ;
        }

    if (*ppSV == NULL || SvTYPE (*ppSV) != SVt_PVCV)
	{ /* Not already compiled -> build a perl frame program */
	char * pStart = r -> Component.pBuf ;
	char * pEnd   = r -> Component.pEndPos ;
	char * pOpenBracket  = r -> pConf -> pOpenBracket ;
	char * pCloseBracket = r -> pConf -> pCloseBracket ;
	int  lenOpenBracket  = strlen (pOpenBracket) ;
	int  lenCloseBracket = strlen (pCloseBracket) ;
	char * pOpen  ;
	char * pClose ;
	char   buf [256] ;
        int    nBlockNo = 1 ;

        
	if (r -> sSubName && *(r -> sSubName))
	    {
	    int nPos = GetSubTextPos (r, r -> sSubName) ;
	    
	    if (!nPos || pStart + nPos > pEnd || nPos < 0)
		{
		strncpy (r -> errdat1, r -> sSubName, sizeof (r -> errdat1) - 1) ; 
		return rcSubNotFound ;
		}
	    pStart += nPos ; 
	    }
	pOpen = pStart - 1 ;
	
	do 
            pOpen  = strstr (pOpen + 1, pOpenBracket) ;
        while (pOpen && pOpen > pStart && pOpen[-1] == '[') ;
        
        
        if (!pOpen)
            { /* no top level perl blocks -> call ProcessBlock directly */
            ProcessBlock (r, pStart - r -> Component.pBuf, r -> Component.pEndPos - r -> Component.pBuf, 1) ;
            return ok ;
            }


	OutputToMemBuf (r, NULL, r -> Component.pEndPos - r -> Component.pBuf) ;

	while (pStart)
	    {
	    pClose = NULL ;
	    if (pOpen)
                {
		if ((pClose = strstr (pOpen + lenOpenBracket, pCloseBracket)) == NULL)
                    {
                    strncpy (r -> errdat1, pCloseBracket, sizeof (r -> errdat1) - 1) ; 
                    return rcMissingRight ;
                    }
                *pOpen = '\0' ;
                }
            else
		pOpen = pEnd ;


            sprintf (buf, "\n$___b=$_[0] -> ProcessBlock (%d,%d,%d);\ngoto \"b$___b\";\nb%d:;\n", pStart - r -> Component.pBuf, pOpen - pStart, nBlockNo, nBlockNo) ;
            oputs  (r, buf) ;
            nBlockNo++ ;
	    if (pClose)
		{
		owrite (r, pOpen + lenOpenBracket, pClose - (pOpen + lenOpenBracket)) ;
		pStart = pClose + lenCloseBracket ;
                /* skip trailing whitespaces */
                while (isspace(*pStart))
                    pStart++ ;
                pOpen  = pStart - 1 ;
                do 
                    pOpen  = strstr (pOpen + 1, pOpenBracket) ;
                while (pOpen && pOpen > pStart && pOpen[-1] == '[') ;
                }
	    else
                {
                pStart = NULL ;
                }
            }

        oputs  (r, "\nb0:\n\0") ;

	sProg = OutputToStd (r) ;
	if (sProg == NULL)
	    return rcOutOfMemory ;

        /* strip off all <HTML> Tags */
	TransHtml (r, sProg, 0) ;

        if ((rc = EvalAndCall (r, sProg, ppSV, flags, &pRet)) != ok)
            return rc ;
        return ok ; /* SvIV (pRet) ;*/
        }

    r -> numCacheHits++ ;
    
    if ((rc = CallCV (r, sProg, (CV *)*ppSV, flags, &pRet)) != ok)
        return rc ;
    return ok ; /* SvIV (pRet) ;*/
    }
#endif