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      sub_op_init(&c);
  54      c.name     = "reftype";
  55      c.namelen  = sizeof("reftype")-1;
  56      c.proto    = "$";
  57      c.protolen = sizeof("$")-1;
  58      c.pp       = scalar_util_reftype;
  59      c.check    = 0;
  60      c.ud       = NULL;
  61      sub_op_register(aTHX_ &c, 0);
  62     }
  63
  64 In your Perl module file :
  65
  66     package Scalar::Util::Ops;
  67
  68     use strict;
  69     use warnings;
  70
  71     our ($VERSION, @ISA);
  72
  73     use Sub::Op; # Before loading our own shared library
  74
  75     BEGIN {
  76      $VERSION = '0.01';
  77      require DynaLoader;
  78      push @ISA, 'DynaLoader';
  79      __PACKAGE__->bootstrap($VERSION);
  80     }
  81
  82     sub import   { Sub::Op::enable(reftype => scalar caller) }
  83
  84     sub unimport { Sub::Op::disable(reftype => scalar caller) }
  85
  86     1;
  87
  88 In your F<Makefile.PL> :
  89
  90     use ExtUtils::Depends;
  91
  92     my $ed = ExtUtils::Depends->new('Scalar::Util::Ops' => 'Sub::Op');
  93
  94     WriteMakefile(
  95      $ed->get_makefile_vars,
  96      ...
  97     );
  98
  99 =head1 DESCRIPTION
 100
 101 This module provides a C and Perl API for replacing subroutine calls by custom opcodes.
 102 This has two main advantages :
 103
 104 =over 4
 105
 106 =item *
 107
 108 it gets rid of the overhead of a normal subroutine call ;
 109
 110 =item *
 111
 112 there's no symbol table entry defined for the subroutine.
 113
 114 =back
 115
 116 Subroutine calls with and without parenthesis are handled.
 117 Ampersand calls are B<not> replaced, and as such will still allow to call a subroutine with same name defined earlier.
 118 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.
 119
 120 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.
 121
 122 =cut
 123
 124 use Scalar::Util;
 125
 126 use B::Hooks::EndOfScope;
 127 use Variable::Magic 0.08;
 128
 129 my $placeholder;
 130 BEGIN {
 131  $placeholder = sub { require Carp; Carp::croak('PLACEHOLDER') };
 132  _placeholder($placeholder);
 133 }
 134
 135 my $sw = Variable::Magic::wizard(
 136  data  => sub { +{ guard => 0, pkg => $_[1], map => $_[2] } },
 137  fetch => sub {
 138   my ($var, $data, $name) = @_;
 139
 140   return if $data->{guard};
 141   local $data->{guard} = 1;
 142
 143   return unless $data->{map}->{$name};
 144
 145   my $pkg = $data->{pkg};
 146   my $fqn = join '::', $pkg, $name;
 147
 148   {
 149    local $SIG{__WARN__} = sub {
 150     CORE::warn(@_) unless $_[0] =~ /^Constant subroutine.*redefined/;
 151    } if _constant_sub(do { no strict 'refs'; \&$fqn });
 152    no strict 'refs';
 153    no warnings qw/prototype redefine/;
 154    *$fqn = $placeholder;
 155   }
 156
 157   {
 158    my $proto = _get_prototype($name);
 159    no strict 'refs';
 160    Scalar::Util::set_prototype(\&$fqn, $proto);
 161   }
 162
 163   return;
 164  },
 165 );
 166
 167 sub _tag {
 168  my ($pkg, $name) = @_;
 169
 170  my $fqn = join '::', $pkg, $name;
 171
 172  return {
 173   old   => _defined_sub($fqn) ? \&$fqn : undef,
 174   proto => prototype($fqn),
 175  };
 176 }
 177
 178 sub _map {
 179  my ($pkg) = @_;
 180
 181  my $data = do {
 182   no strict 'refs';
 183   Variable::Magic::getdata(%{"${pkg}::"}, $sw);
 184  };
 185
 186  defined $data ? $data->{map} : undef;
 187 }
 188
 189 sub _cast {
 190  my ($pkg, $name) = @_;
 191
 192  my $map = { $name => _tag(@_) };
 193
 194  {
 195   no strict 'refs';
 196   Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, $map);
 197  }
 198
 199  return $map;
 200 }
 201
 202 sub _dispell {
 203  my ($pkg) = @_;
 204
 205  no strict 'refs';
 206  Variable::Magic::dispell(%{"${pkg}::"}, $sw);
 207 }
 208
 209 =head1 C API
 210
 211 =head2 C<sub_op_config_t>
 212
 213 A typedef'd struct that configures how L<Sub::Op> should handle a given subroutine name.
 214 It has the following members :
 215
 216 =over 4
 217
 218 =item *
 219
 220 C<const char *name>
 221
 222 The name of the subroutine you want to replace.
 223 Allowed to be static.
 224
 225 =item *
 226
 227 C<STRLEN namelen>
 228
 229 C<name>'s length, in bytes.
 230
 231 =item *
 232
 233 C<const char *proto>
 234
 235 The prototype you want to apply to the subroutine, or C<NULL> if none.
 236 Allowed to be static.
 237
 238 =item *
 239
 240 C<STRLEN protolen>
 241
 242 C<proto>'s length, in bytes.
 243
 244 =item *
 245
 246 C<Perl_ppaddr_t pp>
 247
 248 The pp function that will be called instead of the subroutine.
 249 C<Perl_ppaddr_t> is a typedef'd function pointer defined by perl as :
 250
 251     typedef OP *(*Perl_ppaddr_t)(pTHX);
 252
 253 =item *
 254
 255 C<sub_op_check_t check>
 256
 257 An optional callback that will be called each time a call to C<name> is replaced.
 258 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.
 259 C<sub_op_check_t> is a typedef'd function pointer defined by :
 260
 261     typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
 262
 263 =item *
 264
 265 C<void *ud>
 266
 267 An optional user data passed to the C<check> callback.
 268
 269 =back
 270
 271 =head2 C<void sub_op_init(sub_op_config_t *c)>
 272
 273 Initializes the fields of the C<sub_op_config_t> object.
 274 For future compatibility, it is required to call this function with your config object before storing your actual values.
 275 It will store safe defaults for members you won't set.
 276
 277 =head2 C<void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags)>
 278
 279 Registers a name and its configuration into L<Sub::Op>.
 280 The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
 281 No pointer to it or to its members is kept, except if you pass the flag C<SUB_OP_REGISTER_STEAL> in which case the configuration object will be stolen to be stored into L<Sub::Op>'s internal datastructure.
 282
 283 =head2 C<sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig)>
 284
 285 Deeply clones the specified C<sub_op_config_t> object.
 286
 287 =head2 C<void sub_op_free(pTHX_ sub_op_config_t *c)>
 288
 289 Free the memory associated with the specified C<sub_op_config_t> object.
 290
 291 =head1 PERL API
 292
 293 =head2 C<enable $name, [ $pkg ]>
 294
 295 Enable the replacement with a custom opcode of calls to the C<$name> subroutine of the C<$pkg> package in the current lexical scope.
 296 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.
 297
 298 When C<$pkg> is not set, it defaults to the caller package.
 299
 300 =cut
 301
 302 sub enable {
 303  my $name = shift;
 304
 305  my $pkg = @_ > 0 ? $_[0] : caller;
 306  my $map = _map($pkg);
 307
 308  if (defined $map) {
 309   $map->{$name} = _tag($pkg, $name);
 310  } else {
 311   $map = _cast($pkg, $name);
 312  }
 313
 314  my $proto = $map->{$name}->{proto};
 315  if (defined $proto) {
 316   no strict 'refs';
 317   Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
 318  }
 319
 320  $^H |= 0x00020000;
 321  $^H{+(__PACKAGE__)} = 1;
 322
 323  on_scope_end { disable($name, $pkg) };
 324
 325  return;
 326 }
 327
 328 =head2 C<disable $name, [ $pkg ]>
 329
 330 Disable the replacement for calls to C<$name> in the package C<$pkg>.
 331
 332 When C<$pkg> is not set, it defaults to the caller package.
 333
 334 =cut
 335
 336 sub disable {
 337  my $name = shift;
 338
 339  my $pkg = @_ > 0 ? $_[0] : caller;
 340  my $map = _map($pkg);
 341
 342  my $fqn = join '::', $pkg, $name;
 343
 344  if (defined $map) {
 345   my $tag = $map->{$name};
 346
 347   my $old = $tag->{old};
 348   if (defined $old) {
 349    no strict 'refs';
 350    no warnings 'redefine';
 351    *$fqn = $old;
 352   }
 353
 354   my $proto = $tag->{proto};
 355   if (defined $proto) {
 356    no strict 'refs';
 357    Scalar::Util::set_prototype(\&$fqn, $proto);
 358   }
 359
 360   delete $map->{$name};
 361   unless (keys %$map) {
 362    _dispell($pkg);
 363   }
 364  }
 365
 366  return;
 367 }
 368
 369 sub _inject {
 370  my ($pkg, $inject) = @_;
 371
 372  my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
 373
 374  while (my ($meth, $code) = each %$inject) {
 375   next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
 376   no strict 'refs';
 377   *{"${pkg}::$meth"} = $code;
 378  }
 379 }
 380
 381 sub _defined_sub {
 382  my ($fqn) = @_;
 383  my @parts = split /::/, $fqn;
 384  my $name  = pop @parts;
 385  my $pkg   = '';
 386  for (@parts) {
 387   $pkg .= $_ . '::';
 388   return 0 unless do { no strict 'refs'; %$pkg };
 389  }
 390  return do { no strict 'refs'; defined &{"$pkg$name"} };
 391 }
 392
 393 {
 394  my $injector;
 395  BEGIN {
 396   $injector = Variable::Magic::wizard(
 397    data  => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
 398    store => sub {
 399     my ($stash, $data, $key) = @_;
 400
 401     return if $data->{guard};
 402     local $data->{guard} = 1;
 403
 404     _inject($data->{pkg}, $data->{subs});
 405
 406     return;
 407    },
 408   );
 409  }
 410
 411  sub _monkeypatch {
 412   my %B_OP_inject;
 413
 414   $B_OP_inject{first} = sub {
 415    if (defined _custom_name($_[0])) {
 416     $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
 417     goto $_[0]->can('first') || die 'oops';
 418    }
 419    require Carp;
 420    Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
 421   };
 422
 423   $B_OP_inject{can} = sub {
 424    my ($obj, $meth) = @_;
 425    if ($meth eq 'first') {
 426     return undef unless $obj->isa('B::UNOP') or defined _custom_name($obj);
 427    }
 428    $obj->SUPER::can($meth);
 429   };
 430
 431   if (_defined_sub('B::OP::type')) {
 432    _inject('B::OP', \%B_OP_inject);
 433   } else {
 434    no strict 'refs';
 435    Variable::Magic::cast %{'B::OP::'}, $injector, 'B::OP', \%B_OP_inject;
 436   }
 437
 438   my $B_Deparse_inject = {
 439    pp_custom => sub {
 440     my ($self, $op, $cx) = @_;
 441     my $name = _custom_name($op);
 442     die 'unhandled custom op' unless defined $name;
 443     if ($op->flags & do { no strict 'refs'; &{'B::OPf_STACKED'}() }) {
 444      my $kid = $op->first;
 445      $kid = $kid->first->sibling; # skip ex-list, pushmark
 446      my @exprs;
 447      while (not do { no strict 'refs'; &{'B::Deparse::null'}($kid) }) {
 448       push @exprs, $self->deparse($kid, 6);
 449       $kid = $kid->sibling;
 450      }
 451      my $args = join(", ", @exprs);
 452      return "$name($args)";
 453     } else {
 454      return $name;
 455     }
 456    },
 457   };
 458
 459   if (_defined_sub('B::Deparse::pp_entersub')) {
 460    _inject('B::Deparse', $B_Deparse_inject);
 461   } else {
 462    no strict 'refs';
 463    Variable::Magic::cast %{'B::Deparse::'}, $injector, 'B::Deparse', $B_Deparse_inject;
 464   }
 465  }
 466 }
 467
 468 BEGIN { _monkeypatch() }
 469
 470 =head1 EXAMPLES
 471
 472 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
 473
 474 =head1 CAVEATS
 475
 476 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.
 477 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.
 478
 479 Function calls without parenthesis inside an C<eval STRING> in the scope of the pragma won't be replaced.
 480 I know a few ways of fixing this, but I've not yet decided on which.
 481
 482 =head1 DEPENDENCIES
 483
 484 L<perl> 5.10.
 485
 486 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
 487
 488 L<ExtUtils::Depends>.
 489
 490 =head1 SEE ALSO
 491
 492 L<subs::auto>.
 493
 494 L<B::Hooks::XSUB::CallAsOp> provides a C API to declare XSUBs that effectively call a specific PP function.
 495 Thus, it allows you to write XSUBs with the PP stack conventions used for implementing perl core keywords.
 496 There's no opcode replacement and no parsing hacks.
 497
 498 L<B::Hooks::OP::Check::EntersubForCV>.
 499
 500 =head1 AUTHOR
 501
 502 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 503
 504 You can contact me by mail or on C<irc.perl.org> (vincent).
 505
 506 =head1 BUGS
 507
 508 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>.
 509 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 510
 511 =head1 SUPPORT
 512
 513 You can find documentation for this module with the perldoc command.
 514
 515     perldoc Sub::Op
 516
 517 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
 518
 519 =head1 COPYRIGHT & LICENSE
 520
 521 Copyright 2010 Vincent Pit, all rights reserved.
 522
 523 This program is free software; you can redistribute it and/or modify it
 524 under the same terms as Perl itself.
 525
 526 =cut
 527
 528 1; # End of Sub::Op