perl-dev mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From "Philippe M. Chiasson" <go...@cpan.org>
Subject [mp2 Patch] ModPerl::Util::undef(coderef)
Date Thu, 19 Jun 2003 05:06:13 GMT
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}'


Mime
View raw message