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.
121 use B::Hooks::EndOfScope;
122 use Variable::Magic 0.08;
126 $placeholder = sub { require Carp; Carp::croak('PLACEHOLDER') };
127 _placeholder($placeholder);
130 my $sw = Variable::Magic::wizard(
131 data => sub { +{ guard => 0, pkg => $_[1], map => $_[2] } },
133 my ($var, $data, $name) = @_;
135 return if $data->{guard};
136 local $data->{guard} = 1;
138 return unless $data->{map}->{$name};
140 my $pkg = $data->{pkg};
141 my $fqn = join '::', $pkg, $name;
144 *$fqn = $placeholder unless exists &$fqn;
155 Variable::Magic::getdata(%{"${pkg}::"}, $sw);
158 defined $data ? $data->{map} : undef;
162 my ($pkg, $name) = @_;
165 Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, { $name => 1 });
172 Variable::Magic::dispell(%{"${pkg}::"}, $sw);
177 =head2 C<sub_op_config_t>
179 A typedef'd struct that configures how L<Sub::Op> should handle a given subroutine name.
180 It has the following members :
188 The name of the subroutine you want to replace.
189 Allowed to be static.
195 C<name>'s length, in bytes.
201 The pp function that will be called instead of the subroutine.
202 C<Perl_ppaddr_t> is a typedef'd function pointer defined by perl as :
204 typedef OP *(*Perl_ppaddr_t)(pTHX);
208 C<sub_op_check_t check>
210 An optional callback that will be called each time a call to C<name> is replaced.
211 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.
212 C<sub_op_check_t> is a typedef'd function pointer defined by :
214 typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
220 An optional user data passed to the C<check> callback.
224 =head2 C<void sub_op_register(pTHX_ const sub_op_config_t *c)>
226 Registers a name and its configuration into L<Sub::Op>.
227 The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
228 No pointer to it or to its members is kept.
232 =head2 C<enable $name, [ $pkg ]>
234 Enable the replacement with a custom opcode of calls to the C<$name> subroutine of the C<$pkg> package in the current lexical scope.
235 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.
237 When C<$pkg> is not set, it defaults to the caller package.
244 my $pkg = @_ > 0 ? $_[0] : caller;
245 my $map = _map($pkg);
254 $^H{+(__PACKAGE__)} = 1;
256 on_scope_end { disable($name, $pkg) };
261 =head2 C<disable $name, [ $pkg ]>
263 Disable the replacement for calls to C<$name> in the package C<$pkg>.
265 When C<$pkg> is not set, it defaults to the caller package.
272 my $pkg = @_ > 0 ? $_[0] : caller;
273 my $map = _map($pkg);
276 delete $map->{$name};
277 unless (keys %$map) {
286 my ($pkg, $inject) = @_;
288 my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
290 while (my ($meth, $code) = each %$inject) {
291 next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
293 *{"${pkg}::$meth"} = $code;
300 $injector = Variable::Magic::wizard(
301 data => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
303 my ($stash, $data, $key) = @_;
305 return if $data->{guard};
306 local $data->{guard} = 1;
308 _inject($data->{pkg}, $data->{subs});
318 $B_OP_inject{first} = sub {
319 if (defined _custom_name($_[0])) {
320 $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
321 goto $_[0]->can('first') || die 'oops';
324 Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
327 $B_OP_inject{can} = sub {
328 my ($obj, $meth) = @_;
329 if ($meth eq 'first') {
330 return undef unless $obj->isa('B::UNOP') or defined _custom_name($obj);
332 $obj->SUPER::can($meth);
335 if (%B:: and %B::OP:: and *B::OP::type{CODE}) {
336 _inject('B::OP', \%B_OP_inject);
338 Variable::Magic::cast %B::OP::, $injector, 'B::OP', \%B_OP_inject;
341 my $B_Deparse_inject = {
343 my ($self, $op, $cx) = @_;
344 my $name = _custom_name($op);
345 die 'unhandled custom op' unless defined $name;
346 if ($op->flags & B::OPf_STACKED()) {
347 my $kid = $op->first;
348 $kid = $kid->first->sibling; # skip ex-list, pushmark
350 for (; not B::Deparse::null($kid); $kid = $kid->sibling) {
351 push @exprs, $self->deparse($kid, 6);
353 my $args = join(", ", @exprs);
354 return "$name($args)";
361 if (%B:: and %B::Deparse:: and *B::Deparse::pp_entersub{CODE}) {
362 _inject('B::Deparse', $B_Deparse_inject);
364 Variable::Magic::cast %B::Deparse::, $injector, 'B::Deparse', $B_Deparse_inject;
369 BEGIN { _monkeypatch() }
373 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
379 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
381 L<ExtUtils::Depends>.
387 L<B::Hooks::OP::Check::EntersubForCV>.
391 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
393 You can contact me by mail or on C<irc.perl.org> (vincent).
397 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>.
398 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
402 You can find documentation for this module with the perldoc command.
406 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
408 =head1 COPYRIGHT & LICENSE
410 Copyright 2010 Vincent Pit, all rights reserved.
412 This program is free software; you can redistribute it and/or modify it
413 under the same terms as Perl itself.