X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FSub%2FOp.pm;h=a0f25a9473d31ab4b9e82f847e020d5471fcbb73;hb=32384f24279ef75bc0b95279c093cf90d8c47195;hp=8c8f6c87a4df667033ccba09f8a57db8b118221f;hpb=5ae3324ff295015e051249ded13b2353ee8af258;p=perl%2Fmodules%2FSub-Op.git diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm index 8c8f6c8..a0f25a9 100644 --- a/lib/Sub/Op.pm +++ b/lib/Sub/Op.pm @@ -11,7 +11,7 @@ Sub::Op - Install subroutines as opcodes. =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); @@ -50,12 +50,15 @@ In your XS file : BOOT: { sub_op_config_t c; - c.name = "reftype"; - c.len = 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 = "reftype"; + c.namelen = sizeof("reftype")-1; + c.proto = "$"; + c.protolen = sizeof("$")-1; + c.pp = scalar_util_reftype; + c.check = 0; + c.ud = NULL; + sub_op_register(aTHX_ &c, 0); } In your Perl module file : @@ -142,8 +145,20 @@ my $sw = Variable::Magic::wizard( my $pkg = $data->{pkg}; my $fqn = join '::', $pkg, $name; - no strict 'refs'; - *$fqn = $placeholder unless exists &$fqn; + { + 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; + } + + { + my $proto = _get_prototype($name); + no strict 'refs'; + Scalar::Util::set_prototype(\&$fqn, $proto); + } return; }, @@ -155,6 +170,7 @@ sub _tag { my $fqn = join '::', $pkg, $name; return { + old => _defined_sub($fqn) ? \&$fqn : undef, proto => prototype($fqn), }; } @@ -208,12 +224,25 @@ Allowed to be static. =item * -C +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 The pp function that will be called instead of the subroutine. @@ -239,11 +268,25 @@ An optional user data passed to the C callback. =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. =head1 PERL API @@ -296,11 +339,22 @@ sub disable { my $pkg = @_ > 0 ? $_[0] : caller; my $map = _map($pkg); + my $fqn = join '::', $pkg, $name; + if (defined $map) { - my $proto = $map->{$name}->{proto}; + 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(\&{"${pkg}::$name"}, $proto); + Scalar::Util::set_prototype(\&$fqn, $proto); } delete $map->{$name}; @@ -324,6 +378,18 @@ sub _inject { } } +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 { @@ -362,10 +428,11 @@ sub _inject { $obj->SUPER::can($meth); }; - if (%B:: and %B::OP:: and *B::OP::type{CODE}) { + if (_defined_sub('B::OP::type')) { _inject('B::OP', \%B_OP_inject); } else { - Variable::Magic::cast %B::OP::, $injector, 'B::OP', \%B_OP_inject; + no strict 'refs'; + Variable::Magic::cast %{'B::OP::'}, $injector, 'B::OP', \%B_OP_inject; } my $B_Deparse_inject = { @@ -373,12 +440,13 @@ sub _inject { my ($self, $op, $cx) = @_; my $name = _custom_name($op); die 'unhandled custom op' unless defined $name; - if ($op->flags & B::OPf_STACKED()) { + if ($op->flags & do { no strict 'refs'; &{'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) { + 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)"; @@ -388,10 +456,11 @@ sub _inject { }, }; - if (%B:: and %B::Deparse:: and *B::Deparse::pp_entersub{CODE}) { + if (_defined_sub('B::Deparse::pp_entersub')) { _inject('B::Deparse', $B_Deparse_inject); } else { - Variable::Magic::cast %B::Deparse::, $injector, 'B::Deparse', $B_Deparse_inject; + no strict 'refs'; + Variable::Magic::cast %{'B::Deparse::'}, $injector, 'B::Deparse', $B_Deparse_inject; } } } @@ -402,6 +471,14 @@ BEGIN { _monkeypatch() } See the F directory that implements a complete example. +=head1 CAVEATS + +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. @@ -414,6 +491,10 @@ 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