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.02
  15
  16 =cut
  17
  18 our ($VERSION, @ISA);
  19
  20 sub dl_load_flags { 0x01 }
  21
  22 BEGIN {
  23  $VERSION = '0.02';
  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.namelen = 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   {
 146    local $SIG{__WARN__} = sub {
 147     CORE::warn(@_) unless $_[0] =~ /^Constant subroutine.*redefined/;
 148    } if _constant_sub(do { no strict 'refs'; \&$fqn });
 149    no strict 'refs';
 150    no warnings 'redefine';
 151    *$fqn = $placeholder;
 152   }
 153
 154   return;
 155  },
 156 );
 157
 158 sub _tag {
 159  my ($pkg, $name) = @_;
 160
 161  my $fqn = join '::', $pkg, $name;
 162
 163  return {
 164   old   => _defined_sub($fqn) ? \&$fqn : undef,
 165   proto => prototype($fqn),
 166  };
 167 }
 168
 169 sub _map {
 170  my ($pkg) = @_;
 171
 172  my $data = do {
 173   no strict 'refs';
 174   Variable::Magic::getdata(%{"${pkg}::"}, $sw);
 175  };
 176
 177  defined $data ? $data->{map} : undef;
 178 }
 179
 180 sub _cast {
 181  my ($pkg, $name) = @_;
 182
 183  my $map = { $name => _tag(@_) };
 184
 185  {
 186   no strict 'refs';
 187   Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, $map);
 188  }
 189
 190  return $map;
 191 }
 192
 193 sub _dispell {
 194  my ($pkg) = @_;
 195
 196  no strict 'refs';
 197  Variable::Magic::dispell(%{"${pkg}::"}, $sw);
 198 }
 199
 200 =head1 C API
 201
 202 =head2 C<sub_op_config_t>
 203
 204 A typedef'd struct that configures how L<Sub::Op> should handle a given subroutine name.
 205 It has the following members :
 206
 207 =over 4
 208
 209 =item *
 210
 211 C<const char *name>
 212
 213 The name of the subroutine you want to replace.
 214 Allowed to be static.
 215
 216 =item *
 217
 218 C<STRLEN namelen>
 219
 220 C<name>'s length, in bytes.
 221
 222 =item *
 223
 224 C<Perl_ppaddr_t pp>
 225
 226 The pp function that will be called instead of the subroutine.
 227 C<Perl_ppaddr_t> is a typedef'd function pointer defined by perl as :
 228
 229     typedef OP *(*Perl_ppaddr_t)(pTHX);
 230
 231 =item *
 232
 233 C<sub_op_check_t check>
 234
 235 An optional callback that will be called each time a call to C<name> is replaced.
 236 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.
 237 C<sub_op_check_t> is a typedef'd function pointer defined by :
 238
 239     typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
 240
 241 =item *
 242
 243 C<void *ud>
 244
 245 An optional user data passed to the C<check> callback.
 246
 247 =back
 248
 249 =head2 C<void sub_op_register(pTHX_ const sub_op_config_t *c)>
 250
 251 Registers a name and its configuration into L<Sub::Op>.
 252 The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
 253 No pointer to it or to its members is kept.
 254
 255 =head1 PERL API
 256
 257 =head2 C<enable $name, [ $pkg ]>
 258
 259 Enable the replacement with a custom opcode of calls to the C<$name> subroutine of the C<$pkg> package in the current lexical scope.
 260 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.
 261
 262 When C<$pkg> is not set, it defaults to the caller package.
 263
 264 =cut
 265
 266 sub enable {
 267  my $name = shift;
 268
 269  my $pkg = @_ > 0 ? $_[0] : caller;
 270  my $map = _map($pkg);
 271
 272  if (defined $map) {
 273   $map->{$name} = _tag($pkg, $name);
 274  } else {
 275   $map = _cast($pkg, $name);
 276  }
 277
 278  my $proto = $map->{$name}->{proto};
 279  if (defined $proto) {
 280   no strict 'refs';
 281   Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
 282  }
 283
 284  $^H |= 0x00020000;
 285  $^H{+(__PACKAGE__)} = 1;
 286
 287  on_scope_end { disable($name, $pkg) };
 288
 289  return;
 290 }
 291
 292 =head2 C<disable $name, [ $pkg ]>
 293
 294 Disable the replacement for calls to C<$name> in the package C<$pkg>.
 295
 296 When C<$pkg> is not set, it defaults to the caller package.
 297
 298 =cut
 299
 300 sub disable {
 301  my $name = shift;
 302
 303  my $pkg = @_ > 0 ? $_[0] : caller;
 304  my $map = _map($pkg);
 305
 306  my $fqn = join '::', $pkg, $name;
 307
 308  if (defined $map) {
 309   my $tag = $map->{$name};
 310
 311   my $old = $tag->{old};
 312   if (defined $old) {
 313    no strict 'refs';
 314    no warnings 'redefine';
 315    *$fqn = $old;
 316   }
 317
 318   my $proto = $tag->{proto};
 319   if (defined $proto) {
 320    no strict 'refs';
 321    Scalar::Util::set_prototype(\&$fqn, $proto);
 322   }
 323
 324   delete $map->{$name};
 325   unless (keys %$map) {
 326    _dispell($pkg);
 327   }
 328  }
 329
 330  return;
 331 }
 332
 333 sub _inject {
 334  my ($pkg, $inject) = @_;
 335
 336  my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
 337
 338  while (my ($meth, $code) = each %$inject) {
 339   next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
 340   no strict 'refs';
 341   *{"${pkg}::$meth"} = $code;
 342  }
 343 }
 344
 345 sub _defined_sub {
 346  my ($fqn) = @_;
 347  my @parts = split /::/, $fqn;
 348  my $name  = pop @parts;
 349  my $pkg   = '';
 350  for (@parts) {
 351   $pkg .= $_ . '::';
 352   return 0 unless do { no strict 'refs'; %$pkg };
 353  }
 354  return do { no strict 'refs'; defined &{"$pkg$name"} };
 355 }
 356
 357 {
 358  my $injector;
 359  BEGIN {
 360   $injector = Variable::Magic::wizard(
 361    data  => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
 362    store => sub {
 363     my ($stash, $data, $key) = @_;
 364
 365     return if $data->{guard};
 366     local $data->{guard} = 1;
 367
 368     _inject($data->{pkg}, $data->{subs});
 369
 370     return;
 371    },
 372   );
 373  }
 374
 375  sub _monkeypatch {
 376   my %B_OP_inject;
 377
 378   $B_OP_inject{first} = sub {
 379    if (defined _custom_name($_[0])) {
 380     $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
 381     goto $_[0]->can('first') || die 'oops';
 382    }
 383    require Carp;
 384    Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
 385   };
 386
 387   $B_OP_inject{can} = sub {
 388    my ($obj, $meth) = @_;
 389    if ($meth eq 'first') {
 390     return undef unless $obj->isa('B::UNOP') or defined _custom_name($obj);
 391    }
 392    $obj->SUPER::can($meth);
 393   };
 394
 395   if (_defined_sub('B::OP::type')) {
 396    _inject('B::OP', \%B_OP_inject);
 397   } else {
 398    no strict 'refs';
 399    Variable::Magic::cast %{'B::OP::'}, $injector, 'B::OP', \%B_OP_inject;
 400   }
 401
 402   my $B_Deparse_inject = {
 403    pp_custom => sub {
 404     my ($self, $op, $cx) = @_;
 405     my $name = _custom_name($op);
 406     die 'unhandled custom op' unless defined $name;
 407     if ($op->flags & do { no strict 'refs'; &{'B::OPf_STACKED'}() }) {
 408      my $kid = $op->first;
 409      $kid = $kid->first->sibling; # skip ex-list, pushmark
 410      my @exprs;
 411      while (not do { no strict 'refs'; &{'B::Deparse::null'}($kid) }) {
 412       push @exprs, $self->deparse($kid, 6);
 413       $kid = $kid->sibling;
 414      }
 415      my $args = join(", ", @exprs);
 416      return "$name($args)";
 417     } else {
 418      return $name;
 419     }
 420    },
 421   };
 422
 423   if (_defined_sub('B::Deparse::pp_entersub')) {
 424    _inject('B::Deparse', $B_Deparse_inject);
 425   } else {
 426    no strict 'refs';
 427    Variable::Magic::cast %{'B::Deparse::'}, $injector, 'B::Deparse', $B_Deparse_inject;
 428   }
 429  }
 430 }
 431
 432 BEGIN { _monkeypatch() }
 433
 434 =head1 EXAMPLES
 435
 436 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
 437
 438 =head1 CAVEATS
 439
 440 Preexistent definitions of a sub whose name is handled by L<Sub::Op> are restored at the end of the lexical scope in which the module is used.
 441 But if you define a sub in the scope of action of L<Sub::Op> with a name that is currently being replaced, the new declaration will be obliterated at the scope end.
 442
 443 Function calls without parenthesis inside an C<eval STRING> in the scope of the pragma won't be replaced.
 444 I know a few ways of fixing this, but I've not yet decided on which.
 445
 446 =head1 DEPENDENCIES
 447
 448 L<perl> 5.10.
 449
 450 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
 451
 452 L<ExtUtils::Depends>.
 453
 454 =head1 SEE ALSO
 455
 456 L<subs::auto>.
 457
 458 L<B::Hooks::XSUB::CallAsOp> provides a C API to declare XSUBs that effectively call a specific PP function.
 459 Thus, it allows you to write XSUBs with the PP stack conventions used for implementing perl core keywords.
 460 There's no opcode replacement and no parsing hacks.
 461
 462 L<B::Hooks::OP::Check::EntersubForCV>.
 463
 464 =head1 AUTHOR
 465
 466 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 467
 468 You can contact me by mail or on C<irc.perl.org> (vincent).
 469
 470 =head1 BUGS
 471
 472 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>.
 473 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 474
 475 =head1 SUPPORT
 476
 477 You can find documentation for this module with the perldoc command.
 478
 479     perldoc Sub::Op
 480
 481 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
 482
 483 =head1 COPYRIGHT & LICENSE
 484
 485 Copyright 2010 Vincent Pit, all rights reserved.
 486
 487 This program is free software; you can redistribute it and/or modify it
 488 under the same terms as Perl itself.
 489
 490 =cut
 491
 492 1; # End of Sub::Op