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