lib/Sub/Op.pm

   1 package Sub::Op;
   2
   3 use 5.010;
   4
   5 use strict;
   6 use warnings;
   7
   8 =head1 NAME
   9
  10 Sub::Op - Install subroutines as opcodes.
  11
  12 =head1 VERSION
  13
  14 Version 0.01
  15
  16 =cut
  17
  18 our ($VERSION, @ISA);
  19
  20 sub dl_load_flags { 0x01 }
  21
  22 BEGIN {
  23  $VERSION = '0.01';
  24  require DynaLoader;
  25  push @ISA, 'DynaLoader';
  26  __PACKAGE__->bootstrap($VERSION);
  27 }
  28
  29 =head1 SYNOPSIS
  30
  31 In your XS file :
  32
  33     #include "sub_op.h"
  34
  35     STATIC OP *scalar_util_reftype(pTHX) {
  36      dSP;
  37      dMARK;
  38      SV *sv = POPs;
  39      if (SvMAGICAL(sv))
  40       mg_get(sv);
  41      if (SvROK(sv))
  42       PUSHs(sv_reftype(SvRV(sv), 0));
  43      else
  44       PUSHs(&PL_sv_undef);
  45      RETURN;
  46     }
  47
  48     MODULE = Scalar::Util::Ops       PACKAGE = Scalar::Util::Ops
  49
  50     BOOT:
  51     {
  52      sub_op_keyword k;
  53      k.name  = "reftype";
  54      k.len   = sizeof("reftype")-1;
  55      k.pp    = scalar_util_reftype;
  56      k.check = 0;
  57      k.ud    = NULL;
  58      sub_op_register(aTHX_ &k);
  59     }
  60
  61 In your Perl module file :
  62
  63     package Scalar::Util::Ops;
  64
  65     use strict;
  66     use warnings;
  67
  68     our ($VERSION, @ISA);
  69
  70     use Sub::Op; # Before loading our own shared library
  71
  72     BEGIN {
  73      $VERSION = '0.01';
  74      require DynaLoader;
  75      push @ISA, 'DynaLoader';
  76      __PACKAGE__->bootstrap($VERSION);
  77     }
  78
  79     sub import   { Sub::Op::enable(reftype => scalar caller) }
  80
  81     sub unimport { Sub::Op::disable(reftype => scalar caller) }
  82
  83     1;
  84
  85 In your F<Makefile.PL> :
  86
  87     use ExtUtils::Depends;
  88
  89     my $ed = ExtUtils::Depends->new('Scalar::Util::Ops' => 'Sub::Op');
  90
  91     WriteMakefile(
  92      $ed->get_makefile_vars,
  93      ...
  94     );
  95
  96 =cut
  97
  98 use B::Hooks::EndOfScope;
  99 use Variable::Magic 0.08;
 100
 101 my $placeholder;
 102 BEGIN {
 103  $placeholder = sub { require Carp; Carp::croak('PLACEHOLDER') };
 104  _placeholder($placeholder);
 105 }
 106
 107 my $sw = Variable::Magic::wizard(
 108  data  => sub { +{ guard => 0, pkg => $_[1], map => $_[2] } },
 109  fetch => sub {
 110   my ($var, $data, $name) = @_;
 111
 112   return if $data->{guard};
 113   local $data->{guard} = 1;
 114
 115   return unless $data->{map}->{$name};
 116
 117   my $pkg = $data->{pkg};
 118   my $fqn = join '::', $pkg, $name;
 119
 120   no strict 'refs';
 121   *$fqn = $placeholder unless exists &$fqn;
 122
 123   return;
 124  },
 125 );
 126
 127 sub _map {
 128  my ($pkg) = @_;
 129
 130  my $data = do {
 131   no strict 'refs';
 132   Variable::Magic::getdata(%{"${pkg}::"}, $sw);
 133  };
 134
 135  defined $data ? $data->{map} : undef;
 136 }
 137
 138 sub _cast {
 139  my ($pkg, $name) = @_;
 140
 141  no strict 'refs';
 142  Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, { $name => 1 });
 143 }
 144
 145 sub _dispell {
 146  my ($pkg) = @_;
 147
 148  no strict 'refs';
 149  Variable::Magic::dispell(%{"${pkg}::"}, $sw);
 150 }
 151
 152 sub enable {
 153  my $name = shift;
 154
 155  my $pkg = @_ > 0 ? $_[0] : caller;
 156  my $fqn = "${pkg}::$name";
 157
 158  my $map = _map($pkg);
 159
 160  if (defined $map) {
 161   $map->{$name} = 1;
 162  } else {
 163   _cast($pkg, $name);
 164  }
 165
 166  $^H |= 0x00020000;
 167  $^H{+(__PACKAGE__)} = 1;
 168
 169  on_scope_end { disable($name, $pkg) };
 170
 171  return;
 172 }
 173
 174 sub disable {
 175  my $name = shift;
 176
 177  my $pkg = @_ > 0 ? $_[0] : caller;
 178  my $fqn = "${pkg}::$name";
 179
 180  my $map = _map($pkg);
 181
 182  if (defined $map) {
 183   delete $map->{$name};
 184   unless (keys %$map) {
 185    _dispell($pkg);
 186   }
 187  }
 188
 189  return;
 190 }
 191
 192 sub _inject {
 193  my ($pkg, $inject) = @_;
 194
 195  my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
 196
 197  while (my ($meth, $code) = each %$inject) {
 198   next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
 199   no strict 'refs';
 200   *{"${pkg}::$meth"} = $code;
 201  }
 202 }
 203
 204 {
 205  my $injector;
 206  BEGIN {
 207   $injector = Variable::Magic::wizard(
 208    data  => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
 209    store => sub {
 210     my ($stash, $data, $key) = @_;
 211
 212     return if $data->{guard};
 213     local $data->{guard} = 1;
 214
 215     _inject($data->{pkg}, $data->{subs});
 216
 217     return;
 218    },
 219   );
 220  }
 221
 222  sub _monkeypatch {
 223   my %B_OP_inject;
 224
 225   $B_OP_inject{first} = sub {
 226    if (defined _custom_name($_[0])) {
 227     $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
 228     goto $_[0]->can('first') || die 'oops';
 229    }
 230    require Carp;
 231    Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
 232   };
 233
 234   $B_OP_inject{can} = sub {
 235    my ($obj, $meth) = @_;
 236    if ($meth eq 'first') {
 237     return undef unless defined _custom_name($obj);
 238    }
 239    $obj->SUPER::can($meth);
 240   };
 241
 242   if (%B:: and %B::OP:: and *B::OP::type{CODE}) {
 243    _inject('B::OP', \%B_OP_inject);
 244   } else {
 245    Variable::Magic::cast %B::OP::, $injector, 'B::OP', \%B_OP_inject;
 246   }
 247
 248   my $B_Deparse_inject = {
 249    pp_custom => sub {
 250     my ($self, $op, $cx) = @_;
 251     my $name = _custom_name($op);
 252     die 'unhandled custom op' unless defined $name;
 253     if ($op->flags & B::OPf_STACKED()) {
 254      my $kid = $op->first;
 255      $kid = $kid->first->sibling; # skip ex-list, pushmark
 256      my @exprs;
 257      for (; not B::Deparse::null($kid); $kid = $kid->sibling) {
 258       push @exprs, $self->deparse($kid, 6);
 259      }
 260      my $args = join(", ", @exprs);
 261      return "$name($args)";
 262     } else {
 263      return $name;
 264     }
 265    },
 266   };
 267
 268   if (%B:: and %B::Deparse:: and *B::Deparse::pp_entersub{CODE}) {
 269    _inject('B::Deparse', $B_Deparse_inject);
 270   } else {
 271    Variable::Magic::cast %B::Deparse::, $injector, 'B::Deparse', $B_Deparse_inject;
 272   }
 273  }
 274 }
 275
 276 BEGIN { _monkeypatch() }
 277
 278 =head1 DEPENDENCIES
 279
 280 L<perl> 5.10.
 281
 282 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
 283
 284 L<ExtUtils::Depends>.
 285
 286 =head1 SEE ALSO
 287
 288 L<subs::auto>.
 289
 290 L<B::Hooks::OP::Check::EntersubForCV>.
 291
 292 =head1 AUTHOR
 293
 294 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 295
 296 You can contact me by mail or on C<irc.perl.org> (vincent).
 297
 298 =head1 BUGS
 299
 300 Please report any bugs or feature requests to C<bug-sub-op at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Sub-Op>.
 301 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 302
 303 =head1 SUPPORT
 304
 305 You can find documentation for this module with the perldoc command.
 306
 307     perldoc Sub::Op
 308
 309 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
 310
 311 =head1 COPYRIGHT & LICENSE
 312
 313 Copyright 2010 Vincent Pit, all rights reserved.
 314
 315 This program is free software; you can redistribute it and/or modify it
 316 under the same terms as Perl itself.
 317
 318 =cut
 319
 320 1; # End of Sub::Op