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