X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FSub%2FOp.pm;h=6b421c4be5a17f3f6b3a9a2f91e63386c48f53b5;hb=a0c0873977f66d8024a988b8dbd8e1c092927189;hp=bb2f345fbb67b2773640139be21ff6a60c1bc729;hpb=cca835349c605e0526dc400c6224e4551bf8b54a;p=perl%2Fmodules%2FSub-Op.git

diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm
index bb2f345..6b421c4 100644
--- a/lib/Sub/Op.pm
+++ b/lib/Sub/Op.pm
@@ -50,11 +50,11 @@ In your XS file :
     BOOT:
     {
      sub_op_config_t c;
-     c.name  = "reftype";
-     c.len   = sizeof("reftype")-1;
-     c.pp    = scalar_util_reftype;
-     c.check = 0;
-     c.ud    = NULL;
+     c.name    = "reftype";
+     c.namelen = sizeof("reftype")-1;
+     c.pp      = scalar_util_reftype;
+     c.check   = 0;
+     c.ud      = NULL;
      sub_op_register(aTHX_ &c);
     }
 
@@ -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;
 
@@ -140,13 +142,30 @@ 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;
  },
 );
 
+sub _tag {
+ my ($pkg, $name) = @_;
+
+ my $fqn = join '::', $pkg, $name;
+
+ return {
+  old   => _defined_sub($fqn) ? \&$fqn : undef,
+  proto => prototype($fqn),
+ };
+}
+
 sub _map {
  my ($pkg) = @_;
 
@@ -161,8 +180,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 {
@@ -190,7 +215,7 @@ Allowed to be static.
 
 =item *
 
-C<STRLEN len>
+C<STRLEN namelen>
 
 C<name>'s length, in bytes.
 
@@ -242,14 +267,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 +301,26 @@ sub disable {
  my $name = shift;
 
  my $pkg = @_ > 0 ? $_[0] : caller;
- my $fqn = "${pkg}::$name";
-
  my $map = _map($pkg);
 
+ my $fqn = join '::', $pkg, $name;
+
  if (defined $map) {
+  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(\&$fqn, $proto);
+  }
+
   delete $map->{$name};
   unless (keys %$map) {
    _dispell($pkg);
@@ -298,6 +342,18 @@ sub _inject {
  }
 }
 
+sub _defined_sub {
+ my ($fqn) = @_;
+ my @parts = split /::/, $fqn;
+ my $name  = pop @parts;
+ my $pkg   = '';
+ for (@parts) {
+  $pkg .= $_ . '::';
+  return 0 unless do { no strict 'refs'; %$pkg };
+ }
+ return do { no strict 'refs'; defined &{"$pkg$name"} };
+}
+
 {
  my $injector;
  BEGIN {
@@ -336,10 +392,11 @@ sub _inject {
    $obj->SUPER::can($meth);
   };
 
-  if (%B:: and %B::OP:: and *B::OP::type{CODE}) {
+  if (_defined_sub('B::OP::type')) {
    _inject('B::OP', \%B_OP_inject);
   } else {
-   Variable::Magic::cast %B::OP::, $injector, 'B::OP', \%B_OP_inject;
+   no strict 'refs';
+   Variable::Magic::cast %{'B::OP::'}, $injector, 'B::OP', \%B_OP_inject;
   }
 
   my $B_Deparse_inject = {
@@ -347,12 +404,13 @@ sub _inject {
     my ($self, $op, $cx) = @_;
     my $name = _custom_name($op);
     die 'unhandled custom op' unless defined $name;
-    if ($op->flags & B::OPf_STACKED()) {
+    if ($op->flags & do { no strict 'refs'; &{'B::OPf_STACKED'}() }) {
      my $kid = $op->first;
      $kid = $kid->first->sibling; # skip ex-list, pushmark
      my @exprs;
-     for (; not B::Deparse::null($kid); $kid = $kid->sibling) {
+     while (not do { no strict 'refs'; &{'B::Deparse::null'}($kid) }) {
       push @exprs, $self->deparse($kid, 6);
+      $kid = $kid->sibling;
      }
      my $args = join(", ", @exprs);
      return "$name($args)";
@@ -362,10 +420,11 @@ sub _inject {
    },
   };
 
-  if (%B:: and %B::Deparse:: and *B::Deparse::pp_entersub{CODE}) {
+  if (_defined_sub('B::Deparse::pp_entersub')) {
    _inject('B::Deparse', $B_Deparse_inject);
   } else {
-   Variable::Magic::cast %B::Deparse::, $injector, 'B::Deparse', $B_Deparse_inject;
+   no strict 'refs';
+   Variable::Magic::cast %{'B::Deparse::'}, $injector, 'B::Deparse', $B_Deparse_inject;
   }
  }
 }
@@ -388,6 +447,10 @@ L<ExtUtils::Depends>.
 
 L<subs::auto>.
 
+L<B::Hooks::XSUB::CallAsOp> provides a C API to declare XSUBs that effectively call a specific PP function.
+Thus, it allows you to write XSUBs with the PP stack conventions used for implementing perl core keywords.
+There's no opcode replacement and no parsing hacks.
+
 L<B::Hooks::OP::Check::EntersubForCV>.
 
 =head1 AUTHOR