10 Sub::Op - Install subroutines as opcodes.
20 sub dl_load_flags { 0x01 }
25 push @ISA, 'DynaLoader';
26 __PACKAGE__->bootstrap($VERSION);
35 STATIC OP *scalar_util_reftype(pTHX) {
42 PUSHs(sv_reftype(SvRV(sv), 0));
48 MODULE = Scalar::Util::Ops PACKAGE = Scalar::Util::Ops
54 c.len = sizeof("reftype")-1;
55 c.pp = scalar_util_reftype;
58 sub_op_register(aTHX_ &c);
61 In your Perl module file :
63 package Scalar::Util::Ops;
70 use Sub::Op; # Before loading our own shared library
75 push @ISA, 'DynaLoader';
76 __PACKAGE__->bootstrap($VERSION);
79 sub import { Sub::Op::enable(reftype => scalar caller) }
81 sub unimport { Sub::Op::disable(reftype => scalar caller) }
85 In your F<Makefile.PL> :
87 use ExtUtils::Depends;
89 my $ed = ExtUtils::Depends->new('Scalar::Util::Ops' => 'Sub::Op');
92 $ed->get_makefile_vars,
98 This module provides a C and Perl API for replacing subroutine calls by custom opcodes.
99 This has two main advantages :
105 it gets rid of the overhead of a normal subroutine call ;
109 there's no symbol table entry defined for the subroutine.
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.
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.
123 use B::Hooks::EndOfScope;
124 use Variable::Magic 0.08;
128 $placeholder = sub { require Carp; Carp::croak('PLACEHOLDER') };
129 _placeholder($placeholder);
132 my $sw = Variable::Magic::wizard(
133 data => sub { +{ guard => 0, pkg => $_[1], map => $_[2] } },
135 my ($var, $data, $name) = @_;
137 return if $data->{guard};
138 local $data->{guard} = 1;
140 return unless $data->{map}->{$name};
142 my $pkg = $data->{pkg};
143 my $fqn = join '::', $pkg, $name;
146 local $SIG{__WARN__} = sub {
147 CORE::warn(@_) unless $_[0] =~ /^Constant subroutine.*redefined/;
148 } if _constant_sub(do { no strict 'refs'; \&$fqn });
150 no warnings 'redefine';
151 *$fqn = $placeholder;
159 my ($pkg, $name) = @_;
161 my $fqn = join '::', $pkg, $name;
164 old => _defined_sub($fqn) ? \&$fqn : undef,
165 proto => prototype($fqn),
174 Variable::Magic::getdata(%{"${pkg}::"}, $sw);
177 defined $data ? $data->{map} : undef;
181 my ($pkg, $name) = @_;
183 my $map = { $name => _tag(@_) };
187 Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, $map);
197 Variable::Magic::dispell(%{"${pkg}::"}, $sw);
202 =head2 C<sub_op_config_t>
204 A typedef'd struct that configures how L<Sub::Op> should handle a given subroutine name.
205 It has the following members :
213 The name of the subroutine you want to replace.
214 Allowed to be static.
220 C<name>'s length, in bytes.
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 :
229 typedef OP *(*Perl_ppaddr_t)(pTHX);
233 C<sub_op_check_t check>
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 :
239 typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
245 An optional user data passed to the C<check> callback.
249 =head2 C<void sub_op_register(pTHX_ const sub_op_config_t *c)>
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.
257 =head2 C<enable $name, [ $pkg ]>
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.
262 When C<$pkg> is not set, it defaults to the caller package.
269 my $pkg = @_ > 0 ? $_[0] : caller;
270 my $map = _map($pkg);
273 $map->{$name} = _tag($pkg, $name);
275 $map = _cast($pkg, $name);
278 my $proto = $map->{$name}->{proto};
279 if (defined $proto) {
281 Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
285 $^H{+(__PACKAGE__)} = 1;
287 on_scope_end { disable($name, $pkg) };
292 =head2 C<disable $name, [ $pkg ]>
294 Disable the replacement for calls to C<$name> in the package C<$pkg>.
296 When C<$pkg> is not set, it defaults to the caller package.
303 my $pkg = @_ > 0 ? $_[0] : caller;
304 my $map = _map($pkg);
306 my $fqn = join '::', $pkg, $name;
309 my $tag = $map->{$name};
311 my $old = $tag->{old};
314 no warnings 'redefine';
318 my $proto = $tag->{proto};
319 if (defined $proto) {
321 Scalar::Util::set_prototype(\&$fqn, $proto);
324 delete $map->{$name};
325 unless (keys %$map) {
334 my ($pkg, $inject) = @_;
336 my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
338 while (my ($meth, $code) = each %$inject) {
339 next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
341 *{"${pkg}::$meth"} = $code;
347 my @parts = split /::/, $fqn;
348 my $name = pop @parts;
352 return 0 unless do { no strict 'refs'; %$pkg };
354 return do { no strict 'refs'; defined &{"$pkg$name"} };
360 $injector = Variable::Magic::wizard(
361 data => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
363 my ($stash, $data, $key) = @_;
365 return if $data->{guard};
366 local $data->{guard} = 1;
368 _inject($data->{pkg}, $data->{subs});
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';
384 Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
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);
392 $obj->SUPER::can($meth);
395 if (_defined_sub('B::OP::type')) {
396 _inject('B::OP', \%B_OP_inject);
399 Variable::Magic::cast %{'B::OP::'}, $injector, 'B::OP', \%B_OP_inject;
402 my $B_Deparse_inject = {
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
411 while (not do { no strict 'refs'; &{'B::Deparse::null'}($kid) }) {
412 push @exprs, $self->deparse($kid, 6);
413 $kid = $kid->sibling;
415 my $args = join(", ", @exprs);
416 return "$name($args)";
423 if (_defined_sub('B::Deparse::pp_entersub')) {
424 _inject('B::Deparse', $B_Deparse_inject);
427 Variable::Magic::cast %{'B::Deparse::'}, $injector, 'B::Deparse', $B_Deparse_inject;
432 BEGIN { _monkeypatch() }
436 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
442 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
444 L<ExtUtils::Depends>.
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.
454 L<B::Hooks::OP::Check::EntersubForCV>.
458 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
460 You can contact me by mail or on C<irc.perl.org> (vincent).
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.
469 You can find documentation for this module with the perldoc command.
473 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
475 =head1 COPYRIGHT & LICENSE
477 Copyright 2010 Vincent Pit, all rights reserved.
479 This program is free software; you can redistribute it and/or modify it
480 under the same terms as Perl itself.