X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Op.git;a=blobdiff_plain;f=lib%2FSub%2FOp.pm;h=7e10b4eba475c3916a6e1685d43c8b6ddcea90f1;hp=20cc912081d5e6f7ea6e7078c90d9f09c2599a09;hb=d96bad52a8f49276e74bf1028960ff524433af1d;hpb=b9c3a456f75424383f35cb83000965d76e56d4ed

diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm
index 20cc912..7e10b4e 100644
--- a/lib/Sub/Op.pm
+++ b/lib/Sub/Op.pm
@@ -7,7 +7,7 @@ use warnings;
 
 =head1 NAME
 
-Sub::Op - Install subroutines as opcodes.
+Sub::Op - Hook compilation of keyword calls and reference constructors.
 
 =head1 VERSION
 
@@ -28,34 +28,50 @@ 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;
      sub_op_init(&c);
-     c.name    = "reftype";
-     c.namelen = sizeof("reftype")-1;
-     c.pp      = scalar_util_reftype;
-     c.check   = 0;
-     c.ud      = NULL;
+     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);
     }
 
@@ -77,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;
 
@@ -96,26 +112,10 @@ 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 *
+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<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.
+Subroutine calls with and without parenthesis are handled, but ampersand calls are B<not> caught.
 
 =cut
 
@@ -148,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) = @_;
 
@@ -222,57 +240,86 @@ C<name>'s length, in bytes.
 
 =item *
 
-C<Perl_ppaddr_t pp>
+C<const char *proto>
+
+The prototype you want to apply to the subroutine, or C<NULL> if none.
+Allowed to be static.
+
+=item *
 
-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 :
+C<STRLEN protolen>
 
-    typedef OP *(*Perl_ppaddr_t)(pTHX);
+C<proto>'s length, in bytes.
 
 =item *
 
-C<sub_op_check_t check>
+C<sub_op_check_t call>
 
-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.
+An optional callback that will be fired each time C<perl> compiles a function call to C<name>.
+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<sub_op_check_t> is a typedef'd function pointer defined by :
 
     typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
 
 =item *
 
+C<sub_op_check_t ref>
+
+An optional callback that will be fired each time a reference to C<name> is taken.
+
+=item *
+
 C<void *ud>
 
-An optional user data passed to the C<check> callback.
+An optional user data passed to the C<call> and C<ref> callbacks.
 
 =back
 
-=head2 C<void sub_op_init(sub_op_config_t *c)>
+=head2 C<sub_op_init>
+
+    void sub_op_init(sub_op_config_t *c);
 
 Initializes the fields of the C<sub_op_config_t> 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)>
+=head2 C<sub_op_register>
+
+    void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags);
 
 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.
+No pointer to it or to its members is kept, except if you pass the flag C<SUB_OP_REGISTER_STEAL> in which case the configuration object will be stolen to be stored into L<Sub::Op>'s internal datastructure.
+
+=head2 C<sub_op_dup>
 
-=head2 C<sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig)>
+    sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig);
 
 Deeply clones the specified C<sub_op_config_t> object.
 
-=head2 C<void sub_op_free(pTHX_ sub_op_config_t *c)>
+=head2 C<sub_op_free>
+
+    void sub_op_free(pTHX_ sub_op_config_t *c);
 
 Free the memory associated with the specified C<sub_op_config_t> object.
 
+=head2 C<sub_op_study>
+
+    OP *sub_op_study(OP *o, OP **last_arg_p, OP **rv2cv_p);
+
+Studies the subset of the optree based on C<o>, expecting it to be an C<entersub> or C<rv2cv> op (the ones you get in the C<call> and C<ref> 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<rv2cv> op that resolves the function name, and the C<gv> op will be returned.
+Otherwise, this function returns C<NULL>.
+
 =head1 PERL API
 
-=head2 C<enable $name, [ $pkg ]>
+=head2 C<enable>
 
-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.
+    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<sub_op_config_t> configuration 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.
 
@@ -304,9 +351,12 @@ sub enable {
  return;
 }
 
-=head2 C<disable $name, [ $pkg ]>
+=head2 C<disable>
+
+    disable($name);
+    disable($name, $pkg);
 
-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.
 
@@ -345,107 +395,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<t/Sub-Op-LexicalSub> directory that implements a complete example.
@@ -470,10 +419,6 @@ L<ExtUtils::Depends>.
 
 L<subs::auto>.
 
-L<B::Hooks::XSUB::CallAsOp> 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<B::Hooks::OP::Check::EntersubForCV>.
 
 =head1 AUTHOR