X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FSub%2FOp.pm;h=76d22dacb4dab4ba36869b65ecbceaf8353ffae7;hb=03a0301f7c3c094686a5412c86319e32354a3521;hp=94cfe955a538c5d59d7b7b72c8a8e7619570bc9a;hpb=a4ea0141e593c7b7afc86b15fb96d7f0ec5ab38a;p=perl%2Fmodules%2FSub-Op.git diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm index 94cfe95..76d22da 100644 --- a/lib/Sub/Op.pm +++ b/lib/Sub/Op.pm @@ -5,6 +5,16 @@ use 5.010; use strict; use warnings; +=head1 NAME + +Sub::Op - Install subroutines as opcodes. + +=head1 VERSION + +Version 0.01 + +=cut + our ($VERSION, @ISA); sub dl_load_flags { 0x01 } @@ -16,6 +26,98 @@ BEGIN { __PACKAGE__->bootstrap($VERSION); } +=head1 SYNOPSIS + +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; + } + + MODULE = Scalar::Util::Ops PACKAGE = Scalar::Util::Ops + + 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); + } + +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(reftype => scalar caller) } + + sub unimport { Sub::Op::disable(reftype => 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 replacing subroutine calls by custom opcodes. +This has two main advantages : + +=over 4 + +=item * + +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. + +=cut + use B::Hooks::EndOfScope; use Variable::Magic 0.08; @@ -38,8 +140,6 @@ my $sw = Variable::Magic::wizard( my $pkg = $data->{pkg}; my $fqn = join '::', $pkg, $name; - _incoming($name, $pkg); - no strict 'refs'; *$fqn = $placeholder unless exists &$fqn; @@ -72,12 +172,76 @@ 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 pp function that will be called instead of the subroutine. +C is a typedef'd function pointer defined by perl as : + + typedef OP *(*Perl_ppaddr_t)(pTHX); + +=item * + +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. +C is a typedef'd function pointer defined by : + + typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *); + +=item * + +C + +An optional user data passed to the C callback. + +=back + +=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. + +=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. + +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) { @@ -94,12 +258,18 @@ sub enable { return; } +=head2 C + +Disable the replacement for calls 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); if (defined $map) { @@ -157,7 +327,7 @@ sub _inject { $B_OP_inject{can} = sub { my ($obj, $meth) = @_; if ($meth eq 'first') { - return undef unless defined _custom_name($obj); + return undef unless $obj->isa('B::UNOP') or defined _custom_name($obj); } $obj->SUPER::can($meth); }; @@ -198,4 +368,50 @@ sub _inject { BEGIN { _monkeypatch() } +=head1 EXAMPLES + +See the F directory that implements a complete example. + +=head1 DEPENDENCIES + +L 5.10. + +L, L. + +L. + +=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. + +=cut + 1; # End of Sub::Op