[Patch mp2] Solving module reloading problems (Apache::Reload) with ModPerl::Util::clear_namespace()

I have been trying to take care of the problem Apache::Reload is having with
clearing certain types of subroutines.  This problem also exist in at least
2 other places, namely ModPerl::PerlRun and <Perl> sections, that both also
need to be able to destroy a namespace (a module, really).

It occured to me that there was an alternative approach to trying to manually
delete each entry in a package's namespace. If you want to destroy a loaded 
module,
say Foo::Bar::Baz, you can try to iterate over it's stash and destroy all 
that's in
there, our currrent approach.

Or you can (simply put) "delete $Foo::Bar::{'Baz::'};". Deleting the entire 
stash
from that package. This is has many advantages. 1. If other modules are holding
references to internal constructs of that package, thru reference couting, they
will still hold _valid_ references to whatever they are currently pointing, a 
good
thing. 2. General cleanup will happen in that module, so package globals with
DESTROY methods will be called, etc.

All together, it's a pretty clean approach, with the only downside that 
'unloading'
a module that way might not entirely flush the memory it's using (if things are 
kept
alive thru references).

I've attached a patch that does this. It adds a ModPerl::Util::clear_namespace()
and it's used in the 3 places that I could see need it, PerlSections, 
ModPerl::PerlRun
and Apache::Reload.

Thoughts ?

P.S. Documentation patch not yet complete, I am working on it too.
--
--------------------------------------------------------------------------------
Philippe M. Chiasson m/gozer\@(apache|cpan|ectoplasm)\.org/ GPG KeyID : 88C3A5A5
http://gozer.ectoplasm.org/     F9BF E0C2 480E 7680 1AE5 3631 CB32 A107 88C3A5A5
Index: ModPerl-Registry/lib/ModPerl/RegistryCooker.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryCooker.pm,v
retrieving revision 1.50
diff -u -I$Id -r1.50 RegistryCooker.pm
--- ModPerl-Registry/lib/ModPerl/RegistryCooker.pm      27 Jun 2004 21:26:45 
-0000      1.50
+++ ModPerl-Registry/lib/ModPerl/RegistryCooker.pm      24 Aug 2004 17:52:01 
-0000
@@ -526,47 +526,7 @@
 
     $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::clear_namespace($self->{REQ}->pool, $self->{PACKAGE});
 }
 
 
Index: lib/Apache/Reload.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/Apache/Reload.pm,v
retrieving revision 1.14
diff -u -I$Id -r1.14 Reload.pm
--- lib/Apache/Reload.pm        11 Mar 2004 06:34:24 -0000      1.14
+++ lib/Apache/Reload.pm        24 Aug 2004 17:52:01 -0000
@@ -27,6 +27,8 @@
 use Apache::ServerUtil;
 use Apache::RequestUtil;
 
+use ModPerl::Util;
+
 use vars qw(%INCS %Stat $TouchTime %UndefFields);
 
 %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";
-    }
 }
 
 # the first argument is:
@@ -110,15 +114,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";
-                        }
                     }
                 }
             }
@@ -152,29 +147,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::clear_namespace($o->pool, $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;
Index: src/modules/perl/modperl_cmd.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_cmd.c,v
retrieving revision 1.64
diff -u -I$Id -r1.64 modperl_cmd.c
--- src/modules/perl/modperl_cmd.c      23 Aug 2004 21:16:27 -0000      1.64
+++ src/modules/perl/modperl_cmd.c      24 Aug 2004 17:52:01 -0000
@@ -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_clear_stash(aTHX_ p, pkg_name);
         }
         
         if (status != OK) {
Index: src/modules/perl/modperl_mgv.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_mgv.c,v
retrieving revision 1.35
diff -u -I$Id -r1.35 modperl_mgv.c
--- src/modules/perl/modperl_mgv.c      4 Mar 2004 06:01:07 -0000       1.35
+++ src/modules/perl/modperl_mgv.c      24 Aug 2004 17:52:01 -0000
@@ -171,32 +171,6 @@
 }
 #endif
 
-
-static void package2filename(apr_pool_t *p, const char *package,
-                             char **filename, int *len)
-{
-    const char *s;
-    char *d;
-
-    *filename = apr_palloc(p, (strlen(package)+4)*sizeof(char));
-
-    for (s = package, d = *filename; *s; s++, d++) {
-        if (*s == ':' && s[1] == ':') {
-            *d = '/';
-            s++;
-        }
-        else {
-            *d = *s;
-        }
-    }
-    *d++ = '.';
-    *d++ = 'p';
-    *d++ = 'm';
-    *d   = '\0';
-
-    *len = d - *filename;
-}
-
 /* currently used for complex filters attributes parsing */
 /* XXX: may want to generalize it for any handlers */
 #define MODPERL_MGV_DEEP_RESOLVE(handler, p) \
