/*###################################################################################
#
#   Embperl - Copyright (c) 1997-2001 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: epeval.c,v 1.30 2001/11/02 10:03:48 richter Exp $
#
###################################################################################*/


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


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

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

    EPENTRY (EvalDirect) ;

    tainted = 0 ;
    pCurrReq = r ;

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

    perl_eval_sv(pArg, G_SCALAR | G_KEEPERR);


    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,"");
        return rcEvalErr ;
        }

    return ok ;
    }


/* -------------------------------------------------------------------------------
*
* 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 ;
    }


    

/* -------------------------------------------------------------------------------
*
* 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)             
    {
    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 -> bDebug & dbgDefEval)
        lprintf (r, "[%d]DEF:  Line %d: %s\n", r -> nPid, r -> Buf.nSourceline, sArg?sArg:"<unknown>") ;

    tainted = 0 ;
    pCurrReq = r ;

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

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

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

    if (r -> bDebug & dbgMem)
        lprintf (r, "[%d]SVs:  %d\n", r -> 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 ;
    }


/* -------------------------------------------------------------------------------
*
* Eval PERL Statements without any caching of p-code
* 
* in  sArg   Statement to eval
* out pRet   pointer to SV contains the eval return
*
------------------------------------------------------------------------------- */

#define EVAL_SUB

static int EvalAllNoCache (/*i/o*/ register req * r,
			/*in*/  const char *  sArg,
                           /*out*/ SV **         pRet)             
    {
    dTHXsem 
    int   num ;         
    int   nCountUsed = r -> TableStack.State.nCountUsed ;
    int   nRowUsed   = r -> TableStack.State.nRowUsed ;
    int   nColUsed   = r -> TableStack.State.nColUsed ;
#ifndef EVAL_SUB    
    SV *  pSVArg ;
#endif
    SV *  pSVErr ;
    dSP;                            /* initialize stack pointer      */

    EPENTRY (EvalAll) ;

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

    tainted = 0 ;
    pCurrReq = r ;

#ifdef EVAL_SUB    

    ENTER;                          /* everything created after here */
    SAVETMPS;                       /* ...is a temporary variable.   */
    PUSHMARK(sp);                   /* remember the stack pointer    */
    XPUSHs(sv_2mortal(newSVpv((char *)sArg, strlen (sArg)))); /* push the base onto the stack  */
    PUTBACK;                        /* make local stack pointer global */
    num = perl_call_pv ("_eval_", G_SCALAR /*| G_EVAL*/) ; /* call the function             */
#else
    
    pSVArg = sv_2mortal(newSVpv((char *)sArg, strlen (sArg))) ;

    /*num = perl_eval_sv (pSVArg, G_SCALAR) ; / * call the function             */ */
    num = perl_eval_sv (pSVArg, G_DISCARD) ; /* call the function             */
    num = 0 ;
#endif    
    SPAGAIN;                        /* refresh stack pointer         */
    
    if (r -> bDebug & dbgMem)
        lprintf (r, "[%d]SVs:  %d\n", r -> nPid, sv_count) ;
    /* pop the return value from stack */
    if (num == 1)   
        {
        *pRet = POPs ;
        SvREFCNT_inc (*pRet) ;

        if (r -> bDebug & dbgEval)
            if (SvOK (*pRet))
                lprintf (r, "[%d]EVAL> %s\n", r -> nPid, SvPV (*pRet, na)) ;
            else
                lprintf (r, "[%d]EVAL> <undefined>\n", r -> nPid) ;
        
        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 -> bDebug & dbgTab) &&
            (r -> TableStack.State.nCountUsed ||
             r -> TableStack.State.nColUsed ||
             r -> TableStack.State.nRowUsed))
            lprintf (r, "[%d]TAB:  nResult = %d\n", r -> nPid, r -> TableStack.State.nResult) ;
        }
    else
        {
        *pRet = NULL ;
        if (r -> bDebug & dbgEval)
            lprintf (r, "[%d]EVAL> <NULL>\n", r -> nPid) ;
        }

	PUTBACK;

    pSVErr = ERRSV ;
    if (SvTRUE (pSVErr))
        {
        strncpy (r -> errdat1, SvPV (pSVErr, na), sizeof (r -> errdat1) - 1) ;
        LogError (r, rcEvalErr) ;
	num = rcEvalErr ;
        }
    else
        num = ok ;



