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::XSUB::CallAsOp> provides a C API to declare XSUBs that effectively call a specific PP function.
433 Thus, it allows you to write XSUBs with the PP stack conventions used for implementing perl core keywords.
434 There's no opcode replacement and no parsing hacks.
436 L<B::Hooks::OP::Check::EntersubForCV>.
440 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
442 You can contact me by mail or on C<irc.perl.org> (vincent).
446 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>.
447 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
451 You can find documentation for this module with the perldoc command.
455 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
457 =head1 COPYRIGHT & LICENSE
459 Copyright 2010 Vincent Pit, all rights reserved.
461 This program is free software; you can redistribute it and/or modify it
462 under the same terms as Perl itself.