Following the discussion on Apache::Reload and Apache::Symbol, I've taken out Apache::Symbol::undef from mp1, massaged it a bit and made it into ModPerl::Util::undef for mod_perl 2.
Works wonders when you want to undefine subroutines, constant or not,
with or without prototypes. Very usefull for Apache::Reload (can get rid
of that $SIG{__WARN__} trap).
# $Id: ModPerl-Util-undef.patch,v 1.1 2003/06/19 05:02:53 gozer Exp $
Index: t/response/TestModperl/util.pm
===================================================================
RCS file: t/response/TestModperl/util.pm
diff -N t/response/TestModperl/util.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ t/response/TestModperl/util.pm 19 Jun 2003 05:01:32 -0000
@@ -0,0 +1,83 @@
+package TestModperl::util;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::Test;
+use Apache::TestUtil;
+
+use Apache::Const -compile => 'OK';
+
+use ModPerl::Util;
+
+sub ModPerlUtilTestConst { 42 }
+sub ModPerlUtilTest { return $_[0] * 2 }
+
+sub handler {
+ my $r = shift;
+
+ plan $r, tests => 14;
+
+ ok &ModPerlUtilTestConst == 42;
+
+ ModPerl::Util::undef(\&ModPerlUtilTestConst);
+
+ ok ! eval {
+ &ModPerlUtilTestConst == 42;
+ };
+
+ ok $@;
+
+ eval 'sub ModPerlUtilTestConst { 84 }';
+
+ ok !$@;
+
+ ok &ModPerlUtilTestConst == 84;
+
+ ok ModPerlUtilTest(42) == 84;
+
+ ModPerl::Util::undef(\&ModPerlUtilTest);
+
+ ok ! eval {
+ &ModPerlUtilTest(42) == 84;
+ };
+
+ ok $@;
+
+ eval 'sub ModPerlUtilTest { return $_[0] / 2 }';
+
+ ok !$@;
+
+ ok ModPerlUtilTest(84) == 42;
+
+ {
+ my $warning;
+
+ local $SIG{__WARN__} = sub { $warning = shift; };
+
+ undef $warning;
+ eval {
+ ModPerl::Util::undef({ foo => 'bar'});
+ };
+
+ ok $warning;
+
+ undef $warning;
+ eval {
+ ModPerl::Util::undef("foo");
+ };
+
+ ok $warning;
+
+ undef $warning;
+ eval {
+ ModPerl::Util::undef(sub { "foo"; });
+ };
+
+ ok !$warning;
+ }
+
+ Apache::OK;
+}
+
+1;
Index: xs/ModPerl/Util/ModPerl__Util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/ModPerl/Util/ModPerl__Util.h,v
retrieving revision 1.4
diff -u -I$Id -r1.4 ModPerl__Util.h
--- xs/ModPerl/Util/ModPerl__Util.h 17 Feb 2003 09:03:17 -0000 1.4
+++ xs/ModPerl/Util/ModPerl__Util.h 19 Jun 2003 05:01:33 -0000
@@ -14,4 +14,44 @@
#define mpxs_Apache_current_callback modperl_callback_current_callback_get
+static MP_INLINE void mpxs_ModPerl__Util_undef(pTHX_ SV *ref)
+{
+ GV *gv;
+ SV *sv;
+ CV *cv;
+ I32 has_proto=FALSE;
+
+ if (SvROK(ref)) {
+ sv = SvRV(ref);
+ }
+ else {
+ warn("undef called without a reference!");
+ return;
+ }
+
+ switch (SvTYPE(sv)) {
+ case SVt_PVCV:
+ cv = (CV*)sv;
+ if (!CvXSUB(cv) && CvROOT(cv) && CvDEPTH(cv)) {
+ return; /* subroutine is active */
+ }
+
+ gv = (GV*)SvREFCNT_inc(CvGV(cv));
+ if(SvPOK(cv)) {
+ has_proto = TRUE;
+ }
+
+ cv_undef(cv);
+ CvGV(cv) = gv; /* let user-undef'd sub keep its identity */
+ if(has_proto) {
+ SvPOK_on(cv); /* otherwise we get `Prototype mismatch:' */
+ }
+
+ break;
+
+ default:
+ warn("undef called without a CODE reference!\n");
+ }
+}
+
Index: xs/maps/modperl_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.57
diff -u -I$Id -r1.57 modperl_functions.map
--- xs/maps/modperl_functions.map 30 May 2003 12:55:14 -0000 1.57
+++ xs/maps/modperl_functions.map 19 Jun 2003 05:01:33 -0000
@@ -2,6 +2,7 @@
MODULE=ModPerl::Util
mpxs_ModPerl__Util_untaint | | ...
+ mpxs_ModPerl__Util_undef
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.116
diff -u -I$Id -r1.116 FunctionTable.pm
--- xs/tables/current/ModPerl/FunctionTable.pm 4 Jun 2003 16:50:38 -0000 1.116
+++ xs/tables/current/ModPerl/FunctionTable.pm 19 Jun 2003 05:01:33 -0000
@@ -3675,6 +3675,20 @@
},
],
},
+ {
+ 'return_type' => 'void',
+ 'name' => 'mpxs_ModPerl__Util_undef',
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'SV *',
+ 'name' => 'ref'
+ },
+ ],
+ },
{
'return_type' => 'HE *',
'name' => 'modperl_perl_hv_fetch_he',
--
--------------------------------------------------------------------------------
Philippe M. Chiasson /gozer\@(cpan|ectoplasm)\.org/ 88C3A5A5 (122FF51B/C634E37B)
http://gozer.ectoplasm.org/ F9BF E0C2 480E 7680 1AE5 3631 CB32 A107 88C3 A5A5
Q: It is impossible to make anything foolproof because fools are so ingenious.
perl -e'$$=\${gozer};{$_=unpack(P7,pack(L,$$));/^JAm_pH\n$/&&print||$$++&&redo}'
signature.asc
Description: This is a digitally signed message part
