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 *$fqn = $placeholder unless exists &$fqn;
153 my ($pkg, $name) = @_;
155 my $fqn = join '::', $pkg, $name;
158 proto => prototype($fqn),
167 Variable::Magic::getdata(%{"${pkg}::"}, $sw);
170 defined $data ? $data->{map} : undef;
174 my ($pkg, $name) = @_;
176 my $map = { $name => _tag(@_) };
180 Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, $map);
190 Variable::Magic::dispell(%{"${pkg}::"}, $sw);
195 =head2 C<sub_op_config_t>
197 A typedef'd struct that configures how L<Sub::Op> should handle a given subroutine name.
198 It has the following members :
206 The name of the subroutine you want to replace.
207 Allowed to be static.
213 C<name>'s length, in bytes.
219 The pp function that will be called instead of the subroutine.
220 C<Perl_ppaddr_t> is a typedef'd function pointer defined by perl as :
222 typedef OP *(*Perl_ppaddr_t)(pTHX);
226 C<sub_op_check_t check>
228 An optional callback that will be called each time a call to C<name> is replaced.
229 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.
230 C<sub_op_check_t> is a typedef'd function pointer defined by :
232 typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
238 An optional user data passed to the C<check> callback.
242 =head2 C<void sub_op_register(pTHX_ const sub_op_config_t *c)>
244 Registers a name and its configuration into L<Sub::Op>.
245 The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
246 No pointer to it or to its members is kept.
250 =head2 C<enable $name, [ $pkg ]>
252 Enable the replacement with a custom opcode of calls to the C<$name> subroutine of the C<$pkg> package in the current lexical scope.
253 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.
255 When C<$pkg> is not set, it defaults to the caller package.
262 my $pkg = @_ > 0 ? $_[0] : caller;
263 my $map = _map($pkg);
266 $map->{$name} = _tag($pkg, $name);
268 $map = _cast($pkg, $name);
271 my $proto = $map->{$name}->{proto};
272 if (defined $proto) {
274 Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
278 $^H{+(__PACKAGE__)} = 1;
280 on_scope_end { disable($name, $pkg) };
285 =head2 C<disable $name, [ $pkg ]>
287 Disable the replacement for calls to C<$name> in the package C<$pkg>.
289 When C<$pkg> is not set, it defaults to the caller package.
296 my $pkg = @_ > 0 ? $_[0] : caller;
297 my $map = _map($pkg);
300 my $proto = $map->{$name}->{proto};
301 if (defined $proto) {
303 Scalar::Util::set_prototype(\&{"${pkg}::$name"}, $proto);
306 delete $map->{$name};
307 unless (keys %$map) {
316 my ($pkg, $inject) = @_;
318 my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
320 while (my ($meth, $code) = each %$inject) {
321 next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
323 *{"${pkg}::$meth"} = $code;
329 my @parts = split /::/, $fqn;
330 my $name = pop @parts;
334 return 0 unless do { no strict 'refs'; %$pkg };
336 return do { no strict 'refs'; defined &{"$pkg$name"} };
342 $injector = Variable::Magic::wizard(
343 data => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
345 my ($stash, $data, $key) = @_;
347 return if $data->{guard};
348 local $data->{guard} = 1;
350 _inject($data->{pkg}, $data->{subs});
360 $B_OP_inject{first} = sub {
361 if (defined _custom_name($_[0])) {
362 $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
363 goto $_[0]->can('first') || die 'oops';
366 Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
369 $B_OP_inject{can} = sub {
370 my ($obj, $meth) = @_;
371 if ($meth eq 'first') {
372 return undef unless $obj->isa('B::UNOP') or defined _custom_name($obj);
374 $obj->SUPER::can($meth);
377 if (_defined_sub('B::OP::type')) {
378 _inject('B::OP', \%B_OP_inject);
381 Variable::Magic::cast %{'B::OP::'}, $injector, 'B::OP', \%B_OP_inject;
384 my $B_Deparse_inject = {
386 my ($self, $op, $cx) = @_;
387 my $name = _custom_name($op);
388 die 'unhandled custom op' unless defined $name;
389 if ($op->flags & do { no strict 'refs'; &{'B::OPf_STACKED'}() }) {
390 my $kid = $op->first;
391 $kid = $kid->first->sibling; # skip ex-list, pushmark
393 while (not do { no strict 'refs'; &{'B::Deparse::null'}($kid) }) {
394 push @exprs, $self->deparse($kid, 6);
395 $kid = $kid->sibling;
397 my $args = join(", ", @exprs);
398 return "$name($args)";
405 if (_defined_sub('B::Deparse::pp_entersub')) {
406 _inject('B::Deparse', $B_Deparse_inject);
409 Variable::Magic::cast %{'B::Deparse::'}, $injector, 'B::Deparse', $B_Deparse_inject;
414 BEGIN { _monkeypatch() }
418 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
424 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
426 L<ExtUtils::Depends>.
432 L<B::Hooks::OP::Check::EntersubForCV>.
436 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
438 You can contact me by mail or on C<irc.perl.org> (vincent).
442 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>.
443 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
447 You can find documentation for this module with the perldoc command.
451 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
453 =head1 COPYRIGHT & LICENSE
455 Copyright 2010 Vincent Pit, all rights reserved.
457 This program is free software; you can redistribute it and/or modify it
458 under the same terms as Perl itself.