Mailing-List: contact dev-help@perl.apache.org; run by ezmlm
Message-ID: <005b01c08a7c$04177d80$0a0c0b0a@gr.ecos.de>
From: "Gerald Richter" <richter@ecos.de>
To: "Doug MacEachern" <dougm@covalent.net>,
	"Ken Williams" <ken@forum.swarthmore.edu>
Cc: <dev@perl.apache.org>
References: <Pine.LNX.4.21.0101291413450.970-100000@mako.covalent.net>
Subject: Re: cvs commit: modperl/lib/Apache PerlRun.pm
Date: Tue, 30 Jan 2001 06:18:00 +0100
MIME-Version: 1.0
Content-Type: text/plain;
	charset="iso-8859-1"
Content-Transfer-Encoding: 7bit

>
> much better, thanks ken.  it'll be even faster when this ToDo item gets
> done :)
>
> - Apache::PerlRun::flush_namespace should be re-written in c
>
>

Just a few weeks ago I have rewritten the Embperl cleanup in C and it's
really much much faster now!

I append my source, maybe it helpfull for PerlRun too. Note that r is not
the Apache request_rec, but Embperl internal request record, it's only
needed for logging here. Also this function takes care about not to cleanup
variables that are imported from other modules. I am not quite sure if this
makes sense for PerlRun too, but I guess so. Additionaly there are a hash
%CLEANUP, here you can disable the cleanup for some variables or add some
that are normaly not cleanedup. Also if the function CLEANUP is defined, it
is called before the CLEANUP happens. I think it's easy to strip those parts
that are not necessary for PerlRun.

Gerald


void ClearSymtab (/*i/o*/ register req * r,
    /*in*/  const char *    sPackage)

    {
    SV * val;
    char * key;
    I32  klen;
    int  bDebug = 1 ;
    SV * sv;
    HV * hv;
    AV * av;
    struct io * io ;
    HV * symtab ;
    STRLEN l ;
    CV * pCV ;
    SV * pSV ;
    SV * * ppSV ;
    SV * pSVErr ;
    HV * pCleanupHV ;
    char *      s ;
    GV * pFileGV ;
    GV * symtabgv ;
    GV * symtabfilegv ;

    dTHR;

    if ((symtab = gv_stashpv ((char *)sPackage, 0)) == NULL)
 return ;

    ppSV = hv_fetch (symtab, "__ANON__", 8, 0) ;
    if (!ppSV || !*ppSV)
 {
 if (bDebug)
     lprintf (r, "[%d]CUP: No Perl code in %s\n", r -> nPid, sPackage) ;
 return ;
 }

    symtabgv = (GV *)*ppSV ;
    symtabfilegv = (GV *)GvFILEGV (symtabgv) ;

    pSV = newSVpvf ("%s::CLEANUP", sPackage) ;
    s   = SvPV (pSV, l) ;
    pCV = perl_get_cv (s, 0) ;
    if (pCV)
 {
 if (bDebug)
     lprintf (r, "[%d]CUP: Call &%s::CLEANUP\n", r -> nPid, sPackage) ;
 perl_call_sv ((SV *)pCV, G_EVAL | G_NOARGS | G_DISCARD) ;
 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,"");
     }
 }


    pCleanupHV = perl_get_hv (s, 1) ;

    SvREFCNT_dec(pSV) ;

    (void)hv_iterinit(symtab);
    while ((val = hv_iternextsv(symtab, &key, &klen)))
 {
 if(SvTYPE(val) != SVt_PVGV)
     continue;

 s = GvNAME((GV *)val) ;
 l = strlen (s) ;

 ppSV = hv_fetch (pCleanupHV, s, l, 0) ;

 if (ppSV && *ppSV && SvIV (*ppSV) == 0)
     {
     if (bDebug)
         lprintf (r, "[%d]CUP: Ignore %s because it's in %%CLEANUP\n", r ->
nPid, s) ;
     continue ;
     }


 if (!(ppSV && *ppSV && SvTRUE (*ppSV)))
     {
     if(GvIMPORTED((GV*)val))
  {
  if (bDebug)
      lprintf (r, "[%d]CUP: Ignore %s because it's imported\n", r -> nPid,
s) ;
  continue ;
  }

     pFileGV = GvFILEGV ((GV *)val) ;
     if (pFileGV != symtabfilegv)
  {
  if (bDebug)
      lprintf (r, "[%d]CUP: Ignore %s because it's defined in another source
file\n", r -> nPid, s) ;
  continue ;
  }
     }

 if((sv = GvSV((GV*)val)) && SvOK (sv))
     {
     if (bDebug)
         lprintf (r, "[%d]CUP: $%s = %s\n", r -> nPid, s, SvPV (sv, l)) ;

     sv_unmagic (sv, 'q') ; /* untie */
     sv_setsv(sv, &sv_undef);
     }
 if((hv = GvHV((GV*)val)))
     {
     if (bDebug)
         lprintf (r, "[%d]CUP: %%%s = ...\n", r -> nPid, s) ;
     sv_unmagic ((SV *)hv, 'P') ; /* untie */
     hv_clear(hv);
     }
 if((av = GvAV((GV*)val)))
     {
     if (bDebug)
         lprintf (r, "[%d]CUP: @%s = ...\n", r -> nPid, s) ;
     sv_unmagic ((SV *)av, 'P') ; /* untie */
     av_clear(av);
     }
 if((io = GvIO((GV*)val)))
     {
     if (bDebug)
         lprintf (r, "[%d]CUP: IO %s = ...\n", r -> nPid, s) ;
     //sv_unmagic ((SV *)io, 'q') ; /* untie */
     //do_close((GV *)val, 0);
     }
 }
    }


-------------------------------------------------------------
Gerald Richter    ecos electronic communication services gmbh
Internetconnect * Webserver/-design/-datenbanken * Consulting

Post:       Tulpenstrasse 5         D-55276 Dienheim b. Mainz
E-Mail:     richter@ecos.de         Voice:    +49 6133 925131
WWW:        http://www.ecos.de      Fax:      +49 6133 925152
-------------------------------------------------------------