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