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