X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FSub%2FOp.pm;h=8c8f6c87a4df667033ccba09f8a57db8b118221f;hb=5ae3324ff295015e051249ded13b2353ee8af258;hp=8e380ca6835b49a9410b0753778e5a418812b292;hpb=14a44e7b2f834cbd0d2ba8cc63deda55b3e5f0dd;p=perl%2Fmodules%2FSub-Op.git

diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm
index 8e380ca..8c8f6c8 100644
--- a/lib/Sub/Op.pm
+++ b/lib/Sub/Op.pm
@@ -118,6 +118,8 @@ When L<B> and L<B::Deparse> are loaded, they get automatically monkeypatched so
 
 =cut
 
+use Scalar::Util;
+
 use B::Hooks::EndOfScope;
 use Variable::Magic 0.08;
 
@@ -147,6 +149,16 @@ my $sw = Variable::Magic::wizard(
  },
 );
 
+sub _tag {
+ my ($pkg, $name) = @_;
+
+ my $fqn = join '::', $pkg, $name;
+
+ return {
+  proto => prototype($fqn),
+ };
+}
+
 sub _map {
  my ($pkg) = @_;
 
@@ -161,8 +173,14 @@ sub _map {
 sub _cast {
  my ($pkg, $name) = @_;
 
- no strict 'refs';
- Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, { $name => 1 });
+ my $map = { $name => _tag(@_) };
+
+ {
+  no strict 'refs';
+  Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, $map);
+ }
+
+ return $map;
 }
 
 sub _dispell {
@@ -242,14 +260,18 @@ sub enable {
  my $name = shift;
 
  my $pkg = @_ > 0 ? $_[0] : caller;
- my $fqn = "${pkg}::$name";
-
  my $map = _map($pkg);
 
  if (defined $map) {
-  $map->{$name} = 1;
+  $map->{$name} = _tag($pkg, $name);
  } else {
-  _cast($pkg, $name);
+  $map = _cast($pkg, $name);
+ }
+
+ my $proto = $map->{$name}->{proto};
+ if (defined $proto) {
+  no strict 'refs';
+  Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
  }
 
  $^H |= 0x00020000;
@@ -272,11 +294,15 @@ sub disable {
  my $name = shift;
 
  my $pkg = @_ > 0 ? $_[0] : caller;
- my $fqn = "${pkg}::$name";
-
  my $map = _map($pkg);
 
  if (defined $map) {
+  my $proto = $map->{$name}->{proto};
+  if (defined $proto) {
+   no strict 'refs';
+   Scalar::Util::set_prototype(\&{"${pkg}::$name"}, $proto);
+  }
+
   delete $map->{$name};
   unless (keys %$map) {
    _dispell($pkg);
@@ -331,7 +357,7 @@ sub _inject {
   $B_OP_inject{can} = sub {
    my ($obj, $meth) = @_;
    if ($meth eq 'first') {
-    return undef unless defined _custom_name($obj);
+    return undef unless $obj->isa('B::UNOP') or defined _custom_name($obj);
    }
    $obj->SUPER::can($meth);
   };