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