X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Op.git;a=blobdiff_plain;f=lib%2FSub%2FOp.pm;h=c7b705de91d83b91b608ddade95ea24de38f9767;hp=e44ebcaa8afa9635d934cb09c68cd52b0d586e0c;hb=45db99eaea3d62c21f1f9ca9503b671a4040af6f;hpb=e7ec7b5660437ed920a2d671f933d8db331e27d0 diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm index e44ebca..c7b705d 100644 --- a/lib/Sub/Op.pm +++ b/lib/Sub/Op.pm @@ -7,11 +7,11 @@ use warnings; =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 @@ -20,7 +20,7 @@ our ($VERSION, @ISA); sub dl_load_flags { 0x01 } BEGIN { - $VERSION = '0.01'; + $VERSION = '0.02'; require DynaLoader; push @ISA, 'DynaLoader'; __PACKAGE__->bootstrap($VERSION); @@ -28,34 +28,51 @@ BEGIN { =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_config_t c; - c.name = "reftype"; - c.namelen = sizeof("reftype")-1; - c.pp = scalar_util_reftype; - c.check = 0; - c.ud = NULL; - sub_op_register(aTHX_ &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 : @@ -76,9 +93,9 @@ 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; @@ -95,26 +112,10 @@ In your F : =head1 DESCRIPTION -This module provides a C and Perl API for replacing subroutine calls by custom opcodes. -This has two main advantages : - -=over 4 - -=item * +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. -it gets rid of the overhead of a normal subroutine call ; - -=item * - -there's no symbol table entry defined for the subroutine. - -=back - -Subroutine calls with and without parenthesis are handled. -Ampersand calls are B replaced, and as such will still allow to call a subroutine with same name defined earlier. -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. - -When L and L are loaded, they get automatically monkeypatched so that introspecting modules like L and L still produce a valid output. +Subroutine calls with and without parenthesis are handled, but ampersand calls are B caught. =cut @@ -147,14 +148,32 @@ my $sw = Variable::Magic::wizard( CORE::warn(@_) unless $_[0] =~ /^Constant subroutine.*redefined/; } if _constant_sub(do { no strict 'refs'; \&$fqn }); no strict 'refs'; - no warnings 'redefine'; + no warnings qw/prototype redefine/; *$fqn = $placeholder; } + { + 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) = @_; @@ -221,43 +240,73 @@ C's length, in bytes. =item * -C +C + +The prototype you want to apply to the subroutine, or C if none. +Allowed to be static. + +=item * -The pp function that will be called instead of the subroutine. -C is a typedef'd function pointer defined by perl as : +C - typedef OP *(*Perl_ppaddr_t)(pTHX); +C's length, in bytes. =item * -C +C -An optional callback that will be called each time a call to C is replaced. -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. +An optional callback that will be fired each time C compiles a function call to C. +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 is a typedef'd function pointer defined by : typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *); =item * +C + +An optional callback that will be fired each time a reference to C is taken. + +=item * + C -An optional user data passed to the C callback. +An optional user data passed to the C and C callbacks. =back -=head2 C +=head2 C + +Initializes the fields of the C 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 Registers a name and its configuration into L. The caller is responsible for allocating and freeing the C object. -No pointer to it or to its members is kept. +No pointer to it or to its members is kept, except if you pass the flag C in which case the configuration object will be stolen to be stored into L's internal datastructure. + +=head2 C + +Deeply clones the specified C object. + +=head2 C + +Free the memory associated with the specified C object. + +=head2 C + +Studies the subset of the optree based on C, expecting it to be an C or C op (the ones you get in the C and C 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 op that resolves the function name, and the C op will be returned. +Otherwise, this function returns C. =head1 PERL API =head2 C -Enable the replacement with a custom opcode of calls to the C<$name> subroutine of the C<$pkg> package in the current lexical scope. -A pp callback must have been registered for C<$name> by calling the C function C in the XS section of your module. +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 configuration by calling the C function C in the XS section of your module. When C<$pkg> is not set, it defaults to the caller package. @@ -291,7 +340,7 @@ sub enable { =head2 C -Disable the replacement for calls to C<$name> in the package C<$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. @@ -330,107 +379,6 @@ sub disable { return; } -sub _inject { - my ($pkg, $inject) = @_; - - my $stash = do { no strict 'refs'; \%{"${pkg}::"} }; - - while (my ($meth, $code) = each %$inject) { - next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code; - no strict 'refs'; - *{"${pkg}::$meth"} = $code; - } -} - -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"} }; -} - -{ - 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 $obj->isa('B::UNOP') or defined _custom_name($obj); - } - $obj->SUPER::can($meth); - }; - - if (_defined_sub('B::OP::type')) { - _inject('B::OP', \%B_OP_inject); - } else { - no strict 'refs'; - 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 & do { no strict 'refs'; &{'B::OPf_STACKED'}() }) { - my $kid = $op->first; - $kid = $kid->first->sibling; # skip ex-list, pushmark - my @exprs; - while (not do { no strict 'refs'; &{'B::Deparse::null'}($kid) }) { - push @exprs, $self->deparse($kid, 6); - $kid = $kid->sibling; - } - my $args = join(", ", @exprs); - return "$name($args)"; - } else { - return $name; - } - }, - }; - - if (_defined_sub('B::Deparse::pp_entersub')) { - _inject('B::Deparse', $B_Deparse_inject); - } else { - no strict 'refs'; - Variable::Magic::cast %{'B::Deparse::'}, $injector, 'B::Deparse', $B_Deparse_inject; - } - } -} - -BEGIN { _monkeypatch() } - =head1 EXAMPLES See the F directory that implements a complete example. @@ -440,6 +388,9 @@ See the F directory that implements a complete example. Preexistent definitions of a sub whose name is handled by L 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 with a name that is currently being replaced, the new declaration will be obliterated at the scope end. +Function calls without parenthesis inside an C 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 L 5.10. @@ -452,10 +403,6 @@ L. L. -L provides a C API to declare XSUBs that effectively call a specific PP function. -Thus, it allows you to write XSUBs with the PP stack conventions used for implementing perl core keywords. -There's no opcode replacement and no parsing hacks. - L. =head1 AUTHOR