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_config_t c;
  53      c.name  = "reftype";
  54      c.len   = sizeof("reftype")-1;
  55      c.pp    = scalar_util_reftype;
  56      c.check = 0;
  57      c.ud    = NULL;
  58      sub_op_register(aTHX_ &c);
  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 =head1 DESCRIPTION
  97
  98 This module provides a C and Perl API for replacing subroutine calls by custom opcodes.
  99 This has two main advantages :
 100
 101 =over 4
 102
 103 =item *
 104
 105 it gets rid of the overhead of a normal subroutine call ;
 106
 107 =item *
 108
 109 there's no symbol table entry defined for the subroutine.
 110
 111 =back
 112
 113 Subroutine calls with and without parenthesis are handled.
 114 Ampersand calls are B<not> replaced, and as such will still allow to call a subroutine with same name defined earlier.
 115 This may or may not be considered as a bug, but it gives the same semantics as Perl keywords, so I believe it's reasonable.
 116
 117 When L<B> and L<B::Deparse> are loaded, they get automatically monkeypatched so that introspecting modules like L<B::Concise> and L<B::Deparse> still produce a valid output.
 118
 119 =cut
 120
 121 use Scalar::Util;
 122
 123 use B::Hooks::EndOfScope;
 124 use Variable::Magic 0.08;
 125
 126 my $placeholder;
 127 BEGIN {
 128  $placeholder = sub { require Carp; Carp::croak('PLACEHOLDER') };
 129  _placeholder($placeholder);
 130 }
 131
 132 my $sw = Variable::Magic::wizard(
 133  data  => sub { +{ guard => 0, pkg => $_[1], map => $_[2] } },
 134  fetch => sub {
 135   my ($var, $data, $name) = @_;
 136
 137   return if $data->{guard};
 138   local $data->{guard} = 1;
 139
 140   return unless $data->{map}->{$name};
 141
 142   my $pkg = $data->{pkg};
 143   my $fqn = join '::', $pkg, $name;
 144
 145   no strict 'refs';
 146   *$fqn = $placeholder unless exists &$fqn;
 147
 148   return;
 149  },
 150 );
 151
 152 sub _tag {
 153  my ($pkg, $name) = @_;
 154
 155  my $fqn = join '::', $pkg, $name;
 156
 157  return {
 158   proto => prototype($fqn),
 159  };
 160 }
 161
 162 sub _map {
 163  my ($pkg) = @_;
 164
 165  my $data = do {
 166   no strict 'refs';
 167   Variable::Magic::getdata(%{"${pkg}::"}, $sw);
 168  };
 169
 170  defined $data ? $data->{map} : undef;
 171 }
 172
 173 sub _cast {
 174  my ($pkg, $name) = @_;
 175
 176  my $map = { $name => _tag(@_) };
 177
 178  {
 179   no strict 'refs';
 180   Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, $map);
 181  }
 182
 183  return $map;
 184 }
 185
 186 sub _dispell {
 187  my ($pkg) = @_;
 188
 189  no strict 'refs';
 190  Variable::Magic::dispell(%{"${pkg}::"}, $sw);
 191 }
 192
 193 =head1 C API
 194
 195 =head2 C<sub_op_config_t>
 196
 197 A typedef'd struct that configures how L<Sub::Op> should handle a given subroutine name.
 198 It has the following members :
 199
 200 =over 4
 201
 202 =item *
 203
 204 C<const char *name>
 205
 206 The name of the subroutine you want to replace.
 207 Allowed to be static.
 208
 209 =item *
 210
 211 C<STRLEN len>
 212
 213 C<name>'s length, in bytes.
 214
 215 =item *
 216
 217 C<Perl_ppaddr_t pp>
 218
 219 The pp function that will be called instead of the subroutine.
 220 C<Perl_ppaddr_t> is a typedef'd function pointer defined by perl as :
 221
 222     typedef OP *(*Perl_ppaddr_t)(pTHX);
 223
 224 =item *
 225
 226 C<sub_op_check_t check>
 227
 228 An optional callback that will be called each time a call to C<name> is replaced.
 229 You can use it to attach extra info to those ops (e.g. with a pointer table) or to perform more optimizations to the optree.
 230 C<sub_op_check_t> is a typedef'd function pointer defined by :
 231
 232     typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
 233
 234 =item *
 235
 236 C<void *ud>
 237
 238 An optional user data passed to the C<check> callback.
 239
 240 =back
 241
 242 =head2 C<void sub_op_register(pTHX_ const sub_op_config_t *c)>
 243
 244 Registers a name and its configuration into L<Sub::Op>.
 245 The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
 246 No pointer to it or to its members is kept.
 247
 248 =head1 PERL API
 249
 250 =head2 C<enable $name, [ $pkg ]>
 251
 252 Enable the replacement with a custom opcode of calls to the C<$name> subroutine of the C<$pkg> package in the current lexical scope.
 253 A pp callback must have been registered for C<$name> by calling the C function C<sub_op_register> in the XS section of your module.
 254
 255 When C<$pkg> is not set, it defaults to the caller package.
 256
 257 =cut
 258
 259 sub enable {
 260  my $name = shift;
 261
 262  my $pkg = @_ > 0 ? $_[0] : caller;
 263  my $map = _map($pkg);
 264
 265  if (defined $map) {
 266   $map->{$name} = _tag($pkg, $name);
 267  } else {
 268   $map = _cast($pkg, $name);
 269  }
 270
 271  my $proto = $map->{$name}->{proto};
 272  if (defined $proto) {
 273   no strict 'refs';
 274   Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
 275  }
 276
 277  $^H |= 0x00020000;
 278  $^H{+(__PACKAGE__)} = 1;
 279
 280  on_scope_end { disable($name, $pkg) };
 281
 282  return;
 283 }
 284
 285 =head2 C<disable $name, [ $pkg ]>
 286
 287 Disable the replacement for calls to C<$name> in the package C<$pkg>.
 288
 289 When C<$pkg> is not set, it defaults to the caller package.
 290
 291 =cut
 292
 293 sub disable {
 294  my $name = shift;
 295
 296  my $pkg = @_ > 0 ? $_[0] : caller;
 297  my $map = _map($pkg);
 298
 299  if (defined $map) {
 300   my $proto = $map->{$name}->{proto};
 301   if (defined $proto) {
 302    no strict 'refs';
 303    Scalar::Util::set_prototype(\&{"${pkg}::$name"}, $proto);
 304   }
 305
 306   delete $map->{$name};
 307   unless (keys %$map) {
 308    _dispell($pkg);
 309   }
 310  }
 311
 312  return;
 313 }
 314
 315 sub _inject {
 316  my ($pkg, $inject) = @_;
 317
 318  my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
 319
 320  while (my ($meth, $code) = each %$inject) {
 321   next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
 322   no strict 'refs';
 323   *{"${pkg}::$meth"} = $code;
 324  }
 325 }
 326
 327 {
 328  my $injector;
 329  BEGIN {
 330   $injector = Variable::Magic::wizard(
 331    data  => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
 332    store => sub {
 333     my ($stash, $data, $key) = @_;
 334
 335     return if $data->{guard};
 336     local $data->{guard} = 1;
 337
 338     _inject($data->{pkg}, $data->{subs});
 339
 340     return;
 341    },
 342   );
 343  }
 344
 345  sub _monkeypatch {
 346   my %B_OP_inject;
 347
 348   $B_OP_inject{first} = sub {
 349    if (defined _custom_name($_[0])) {
 350     $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
 351     goto $_[0]->can('first') || die 'oops';
 352    }
 353    require Carp;
 354    Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
 355   };
 356
 357   $B_OP_inject{can} = sub {
 358    my ($obj, $meth) = @_;
 359    if ($meth eq 'first') {
 360     return undef unless $obj->isa('B::UNOP') or defined _custom_name($obj);
 361    }
 362    $obj->SUPER::can($meth);
 363   };
 364
 365   if (%B:: and %B::OP:: and *B::OP::type{CODE}) {
 366    _inject('B::OP', \%B_OP_inject);
 367   } else {
 368    Variable::Magic::cast %B::OP::, $injector, 'B::OP', \%B_OP_inject;
 369   }
 370
 371   my $B_Deparse_inject = {
 372    pp_custom => sub {
 373     my ($self, $op, $cx) = @_;
 374     my $name = _custom_name($op);
 375     die 'unhandled custom op' unless defined $name;
 376     if ($op->flags & B::OPf_STACKED()) {
 377      my $kid = $op->first;
 378      $kid = $kid->first->sibling; # skip ex-list, pushmark
 379      my @exprs;
 380      for (; not B::Deparse::null($kid); $kid = $kid->sibling) {
 381       push @exprs, $self->deparse($kid, 6);
 382      }
 383      my $args = join(", ", @exprs);
 384      return "$name($args)";
 385     } else {
 386      return $name;
 387     }
 388    },
 389   };
 390
 391   if (%B:: and %B::Deparse:: and *B::Deparse::pp_entersub{CODE}) {
 392    _inject('B::Deparse', $B_Deparse_inject);
 393   } else {
 394    Variable::Magic::cast %B::Deparse::, $injector, 'B::Deparse', $B_Deparse_inject;
 395   }
 396  }
 397 }
 398
 399 BEGIN { _monkeypatch() }
 400
 401 =head1 EXAMPLES
 402
 403 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
 404
 405 =head1 DEPENDENCIES
 406
 407 L<perl> 5.10.
 408
 409 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
 410
 411 L<ExtUtils::Depends>.
 412
 413 =head1 SEE ALSO
 414
 415 L<subs::auto>.
 416
 417 L<B::Hooks::OP::Check::EntersubForCV>.
 418
 419 =head1 AUTHOR
 420
 421 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 422
 423 You can contact me by mail or on C<irc.perl.org> (vincent).
 424
 425 =head1 BUGS
 426
 427 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>.
 428 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 429
 430 =head1 SUPPORT
 431
 432 You can find documentation for this module with the perldoc command.
 433
 434     perldoc Sub::Op
 435
 436 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
 437
 438 =head1 COPYRIGHT & LICENSE
 439
 440 Copyright 2010 Vincent Pit, all rights reserved.
 441
 442 This program is free software; you can redistribute it and/or modify it
 443 under the same terms as Perl itself.
 444
 445 =cut
 446
 447 1; # End of Sub::Op