10 Sub::Op - Hook compilation of keyword calls and reference constructors.
20 sub dl_load_flags { 0x01 }
25 push @ISA, 'DynaLoader';
26 __PACKAGE__->bootstrap($VERSION);
31 In the end user Perl code :
35 # There's no "call" symbol defined in this scope
37 # Compiles to "sub { $_[0] + $_[1] }->(1, 2)"
38 my $three = call { $_[0] + $_[1] } 1, 2;
45 STATIC OP *sub_recall_call(pTHX_ OP *, void *ud_) {
46 OP *ex_list, *pushmark, *refgen, *gvop, *last_arg, *rv2cv;
48 ex_list = cUNOPo->op_first;
49 pushmark = cUNOPx(ex_list)->op_first;
50 refgen = pushmark->op_sibling;
51 gvop = sub_op_study(o, &last_arg, &rv2cv);
53 /* Replace the function name by the refgen that contains the anon sub */
55 last_arg->op_sibling = refgen;
56 pushmark->op_sibling = refgen->op_sibling;
57 refgen->op_sibling = NULL;
62 MODULE = Sub::Recall PACKAGE = Sub::Recall
69 c.namelen = sizeof("call")-1;
71 c.protolen = sizeof("&@")-1;
72 c.call = sub_recall_call;
75 sub_op_register(aTHX_ &c, 0);
78 In your Perl module file :
80 package Scalar::Util::Ops;
87 use Sub::Op; # Before loading our own shared library
92 push @ISA, 'DynaLoader';
93 __PACKAGE__->bootstrap($VERSION);
96 sub import { Sub::Op::enable(call => scalar caller) }
98 sub unimport { Sub::Op::disable(call => scalar caller) }
102 In your F<Makefile.PL> :
104 use ExtUtils::Depends;
106 my $ed = ExtUtils::Depends->new('Scalar::Util::Ops' => 'Sub::Op');
109 $ed->get_makefile_vars,
115 This module provides a C and Perl API for hooking compilation of subroutine calls and reference constructors for a given name and prototype, and this without polluting the caller namespace with a dummy symbol.
116 This allows you to define customized keywords that compile to whatever construct you want.
118 Subroutine calls with and without parenthesis are handled, but ampersand calls are B<not> caught.
124 use B::Hooks::EndOfScope;
125 use Variable::Magic 0.08;
129 $placeholder = sub { require Carp; Carp::croak('PLACEHOLDER') };
130 _placeholder($placeholder);
133 my $sw = Variable::Magic::wizard(
134 data => sub { +{ guard => 0, pkg => $_[1], map => $_[2] } },
136 my ($var, $data, $name) = @_;
138 return if $data->{guard};
139 local $data->{guard} = 1;
141 return unless $data->{map}->{$name};
143 my $pkg = $data->{pkg};
144 my $fqn = join '::', $pkg, $name;
147 local $SIG{__WARN__} = sub {
148 CORE::warn(@_) unless $_[0] =~ /^Constant subroutine.*redefined/;
149 } if _constant_sub(do { no strict 'refs'; \&$fqn });
151 no warnings qw/prototype redefine/;
152 *$fqn = $placeholder;
156 my $proto = _get_prototype($name);
158 Scalar::Util::set_prototype(\&$fqn, $proto);
167 my @parts = split /::/, $fqn;
168 my $name = pop @parts;
172 return 0 unless do { no strict 'refs'; %$pkg };
174 return do { no strict 'refs'; defined &{"$pkg$name"} };
178 my ($pkg, $name) = @_;
180 my $fqn = join '::', $pkg, $name;
183 old => _defined_sub($fqn) ? \&$fqn : undef,
184 proto => prototype($fqn),
193 Variable::Magic::getdata(%{"${pkg}::"}, $sw);
196 defined $data ? $data->{map} : undef;
200 my ($pkg, $name) = @_;
202 my $map = { $name => _tag(@_) };
206 Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, $map);
216 Variable::Magic::dispell(%{"${pkg}::"}, $sw);
221 =head2 C<sub_op_config_t>
223 A typedef'd struct that configures how L<Sub::Op> should handle a given subroutine name.
224 It has the following members :
232 The name of the subroutine you want to replace.
233 Allowed to be static.
239 C<name>'s length, in bytes.
245 The prototype you want to apply to the subroutine, or C<NULL> if none.
246 Allowed to be static.
252 C<proto>'s length, in bytes.
256 C<sub_op_check_t call>
258 An optional callback that will be fired each time C<perl> compiles a function call to C<name>.
259 You can use it to attach extra info to those ops (e.g. with a pointer table), perform some optimizations to the optree, or completely replace the call.
260 C<sub_op_check_t> is a typedef'd function pointer defined by :
262 typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
266 C<sub_op_check_t ref>
268 An optional callback that will be fired each time a reference to C<name> is taken.
274 An optional user data passed to the C<call> and C<ref> callbacks.
278 =head2 C<void sub_op_init(sub_op_config_t *c)>
280 Initializes the fields of the C<sub_op_config_t> object.
281 For future compatibility, it is required to call this function with your config object before storing your actual values.
282 It will store safe defaults for members you won't set.
284 =head2 C<void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags)>
286 Registers a name and its configuration into L<Sub::Op>.
287 The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
288 No pointer to it or to its members is kept, except if you pass the flag C<SUB_OP_REGISTER_STEAL> in which case the configuration object will be stolen to be stored into L<Sub::Op>'s internal datastructure.
290 =head2 C<sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig)>
292 Deeply clones the specified C<sub_op_config_t> object.
294 =head2 C<void sub_op_free(pTHX_ sub_op_config_t *c)>
296 Free the memory associated with the specified C<sub_op_config_t> object.
298 =head2 C<OP *sub_op_study(OP *o, OP **last_arg_p, OP **rv2cv_p)>
300 Studies the subset of the optree based on C<o>, expecting it to be an C<entersub> or C<rv2cv> op (the ones you get in the C<call> and C<ref> callbacks).
301 If the tree is well-formed, C<*last_arg_p> will be set to the last argument of the call, C<*rv2cv_p> to the C<rv2cv> op that resolves the function name, and the C<gv> op will be returned.
302 Otherwise, this function returns C<NULL>.
306 =head2 C<enable $name, [ $pkg ]>
308 Enable the capture of function calls and references constructors to C<$name> in the C<$pkg> package in the current lexical scope.
309 You must have registered an appropriate C<sub_op_config_t> configuration by calling the C function C<sub_op_register> in the XS section of your module.
311 When C<$pkg> is not set, it defaults to the caller package.
318 my $pkg = @_ > 0 ? $_[0] : caller;
319 my $map = _map($pkg);
322 $map->{$name} = _tag($pkg, $name);
324 $map = _cast($pkg, $name);
327 my $proto = $map->{$name}->{proto};
328 if (defined $proto) {
330 Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
334 $^H{+(__PACKAGE__)} = 1;
336 on_scope_end { disable($name, $pkg) };
341 =head2 C<disable $name, [ $pkg ]>
343 Disable the capture of function calls and reference constructors to C<$name> in the package C<$pkg>.
345 When C<$pkg> is not set, it defaults to the caller package.
352 my $pkg = @_ > 0 ? $_[0] : caller;
353 my $map = _map($pkg);
355 my $fqn = join '::', $pkg, $name;
358 my $tag = $map->{$name};
360 my $old = $tag->{old};
363 no warnings 'redefine';
367 my $proto = $tag->{proto};
368 if (defined $proto) {
370 Scalar::Util::set_prototype(\&$fqn, $proto);
373 delete $map->{$name};
374 unless (keys %$map) {
384 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
388 Preexistent definitions of a sub whose name is handled by L<Sub::Op> are restored at the end of the lexical scope in which the module is used.
389 But if you define a sub in the scope of action of L<Sub::Op> with a name that is currently being replaced, the new declaration will be obliterated at the scope end.
391 Function calls without parenthesis inside an C<eval STRING> in the scope of the pragma won't be replaced.
392 I know a few ways of fixing this, but I've not yet decided on which.
398 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
400 L<ExtUtils::Depends>.
406 L<B::Hooks::OP::Check::EntersubForCV>.
410 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
412 You can contact me by mail or on C<irc.perl.org> (vincent).
416 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>.
417 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
421 You can find documentation for this module with the perldoc command.
425 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
427 =head1 COPYRIGHT & LICENSE
429 Copyright 2010 Vincent Pit, all rights reserved.
431 This program is free software; you can redistribute it and/or modify it
432 under the same terms as Perl itself.