#ifdef EVAL_SUB    
    FREETMPS;                       /* free that return value        */
    LEAVE;                       /* ...and the XPUSHed "mortal" args.*/
#endif
    
    return num ;
    }

/* -------------------------------------------------------------------------------
*
* Watch if there are any variables changed
* 
------------------------------------------------------------------------------- */


static int Watch (/*i/o*/ register req * r)

    {
    dSP;                            /* initialize stack pointer      */

    EPENTRY (Watch) ;

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

    perl_call_pv ("HTML::Embperl::watch", G_DISCARD | G_NOARGS) ; /* call the function             */
    
    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)             
    {
    dTHXsem 
    int   num ;         
    int   nCountUsed = r -> TableStack.State.nCountUsed ;
    int   nRowUsed   = r -> TableStack.State.nRowUsed ;
    int   nColUsed   = r -> TableStack.State.nColUsed ;
    SV *  pSVErr ;
    dSP;                            /* initialize stack pointer      */


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

    EPENTRY (CallCV) ;

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

    tainted = 0 ;
    pCurrReq = r ;

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

    num = perl_call_sv ((SV *)pSub, flags | G_EVAL | G_NOARGS) ; /* call the function             */
    
    SPAGAIN;                        /* refresh stack pointer         */
    
    if (r -> bDebug & dbgMem)
        lprintf (r, "[%d]SVs:  %d\n", r -> 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 -> bDebug & dbgEval)
            {
            if (SvOK (*pRet))
                lprintf (r, "[%d]EVAL> %s\n", r -> nPid, SvPV (*pRet, na)) ;
            else
                lprintf (r, "[%d]EVAL> <undefined>\n", r -> nPid) ;
            }                
            
        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 -> bDebug & dbgTab) &&
            (r -> TableStack.State.nCountUsed ||
             r -> TableStack.State.nColUsed ||
             r -> TableStack.State.nRowUsed))
            lprintf (r, "[%d]TAB:  nResult = %d\n", r -> nPid, r -> TableStack.State.nResult) ;

        }
     else if (num == 0)
        {
        *pRet = NULL ;
        if (r -> bDebug & dbgEval)
            lprintf (r, "[%d]EVAL> <NULL>\n", r -> nPid) ;
        }
     else
        {
        *pRet = &sv_undef ;
        if (r -> bDebug & dbgEval)
            lprintf (r, "[%d]EVAL> returns %d args instead of one\n", r -> nPid, num) ;
        }

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

     PUTBACK;
     FREETMPS ;
     LEAVE ;

     if (r -> bExit)
	 {
	 if (*pRet)
	     SvREFCNT_dec (*pRet) ;
	 *pRet = NULL ;
	 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) ;*/

	    sv_unmagic(pSVErr,'U');
	    sv_setpv(pSVErr,"");

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


