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<void sub_op_init(sub_op_config_t *c)>
 279
 280 Initializes the fields of the C<sub_op_config_t> object.
 281 For future compatibility, it is required to call this function with your config object before storing your actual values.
 282 It will store safe defaults for members you won't set.
 283
 284 =head2 C<void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags)>
 285
 286 Registers a name and its configuration into L<Sub::Op>.
 287 The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
 288 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.
 289
 290 =head2 C<sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig)>
 291
 292 Deeply clones the specified C<sub_op_config_t> object.
 293
 294 =head2 C<void sub_op_free(pTHX_ sub_op_config_t *c)>
 295
 296 Free the memory associated with the specified C<sub_op_config_t> object.
 297
 298 =head2 C<OP *sub_op_study(OP *o, OP **last_arg_p, OP **rv2cv_p)>
 299
 300 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).
 301 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.
 302 Otherwise, this function returns C<NULL>.
 303
 304 =head1 PERL API
 305
 306 =head2 C<enable $name, [ $pkg ]>
 307
 308 Enable the capture of function calls and references constructors to C<$name> in the C<$pkg> package in the current lexical scope.
 309 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.
 310
 311 When C<$pkg> is not set, it defaults to the caller package.
 312
 313 =cut
 314
 315 sub enable {
 316  my $name = shift;
 317
 318  my $pkg = @_ > 0 ? $_[0] : caller;
 319  my $map = _map($pkg);
 320
 321  if (defined $map) {
 322   $map->{$name} = _tag($pkg, $name);
 323  } else {
 324   $map = _cast($pkg, $name);
 325  }
 326
 327  my $proto = $map->{$name}->{proto};
 328  if (defined $proto) {
 329   no strict 'refs';
 330   Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
 331  }
 332
 333  $^H |= 0x00020000;
 334  $^H{+(__PACKAGE__)} = 1;
 335
 336  on_scope_end { disable($name, $pkg) };
 337
 338  return;
 339 }
 340
 341 =head2 C<disable $name, [ $pkg ]>
 342
 343 Disable the capture of function calls and reference constructors to C<$name> in the package C<$pkg>.
 344
 345 When C<$pkg> is not set, it defaults to the caller package.
 346
 347 =cut
 348
 349 sub disable {
 350  my $name = shift;
 351
 352  my $pkg = @_ > 0 ? $_[0] : caller;
 353  my $map = _map($pkg);
 354
 355  my $fqn = join '::', $pkg, $name;
 356
 357  if (defined $map) {
 358   my $tag = $map->{$name};
 359
 360   my $old = $tag->{old};
 361   if (defined $old) {
 362    no strict 'refs';
 363    no warnings 'redefine';
 364    *$fqn = $old;
 365   }
 366
 367   my $proto = $tag->{proto};
 368   if (defined $proto) {
 369    no strict 'refs';
 370    Scalar::Util::set_prototype(\&$fqn, $proto);
 371   }
 372
 373   delete $map->{$name};
 374   unless (keys %$map) {
 375    _dispell($pkg);
 376   }
 377  }
 378
 379  return;
 380 }
 381
 382 =head1 EXAMPLES
 383
 384 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
 385
 386 =head1 CAVEATS
 387
 388 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.
 389 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.
 390
 391 Function calls without parenthesis inside an C<eval STRING> in the scope of the pragma won't be replaced.
 392 I know a few ways of fixing this, but I've not yet decided on which.
 393
 394 =head1 DEPENDENCIES
 395
 396 L<perl> 5.10.
 397
 398 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
 399
 400 L<ExtUtils::Depends>.
 401
 402 =head1 SEE ALSO
 403
 404 L<subs::auto>.
 405
 406 L<B::Hooks::OP::Check::EntersubForCV>.
 407
 408 =head1 AUTHOR
 409
 410 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 411
 412 You can contact me by mail or on C<irc.perl.org> (vincent).
 413
 414 =head1 BUGS
 415
 416 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>.
 417 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 418
 419 =head1 SUPPORT
 420
 421 You can find documentation for this module with the perldoc command.
 422
 423     perldoc Sub::Op
 424
 425 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
 426
 427 =head1 COPYRIGHT & LICENSE
 428
 429 Copyright 2010 Vincent Pit, all rights reserved.
 430
 431 This program is free software; you can redistribute it and/or modify it
 432 under the same terms as Perl itself.
 433
 434 =cut
 435
 436 1; # End of Sub::Op