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