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
56 last_arg->op_sibling = refgen;
57 pushmark->op_sibling = refgen->op_sibling;
58 refgen->op_sibling = NULL;
63 MODULE = Sub::Recall PACKAGE = Sub::Recall
70 c.namelen = sizeof("call")-1;
72 c.protolen = sizeof("&@")-1;
73 c.call = sub_recall_call;
76 sub_op_register(aTHX_ &c, 0);
79 In your Perl module file :
81 package Scalar::Util::Ops;
88 use Sub::Op; # Before loading our own shared library
93 push @ISA, 'DynaLoader';
94 __PACKAGE__->bootstrap($VERSION);
97 sub import { Sub::Op::enable(call => scalar caller) }
99 sub unimport { Sub::Op::disable(call => scalar caller) }
103 In your F<Makefile.PL> :
105 use ExtUtils::Depends;
107 my $ed = ExtUtils::Depends->new('Scalar::Util::Ops' => 'Sub::Op');
110 $ed->get_makefile_vars,
116 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.
117 This allows you to define customized keywords that compile to whatever construct you want.
119 Subroutine calls with and without parenthesis are handled, but ampersand calls are B<not> caught.
125 use B::Hooks::EndOfScope;
126 use Variable::Magic 0.08;
130 $placeholder = sub { require Carp; Carp::croak('PLACEHOLDER') };
131 _placeholder($placeholder);
134 my $sw = Variable::Magic::wizard(
135 data => sub { +{ guard => 0, pkg => $_[1], map => $_[2] } },
137 my ($var, $data, $name) = @_;
139 return if $data->{guard};
140 local $data->{guard} = 1;
142 return unless $data->{map}->{$name};
144 my $pkg = $data->{pkg};
145 my $fqn = join '::', $pkg, $name;
148 local $SIG{__WARN__} = sub {
149 CORE::warn(@_) unless $_[0] =~ /^Constant subroutine.*redefined/;
150 } if _constant_sub(do { no strict 'refs'; \&$fqn });
152 no warnings qw/prototype redefine/;
153 *$fqn = $placeholder;
157 my $proto = _get_prototype($name);
159 Scalar::Util::set_prototype(\&$fqn, $proto);
168 my @parts = split /::/, $fqn;
169 my $name = pop @parts;
173 return 0 unless do { no strict 'refs'; %$pkg };
175 return do { no strict 'refs'; defined &{"$pkg$name"} };
179 my ($pkg, $name) = @_;
181 my $fqn = join '::', $pkg, $name;
184 old => _defined_sub($fqn) ? \&$fqn : undef,
185 proto => prototype($fqn),
194 Variable::Magic::getdata(%{"${pkg}::"}, $sw);
197 defined $data ? $data->{map} : undef;
201 my ($pkg, $name) = @_;
203 my $map = { $name => _tag(@_) };
207 Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, $map);
217 Variable::Magic::dispell(%{"${pkg}::"}, $sw);
222 =head2 C<sub_op_config_t>
224 A typedef'd struct that configures how L<Sub::Op> should handle a given subroutine name.
225 It has the following members :
233 The name of the subroutine you want to replace.
234 Allowed to be static.
240 C<name>'s length, in bytes.
246 The prototype you want to apply to the subroutine, or C<NULL> if none.
247 Allowed to be static.
253 C<proto>'s length, in bytes.
257 C<sub_op_check_t call>
259 An optional callback that will be fired each time C<perl> compiles a function call to C<name>.
260 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.
261 C<sub_op_check_t> is a typedef'd function pointer defined by :
263 typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
267 C<sub_op_check_t ref>
269 An optional callback that will be fired each time a reference to C<name> is taken.
275 An optional user data passed to the C<call> and C<ref> callbacks.
279 =head2 C<sub_op_init>
281 void sub_op_init(sub_op_config_t *c);
283 Initializes the fields of the C<sub_op_config_t> object.
284 For future compatibility, it is required to call this function with your config object before storing your actual values.
285 It will store safe defaults for members you won't set.
287 =head2 C<sub_op_register>
289 void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags);
291 Registers a name and its configuration into L<Sub::Op>.
292 The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
293 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.
297 sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig);
299 Deeply clones the specified C<sub_op_config_t> object.
301 =head2 C<sub_op_free>
303 void sub_op_free(pTHX_ sub_op_config_t *c);
305 Free the memory associated with the specified C<sub_op_config_t> object.
307 =head2 C<sub_op_study>
309 OP *sub_op_study(OP *o, OP **last_arg_p, OP **rv2cv_p);
311 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).
312 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.
313 Otherwise, this function returns C<NULL>.
322 Enable the capture of function calls and references constructors to C<$name> in the C<$pkg> package in the current lexical scope.
323 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.
325 When C<$pkg> is not set, it defaults to the caller package.
332 my $pkg = @_ > 0 ? $_[0] : caller;
333 my $map = _map($pkg);
336 $map->{$name} = _tag($pkg, $name);
338 $map = _cast($pkg, $name);
341 my $proto = $map->{$name}->{proto};
342 if (defined $proto) {
344 Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
348 $^H{+(__PACKAGE__)} = 1;
350 on_scope_end { disable($name, $pkg) };
358 disable($name, $pkg);
360 Disable the capture of function calls and reference constructors to C<$name> in the package C<$pkg>.
362 When C<$pkg> is not set, it defaults to the caller package.
369 my $pkg = @_ > 0 ? $_[0] : caller;
370 my $map = _map($pkg);
372 my $fqn = join '::', $pkg, $name;
375 my $tag = $map->{$name};
377 my $old = $tag->{old};
380 no warnings 'redefine';
384 my $proto = $tag->{proto};
385 if (defined $proto) {
387 Scalar::Util::set_prototype(\&$fqn, $proto);
390 delete $map->{$name};
391 unless (keys %$map) {
401 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
405 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.
406 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.
408 Function calls without parenthesis inside an C<eval STRING> in the scope of the pragma won't be replaced.
409 I know a few ways of fixing this, but I've not yet decided on which.
415 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
417 L<ExtUtils::Depends>.
423 L<B::Hooks::OP::Check::EntersubForCV>.
427 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
429 You can contact me by mail or on C<irc.perl.org> (vincent).
433 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>.
434 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
438 You can find documentation for this module with the perldoc command.
442 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
444 =head1 COPYRIGHT & LICENSE
446 Copyright 2010 Vincent Pit, all rights reserved.
448 This program is free software; you can redistribute it and/or modify it
449 under the same terms as Perl itself.