X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FSub%2FOp.pm;h=8c8f6c87a4df667033ccba09f8a57db8b118221f;hb=5ae3324ff295015e051249ded13b2353ee8af258;hp=a7ad9f9cbd8081eb8fa66833516d5f6bbac6bce5;hpb=0661466030b3dd0fb805da10aaed883fbe931093;p=perl%2Fmodules%2FSub-Op.git

diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm
index a7ad9f9..8c8f6c8 100644
--- a/lib/Sub/Op.pm
+++ b/lib/Sub/Op.pm
@@ -49,13 +49,13 @@ In your XS file :
 
     BOOT:
     {
-     sub_op_keyword k;
-     k.name  = "reftype";
-     k.len   = sizeof("reftype")-1;
-     k.pp    = scalar_util_reftype;
-     k.check = 0;
-     k.ud    = NULL;
-     sub_op_register(aTHX_ &k);
+     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 :
@@ -93,8 +93,33 @@ In your F<Makefile.PL> :
      ...
     );
 
+=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<not> 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<B> and L<B::Deparse> are loaded, they get automatically monkeypatched so that introspecting modules like L<B::Concise> and L<B::Deparse> still produce a valid output.
+
 =cut
 
+use Scalar::Util;
+
 use B::Hooks::EndOfScope;
 use Variable::Magic 0.08;
 
@@ -117,8 +142,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;
 
@@ -126,6 +149,16 @@ my $sw = Variable::Magic::wizard(
  },
 );
 
+sub _tag {
+ my ($pkg, $name) = @_;
+
+ my $fqn = join '::', $pkg, $name;
+
+ return {
+  proto => prototype($fqn),
+ };
+}
+
 sub _map {
  my ($pkg) = @_;
 
@@ -140,8 +173,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 {
@@ -151,18 +190,88 @@ 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 len>
+
+C<name>'s length, in bytes.
+
+=item *
+
+C<Perl_ppaddr_t pp>
+
+The pp function that will be called instead of the subroutine.
+C<Perl_ppaddr_t> is a typedef'd function pointer defined by perl as :
+
+    typedef OP *(*Perl_ppaddr_t)(pTHX);
+
+=item *
+
+C<sub_op_check_t check>
+
+An optional callback that will be called each time a call to C<name> 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<sub_op_check_t> is a typedef'd function pointer defined by :
+
+    typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
+
+=item *
+
+C<void *ud>
+
+An optional user data passed to the C<check> callback.
+
+=back
+
+=head2 C<void sub_op_register(pTHX_ const sub_op_config_t *c)>
+
+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.
+
+=head1 PERL API
+
+=head2 C<enable $name, [ $pkg ]>
+
+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<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;
@@ -173,15 +282,27 @@ sub enable {
  return;
 }
 
+=head2 C<disable $name, [ $pkg ]>
+
+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) {
+  my $proto = $map->{$name}->{proto};
+  if (defined $proto) {
+   no strict 'refs';
+   Scalar::Util::set_prototype(\&{"${pkg}::$name"}, $proto);
+  }
+
   delete $map->{$name};
   unless (keys %$map) {
    _dispell($pkg);
@@ -236,7 +357,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);
   };
@@ -277,6 +398,10 @@ sub _inject {
 
 BEGIN { _monkeypatch() }
 
+=head1 EXAMPLES
+
+See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
+
 =head1 DEPENDENCIES
 
 L<perl> 5.10.