@@ -285,7 +259,7 @@
         char *filename;
         SV **svp;
 
-        package2filename(p, name, &filename, &len);
+        modperl_package2filename(p, name, &filename, &len);
         svp = hv_fetch(GvHVn(PL_incgv), filename, len, 0);
 
         if (!(svp && *svp != &PL_sv_undef)) { /* not in %INC */
Index: src/modules/perl/modperl_util.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.c,v
retrieving revision 1.76
diff -u -I$Id -r1.76 modperl_util.c
--- src/modules/perl/modperl_util.c     22 Aug 2004 20:47:37 -0000      1.76
+++ src/modules/perl/modperl_util.c     24 Aug 2004 17:52:01 -0000
@@ -491,60 +491,6 @@
     return (*name && gv_stashpv(name, FALSE)) ? 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); \
@@ -749,4 +695,95 @@
     }
 
     return array;
+}
+
+void modperl_package2filename(apr_pool_t *p, const char *package,
+                              char **filename, int *len)
+{
+    const char *s;
+    char *d;
+                                                                               
                       
+    *filename = apr_palloc(p, (strlen(package)+4)*sizeof(char));
+                                                                               
                       
+    for (s = package, d = *filename; *s; s++, d++) {
+        if (*s == ':' && s[1] == ':') {
+            *d = '/';
+            s++;
+        }
+        else {
+            *d = *s;
+        }
+    }
+    *d++ = '.';
+    *d++ = 'p';
+    *d++ = 'm';
+    *d   = '\0';
+                                                                               
                       
+    *len = d - *filename;
+}
+
+void modperl_clear_stash(pTHX_ apr_pool_t *p, const char *package)
+{
+    char const *start_colon, *end_colon;
+    char const *c;
+    char *parent, *child;
+    int size;
+    HV *stash;
+
+    /* Short-circuit out if the package doesn't exist */
+    if (!modperl_perl_module_loaded(aTHX_ package)) {
+        return;
+    }
+
+    /* Split the package name on the last '::' */
+    /* Foo::Bar::Baz */
+    c = start_colon = end_colon = package;
+
+    while (*c) {
+        if (*c == ':') {
+            start_colon = c - 1;
+            end_colon = c + 1;
+        }
+        c++;
+    }
+
+    /* parent = Foo::Bar */
+    size = (start_colon - package) + 1;
+    parent = apr_palloc(p, size);
+    apr_cpystrn(parent, package, size);
+
+    /* child = Baz:: */
+    size = strlen(package) - (end_colon - package) + 2 + 1;
+    child = apr_palloc(p, size);
+    apr_snprintf(child, size, "%s::", end_colon);
+    
+    /* delete the child entry in the parent stash */
+    if ((stash = gv_stashpv(parent, FALSE))) {
+        MP_TRACE_h(MP_FUNC, "Deleting package %s with delete $%s::{%s}",
+                   package, parent, child);
+        hv_delete(stash, child, size-1, G_DISCARD);
+    }
+}
+
+static void modperl_delete_from_inc(pTHX_ apr_pool_t *p, 
+                                    const char *package)
+{
+    int len;
+    char *filename;
+    
+    modperl_package2filename(p, package, &filename, &len);
+    hv_delete(GvHVn(PL_incgv), filename, len, G_DISCARD);   
+    
+    return;
+}
+
+void modperl_clear_namespace(pTHX_ apr_pool_t *p, const char *package)
+{
+    /* delete $INC{'Some/Package.pm} */
+    modperl_delete_from_inc(aTHX_ p, package);
+
+    /* delete $Some::{'Package::'}; */
+    modperl_clear_stash(aTHX_ p, package);
+    
+    return;
 }
Index: src/modules/perl/modperl_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.h,v
retrieving revision 1.66
diff -u -I$Id -r1.66 modperl_util.h
--- src/modules/perl/modperl_util.h     22 Aug 2004 20:47:37 -0000      1.66
+++ src/modules/perl/modperl_util.h     24 Aug 2004 17:52:01 -0000
@@ -94,8 +94,6 @@
  */
 SV *modperl_slurp_filename(pTHX_ request_rec *r, int tainted);
 
-void modperl_clear_symtab(pTHX_ HV *symtab);
-
 char *modperl_file2package(apr_pool_t *p, const char *file);
 
 /**
@@ -105,6 +103,11 @@
  * @return string of original source code
  */
 char *modperl_coderef2text(pTHX_ apr_pool_t *p, CV *cv);