/* -------------------------------------------------------------------------------
*
* 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 ;
    
    
    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 ;
    }

#ifdef EP2

/* -------------------------------------------------------------------------------
*
* 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)             
    {
    dTHXsem
    int   num ;         
    SV *  pSVErr ;

    dSP;                            /* initialize stack pointer      */

    EPENTRY (CallCV) ;

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

    tainted = 0 ;
    pCurrReq = r ;

    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             */
    
    SPAGAIN;                        /* refresh stack pointer         */
    
    if (r -> bDebug & dbgMem)
        lprintf (r, "[%d]SVs:  %d\n", r -> 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 -> bDebug & dbgEval)
            {
            if (SvOK (*pRet))
                lprintf (r, "[%d]EVAL> %s\n", r -> nPid, SvPV (*pRet, na)) ;
            else
                lprintf (r, "[%d]EVAL> <undefined>\n", r -> nPid) ;
            }                
        }
     else if (num == 0)
        {
        *pRet = NULL ;
        if (r -> bDebug & dbgEval)
            lprintf (r, "[%d]EVAL> <NULL>\n", r -> nPid) ;
        }
     else
        {
        *pRet = &sv_undef ;
        if (r -> bDebug & dbgEval)
            lprintf (r, "[%d]EVAL> returns %d args instead of one\n", r -> nPid, num) ;
        }

     PUTBACK;
     FREETMPS ;
     LEAVE ;

     if (r -> bExit)
	 {
	 if (*pRet)
	     SvREFCNT_dec (*pRet) ;
	 *pRet = NULL ;
	 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) ;*/

	    sv_unmagic(pSVErr,'U');
	    sv_setpv(pSVErr,"");

	    r -> 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' ;
         
	LogError (r, rcEvalErr) ;

	sv_setpv(pSVErr,"");

	return rcEvalErr ;
        }

     
    return ok ;
    }


/* -------------------------------------------------------------------------------
*
* 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 ;
    
    
    EPENTRY (Eval) ;

    r -> numEvals++ ;
    *pRet = NULL ;

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

    ppSV = hv_fetch(r -> Buf.pFile -> pCacheHash, (char *)&nFilepos, sizeof (nFilepos), 1) ;  
    if (ppSV == NULL)
        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, "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 ;
    
    
    EPENTRY (Eval) ;

    r -> numEvals++ ;
    *pRet = NULL ;

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

    ppSV = hv_fetch(r -> Buf.pFile -> pCacheHash, (char *)&nFilepos, sizeof (nFilepos), 1) ;  
    if (ppSV == NULL)
        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 ;
    
    EPENTRY (EvalTrans) ;


    r -> numEvals++ ;
    *pRet = NULL ;

    /*
    if (r -> 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)
        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 ;
    
    EPENTRY (EvalTrans) ;


    r -> numEvals++ ;
    *pRet = NULL ;

    /* Already compiled ? */

    ppSV = hv_fetch(r -> Buf.pFile -> pCacheHash, (char *)&nFilepos, sizeof (nFilepos), 1) ;  
    if (ppSV == NULL)
        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 -> pImportStash ;
	r -> pImportStash = NULL ; /* temporarely disable import */

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

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

       	r -> 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 ;
    
    
    EPENTRY (EvalSub) ;

    r -> numEvals++ ;


    /* Already compiled ? */

    ppSV = hv_fetch(r -> Buf.pFile -> pCacheHash, (char *)&nFilepos, sizeof (nFilepos), 1) ;  
    if (ppSV == NULL)
        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 -> pImportStash && *ppSV && SvTYPE (*ppSV) == SVt_PVCV)
	    {
	    hv_store (r -> Buf.pFile -> pExportHash, (char *)sName, len, newRV_inc(*ppSV), 0) ;
	    
	    if (r -> bDebug & dbgImport)
		lprintf (r, "[%d]IMP:  %s -> %s (%x)\n", r -> nPid, sName, HvNAME (r -> pImportStash), *ppSV) ;

	    /* 
	    gvp = (GV**)hv_fetch(r -> 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 -> pImportStash, (char *)sName, len, 0);
	    
	    lprintf (r, "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 ;

    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 ;

    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 ;

    /* Already compiled ? */

    ppSV = hv_fetch(r -> Buf.pFile -> pCacheHash, (char *)&nFilepos, sizeof (nFilepos), 1) ;  
    if (ppSV == NULL)
        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 -> Buf.pBuf ;
	char * pEnd   = r -> Buf.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 -> Buf.pBuf, r -> Buf.pEndPos - r -> Buf.pBuf, 1) ;
            return ok ;
            }


	OutputToMemBuf (r, NULL, r -> Buf.pEndPos - r -> Buf.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 -> Buf.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) ;*/
    }