=head1 NAME
-Sub::Op - Install subroutines as opcodes.
+Sub::Op - Hook compilation of keyword calls and reference constructors.
=head1 VERSION
-Version 0.01
+Version 0.02
=cut
sub dl_load_flags { 0x01 }
BEGIN {
- $VERSION = '0.01';
+ $VERSION = '0.02';
require DynaLoader;
push @ISA, 'DynaLoader';
__PACKAGE__->bootstrap($VERSION);
=head1 SYNOPSIS
+In the end user Perl code :
+
+ {
+ use Sub::Recall;
+ # There's no "call" symbol defined in this scope
+
+ # Compiles to "sub { $_[0] + $_[1] }->(1, 2)"
+ my $three = call { $_[0] + $_[1] } 1, 2;
+ }
+
In your XS file :
#include "sub_op.h"
- STATIC OP *scalar_util_reftype(pTHX) {
- dSP;
- dMARK;
- SV *sv = POPs;
- if (SvMAGICAL(sv))
- mg_get(sv);
- if (SvROK(sv))
- PUSHs(sv_reftype(SvRV(sv), 0));
- else
- PUSHs(&PL_sv_undef);
- RETURN;
+ STATIC OP *sub_recall_call(pTHX_ OP *, void *ud_) {
+ OP *ex_list, *pushmark, *refgen, *gvop, *last_arg, *rv2cv;
+
+ ex_list = cUNOPo->op_first;
+ pushmark = cUNOPx(ex_list)->op_first;
+ refgen = pushmark->op_sibling;
+ gvop = sub_op_study(o, &last_arg, &rv2cv);
+
+ /* Replace the function name by the refgen that contains the anon sub */
+ op_free(rv2cv);
+ last_arg->op_sibling = refgen;
+ pushmark->op_sibling = refgen->op_sibling;
+ refgen->op_sibling = NULL;
+
+ return o;
}
- MODULE = Scalar::Util::Ops PACKAGE = Scalar::Util::Ops
+ MODULE = Sub::Recall PACKAGE = Sub::Recall
BOOT:
{
- sub_op_keyword k;
- k.name = "reftype";
- k.len = sizeof("reftype")-1;
- k.check = 0;
- k.pp = scalar_util_reftype;
- sub_op_register(aTHX_ &k);
+ sub_op_config_t c;
+ sub_op_init(&c);
+ c.name = "call";
+ c.namelen = sizeof("call")-1;
+ c.proto = "&@";
+ c.protolen = sizeof("&@")-1;
+ c.call = sub_recall_call;
+ c.ref = 0;
+ c.ud = NULL;
+ sub_op_register(aTHX_ &c, 0);
}
In your Perl module file :
__PACKAGE__->bootstrap($VERSION);
}
- sub import { Sub::Op::enable(reftype => scalar caller) }
+ sub import { Sub::Op::enable(call => scalar caller) }
- sub unimport { Sub::Op::disable(reftype => scalar caller) }
+ sub unimport { Sub::Op::disable(call => scalar caller) }
1;
...
);
+=head1 DESCRIPTION
+
+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.
+This allows you to define customized keywords that compile to whatever construct you want.
+
+Subroutine calls with and without parenthesis are handled, but ampersand calls are B<not> caught.
+
=cut
+use Scalar::Util;
+
use B::Hooks::EndOfScope;
use Variable::Magic 0.08;
my $pkg = $data->{pkg};
my $fqn = join '::', $pkg, $name;
- _incoming($name, $pkg);
+ {
+ local $SIG{__WARN__} = sub {
+ CORE::warn(@_) unless $_[0] =~ /^Constant subroutine.*redefined/;
+ } if _constant_sub(do { no strict 'refs'; \&$fqn });
+ no strict 'refs';
+ no warnings qw/prototype redefine/;
+ *$fqn = $placeholder;
+ }
- no strict 'refs';
- *$fqn = $placeholder unless exists &$fqn;
+ {
+ my $proto = _get_prototype($name);
+ no strict 'refs';
+ Scalar::Util::set_prototype(\&$fqn, $proto);
+ }
return;
},
);
+sub _defined_sub {
+ my ($fqn) = @_;
+ my @parts = split /::/, $fqn;
+ my $name = pop @parts;
+ my $pkg = '';
+ for (@parts) {
+ $pkg .= $_ . '::';
+ return 0 unless do { no strict 'refs'; %$pkg };
+ }
+ return do { no strict 'refs'; defined &{"$pkg$name"} };
+}
+
+sub _tag {
+ my ($pkg, $name) = @_;
+
+ my $fqn = join '::', $pkg, $name;
+
+ return {
+ old => _defined_sub($fqn) ? \&$fqn : undef,
+ proto => prototype($fqn),
+ };
+}
+
sub _map {
my ($pkg) = @_;
sub _cast {
my ($pkg, $name) = @_;
- no strict 'refs';
- Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, { $name => 1 });
+ my $map = { $name => _tag(@_) };
+
+ {
+ no strict 'refs';
+ Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, $map);
+ }
+
+ return $map;
}
sub _dispell {
Variable::Magic::dispell(%{"${pkg}::"}, $sw);
}
+=head1 C API
+
+=head2 C<sub_op_config_t>
+
+A typedef'd struct that configures how L<Sub::Op> should handle a given subroutine name.
+It has the following members :
+
+=over 4
+
+=item *
+
+C<const char *name>
+
+The name of the subroutine you want to replace.
+Allowed to be static.
+
+=item *
+
+C<STRLEN namelen>
+
+C<name>'s length, in bytes.
+
+=item *
+
+C<const char *proto>
+
+The prototype you want to apply to the subroutine, or C<NULL> if none.
+Allowed to be static.
+
+=item *
+
+C<STRLEN protolen>
+
+C<proto>'s length, in bytes.
+
+=item *
+
+C<sub_op_check_t call>
+
+An optional callback that will be fired each time C<perl> compiles a function call to C<name>.
+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.
+C<sub_op_check_t> is a typedef'd function pointer defined by :
+
+ typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
+
+=item *
+
+C<sub_op_check_t ref>
+
+An optional callback that will be fired each time a reference to C<name> is taken.
+
+=item *
+
+C<void *ud>
+
+An optional user data passed to the C<call> and C<ref> callbacks.
+
+=back
+
+=head2 C<sub_op_init>
+
+ void sub_op_init(sub_op_config_t *c);
+
+Initializes the fields of the C<sub_op_config_t> object.
+For future compatibility, it is required to call this function with your config object before storing your actual values.
+It will store safe defaults for members you won't set.
+
+=head2 C<sub_op_register>
+
+ void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags);
+
+Registers a name and its configuration into L<Sub::Op>.
+The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
+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.
+
+=head2 C<sub_op_dup>
+
+ sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig);
+
+Deeply clones the specified C<sub_op_config_t> object.
+
+=head2 C<sub_op_free>
+
+ void sub_op_free(pTHX_ sub_op_config_t *c);
+
+Free the memory associated with the specified C<sub_op_config_t> object.
+
+=head2 C<sub_op_study>
+
+ OP *sub_op_study(OP *o, OP **last_arg_p, OP **rv2cv_p);
+
+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).
+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.
+Otherwise, this function returns C<NULL>.
+
+=head1 PERL API
+
+=head2 C<enable>
+
+ enable($name);
+ enable($name, $pkg);
+
+Enable the capture of function calls and references constructors to C<$name> in the C<$pkg> package in the current lexical scope.
+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.
+
+When C<$pkg> is not set, it defaults to the caller package.
+
+=cut
+
sub enable {
my $name = shift;
my $pkg = @_ > 0 ? $_[0] : caller;
- my $fqn = "${pkg}::$name";
-
my $map = _map($pkg);
if (defined $map) {
- $map->{$name} = 1;
+ $map->{$name} = _tag($pkg, $name);
} else {
- _cast($pkg, $name);
+ $map = _cast($pkg, $name);
+ }
+
+ my $proto = $map->{$name}->{proto};
+ if (defined $proto) {
+ no strict 'refs';
+ Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
}
$^H |= 0x00020000;
return;
}
+=head2 C<disable>
+
+ disable($name);
+ disable($name, $pkg);
+
+Disable the capture of function calls and reference constructors to C<$name> in the package C<$pkg>.
+
+When C<$pkg> is not set, it defaults to the caller package.
+
+=cut
+
sub disable {
my $name = shift;
my $pkg = @_ > 0 ? $_[0] : caller;
- my $fqn = "${pkg}::$name";
-
my $map = _map($pkg);
+ my $fqn = join '::', $pkg, $name;
+
if (defined $map) {
+ my $tag = $map->{$name};
+
+ my $old = $tag->{old};
+ if (defined $old) {
+ no strict 'refs';
+ no warnings 'redefine';
+ *$fqn = $old;
+ }
+
+ my $proto = $tag->{proto};
+ if (defined $proto) {
+ no strict 'refs';
+ Scalar::Util::set_prototype(\&$fqn, $proto);
+ }
+
delete $map->{$name};
unless (keys %$map) {
_dispell($pkg);
return;
}
-sub _inject {
- my ($pkg, $inject) = @_;
+=head1 EXAMPLES
- my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
+See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
- while (my ($meth, $code) = each %$inject) {
- next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
- no strict 'refs';
- *{"${pkg}::$meth"} = $code;
- }
-}
+=head1 CAVEATS
-{
- my $injector;
- BEGIN {
- $injector = Variable::Magic::wizard(
- data => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
- store => sub {
- my ($stash, $data, $key) = @_;
-
- return if $data->{guard};
- local $data->{guard} = 1;
-
- _inject($data->{pkg}, $data->{subs});
-
- return;
- },
- );
- }
-
- sub _monkeypatch {
- my %B_OP_inject;
-
- $B_OP_inject{first} = sub {
- if (defined _custom_name($_[0])) {
- $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
- goto $_[0]->can('first') || die 'oops';
- }
- require Carp;
- Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
- };
-
- $B_OP_inject{can} = sub {
- my ($obj, $meth) = @_;
- if ($meth eq 'first') {
- return undef unless defined _custom_name($obj);
- }
- $obj->SUPER::can($meth);
- };
-
- if (%B:: and %B::OP:: and *B::OP::type{CODE}) {
- _inject('B::OP', \%B_OP_inject);
- } else {
- Variable::Magic::cast %B::OP::, $injector, 'B::OP', \%B_OP_inject;
- }
-
- my $B_Deparse_inject = {
- pp_custom => sub {
- my ($self, $op, $cx) = @_;
- my $name = _custom_name($op);
- die 'unhandled custom op' unless defined $name;
- if ($op->flags & B::OPf_STACKED()) {
- my $kid = $op->first;
- $kid = $kid->first->sibling; # skip ex-list, pushmark
- my @exprs;
- for (; not B::Deparse::null($kid); $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 6);
- }
- my $args = join(", ", @exprs);
- return "$name($args)";
- } else {
- return $name;
- }
- },
- };
-
- if (%B:: and %B::Deparse:: and *B::Deparse::pp_entersub{CODE}) {
- _inject('B::Deparse', $B_Deparse_inject);
- } else {
- Variable::Magic::cast %B::Deparse::, $injector, 'B::Deparse', $B_Deparse_inject;
- }
- }
-}
+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.
+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.
-BEGIN { _monkeypatch() }
+Function calls without parenthesis inside an C<eval STRING> in the scope of the pragma won't be replaced.
+I know a few ways of fixing this, but I've not yet decided on which.
=head1 DEPENDENCIES
projects / perl / modules / Sub-Op.git / blobdiff