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 $fqn = "${pkg}::$name";
 246
 247  my $map = _map($pkg);
 248
 249  if (defined $map) {
 250   $map->{$name} = 1;
 251  } else {
 252   _cast($pkg, $name);
 253  }
 254
 255  $^H |= 0x00020000;
 256  $^H{+(__PACKAGE__)} = 1;
 257
 258  on_scope_end { disable($name, $pkg) };
 259
 260  return;
 261 }
 262
 263 =head2 C<disable $name, [ $pkg ]>
 264
 265 Disable the replacement for calls to C<$name> in the package C<$pkg>.
 266
 267 When C<$pkg> is not set, it defaults to the caller package.
 268
 269 =cut
 270
 271 sub disable {
 272  my $name = shift;
 273
 274  my $pkg = @_ > 0 ? $_[0] : caller;
 275  my $fqn = "${pkg}::$name";
 276
 277  my $map = _map($pkg);
 278
 279  if (defined $map) {
 280   delete $map->{$name};
 281   unless (keys %$map) {
 282    _dispell($pkg);
 283   }
 284  }
 285
 286  return;
 287 }
 288
 289 sub _inject {
 290  my ($pkg, $inject) = @_;
 291
 292  my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
 293
 294  while (my ($meth, $code) = each %$inject) {
 295   next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
 296   no strict 'refs';
 297   *{"${pkg}::$meth"} = $code;
 298  }
 299 }
 300
 301 {
 302  my $injector;
 303  BEGIN {
 304   $injector = Variable::Magic::wizard(
 305    data  => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
 306    store => sub {
 307     my ($stash, $data, $key) = @_;
 308
 309     return if $data->{guard};
 310     local $data->{guard} = 1;
 311
 312     _inject($data->{pkg}, $data->{subs});
 313
 314     return;
 315    },
 316   );
 317  }
 318
 319  sub _monkeypatch {
 320   my %B_OP_inject;
 321
 322   $B_OP_inject{first} = sub {
 323    if (defined _custom_name($_[0])) {
 324     $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
 325     goto $_[0]->can('first') || die 'oops';
 326    }
 327    require Carp;
 328    Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
 329   };
 330
 331   $B_OP_inject{can} = sub {
 332    my ($obj, $meth) = @_;
 333    if ($meth eq 'first') {
 334     return undef unless defined _custom_name($obj);
 335    }
 336    $obj->SUPER::can($meth);
 337   };
 338
 339   if (%B:: and %B::OP:: and *B::OP::type{CODE}) {
 340    _inject('B::OP', \%B_OP_inject);
 341   } else {
 342    Variable::Magic::cast %B::OP::, $injector, 'B::OP', \%B_OP_inject;
 343   }
 344
 345   my $B_Deparse_inject = {
 346    pp_custom => sub {
 347     my ($self, $op, $cx) = @_;
 348     my $name = _custom_name($op);
 349     die 'unhandled custom op' unless defined $name;
 350     if ($op->flags & B::OPf_STACKED()) {
 351      my $kid = $op->first;
 352      $kid = $kid->first->sibling; # skip ex-list, pushmark
 353      my @exprs;
 354      for (; not B::Deparse::null($kid); $kid = $kid->sibling) {
 355       push @exprs, $self->deparse($kid, 6);
 356      }
 357      my $args = join(", ", @exprs);
 358      return "$name($args)";
 359     } else {
 360      return $name;
 361     }
 362    },
 363   };
 364
 365   if (%B:: and %B::Deparse:: and *B::Deparse::pp_entersub{CODE}) {
 366    _inject('B::Deparse', $B_Deparse_inject);
 367   } else {
 368    Variable::Magic::cast %B::Deparse::, $injector, 'B::Deparse', $B_Deparse_inject;
 369   }
 370  }
 371 }
 372
 373 BEGIN { _monkeypatch() }
 374
 375 =head1 EXAMPLES
 376
 377 See the F<t/Sub-Op-Test> directory that implements a complete example.
 378
 379 =head1 DEPENDENCIES
 380
 381 L<perl> 5.10.
 382
 383 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
 384
 385 L<ExtUtils::Depends>.
 386
 387 =head1 SEE ALSO
 388
 389 L<subs::auto>.
 390
 391 L<B::Hooks::OP::Check::EntersubForCV>.
 392
 393 =head1 AUTHOR
 394
 395 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 396
 397 You can contact me by mail or on C<irc.perl.org> (vincent).
 398
 399 =head1 BUGS
 400
 401 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>.
 402 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 403
 404 =head1 SUPPORT
 405
 406 You can find documentation for this module with the perldoc command.
 407
 408     perldoc Sub::Op
 409
 410 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
 411
 412 =head1 COPYRIGHT & LICENSE
 413
 414 Copyright 2010 Vincent Pit, all rights reserved.
 415
 416 This program is free software; you can redistribute it and/or modify it
 417 under the same terms as Perl itself.
 418
 419 =cut
 420
 421 1; # End of Sub::Op