+
+void modperl_clear_namespace(pTHX_ apr_pool_t *p, const char *package);
+void modperl_clear_stash(pTHX_ apr_pool_t *p, const char *package);
+void modperl_package2filename(apr_pool_t *p, const char *package,
+                              char **filename, int *len);
 
 SV *modperl_apr_array_header2avrv(pTHX_ apr_array_header_t *array);
 apr_array_header_t *modperl_avrv2apr_array_header(pTHX_ apr_pool_t *p,
Index: t/response/TestModules/reload.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestModules/reload.pm,v
retrieving revision 1.1
diff -u -I$Id -r1.1 reload.pm
--- t/response/TestModules/reload.pm    24 Aug 2004 17:36:56 -0000      1.1
+++ t/response/TestModules/reload.pm    24 Aug 2004 17:52:01 -0000
@@ -21,5 +21,4 @@
 PerlModule Apache::Reload
 PerlInitHandler Apache::TestHandler::same_interp_fixup Apache::Reload
 PerlSetVar ReloadDebug On
-PerlSetVar ReloadConstantRedefineWarnings Off
 PerlSetVar ReloadAll Off
Index: xs/ModPerl/Util/ModPerl__Util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/ModPerl/Util/ModPerl__Util.h,v
retrieving revision 1.5
diff -u -I$Id -r1.5 ModPerl__Util.h
--- xs/ModPerl/Util/ModPerl__Util.h     4 Mar 2004 06:01:14 -0000       1.5
+++ xs/ModPerl/Util/ModPerl__Util.h     24 Aug 2004 17:52:01 -0000
@@ -28,5 +28,5 @@
 
 #define mpxs_Apache_current_callback modperl_callback_current_callback_get
 
-
+#define mpxs_ModPerl__Util_clear_namespace(p, pkg) 
modperl_clear_namespace(aTHX_ p, pkg)
 
Index: xs/maps/modperl_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.84
diff -u -I$Id -r1.84 modperl_functions.map
--- xs/maps/modperl_functions.map       22 Aug 2004 20:47:37 -0000      1.84
+++ xs/maps/modperl_functions.map       24 Aug 2004 17:52:01 -0000
@@ -5,6 +5,7 @@
 
 MODULE=ModPerl::Util
  mpxs_ModPerl__Util_untaint | | ...
+ DEFINE_clear_namespace | | apr_pool_t *:p, const char *:pkg
  DEFINE_exit | | int:status=0
 
 PACKAGE=Apache
Index: xs/tables/current/ModPerl/FunctionTable.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
retrieving revision 1.175
diff -u -I$Id -r1.175 FunctionTable.pm
--- xs/tables/current/ModPerl/FunctionTable.pm  22 Aug 2004 20:47:37 -0000      
1.175
+++ xs/tables/current/ModPerl/FunctionTable.pm  24 Aug 2004 17:52:01 -0000
@@ -2,7 +2,7 @@
 
 # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 # ! WARNING: generated by ModPerl::ParseSource/0.01
-# !          Fri Aug 20 12:01:12 2004
+# !          Tue Aug 24 00:11:10 2004
 # !          do NOT edit, any changes will be lost !
 # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -360,15 +360,37 @@
   },
   {
     'return_type' => 'void',
-    'name' => 'modperl_clear_symtab',
+    'name' => 'modperl_clear_namespace',
     'args' => [
       {
         'type' => 'PerlInterpreter *',
         'name' => 'my_perl'
       },
       {
-        'type' => 'HV *',
-        'name' => 'symtab'
+        'type' => 'apr_pool_t *',
+        'name' => 'p'
+      },
+      {
+        'type' => 'const char *',
+        'name' => 'package'
+      }
+    ]
+  },
+  {
+    'return_type' => 'void',
+    'name' => 'modperl_clear_stash',
+    'args' => [
+      {
+        'type' => 'PerlInterpreter *',
+        'name' => 'my_perl'
+      },
+      {
+        'type' => 'apr_pool_t *',
+        'name' => 'p'
+      },
+      {
+        'type' => 'const char *',
+        'name' => 'package'
       }
     ]
   },
@@ -3874,6 +3896,28 @@
       },
       {
         'type' => 'apr_size_t *',
+        'name' => 'len'
+      }
+    ]
+  },
+  {
+    'return_type' => 'void',
+    'name' => 'modperl_package2filename',
+    'args' => [
+      {
+        'type' => 'apr_pool_t *',
+        'name' => 'p'
+      },
+      {
+        'type' => 'const char *',
+        'name' => 'package'
+      },
+      {
+        'type' => 'char **',
+        'name' => 'filename'
+      },
+      {
+        'type' => 'int *',
         'name' => 'len'
       }
     ]

signature.asc
Description: OpenPGP digital signature