lib/Sub/Op.pm

   1 package Sub::Op;
   2
   3 use 5.010;
   4
   5 use strict;
   6 use warnings;
   7
   8 our ($VERSION, @ISA);
   9
  10 sub dl_load_flags { 0x01 }
  11
  12 BEGIN {
  13  $VERSION = '0.01';
  14  require DynaLoader;
  15  push @ISA, 'DynaLoader';
  16  __PACKAGE__->bootstrap($VERSION);
  17 }
  18
  19 use B::Hooks::EndOfScope;
  20 use Variable::Magic 0.08;
  21
  22 my $placeholder;
  23 BEGIN {
  24  $placeholder = sub { require Carp; Carp::croak('PLACEHOLDER') };
  25  _placeholder($placeholder);
  26 }
  27
  28 my $sw = Variable::Magic::wizard(
  29  data  => sub { +{ guard => 0, pkg => $_[1], map => $_[2] } },
  30  fetch => sub {
  31   my ($var, $data, $name) = @_;
  32
  33   return if $data->{guard};
  34   local $data->{guard} = 1;
  35
  36   return unless $data->{map}->{$name};
  37
  38   my $pkg = $data->{pkg};
  39   my $fqn = join '::', $pkg, $name;
  40
  41   _incoming($name, $pkg);
  42
  43   no strict 'refs';
  44   *$fqn = $placeholder unless exists &$fqn;
  45
  46   return;
  47  },
  48 );
  49
  50 sub _map {
  51  my ($pkg) = @_;
  52
  53  my $data = do {
  54   no strict 'refs';
  55   Variable::Magic::getdata(%{"${pkg}::"}, $sw);
  56  };
  57
  58  defined $data ? $data->{map} : undef;
  59 }
  60
  61 sub _cast {
  62  my ($pkg, $name) = @_;
  63
  64  no strict 'refs';
  65  Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, { $name => 1 });
  66 }
  67
  68 sub _dispell {
  69  my ($pkg) = @_;
  70
  71  no strict 'refs';
  72  Variable::Magic::dispell(%{"${pkg}::"}, $sw);
  73 }
  74
  75 sub enable {
  76  my $name = shift;
  77
  78  my $pkg = @_ > 0 ? $_[0] : caller;
  79  my $fqn = "${pkg}::$name";
  80
  81  my $map = _map($pkg);
  82
  83  if (defined $map) {
  84   $map->{$name} = 1;
  85  } else {
  86   _cast($pkg, $name);
  87  }
  88
  89  $^H |= 0x00020000;
  90  $^H{+(__PACKAGE__)} = 1;
  91
  92  on_scope_end { disable($name, $pkg) };
  93
  94  return;
  95 }
  96
  97 sub disable {
  98  my $name = shift;
  99
 100  my $pkg = @_ > 0 ? $_[0] : caller;
 101  my $fqn = "${pkg}::$name";
 102
 103  my $map = _map($pkg);
 104
 105  if (defined $map) {
 106   delete $map->{$name};
 107   unless (keys %$map) {
 108    _dispell($pkg);
 109   }
 110  }
 111
 112  return;
 113 }
 114
 115 sub _inject {
 116  my ($pkg, $inject) = @_;
 117
 118  my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
 119
 120  while (my ($meth, $code) = each %$inject) {
 121   next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
 122   no strict 'refs';
 123   *{"${pkg}::$meth"} = $code;
 124  }
 125 }
 126
 127 {
 128  my $injector;
 129  BEGIN {
 130   $injector = Variable::Magic::wizard(
 131    data  => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
 132    store => sub {
 133     my ($stash, $data, $key) = @_;
 134
 135     return if $data->{guard};
 136     local $data->{guard} = 1;
 137
 138     _inject($data->{pkg}, $data->{subs});
 139
 140     return;
 141    },
 142   );
 143  }
 144
 145  sub _monkeypatch {
 146   my %B_OP_inject;
 147
 148   $B_OP_inject{first} = sub {
 149    if (defined _custom_name($_[0])) {
 150     $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
 151     goto $_[0]->can('first') || die 'oops';
 152    }
 153    require Carp;
 154    Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
 155   };
 156
 157   $B_OP_inject{can} = sub {
 158    my ($obj, $meth) = @_;
 159    if ($meth eq 'first') {
 160     return undef unless defined _custom_name($obj);
 161    }
 162    $obj->SUPER::can($meth);
 163   };
 164
 165   if (%B:: and %B::OP:: and *B::OP::type{CODE}) {
 166    _inject('B::OP', \%B_OP_inject);
 167   } else {
 168    Variable::Magic::cast %B::OP::, $injector, 'B::OP', \%B_OP_inject;
 169   }
 170
 171   my $B_Deparse_inject = {
 172    pp_custom => sub {
 173     my ($self, $op, $cx) = @_;
 174     my $name = _custom_name($op);
 175     die 'unhandled custom op' unless defined $name;
 176     if ($op->flags & B::OPf_STACKED()) {
 177      my $kid = $op->first;
 178      $kid = $kid->first->sibling; # skip ex-list, pushmark
 179      my @exprs;
 180      for (; not B::Deparse::null($kid); $kid = $kid->sibling) {
 181       push @exprs, $self->deparse($kid, 6);
 182      }
 183      my $args = join(", ", @exprs);
 184      return "$name($args)";
 185     } else {
 186      return $name;
 187     }
 188    },
 189   };
 190
 191   if (%B:: and %B::Deparse:: and *B::Deparse::pp_entersub{CODE}) {
 192    _inject('B::Deparse', $B_Deparse_inject);
 193   } else {
 194    Variable::Magic::cast %B::Deparse::, $injector, 'B::Deparse', $B_Deparse_inject;
 195   }
 196  }
 197 }
 198
 199 BEGIN { _monkeypatch() }
 200
 201 1; # End of Sub::Op