]> git.vpit.fr Git - perl/modules/Sub-Op.git/blob - lib/Sub/Op.pm
Test if the name member is not NULL before cloning it
[perl/modules/Sub-Op.git] / 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.pp      = scalar_util_reftype;
57      c.check   = 0;
58      c.ud      = NULL;
59      sub_op_register(aTHX_ &c, 0);
60     }
61
62 In your Perl module file :
63
64     package Scalar::Util::Ops;
65
66     use strict;
67     use warnings;
68
69     our ($VERSION, @ISA);
70
71     use Sub::Op; # Before loading our own shared library
72
73     BEGIN {
74      $VERSION = '0.01';
75      require DynaLoader;
76      push @ISA, 'DynaLoader';
77      __PACKAGE__->bootstrap($VERSION);
78     }
79
80     sub import   { Sub::Op::enable(reftype => scalar caller) }
81
82     sub unimport { Sub::Op::disable(reftype => scalar caller) }
83
84     1;
85
86 In your F<Makefile.PL> :
87
88     use ExtUtils::Depends;
89
90     my $ed = ExtUtils::Depends->new('Scalar::Util::Ops' => 'Sub::Op');
91
92     WriteMakefile(
93      $ed->get_makefile_vars,
94      ...
95     );
96
97 =head1 DESCRIPTION
98
99 This module provides a C and Perl API for replacing subroutine calls by custom opcodes.
100 This has two main advantages :
101
102 =over 4
103
104 =item *
105
106 it gets rid of the overhead of a normal subroutine call ;
107
108 =item *
109
110 there's no symbol table entry defined for the subroutine.
111
112 =back
113
114 Subroutine calls with and without parenthesis are handled.
115 Ampersand calls are B<not> replaced, and as such will still allow to call a subroutine with same name defined earlier.
116 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.
117
118 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.
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 'redefine';
152    *$fqn = $placeholder;
153   }
154
155   return;
156  },
157 );
158
159 sub _tag {
160  my ($pkg, $name) = @_;
161
162  my $fqn = join '::', $pkg, $name;
163
164  return {
165   old   => _defined_sub($fqn) ? \&$fqn : undef,
166   proto => prototype($fqn),
167  };
168 }
169
170 sub _map {
171  my ($pkg) = @_;
172
173  my $data = do {
174   no strict 'refs';
175   Variable::Magic::getdata(%{"${pkg}::"}, $sw);
176  };
177
178  defined $data ? $data->{map} : undef;
179 }
180
181 sub _cast {
182  my ($pkg, $name) = @_;
183
184  my $map = { $name => _tag(@_) };
185
186  {
187   no strict 'refs';
188   Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, $map);
189  }
190
191  return $map;
192 }
193
194 sub _dispell {
195  my ($pkg) = @_;
196
197  no strict 'refs';
198  Variable::Magic::dispell(%{"${pkg}::"}, $sw);
199 }
200
201 =head1 C API
202
203 =head2 C<sub_op_config_t>
204
205 A typedef'd struct that configures how L<Sub::Op> should handle a given subroutine name.
206 It has the following members :
207
208 =over 4
209
210 =item *
211
212 C<const char *name>
213
214 The name of the subroutine you want to replace.
215 Allowed to be static.
216
217 =item *
218
219 C<STRLEN namelen>
220
221 C<name>'s length, in bytes.
222
223 =item *
224
225 C<Perl_ppaddr_t pp>
226
227 The pp function that will be called instead of the subroutine.
228 C<Perl_ppaddr_t> is a typedef'd function pointer defined by perl as :
229
230     typedef OP *(*Perl_ppaddr_t)(pTHX);
231
232 =item *
233
234 C<sub_op_check_t check>
235
236 An optional callback that will be called each time a call to C<name> is replaced.
237 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.
238 C<sub_op_check_t> is a typedef'd function pointer defined by :
239
240     typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
241
242 =item *
243
244 C<void *ud>
245
246 An optional user data passed to the C<check> callback.
247
248 =back
249
250 =head2 C<void sub_op_init(sub_op_config_t *c)>
251
252 Initializes the fields of the C<sub_op_config_t> object.
253 For future compatibility, it is required to call this function with your config object before storing your actual values.
254 It will store safe defaults for members you won't set.
255
256 =head2 C<void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags)>
257
258 Registers a name and its configuration into L<Sub::Op>.
259 The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
260 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.
261
262 =head2 C<sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig)>
263
264 Deeply clones the specified C<sub_op_config_t> object.
265
266 =head2 C<void sub_op_free(pTHX_ sub_op_config_t *c)>
267
268 Free the memory associated with the specified C<sub_op_config_t> object.
269
270 =head1 PERL API
271
272 =head2 C<enable $name, [ $pkg ]>
273
274 Enable the replacement with a custom opcode of calls to the C<$name> subroutine of the C<$pkg> package in the current lexical scope.
275 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.
276
277 When C<$pkg> is not set, it defaults to the caller package.
278
279 =cut
280
281 sub enable {
282  my $name = shift;
283
284  my $pkg = @_ > 0 ? $_[0] : caller;
285  my $map = _map($pkg);
286
287  if (defined $map) {
288   $map->{$name} = _tag($pkg, $name);
289  } else {
290   $map = _cast($pkg, $name);
291  }
292
293  my $proto = $map->{$name}->{proto};
294  if (defined $proto) {
295   no strict 'refs';
296   Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
297  }
298
299  $^H |= 0x00020000;
300  $^H{+(__PACKAGE__)} = 1;
301
302  on_scope_end { disable($name, $pkg) };
303
304  return;
305 }
306
307 =head2 C<disable $name, [ $pkg ]>
308
309 Disable the replacement for calls to C<$name> in the package C<$pkg>.
310
311 When C<$pkg> is not set, it defaults to the caller package.
312
313 =cut
314
315 sub disable {
316  my $name = shift;
317
318  my $pkg = @_ > 0 ? $_[0] : caller;
319  my $map = _map($pkg);
320
321  my $fqn = join '::', $pkg, $name;
322
323  if (defined $map) {
324   my $tag = $map->{$name};
325
326   my $old = $tag->{old};
327   if (defined $old) {
328    no strict 'refs';
329    no warnings 'redefine';
330    *$fqn = $old;
331   }
332
333   my $proto = $tag->{proto};
334   if (defined $proto) {
335    no strict 'refs';
336    Scalar::Util::set_prototype(\&$fqn, $proto);
337   }
338
339   delete $map->{$name};
340   unless (keys %$map) {
341    _dispell($pkg);
342   }
343  }
344
345  return;
346 }
347
348 sub _inject {
349  my ($pkg, $inject) = @_;
350
351  my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
352
353  while (my ($meth, $code) = each %$inject) {
354   next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
355   no strict 'refs';
356   *{"${pkg}::$meth"} = $code;
357  }
358 }
359
360 sub _defined_sub {
361  my ($fqn) = @_;
362  my @parts = split /::/, $fqn;
363  my $name  = pop @parts;
364  my $pkg   = '';
365  for (@parts) {
366   $pkg .= $_ . '::';
367   return 0 unless do { no strict 'refs'; %$pkg };
368  }
369  return do { no strict 'refs'; defined &{"$pkg$name"} };
370 }
371
372 {
373  my $injector;
374  BEGIN {
375   $injector = Variable::Magic::wizard(
376    data  => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
377    store => sub {
378     my ($stash, $data, $key) = @_;
379
380     return if $data->{guard};
381     local $data->{guard} = 1;
382
383     _inject($data->{pkg}, $data->{subs});
384
385     return;
386    },
387   );
388  }
389
390  sub _monkeypatch {
391   my %B_OP_inject;
392
393   $B_OP_inject{first} = sub {
394    if (defined _custom_name($_[0])) {
395     $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
396     goto $_[0]->can('first') || die 'oops';
397    }
398    require Carp;
399    Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
400   };
401
402   $B_OP_inject{can} = sub {
403    my ($obj, $meth) = @_;
404    if ($meth eq 'first') {
405     return undef unless $obj->isa('B::UNOP') or defined _custom_name($obj);
406    }
407    $obj->SUPER::can($meth);
408   };
409
410   if (_defined_sub('B::OP::type')) {
411    _inject('B::OP', \%B_OP_inject);
412   } else {
413    no strict 'refs';
414    Variable::Magic::cast %{'B::OP::'}, $injector, 'B::OP', \%B_OP_inject;
415   }
416
417   my $B_Deparse_inject = {
418    pp_custom => sub {
419     my ($self, $op, $cx) = @_;
420     my $name = _custom_name($op);
421     die 'unhandled custom op' unless defined $name;
422     if ($op->flags & do { no strict 'refs'; &{'B::OPf_STACKED'}() }) {
423      my $kid = $op->first;
424      $kid = $kid->first->sibling; # skip ex-list, pushmark
425      my @exprs;
426      while (not do { no strict 'refs'; &{'B::Deparse::null'}($kid) }) {
427       push @exprs, $self->deparse($kid, 6);
428       $kid = $kid->sibling;
429      }
430      my $args = join(", ", @exprs);
431      return "$name($args)";
432     } else {
433      return $name;
434     }
435    },
436   };
437
438   if (_defined_sub('B::Deparse::pp_entersub')) {
439    _inject('B::Deparse', $B_Deparse_inject);
440   } else {
441    no strict 'refs';
442    Variable::Magic::cast %{'B::Deparse::'}, $injector, 'B::Deparse', $B_Deparse_inject;
443   }
444  }
445 }
446
447 BEGIN { _monkeypatch() }
448
449 =head1 EXAMPLES
450
451 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
452
453 =head1 CAVEATS
454
455 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.
456 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.
457
458 Function calls without parenthesis inside an C<eval STRING> in the scope of the pragma won't be replaced.
459 I know a few ways of fixing this, but I've not yet decided on which.
460
461 =head1 DEPENDENCIES
462
463 L<perl> 5.10.
464
465 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
466
467 L<ExtUtils::Depends>.
468
469 =head1 SEE ALSO
470
471 L<subs::auto>.
472
473 L<B::Hooks::XSUB::CallAsOp> provides a C API to declare XSUBs that effectively call a specific PP function.
474 Thus, it allows you to write XSUBs with the PP stack conventions used for implementing perl core keywords.
475 There's no opcode replacement and no parsing hacks.
476
477 L<B::Hooks::OP::Check::EntersubForCV>.
478
479 =head1 AUTHOR
480
481 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
482
483 You can contact me by mail or on C<irc.perl.org> (vincent).
484
485 =head1 BUGS
486
487 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>.
488 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
489
490 =head1 SUPPORT
491
492 You can find documentation for this module with the perldoc command.
493
494     perldoc Sub::Op
495
496 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
497
498 =head1 COPYRIGHT & LICENSE
499
500 Copyright 2010 Vincent Pit, all rights reserved.
501
502 This program is free software; you can redistribute it and/or modify it
503 under the same terms as Perl itself.
504
505 =cut
506
507 1; # End of Sub::Op