From: Vincent Pit <vince@profvince.com>
Date: Mon, 4 Jan 2010 14:49:06 +0000 (+0100)
Subject: Handle existing constant subs
X-Git-Tag: v0.02~6
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=a3c83d0adc138681da18079c268948d2fe9326d7;p=perl%2Fmodules%2FSub-Op.git

Handle existing constant subs
---

diff --git a/Op.xs b/Op.xs
index 89716e7..cdcc89a 100644
--- a/Op.xs
+++ b/Op.xs
@@ -381,3 +381,15 @@ PPCODE:
   XSRETURN_UNDEF;
  ST(0) = sv_2mortal(newSVpvn(&on->buf, on->len));
  XSRETURN(1);
+
+void
+_constant_sub(SV *sv)
+PROTOTYPE: $
+PPCODE:
+ if (!SvROK(sv))
+  XSRETURN_UNDEF;
+ sv = SvRV(sv);
+ if (SvTYPE(sv) < SVt_PVCV)
+  XSRETURN_UNDEF;
+ ST(0) = sv_2mortal(newSVuv(CvCONST(sv)));
+ XSRETURN(1);
diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm
index c8f7c2e..c075bbb 100644
--- a/lib/Sub/Op.pm
+++ b/lib/Sub/Op.pm
@@ -142,8 +142,14 @@ my $sw = Variable::Magic::wizard(
   my $pkg = $data->{pkg};
   my $fqn = join '::', $pkg, $name;
 
-  no strict 'refs';
-  *$fqn = $placeholder unless exists &$fqn;
+  {
+   local $SIG{__WARN__} = sub {
+    CORE::warn(@_) unless $_[0] =~ /^Constant subroutine.*redefined/;
+   } if _constant_sub(do { no strict 'refs'; \&$fqn });
+   no strict 'refs';
+   no warnings 'redefine';
+   *$fqn = $placeholder;
+  }
 
   return;
  },
@@ -155,6 +161,7 @@ sub _tag {
  my $fqn = join '::', $pkg, $name;
 
  return {
+  old   => _defined_sub($fqn) ? \&$fqn : undef,
   proto => prototype($fqn),
  };
 }
@@ -296,11 +303,22 @@ sub disable {
  my $pkg = @_ > 0 ? $_[0] : caller;
  my $map = _map($pkg);
 
+ my $fqn = join '::', $pkg, $name;
+
  if (defined $map) {
-  my $proto = $map->{$name}->{proto};
+  my $tag = $map->{$name};
+
+  my $old = $tag->{old};
+  if (defined $old) {
+   no strict 'refs';
+   no warnings 'redefine';
+   *$fqn = $old;
+  }
+
+  my $proto = $tag->{proto};
   if (defined $proto) {
    no strict 'refs';
-   Scalar::Util::set_prototype(\&{"${pkg}::$name"}, $proto);
+   Scalar::Util::set_prototype(\&$fqn, $proto);
   }
 
   delete $map->{$name};
diff --git a/t/11-existing.t b/t/11-existing.t
index c45a71b..749fff1 100644
--- a/t/11-existing.t
+++ b/t/11-existing.t
@@ -5,7 +5,7 @@ use warnings;
 
 use blib 't/Sub-Op-LexicalSub';
 
-use Test::More tests => 2 *((4 + 2 * 4) + (2 * 5) + 1);
+use Test::More tests => 2 * ((1 + 2) * 4 + (1 + 1) * 5) + (2 + 2) + 4;
 
 our $call_foo;
 sub foo { ok $call_foo, 'the preexistent foo was called' }
@@ -13,6 +13,8 @@ sub foo { ok $call_foo, 'the preexistent foo was called' }
 our $call_bar;
 sub bar () { ok $call_bar, 'the preexistent bar was called' }
 
+sub X () { 1 }
+
 our $called;
 
 {
@@ -74,6 +76,9 @@ our $called;
 
 is prototype('main::foo'), undef, "foo's prototype was preserved";
 is prototype('main::bar'), '',    "bar's prototype was preserved";
+is prototype('main::X'),   '',    "X's prototype was preserved";
+ok Sub::Op::_constant_sub(do { no strict "refs"; \&{"main::X"} }),
+                                  'X is still a constant';
 
 __DATA__
 foo();
@@ -161,3 +166,7 @@ my $bar = \&bar;
 &$bar;
 ----
 bar # () #
+####
+is X, 2, 'constant overriding';
+----
+X # 2 # [ ]