perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From go...@apache.org
Subject cvs commit: modperl-2.0/xs/tables/current/ModPerl FunctionTable.pm
Date Thu, 09 Sep 2004 22:16:38 GMT
gozer       2004/09/09 15:16:38

  Modified:    .        Changes
               ModPerl-Registry/lib/ModPerl RegistryCooker.pm
               lib/Apache Reload.pm
               src/modules/perl modperl_cmd.c modperl_util.c modperl_util.h
               t/response/TestModules reload.pm
               todo     features_optimization release
               xs/ModPerl/Util ModPerl__Util.h
               xs/maps  modperl_functions.map
               xs/tables/current/ModPerl FunctionTable.pm
  Log:
  Added ModPerl::Util::unload_package() to remove a loaded package
  as thoroughly as possible by clearing it's stash.
  
  Adjusted <Perl> sections, Apache::Reload and ModPerl::Registry to use
  the new function.
  
  Revision  Changes    Path
  1.480     +3 -0      modperl-2.0/Changes
  
  Index: Changes
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/Changes,v
  retrieving revision 1.479
  retrieving revision 1.480
  diff -u -r1.479 -r1.480
  --- Changes	9 Sep 2004 18:48:03 -0000	1.479
  +++ Changes	9 Sep 2004 22:16:37 -0000	1.480
  @@ -12,6 +12,9 @@
   
   =item 1.99_17-dev
   
  +Added ModPerl::Util::unload_package() to remove a loaded package
  +as thoroughly as possible by clearing it's stash. [Gozer]
  +
   fix Apache->request($r) to be set-able even w/: PerlOptions
   -GlobalRequest [Stas]
   
  
  
  
  1.51      +1 -42     modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryCooker.pm
  
  Index: RegistryCooker.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryCooker.pm,v
  retrieving revision 1.50
  retrieving revision 1.51
  diff -u -r1.50 -r1.51
  --- RegistryCooker.pm	27 Jun 2004 21:26:45 -0000	1.50
  +++ RegistryCooker.pm	9 Sep 2004 22:16:37 -0000	1.51
  @@ -525,48 +525,7 @@
       my $self = shift;
   
       $self->debug("flushing namespace") if DEBUG & D_NOISE;
  -
  -    no strict 'refs';
  -    my $tab = \%{ $self->{PACKAGE} . '::' };
  -
  -    # below we assign to a symbol first before undef'ing it, to avoid
  -    # nuking aliases. If we undef directly we may undef not only the
  -    # alias but the original function as well
  -
  -    for (keys %$tab) {
  -        my $fullname = join '::', $self->{PACKAGE}, $_;
  -        # code/hash/array/scalar might be imported make sure the gv
  -        # does not point elsewhere before undefing each
  -        if (%$fullname) {
  -            *{$fullname} = {};
  -            undef %$fullname;
  -        }
  -        if (@$fullname) {
  -            *{$fullname} = [];
  -            undef @$fullname;
  -        }
  -        if ($$fullname) {
  -            my $tmp; # argh, no such thing as an anonymous scalar
  -            *{$fullname} = \$tmp;
  -            undef $$fullname;
  -        }
  -        if (defined &$fullname) {
  -            no warnings;
  -            local $^W = 0;
  -            if (defined(my $p = prototype $fullname)) {
  -                *{$fullname} = eval "sub ($p) {}";
  -            }
  -            else {
  -                *{$fullname} = sub {};
  -            }
  -            undef &$fullname;
  -        }
  -        if (*{$fullname}{IO}) {
  -            if (fileno $fullname) {
  -                close $fullname;
  -            }
  -        }
  -    }
  +    ModPerl::Util::unload_package($self->{PACKAGE});
   }
   
   
  
  
  
  1.16      +13 -31    modperl-2.0/lib/Apache/Reload.pm
  
  Index: Reload.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/lib/Apache/Reload.pm,v
  retrieving revision 1.15
  retrieving revision 1.16
  diff -u -r1.15 -r1.16
  --- Reload.pm	9 Sep 2004 18:29:09 -0000	1.15
  +++ Reload.pm	9 Sep 2004 22:16:37 -0000	1.16
  @@ -27,7 +27,9 @@
   use Apache::ServerUtil;
   use Apache::RequestUtil;
   
  -use vars qw(%INCS %Stat $TouchTime %UndefFields);
  +use ModPerl::Util ();
  +
  +use vars qw(%INCS %Stat $TouchTime);
   
   %Stat = ($INC{"Apache/Reload.pm"} => time);
   
  @@ -47,6 +49,13 @@
       return $package;
   }
   
  +sub module_to_package {
  +    my $module = shift;
  +    $module =~ s/\//::/g;
  +    $module =~ s/\.pm$//g;
  +    return $module;
  +}
  +
   sub register_module {
       my($class, $package, $file) = @_;
       my $module = package_to_module($package);
  @@ -59,11 +68,6 @@
           return unless $file;
           $INCS{$module} = $file;
       }
  -
  -    no strict 'refs';
  -    if (%{"${package}::FIELDS"}) {
  -        $UndefFields{$module} = "${package}::FIELDS";
  -    }
   }
   
   sub unregister_module {
  @@ -116,15 +120,6 @@
                   foreach my $match (keys %INC) {
                       if ($match =~ /^\Q$prefix\E/) {
                           $Apache::Reload::INCS{$match} = $INC{$match};
  -                        my $package = $match;
  -                        $package =~ s/\//::/g;
  -                        $package =~ s/\.pm$//;
  -                        no strict 'refs';
  -#                        warn "checking for FIELDS on $package\n";
  -                        if (%{"${package}::FIELDS"}) {
  -#                            warn "found fields in $package\n";
  -                            $UndefFields{$match} = "${package}::FIELDS";
  -                        }
                       }
                   }
               }
  @@ -158,29 +153,16 @@
           }
   
           if ($mtime > $Stat{$file}) {
  -            delete $INC{$key};
  -#           warn "Reloading $key\n";
  -            if (my $symref = $UndefFields{$key}) {
  -#                warn "undeffing fields\n";
  -                no strict 'refs';
  -                undef %{$symref};
  -            }
  -            no warnings FATAL => 'all';
  -            local $SIG{__WARN__} = \&skip_redefine_const_sub_warn
  -                unless $ConstantRedefineWarnings;
  +            my $package = module_to_package($key);
  +            ModPerl::Util::unload_package($package);
               require $key;
  -            warn("Apache::Reload: process $$ reloading $key\n")
  +            warn("Apache::Reload: process $$ reloading $package from $key\n")
                       if $DEBUG;
           }
           $Stat{$file} = $mtime;
       }
   
       return Apache::OK;
  -}
  -
  -sub skip_redefine_const_sub_warn {
  -    return if $_[0] =~ /^Constant subroutine [\w:]+ redefined at/;
  -    CORE::warn(@_);
   }
   
   1;
  
  
  
  1.65      +1 -4      modperl-2.0/src/modules/perl/modperl_cmd.c
  
  Index: modperl_cmd.c
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_cmd.c,v
  retrieving revision 1.64
  retrieving revision 1.65
  diff -u -r1.64 -r1.65
  --- modperl_cmd.c	23 Aug 2004 21:16:27 -0000	1.64
  +++ modperl_cmd.c	9 Sep 2004 22:16:37 -0000	1.65
  @@ -577,10 +577,7 @@
           SvREFCNT_dec((SV*)args);
   
           if (!(saveconfig && SvTRUE(saveconfig))) {
  -            HV *symtab = (HV*)gv_stashpv(pkg_name, FALSE);
  -            if (symtab) {
  -                modperl_clear_symtab(aTHX_ symtab);
  -            }
  +            modperl_package_unload(aTHX_ pkg_name);
           }
           
           if (status != OK) {
  
  
  
  1.80      +95 -54    modperl-2.0/src/modules/perl/modperl_util.c
  
  Index: modperl_util.c
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.c,v
  retrieving revision 1.79
  retrieving revision 1.80
  diff -u -r1.79 -r1.80
  --- modperl_util.c	9 Sep 2004 15:08:38 -0000	1.79
  +++ modperl_util.c	9 Sep 2004 22:16:37 -0000	1.80
  @@ -303,6 +303,59 @@
       free(handles);
   }
   
  +/* XXX: There is no XS accessible splice() */
  +static void modperl_av_remove_entry(pTHX_ AV *av, I32 index)
  +{
  +    I32 i;
  +    AV *tmpav = newAV();
  +
  +    /* stash the entries _before_ the item to delete */
  +    for (i=0; i<=index; i++) {
  +        av_store(tmpav, i, SvREFCNT_inc(av_shift(av)));
  +    }
  +    
  +    /* make size at the beginning of the array */
  +    av_unshift(av, index-1);
  +    
  +    /* add stashed entries back */
  +    for (i=0; i<index; i++) {
  +        av_store(av, i, *av_fetch(tmpav, i, 0));
  +    }
  +    
  +    SvREFCNT_dec(tmpav);
  +}
  +
  +static void modperl_package_unload_dynamic(pTHX_ const char *package, 
  +                                           I32 dl_index)
  +{
  +    AV *librefs = get_av(dl_librefs, 0);
  +    SV *libref = *av_fetch(librefs, dl_index, 0);
  +
  +    modperl_sys_dlclose((void *)SvIV(libref));
  +    
  +    /* remove package from @dl_librefs and @dl_modules */
  +    modperl_av_remove_entry(aTHX_ get_av(dl_librefs, 0), dl_index);
  +    modperl_av_remove_entry(aTHX_ get_av(dl_modules, 0), dl_index);
  +    
  +    return;    
  +}
  +
  +static int modperl_package_is_dynamic(pTHX_ const char *package,
  +                                      I32 *dl_index)
  +{
  +   I32 i;
  +   AV *modules = get_av(dl_modules, FALSE);
  +    
  +   for (i=0; i<av_len(modules); i++) {
  +        SV *module = *av_fetch(modules, i, 0);
  +        if (strEQ(package, SvPVX(module))) {
  +            *dl_index = i;
  +            return TRUE;
  +        }
  +    }
  +    return FALSE;
  +}
  +
   modperl_cleanup_data_t *modperl_cleanup_data_new(apr_pool_t *p, void *data)
   {
       modperl_cleanup_data_t *cdata =
  @@ -526,60 +579,6 @@
       return (svp && *svp != &PL_sv_undef) ? 1 : 0;
   }
   
  -static int modperl_gvhv_is_stash(GV *gv)
  -{
  -    int len = GvNAMELEN(gv);
  -    char *name = GvNAME(gv);
  -
  -    if ((len > 2) && (name[len - 1] == ':') && (name[len - 2] == ':'))
{
  -        return 1;
  -    }
  -
  -    return 0;
  -}
  -
  -/*
  - * we do not clear symbols within packages, the desired behavior
  - * for directive handler classes.  and there should never be a package
  - * within the %Apache::ReadConfig.  nothing else that i'm aware of calls
  - * this function, so we should be ok.
  - */
  -
  -void modperl_clear_symtab(pTHX_ HV *symtab) 
  -{
  -    SV *val;
  -    char *key;
  -    I32 klen;
  -
  -    hv_iterinit(symtab);
  -    
  -    while ((val = hv_iternextsv(symtab, &key, &klen))) {
  -        SV *sv;
  -        HV *hv;
  -        AV *av;
  -        CV *cv;
  -
  -        if ((SvTYPE(val) != SVt_PVGV) || GvIMPORTED((GV*)val)) {
  -            continue;
  -        }
  -        if ((sv = GvSV((GV*)val))) {
  -            sv_setsv(GvSV((GV*)val), &PL_sv_undef);
  -        }
  -        if ((hv = GvHV((GV*)val)) && !modperl_gvhv_is_stash((GV*)val)) {
  -            hv_clear(hv);
  -        }
  -        if ((av = GvAV((GV*)val))) {
  -            av_clear(av);
  -        }
  -        if ((cv = GvCV((GV*)val)) && (GvSTASH((GV*)val) == GvSTASH(CvGV(cv))))
{
  -            GV *gv = CvGV(cv);
  -            cv_undef(cv);
  -            CvGV(cv) = gv;
  -            GvCVGEN(gv) = 1; /* invalidate method cache */
  -        }
  -    }
  -}
  -
   #define SLURP_SUCCESS(action) \
       if (rc != APR_SUCCESS) { \
           SvREFCNT_dec(sv); \
  @@ -784,4 +783,46 @@
       }
   
       return array;
  +}
  +
  +/* Remove a package from %INC */
  +static void modperl_package_delete_from_inc(pTHX_ const char *package)  
  +{
  +    int len;
  +    char *filename = package2filename(package, &len);
  +    hv_delete(GvHVn(PL_incgv), filename, len, G_DISCARD);
  +    free(filename);
  +}
  +
  +/* Destroy a package's stash */
  +static void modperl_package_clear_stash(pTHX_ const char *package)
  +{
  +    HV *stash;
  +    if ((stash = gv_stashpv(package, FALSE))) {
  +        HE *he;
  +        I32 len;
  +        char *key;
  +        hv_iterinit(stash);
  +        while ((he = hv_iternext(stash))) {
  +            key = hv_iterkey(he, &len);
  +            /* We skip entries ending with ::, they are sub-stashes */
  +            if (len > 2 && key[len] != ':' && key[len-1] != ':') {
  +                hv_delete(stash, key, len, G_DISCARD);
  +            }
  +        }
  +    }
  +}
  +
  +/* Unload a module as completely and cleanly as possible */
  +void modperl_package_unload(pTHX_ const char *package)
  +{
  +    I32 dl_index;
  +    
  +    modperl_package_clear_stash(aTHX_ package);
  +    modperl_package_delete_from_inc(aTHX_ package);
  +    
  +    if (modperl_package_is_dynamic(aTHX_ package, &dl_index)) {
  +        modperl_package_unload_dynamic(aTHX_ package, dl_index);
  +    }
  +    
   }
  
  
  
  1.67      +1 -0      modperl-2.0/src/modules/perl/modperl_util.h
  
  Index: modperl_util.h
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.h,v
  retrieving revision 1.66
  retrieving revision 1.67
  diff -u -r1.66 -r1.67
  --- modperl_util.h	22 Aug 2004 20:47:37 -0000	1.66
  +++ modperl_util.h	9 Sep 2004 22:16:37 -0000	1.67
  @@ -109,6 +109,7 @@
   SV *modperl_apr_array_header2avrv(pTHX_ apr_array_header_t *array);
   apr_array_header_t *modperl_avrv2apr_array_header(pTHX_ apr_pool_t *p,
                                                     SV *avrv);
  +void modperl_package_unload(pTHX_ const char *package);
   #if defined(MP_TRACE) && defined(APR_HAS_THREADS)
   #define MP_TRACEf_TID   "/tid 0x%lx"
   #define MP_TRACEv_TID   (unsigned long)apr_os_thread_current()
  
  
  
  1.4       +0 -1      modperl-2.0/t/response/TestModules/reload.pm
  
  Index: reload.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/t/response/TestModules/reload.pm,v
  retrieving revision 1.3
  retrieving revision 1.4
  diff -u -r1.3 -r1.4
  --- reload.pm	9 Sep 2004 18:29:09 -0000	1.3
  +++ reload.pm	9 Sep 2004 22:16:38 -0000	1.4
  @@ -29,5 +29,4 @@
   PerlModule Apache::Reload
   PerlInitHandler Apache::TestHandler::same_interp_fixup Apache::Reload
   PerlSetVar ReloadDebug Off
  -PerlSetVar ReloadConstantRedefineWarnings Off
   PerlSetVar ReloadAll Off
  
  
  
  1.4       +3 -0      modperl-2.0/todo/features_optimization
  
  Index: features_optimization
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/todo/features_optimization,v
  retrieving revision 1.3
  retrieving revision 1.4
  diff -u -r1.3 -r1.4
  --- features_optimization	4 Mar 2004 01:04:28 -0000	1.3
  +++ features_optimization	9 Sep 2004 22:16:38 -0000	1.4
  @@ -15,3 +15,6 @@
   * currently when ithreads-enabled perl is used anon-sub handlers are
     always deparsed and non-cached. there are several cases when this
     can be optimized. See modperl_handler_new_anon in modperl_handler.c
  +
  +* modperl_package_unload() and modperl_xs_dl_*() share some duplicated
  +  logic. The managment of DynaLoaded modules could be somewhat cleaner. 
  
  
  
  1.55      +0 -4      modperl-2.0/todo/release
  
  Index: release
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/todo/release,v
  retrieving revision 1.54
  retrieving revision 1.55
  diff -u -r1.54 -r1.55
  --- release	25 Aug 2004 23:47:33 -0000	1.54
  +++ release	9 Sep 2004 22:16:38 -0000	1.55
  @@ -100,10 +100,6 @@
                  not sure when. we need to ping him every so often. but
                  it'll probably won't happen by the time we release 2.0.
   
  -* Apache::Reload
  -  - needs to handle properly redefined subs warnings
  -  owner: gozer
  -
   * Apache->unescape_url{_info}:
     not yet implemented.  should be moved to Apache::Util (or may be
     APR::URI?)
  
  
  
  1.7       +2 -0      modperl-2.0/xs/ModPerl/Util/ModPerl__Util.h
  
  Index: ModPerl__Util.h
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/xs/ModPerl/Util/ModPerl__Util.h,v
  retrieving revision 1.6
  retrieving revision 1.7
  diff -u -r1.6 -r1.7
  --- ModPerl__Util.h	25 Aug 2004 21:51:21 -0000	1.6
  +++ ModPerl__Util.h	9 Sep 2004 22:16:38 -0000	1.7
  @@ -29,5 +29,7 @@
   #define mpxs_ModPerl__Util_current_callback \
           modperl_callback_current_callback_get
   
  +#define mpxs_ModPerl__Util_unload_package(pkg) \
  +        modperl_package_unload(aTHX_ pkg)
   
   
  
  
  
  1.86      +1 -0      modperl-2.0/xs/maps/modperl_functions.map
  
  Index: modperl_functions.map
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
  retrieving revision 1.85
  retrieving revision 1.86
  diff -u -r1.85 -r1.86
  --- modperl_functions.map	25 Aug 2004 21:51:21 -0000	1.85
  +++ modperl_functions.map	9 Sep 2004 22:16:38 -0000	1.86
  @@ -7,6 +7,7 @@
    mpxs_ModPerl__Util_untaint | | ...
    DEFINE_exit | | int:status=0
    char *:DEFINE_current_callback 
  + DEFINE_unload_package | | const char *:package
   
   MODULE=ModPerl::Global
    mpxs_ModPerl__Global_special_list_call
  
  
  
  1.178     +15 -1     modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm
  
  Index: FunctionTable.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
  retrieving revision 1.177
  retrieving revision 1.178
  diff -u -r1.177 -r1.178
  --- FunctionTable.pm	8 Sep 2004 00:42:02 -0000	1.177
  +++ FunctionTable.pm	9 Sep 2004 22:16:38 -0000	1.178
  @@ -2,7 +2,7 @@
   
   # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   # ! WARNING: generated by ModPerl::ParseSource/0.01
  -# !          Mon Aug 30 22:40:23 2004
  +# !          Wed Sep  8 15:12:22 2004
   # !          do NOT edit, any changes will be lost !
   # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   
  @@ -3875,6 +3875,20 @@
         {
           'type' => 'apr_size_t *',
           'name' => 'len'
  +      }
  +    ]
  +  },
  +  {
  +    'return_type' => 'void',
  +    'name' => 'modperl_package_unload',
  +    'args' => [
  +      {
  +        'type' => 'PerlInterpreter *',
  +        'name' => 'my_perl'
  +      },
  +      {
  +        'type' => 'const char *',
  +        'name' => 'package'
         }
       ]
     },
  
  
  

Mime
View raw message