X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FSub%2FOp.pm;h=7e10b4eba475c3916a6e1685d43c8b6ddcea90f1;hb=d96bad52a8f49276e74bf1028960ff524433af1d;hp=94cfe955a538c5d59d7b7b72c8a8e7619570bc9a;hpb=a4ea0141e593c7b7afc86b15fb96d7f0ec5ab38a;p=perl%2Fmodules%2FSub-Op.git diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm index 94cfe95..7e10b4e 100644 --- a/lib/Sub/Op.pm +++ b/lib/Sub/Op.pm @@ -5,17 +5,122 @@ use 5.010; use strict; use warnings; +=head1 NAME + +Sub::Op - Hook compilation of keyword calls and reference constructors. + +=head1 VERSION + +Version 0.02 + +=cut + our ($VERSION, @ISA); 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 *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 = Sub::Recall PACKAGE = Sub::Recall + + BOOT: + { + 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 Scalar::Util::Ops; + + use strict; + use warnings; + + our ($VERSION, @ISA); + + use Sub::Op; # Before loading our own shared library + + BEGIN { + $VERSION = '0.01'; + require DynaLoader; + push @ISA, 'DynaLoader'; + __PACKAGE__->bootstrap($VERSION); + } + + sub import { Sub::Op::enable(call => scalar caller) } + + sub unimport { Sub::Op::disable(call => scalar caller) } + + 1; + +In your F : + + use ExtUtils::Depends; + + my $ed = ExtUtils::Depends->new('Scalar::Util::Ops' => 'Sub::Op'); + + WriteMakefile( + $ed->get_makefile_vars, + ... + ); + +=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 caught. + +=cut + +use Scalar::Util; + use B::Hooks::EndOfScope; use Variable::Magic 0.08; @@ -38,15 +143,48 @@ my $sw = Variable::Magic::wizard( 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) = @_; @@ -61,8 +199,14 @@ sub _map { 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 { @@ -72,18 +216,131 @@ sub _dispell { Variable::Magic::dispell(%{"${pkg}::"}, $sw); } +=head1 C API + +=head2 C + +A typedef'd struct that configures how L should handle a given subroutine name. +It has the following members : + +=over 4 + +=item * + +C + +The name of the subroutine you want to replace. +Allowed to be static. + +=item * + +C + +C's length, in bytes. + +=item * + +C + +The prototype you want to apply to the subroutine, or C if none. +Allowed to be static. + +=item * + +C + +C's length, in bytes. + +=item * + +C + +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 and C callbacks. + +=back + +=head2 C + + void sub_op_init(sub_op_config_t *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 + + void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags); + +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, 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 + + sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig); + +Deeply clones the specified C object. + +=head2 C + + void sub_op_free(pTHX_ sub_op_config_t *c); + +Free the memory associated with the specified C object. + +=head2 C + + OP *sub_op_study(OP *o, OP **last_arg_p, OP **rv2cv_p); + +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($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 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. + +=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; @@ -94,15 +351,41 @@ sub enable { return; } +=head2 C + + 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); @@ -112,90 +395,58 @@ sub disable { return; } -sub _inject { - my ($pkg, $inject) = @_; +=head1 EXAMPLES - my $stash = do { no strict 'refs'; \%{"${pkg}::"} }; +See the F 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) = @_; +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. - return if $data->{guard}; - local $data->{guard} = 1; +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. - _inject($data->{pkg}, $data->{subs}); +=head1 DEPENDENCIES - return; - }, - ); - } +L 5.10. - 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; - } +L, L. - 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; - } - }, - }; +L. - 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; - } - } -} +=head1 SEE ALSO + +L. + +L. + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +You can contact me by mail or on C (vincent). + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at L. +I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Sub::Op + +Tests code coverage report is available at L. + +=head1 COPYRIGHT & LICENSE + +Copyright 2010 Vincent Pit, all rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. -BEGIN { _monkeypatch() } +=cut 1; # End of Sub::Op