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 _defined_sub {
 168  my ($fqn) = @_;
 169  my @parts = split /::/, $fqn;
 170  my $name  = pop @parts;
 171  my $pkg   = '';
 172  for (@parts) {
 173   $pkg .= $_ . '::';
 174   return 0 unless do { no strict 'refs'; %$pkg };
 175  }
 176  return do { no strict 'refs'; defined &{"$pkg$name"} };
 177 }
 178
 179 sub _tag {
 180  my ($pkg, $name) = @_;
 181
 182  my $fqn = join '::', $pkg, $name;
 183
 184  return {
 185   old   => _defined_sub($fqn) ? \&$fqn : undef,
 186   proto => prototype($fqn),
 187  };
 188 }
 189
 190 sub _map {
 191  my ($pkg) = @_;
 192
 193  my $data = do {
 194   no strict 'refs';
 195   Variable::Magic::getdata(%{"${pkg}::"}, $sw);
 196  };
 197
 198  defined $data ? $data->{map} : undef;
 199 }
 200
 201 sub _cast {
 202  my ($pkg, $name) = @_;
 203
 204  my $map = { $name => _tag(@_) };
 205
 206  {
 207   no strict 'refs';
 208   Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, $map);
 209  }
 210
 211  return $map;
 212 }
 213
 214 sub _dispell {
 215  my ($pkg) = @_;
 216
 217  no strict 'refs';
 218  Variable::Magic::dispell(%{"${pkg}::"}, $sw);
 219 }
 220
 221 =head1 C API
 222
 223 =head2 C<sub_op_config_t>
 224
 225 A typedef'd struct that configures how L<Sub::Op> should handle a given subroutine name.
 226 It has the following members :
 227
 228 =over 4
 229
 230 =item *
 231
 232 C<const char *name>
 233
 234 The name of the subroutine you want to replace.
 235 Allowed to be static.
 236
 237 =item *
 238
 239 C<STRLEN namelen>
 240
 241 C<name>'s length, in bytes.
 242
 243 =item *
 244
 245 C<const char *proto>
 246
 247 The prototype you want to apply to the subroutine, or C<NULL> if none.
 248 Allowed to be static.
 249
 250 =item *
 251
 252 C<STRLEN protolen>
 253
 254 C<proto>'s length, in bytes.
 255
 256 =item *
 257
 258 C<Perl_ppaddr_t pp>
 259
 260 The pp function that will be called instead of the subroutine.
 261 C<Perl_ppaddr_t> is a typedef'd function pointer defined by perl as :
 262
 263     typedef OP *(*Perl_ppaddr_t)(pTHX);
 264
 265 =item *
 266
 267 C<sub_op_check_t check>
 268
 269 An optional callback that will be called each time a call to C<name> is replaced.
 270 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.
 271 C<sub_op_check_t> is a typedef'd function pointer defined by :
 272
 273     typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
 274
 275 =item *
 276
 277 C<void *ud>
 278
 279 An optional user data passed to the C<check> callback.
 280
 281 =back
 282
 283 =head2 C<void sub_op_init(sub_op_config_t *c)>
 284
 285 Initializes the fields of the C<sub_op_config_t> object.
 286 For future compatibility, it is required to call this function with your config object before storing your actual values.
 287 It will store safe defaults for members you won't set.
 288
 289 =head2 C<void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags)>
 290
 291 Registers a name and its configuration into L<Sub::Op>.
 292 The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
 293 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.
 294
 295 =head2 C<sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig)>
 296
 297 Deeply clones the specified C<sub_op_config_t> object.
 298
 299 =head2 C<void sub_op_free(pTHX_ sub_op_config_t *c)>
 300
 301 Free the memory associated with the specified C<sub_op_config_t> object.
 302
 303 =head1 PERL API
 304
 305 =head2 C<enable $name, [ $pkg ]>
 306
 307 Enable the replacement with a custom opcode of calls to the C<$name> subroutine of the C<$pkg> package in the current lexical scope.
 308 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.
 309
 310 When C<$pkg> is not set, it defaults to the caller package.
 311
 312 =cut
 313
 314 sub enable {
 315  my $name = shift;
 316
 317  my $pkg = @_ > 0 ? $_[0] : caller;
 318  my $map = _map($pkg);
 319
 320  if (defined $map) {
 321   $map->{$name} = _tag($pkg, $name);
 322  } else {
 323   $map = _cast($pkg, $name);
 324  }
 325
 326  my $proto = $map->{$name}->{proto};
 327  if (defined $proto) {
 328   no strict 'refs';
 329   Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
 330  }
 331
 332  $^H |= 0x00020000;
 333  $^H{+(__PACKAGE__)} = 1;
 334
 335  on_scope_end { disable($name, $pkg) };
 336
 337  return;
 338 }
 339
 340 =head2 C<disable $name, [ $pkg ]>
 341
 342 Disable the replacement for calls to C<$name> in the package C<$pkg>.
 343
 344 When C<$pkg> is not set, it defaults to the caller package.
 345
 346 =cut
 347
 348 sub disable {
 349  my $name = shift;
 350
 351  my $pkg = @_ > 0 ? $_[0] : caller;
 352  my $map = _map($pkg);
 353
 354  my $fqn = join '::', $pkg, $name;
 355
 356  if (defined $map) {
 357   my $tag = $map->{$name};
 358
 359   my $old = $tag->{old};
 360   if (defined $old) {
 361    no strict 'refs';
 362    no warnings 'redefine';
 363    *$fqn = $old;
 364   }
 365
 366   my $proto = $tag->{proto};
 367   if (defined $proto) {
 368    no strict 'refs';
 369    Scalar::Util::set_prototype(\&$fqn, $proto);
 370   }
 371
 372   delete $map->{$name};
 373   unless (keys %$map) {
 374    _dispell($pkg);
 375   }
 376  }
 377
 378  return;
 379 }
 380
 381 =head1 EXAMPLES
 382
 383 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
 384
 385 =head1 CAVEATS
 386
 387 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.
 388 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.
 389
 390 Function calls without parenthesis inside an C<eval STRING> in the scope of the pragma won't be replaced.
 391 I know a few ways of fixing this, but I've not yet decided on which.
 392
 393 =head1 DEPENDENCIES
 394
 395 L<perl> 5.10.
 396
 397 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
 398
 399 L<ExtUtils::Depends>.
 400
 401 =head1 SEE ALSO
 402
 403 L<subs::auto>.
 404
 405 L<B::Hooks::XSUB::CallAsOp> provides a C API to declare XSUBs that effectively call a specific PP function.
 406 Thus, it allows you to write XSUBs with the PP stack conventions used for implementing perl core keywords.
 407 There's no opcode replacement and no parsing hacks.
 408
 409 L<B::Hooks::OP::Check::EntersubForCV>.
 410
 411 =head1 AUTHOR
 412
 413 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 414
 415 You can contact me by mail or on C<irc.perl.org> (vincent).
 416
 417 =head1 BUGS
 418
 419 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>.
 420 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 421
 422 =head1 SUPPORT
 423
 424 You can find documentation for this module with the perldoc command.
 425
 426     perldoc Sub::Op
 427
 428 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
 429
 430 =head1 COPYRIGHT & LICENSE
 431
 432 Copyright 2010 Vincent Pit, all rights reserved.
 433
 434 This program is free software; you can redistribute it and/or modify it
 435 under the same terms as Perl itself.
 436
 437 =cut
 438
 439 1; # End of Sub::Op