X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Op.git;a=blobdiff_plain;f=lib%2FSub%2FOp.pm;fp=lib%2FSub%2FOp.pm;h=d8a6b738c7461f856af60f1137ac4ac725f9b9b2;hp=a0f25a9473d31ab4b9e82f847e020d5471fcbb73;hb=0eb003f3bbeeada878cab10f7dabc020c775b666;hpb=302bf09fbd4b673e199bdd22b330ebbdbec4e1fe

diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm
index a0f25a9..d8a6b73 100644
--- a/lib/Sub/Op.pm
+++ b/lib/Sub/Op.pm
@@ -164,6 +164,18 @@ my $sw = Variable::Magic::wizard(
  },
 );
 
+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"} };
+}
+
 sub _tag {
  my ($pkg, $name) = @_;
 
@@ -366,107 +378,6 @@ sub disable {
  return;
 }
 
-sub _inject {
- my ($pkg, $inject) = @_;
-
- my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
-
- while (my ($meth, $code) = each %$inject) {
-  next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
-  no strict 'refs';
-  *{"${pkg}::$meth"} = $code;
- }
-}
-
-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 {
-  $injector = Variable::Magic::wizard(
-   data  => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
-   store => sub {
-    my ($stash, $data, $key) = @_;
-
-    return if $data->{guard};
-    local $data->{guard} = 1;
-
-    _inject($data->{pkg}, $data->{subs});
-
-    return;
-   },
-  );
- }
-
- sub _monkeypatch {
-  my %B_OP_inject;
-
-  $B_OP_inject{first} = sub {
-   if (defined _custom_name($_[0])) {
-    $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
-    goto $_[0]->can('first') || die 'oops';
-   }
-   require Carp;
-   Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
-  };
-
-  $B_OP_inject{can} = sub {
-   my ($obj, $meth) = @_;
-   if ($meth eq 'first') {
-    return undef unless $obj->isa('B::UNOP') or defined _custom_name($obj);
-   }
-   $obj->SUPER::can($meth);
-  };
-
-  if (_defined_sub('B::OP::type')) {
-   _inject('B::OP', \%B_OP_inject);
-  } else {
-   no strict 'refs';
-   Variable::Magic::cast %{'B::OP::'}, $injector, 'B::OP', \%B_OP_inject;
-  }
-
-  my $B_Deparse_inject = {
-   pp_custom => sub {
-    my ($self, $op, $cx) = @_;
-    my $name = _custom_name($op);
-    die 'unhandled custom op' unless defined $name;
-    if ($op->flags & do { no strict 'refs'; &{'B::OPf_STACKED'}() }) {
-     my $kid = $op->first;
-     $kid = $kid->first->sibling; # skip ex-list, pushmark
-     my @exprs;
-     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)";
-    } else {
-     return $name;
-    }
-   },
-  };
-
-  if (_defined_sub('B::Deparse::pp_entersub')) {
-   _inject('B::Deparse', $B_Deparse_inject);
-  } else {
-   no strict 'refs';
-   Variable::Magic::cast %{'B::Deparse::'}, $injector, 'B::Deparse', $B_Deparse_inject;
-  }
- }
-}
-
-BEGIN { _monkeypatch() }
-
 =head1 EXAMPLES
 
 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.