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 - Hook compilation of keyword calls and reference constructors.
  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 the end user Perl code :
  32
  33      {
  34       use Sub::Recall;
  35       # There's no "call" symbol defined in this scope
  36
  37       # Compiles to "sub { $_[0] + $_[1] }->(1, 2)"
  38       my $three = call { $_[0] + $_[1] } 1, 2;
  39      }
  40
  41 In your XS file :
  42
  43     #include "sub_op.h"
  44
  45     STATIC OP *sub_recall_call(pTHX_ OP *, void *ud_) {
  46      OP *ex_list, *pushmark, *refgen, *gvop, *last_arg, *rv2cv;
  47
  48      ex_list  = cUNOPo->op_first;
  49      pushmark = cUNOPx(ex_list)->op_first;
  50      refgen   = pushmark->op_sibling;
  51      gvop     = sub_op_study(o, &last_arg, &rv2cv);
  52
  53      /* Replace the function name by the refgen that contains the anon sub */
  54      op_free(rv2cv);
  55      last_arg->op_sibling = refgen;
  56      pushmark->op_sibling = refgen->op_sibling;
  57      refgen->op_sibling   = NULL;
  58
  59      return o;
  60     }
  61
  62     MODULE = Sub::Recall       PACKAGE = Sub::Recall
  63
  64     BOOT:
  65     {
  66      sub_op_config_t c;
  67      sub_op_init(&c);
  68      c.name     = "call";
  69      c.namelen  = sizeof("call")-1;
  70      c.proto    = "&@";
  71      c.protolen = sizeof("&@")-1;
  72      c.call     = sub_recall_call;
  73      c.ref      = 0;
  74      c.ud       = NULL;
  75      sub_op_register(aTHX_ &c, 0);
  76     }
  77
  78 In your Perl module file :
  79
  80     package Scalar::Util::Ops;
  81
  82     use strict;
  83     use warnings;
  84
  85     our ($VERSION, @ISA);
  86
  87     use Sub::Op; # Before loading our own shared library
  88
  89     BEGIN {
  90      $VERSION = '0.01';
  91      require DynaLoader;
  92      push @ISA, 'DynaLoader';
  93      __PACKAGE__->bootstrap($VERSION);
  94     }
  95
  96     sub import   { Sub::Op::enable(call => scalar caller) }
  97
  98     sub unimport { Sub::Op::disable(call => scalar caller) }
  99
 100     1;
 101
 102 In your F<Makefile.PL> :
 103
 104     use ExtUtils::Depends;
 105
 106     my $ed = ExtUtils::Depends->new('Scalar::Util::Ops' => 'Sub::Op');
 107
 108     WriteMakefile(
 109      $ed->get_makefile_vars,
 110      ...
 111     );
 112
 113 =head1 DESCRIPTION
 114
 115 This module provides a C and Perl API for hooking compilation of subroutine calls and reference constructors for a given name and prototype, and this without polluting the caller namespace with a dummy symbol.
 116 This allows you to define customized keywords that compile to whatever construct you want.
 117
 118 Subroutine calls with and without parenthesis are handled, but ampersand calls are B<not> caught.
 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 qw/prototype redefine/;
 152    *$fqn = $placeholder;
 153   }
 154
 155   {
 156    my $proto = _get_prototype($name);
 157    no strict 'refs';
 158    Scalar::Util::set_prototype(\&$fqn, $proto);
 159   }
 160
 161   return;
 162  },
 163 );
 164
 165 sub _defined_sub {
 166  my ($fqn) = @_;
 167  my @parts = split /::/, $fqn;
 168  my $name  = pop @parts;
 169  my $pkg   = '';
 170  for (@parts) {
 171   $pkg .= $_ . '::';
 172   return 0 unless do { no strict 'refs'; %$pkg };
 173  }
 174  return do { no strict 'refs'; defined &{"$pkg$name"} };
 175 }
 176
 177 sub _tag {
 178  my ($pkg, $name) = @_;
 179
 180  my $fqn = join '::', $pkg, $name;
 181
 182  return {
 183   old   => _defined_sub($fqn) ? \&$fqn : undef,
 184   proto => prototype($fqn),
 185  };
 186 }
 187
 188 sub _map {
 189  my ($pkg) = @_;
 190
 191  my $data = do {
 192   no strict 'refs';
 193   Variable::Magic::getdata(%{"${pkg}::"}, $sw);
 194  };
 195
 196  defined $data ? $data->{map} : undef;
 197 }
 198
 199 sub _cast {
 200  my ($pkg, $name) = @_;
 201
 202  my $map = { $name => _tag(@_) };
 203
 204  {
 205   no strict 'refs';
 206   Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, $map);
 207  }
 208
 209  return $map;
 210 }
 211
 212 sub _dispell {
 213  my ($pkg) = @_;
 214
 215  no strict 'refs';
 216  Variable::Magic::dispell(%{"${pkg}::"}, $sw);
 217 }
 218
 219 =head1 C API
 220
 221 =head2 C<sub_op_config_t>
 222
 223 A typedef'd struct that configures how L<Sub::Op> should handle a given subroutine name.
 224 It has the following members :
 225
 226 =over 4
 227
 228 =item *
 229
 230 C<const char *name>
 231
 232 The name of the subroutine you want to replace.
 233 Allowed to be static.
 234
 235 =item *
 236
 237 C<STRLEN namelen>
 238
 239 C<name>'s length, in bytes.
 240
 241 =item *
 242
 243 C<const char *proto>
 244
 245 The prototype you want to apply to the subroutine, or C<NULL> if none.
 246 Allowed to be static.
 247
 248 =item *
 249
 250 C<STRLEN protolen>
 251
 252 C<proto>'s length, in bytes.
 253
 254 =item *
 255
 256 C<sub_op_check_t call>
 257
 258 An optional callback that will be fired each time C<perl> compiles a function call to C<name>.
 259 You can use it to attach extra info to those ops (e.g. with a pointer table), perform some optimizations to the optree, or completely replace the call.
 260 C<sub_op_check_t> is a typedef'd function pointer defined by :
 261
 262     typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
 263
 264 =item *
 265
 266 C<sub_op_check_t ref>
 267
 268 An optional callback that will be fired each time a reference to C<name> is taken.
 269
 270 =item *
 271
 272 C<void *ud>
 273
 274 An optional user data passed to the C<call> and C<ref> callbacks.
 275
 276 =back
 277
 278 =head2 C<sub_op_init>
 279
 280     void sub_op_init(sub_op_config_t *c);
 281
 282 Initializes the fields of the C<sub_op_config_t> object.
 283 For future compatibility, it is required to call this function with your config object before storing your actual values.
 284 It will store safe defaults for members you won't set.
 285
 286 =head2 C<sub_op_register>
 287
 288     void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags);
 289
 290 Registers a name and its configuration into L<Sub::Op>.
 291 The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
 292 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.
 293
 294 =head2 C<sub_op_dup>
 295
 296     sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig);
 297
 298 Deeply clones the specified C<sub_op_config_t> object.
 299
 300 =head2 C<sub_op_free>
 301
 302     void sub_op_free(pTHX_ sub_op_config_t *c);
 303
 304 Free the memory associated with the specified C<sub_op_config_t> object.
 305
 306 =head2 C<sub_op_study>
 307
 308     OP *sub_op_study(OP *o, OP **last_arg_p, OP **rv2cv_p);
 309
 310 Studies the subset of the optree based on C<o>, expecting it to be an C<entersub> or C<rv2cv> op (the ones you get in the C<call> and C<ref> callbacks).
 311 If the tree is well-formed, C<*last_arg_p> will be set to the last argument of the call, C<*rv2cv_p> to the C<rv2cv> op that resolves the function name, and the C<gv> op will be returned.
 312 Otherwise, this function returns C<NULL>.
 313
 314 =head1 PERL API
 315
 316 =head2 C<enable>
 317
 318     enable($name);
 319     enable($name, $pkg);
 320
 321 Enable the capture of function calls and references constructors to C<$name> in the C<$pkg> package in the current lexical scope.
 322 You must have registered an appropriate C<sub_op_config_t> configuration by calling the C function C<sub_op_register> in the XS section of your module.
 323
 324 When C<$pkg> is not set, it defaults to the caller package.
 325
 326 =cut
 327
 328 sub enable {
 329  my $name = shift;
 330
 331  my $pkg = @_ > 0 ? $_[0] : caller;
 332  my $map = _map($pkg);
 333
 334  if (defined $map) {
 335   $map->{$name} = _tag($pkg, $name);
 336  } else {
 337   $map = _cast($pkg, $name);
 338  }
 339
 340  my $proto = $map->{$name}->{proto};
 341  if (defined $proto) {
 342   no strict 'refs';
 343   Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
 344  }
 345
 346  $^H |= 0x00020000;
 347  $^H{+(__PACKAGE__)} = 1;
 348
 349  on_scope_end { disable($name, $pkg) };
 350
 351  return;
 352 }
 353
 354 =head2 C<disable>
 355
 356     disable($name);
 357     disable($name, $pkg);
 358
 359 Disable the capture of function calls and reference constructors to C<$name> in the package C<$pkg>.
 360
 361 When C<$pkg> is not set, it defaults to the caller package.
 362
 363 =cut
 364
 365 sub disable {
 366  my $name = shift;
 367
 368  my $pkg = @_ > 0 ? $_[0] : caller;
 369  my $map = _map($pkg);
 370
 371  my $fqn = join '::', $pkg, $name;
 372
 373  if (defined $map) {
 374   my $tag = $map->{$name};
 375
 376   my $old = $tag->{old};
 377   if (defined $old) {
 378    no strict 'refs';
 379    no warnings 'redefine';
 380    *$fqn = $old;
 381   }
 382
 383   my $proto = $tag->{proto};
 384   if (defined $proto) {
 385    no strict 'refs';
 386    Scalar::Util::set_prototype(\&$fqn, $proto);
 387   }
 388
 389   delete $map->{$name};
 390   unless (keys %$map) {
 391    _dispell($pkg);
 392   }
 393  }
 394
 395  return;
 396 }
 397
 398 =head1 EXAMPLES
 399
 400 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
 401
 402 =head1 CAVEATS
 403
 404 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.
 405 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.
 406
 407 Function calls without parenthesis inside an C<eval STRING> in the scope of the pragma won't be replaced.
 408 I know a few ways of fixing this, but I've not yet decided on which.
 409
 410 =head1 DEPENDENCIES
 411
 412 L<perl> 5.10.
 413
 414 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
 415
 416 L<ExtUtils::Depends>.
 417
 418 =head1 SEE ALSO
 419
 420 L<subs::auto>.
 421
 422 L<B::Hooks::OP::Check::EntersubForCV>.
 423
 424 =head1 AUTHOR
 425
 426 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 427
 428 You can contact me by mail or on C<irc.perl.org> (vincent).
 429
 430 =head1 BUGS
 431
 432 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>.
 433 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 434
 435 =head1 SUPPORT
 436
 437 You can find documentation for this module with the perldoc command.
 438
 439     perldoc Sub::Op
 440
 441 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
 442
 443 =head1 COPYRIGHT & LICENSE
 444
 445 Copyright 2010 Vincent Pit, all rights reserved.
 446
 447 This program is free software; you can redistribute it and/or modify it
 448 under the same terms as Perl itself.
 449
 450 =cut
 451
 452 1; # End of Sub::Op