Make sure the POD headings are linkable

[perl/modules/Sub-Op.git] / lib / Sub / Op.pm

diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm
index 20cc912081d5e6f7ea6e7078c90d9f09c2599a09..7e10b4eba475c3916a6e1685d43c8b6ddcea90f1 100644 (file)
--- a/lib/Sub/Op.pm
+++ b/lib/Sub/Op.pm
@@ -7,7 +7,7 @@ use warnings;
 
 =head1 NAME
 
 
 =head1 NAME
 

-Sub::Op - Install subroutines as opcodes.
+Sub::Op - Hook compilation of keyword calls and reference constructors.

 
 =head1 VERSION
 
 
 =head1 VERSION
 


@@ -28,34 +28,50 @@ BEGIN {
 
 =head1 SYNOPSIS
 
 
 =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"
 
 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);
 
     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);
     }
 
      sub_op_register(aTHX_ &c, 0);
     }
 


@@ -77,9 +93,9 @@ In your Perl module file :
      __PACKAGE__->bootstrap($VERSION);
     }
 
      __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;
 
 
     1;
 


@@ -96,26 +112,10 @@ In your F<Makefile.PL> :
 
 =head1 DESCRIPTION
 
 
 =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
 
 
 =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';
     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;
   }
 
    *$fqn = $placeholder;
   }
 

+  {
+   my $proto = _get_prototype($name);
+   no strict 'refs';
+   Scalar::Util::set_prototype(\&$fqn, $proto);
+  }
+

   return;
  },
 );
 
   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) = @_;
 
 sub _tag {
  my ($pkg, $name) = @_;
 


@@ -222,57 +240,86 @@ C<name>'s length, in bytes.
 
 =item *
 
 
 =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 *
 
 
 =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> 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>
 
 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
 
 
 =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.
 
 
 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.
 
 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.
 
 
 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.
 
 
 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
 
 =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.
 
 
 When C<$pkg> is not set, it defaults to the caller package.
 


@@ -304,9 +351,12 @@ sub enable {
  return;
 }
 
  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.
 
 
 When C<$pkg> is not set, it defaults to the caller package.
 


@@ -345,107 +395,6 @@ sub disable {
  return;
 }
 
  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.
 =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<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
 L<B::Hooks::OP::Check::EntersubForCV>.
 
 =head1 AUTHOR