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<sub_op_init>
280 void sub_op_init(sub_op_config_t *c);
282 Initializes the fields of the C<sub_op_config_t> object.
283 For future compatibility, it is required to call this function with your config object before storing your actual values.
284 It will store safe defaults for members you won't set.
286 =head2 C<sub_op_register>
288 void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags);
290 Registers a name and its configuration into L<Sub::Op>.
291 The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
292 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.
296 sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig);
298 Deeply clones the specified C<sub_op_config_t> object.
300 =head2 C<sub_op_free>
302 void sub_op_free(pTHX_ sub_op_config_t *c);
304 Free the memory associated with the specified C<sub_op_config_t> object.
306 =head2 C<sub_op_study>
308 OP *sub_op_study(OP *o, OP **last_arg_p, OP **rv2cv_p);
310 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).
311 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.
312 Otherwise, this function returns C<NULL>.
321 Enable the capture of function calls and references constructors to C<$name> in the C<$pkg> package in the current lexical scope.
322 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.
324 When C<$pkg> is not set, it defaults to the caller package.
331 my $pkg = @_ > 0 ? $_[0] : caller;
332 my $map = _map($pkg);
335 $map->{$name} = _tag($pkg, $name);
337 $map = _cast($pkg, $name);
340 my $proto = $map->{$name}->{proto};
341 if (defined $proto) {
343 Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
347 $^H{+(__PACKAGE__)} = 1;
349 on_scope_end { disable($name, $pkg) };
357 disable($name, $pkg);
359 Disable the capture of function calls and reference constructors to C<$name> in the package C<$pkg>.
361 When C<$pkg> is not set, it defaults to the caller package.
368 my $pkg = @_ > 0 ? $_[0] : caller;
369 my $map = _map($pkg);
371 my $fqn = join '::', $pkg, $name;
374 my $tag = $map->{$name};
376 my $old = $tag->{old};
379 no warnings 'redefine';
383 my $proto = $tag->{proto};
384 if (defined $proto) {
386 Scalar::Util::set_prototype(\&$fqn, $proto);
389 delete $map->{$name};
390 unless (keys %$map) {
400 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
404 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.
405 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.
407 Function calls without parenthesis inside an C<eval STRING> in the scope of the pragma won't be replaced.
408 I know a few ways of fixing this, but I've not yet decided on which.
414 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
416 L<ExtUtils::Depends>.
422 L<B::Hooks::OP::Check::EntersubForCV>.
426 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
428 You can contact me by mail or on C<irc.perl.org> (vincent).
432 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>.
433 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
437 You can find documentation for this module with the perldoc command.
441 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
443 =head1 COPYRIGHT & LICENSE
445 Copyright 2010 Vincent Pit, all rights reserved.
447 This program is free software; you can redistribute it and/or modify it
448 under the same terms as Perl itself.