perl-dev mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From "Gerald Richter" <rich...@ecos.de>
Subject Re: cvs commit: modperl/lib/Apache PerlRun.pm
Date Tue, 30 Jan 2001 05:18:00 GMT
>
> 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
-------------------------------------------------------------



Mime
View raw message