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 sub _defined_sub {
 328  my ($fqn) = @_;
 329  my @parts = split /::/, $fqn;
 330  my $name  = pop @parts;
 331  my $pkg   = '';
 332  for (@parts) {
 333   $pkg .= $_ . '::';
 334   return 0 unless do { no strict 'refs'; %$pkg };
 335  }
 336  return do { no strict 'refs'; defined &{"$pkg$name"} };
 337 }
 338
 339 {
 340  my $injector;
 341  BEGIN {
 342   $injector = Variable::Magic::wizard(
 343    data  => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
 344    store => sub {
 345     my ($stash, $data, $key) = @_;
 346
 347     return if $data->{guard};
 348     local $data->{guard} = 1;
 349
 350     _inject($data->{pkg}, $data->{subs});
 351
 352     return;
 353    },
 354   );
 355  }
 356
 357  sub _monkeypatch {
 358   my %B_OP_inject;
 359
 360   $B_OP_inject{first} = sub {
 361    if (defined _custom_name($_[0])) {
 362     $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
 363     goto $_[0]->can('first') || die 'oops';
 364    }
 365    require Carp;
 366    Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
 367   };
 368
 369   $B_OP_inject{can} = sub {
 370    my ($obj, $meth) = @_;
 371    if ($meth eq 'first') {
 372     return undef unless $obj->isa('B::UNOP') or defined _custom_name($obj);
 373    }
 374    $obj->SUPER::can($meth);
 375   };
 376
 377   if (_defined_sub('B::OP::type')) {
 378    _inject('B::OP', \%B_OP_inject);
 379   } else {
 380    no strict 'refs';
 381    Variable::Magic::cast %{'B::OP::'}, $injector, 'B::OP', \%B_OP_inject;
 382   }
 383
 384   my $B_Deparse_inject = {
 385    pp_custom => sub {
 386     my ($self, $op, $cx) = @_;
 387     my $name = _custom_name($op);
 388     die 'unhandled custom op' unless defined $name;
 389     if ($op->flags & do { no strict 'refs'; &{'B::OPf_STACKED'}() }) {
 390      my $kid = $op->first;
 391      $kid = $kid->first->sibling; # skip ex-list, pushmark
 392      my @exprs;
 393      while (not do { no strict 'refs'; &{'B::Deparse::null'}($kid) }) {
 394       push @exprs, $self->deparse($kid, 6);
 395       $kid = $kid->sibling;
 396      }
 397      my $args = join(", ", @exprs);
 398      return "$name($args)";
 399     } else {
 400      return $name;
 401     }
 402    },
 403   };
 404
 405   if (_defined_sub('B::Deparse::pp_entersub')) {
 406    _inject('B::Deparse', $B_Deparse_inject);
 407   } else {
 408    no strict 'refs';
 409    Variable::Magic::cast %{'B::Deparse::'}, $injector, 'B::Deparse', $B_Deparse_inject;
 410   }
 411  }
 412 }
 413
 414 BEGIN { _monkeypatch() }
 415
 416 =head1 EXAMPLES
 417
 418 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
 419
 420 =head1 DEPENDENCIES
 421
 422 L<perl> 5.10.
 423
 424 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
 425
 426 L<ExtUtils::Depends>.
 427
 428 =head1 SEE ALSO
 429
 430 L<subs::auto>.
 431
 432 L<B::Hooks::XSUB::CallAsOp> provides a C API to declare XSUBs that effectively call a specific PP function.
 433 Thus, it allows you to write XSUBs with the PP stack conventions used for implementing perl core keywords.
 434 There's no opcode replacement and no parsing hacks.
 435
 436 L<B::Hooks::OP::Check::EntersubForCV>.
 437
 438 =head1 AUTHOR
 439
 440 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 441
 442 You can contact me by mail or on C<irc.perl.org> (vincent).
 443
 444 =head1 BUGS
 445
 446 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>.
 447 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 448
 449 =head1 SUPPORT
 450
 451 You can find documentation for this module with the perldoc command.
 452
 453     perldoc Sub::Op
 454
 455 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
 456
 457 =head1 COPYRIGHT & LICENSE
 458
 459 Copyright 2010 Vincent Pit, all rights reserved.
 460
 461 This program is free software; you can redistribute it and/or modify it
 462 under the same terms as Perl itself.
 463
 464 =cut
 465
 466 1; # End of Sub::Op