From: Vincent Pit <vince@profvince.com>
Date: Sun, 2 Nov 2008 16:01:37 +0000 (+0100)
Subject: Implement recall() in terms of wrap()
X-Git-Tag: v0.09~18
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Prototype-Util.git;a=commitdiff_plain;h=f88d790683ee83e8225ee6b0bcb783260347c814

Implement recall() in terms of wrap()
---

diff --git a/MANIFEST b/MANIFEST
index 6571dbe..941e613 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -7,8 +7,8 @@ samples/try.pl
 t/00-load.t
 t/01-import.t
 t/10-flatten.t
-t/11-recall.t
-t/12-wrap.t
+t/11-wrap.t
+t/12-recall.t
 t/90-boilerplate.t
 t/91-pod.t
 t/92-pod-coverage.t
diff --git a/lib/Sub/Prototype/Util.pm b/lib/Sub/Prototype/Util.pm
index 68ac767..b78f396 100644
--- a/lib/Sub/Prototype/Util.pm
+++ b/lib/Sub/Prototype/Util.pm
@@ -22,7 +22,7 @@ $VERSION = '0.08';
 
 =head1 SYNOPSIS
 
-    use Sub::Prototype::Util qw/flatten recall wrap/;
+    use Sub::Prototype::Util qw/flatten wrap recall/;
 
     my @a = qw/a b c/;
     my @args = ( \@a, 1, { d => 2 }, undef, 3 );
@@ -92,80 +92,19 @@ sub flatten {
  return @args;
 }
 
-=head2 C<recall $name, @args>
-
-Calls the function C<$name> with the prototyped argument list C<@args>. That is, C<@args> should be what C<@_> is when you define a subroutine with the same prototype as C<$name>. For example,
-
-    my $a = [ ];
-    recall 'CORE::push', $a, 1, 2, 3;
-
-will call C<push @$a, 1, 2, 3> and so fill the arrayref C<$a> with C<1, 2, 3>. This is especially needed for core functions because you can't C<goto> into them.
-
-You can also force the use of a specific prototype. In this case, C<$name> must be a hash reference that holds exactly one key/value pair, the key being the function name and the value the prototpye that should be used to call it.
-
-    recall { 'CORE::push' => '\@$' }, $a, 1, 2, 3; # will only push 1
-
-This allows you to recall into C<CORE::grep> and C<CORE::map> by using the C<\&@> prototype :
-
-    sub mygrep (&@) { recall { 'CORE::grep' => '\&@' }, @_ } # the prototypes are intentionally different
+=head2 C<wrap $name, %opts>
 
-=cut
+Generates a wrapper that calls the function C<$name> with a prototyped argument list. That is, the wrapper's arguments should be what C<@_> is when you define a subroutine with the same prototype as C<$name>.
 
-sub _check_name {
- my $name = $_[0];
- croak 'No subroutine specified' unless $name;
- my $proto;
- my $r = ref $name;
- if (!$r) {
-  $proto = prototype $name;
- } elsif ($r eq 'HASH') {
-  croak 'Forced prototype hash reference must contain exactly one key/value pair' unless keys %$name == 1;
-  ($name, $proto) = %$name;
- } else {
-  croak 'Unhandled ' . $r . ' reference as first argument';
- }
- $name =~ s/^\s+//;
- $name =~ s/[\s\$\@\%\*\&;].*//;
- return $name, $proto;
-}
+    my $a = [ 0 .. 2 ];
+    my $push = wrap 'CORE::push', compile => 1;
+    $push->($a, 3, 4); # returns 3 + 2 = 5 and $a now contains 0 .. 4
 
-sub recall {
- my ($name, $proto) = _check_name shift;
- my $call = $name . '(';
- my @cr;
- if (defined $proto) {
-  my $i = 0;
-  while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
-   my $p = $2;
-   if ($1) {
-    my $r = _check_ref $_[$i], $p;
-    $call .= $sigils{$r} . '{$_[' . $i . ']},';
-   } elsif ($p =~ /[\@\%]/) {
-    $call .= '@_[' . $i . '..' . (@_ - 1) . ']';
-    last;
-   } elsif ($p =~ /\&/) {
-    push @cr, $_[$i];
-    $call .= 'sub{&{$cr[' . $#cr . ']}},';
-   } elsif ($p eq '_' && $i >= @_) {
-    $call .= '$_,';
-   } else {
-    $call .= '$_[' . $i . '],';
-   }
-   ++$i; 
-  }
-  $call =~ s/,$//;
- } else {
-  $call .= join ',', map '$_[' . $_ . ']', 0 .. @_ - 1;
- }
- $call .= ');';
- my @ret = eval $call;
- croak $@ if $@;
- return @ret;
-}
+You can force the use of a specific prototype. In this case, C<$name> must be a hash reference that holds exactly one key / value pair, the key being the function name and the value the prototpye that should be used to call it.
 
-=head2 C<wrap $name, %opts>
+    my $push = wrap { 'CORE::push' => '\@$' }, compile => 1; # only pushes 1 arg
 
-Generates a wrapper that does the same thing as L</recall>, but specialized for a given function. This wrapper can be compiled once for all to avoid calling C<eval> at each run (like L</recall> does). You can still force the prototype by passing C<< { $name => $proto } >> as the first argument. Others arguments are seen as key / value pairs and tune the code generated by L</wrap>. Valid keys are :
+Others arguments are seen as key / value pairs that are meant to tune the code generated by L</wrap>. Valid keys are :
 
 =over 4
 
@@ -187,11 +126,10 @@ Makes L</wrap> compile the code generated and return the resulting code referenc
 
 =back
 
-This is how you make your own C<push> that pushes into array references :
+For example, this allows you to recall into C<CORE::grep> and C<CORE::map> by using the C<\&@> prototype :
 
-    my @a = (0 .. 2);
-    my $push = wrap 'CORE::push', compile => 1;
-    $push->(\@a, 3 .. 7); # returns 3 + 5 = 8, and @a now contains 0 .. 7
+    my $grep = wrap { 'CORE::grep' => '\&@' }, compile => 1;
+    sub mygrep (&@) { $grep->(@_) } # the prototypes are intentionally different
 
 =cut
 
@@ -241,6 +179,24 @@ sub _wrap {
  }
 }
 
+sub _check_name {
+ my $name = $_[0];
+ croak 'No subroutine specified' unless $name;
+ my $proto;
+ my $r = ref $name;
+ if (!$r) {
+  $proto = prototype $name;
+ } elsif ($r eq 'HASH') {
+  croak 'Forced prototype hash reference must contain exactly one key/value pair' unless keys %$name == 1;
+  ($name, $proto) = %$name;
+ } else {
+  croak 'Unhandled ' . $r . ' reference as first argument';
+ }
+ $name =~ s/^\s+//;
+ $name =~ s/[\s\$\@\%\*\&;].*//;
+ return $name, $proto;
+}
+
 sub wrap {
  my ($name, $proto) = _check_name shift;
  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
@@ -269,9 +225,27 @@ sub wrap {
  return $call;
 }
 
+=head2 C<recall $name, @args>
+
+Calls the function C<$name> with the prototyped argument list C<@args>. That is, C<@args> should be what C<@_> is when you define a subroutine with the same prototype as C<$name>. You can still force the prototype by passing C<< { $name => $proto } >> as the first argument.
+
+    my $a = [ ];
+    recall { 'CORE::push' => '\@$' }, $a, 1, 2, 3; # $a just contains 1
+
+It's implemented in terms of L</wrap>, and hence calls C<eval> at each run.
+If you plan to recall several times, consider using L</wrap> instead.
+
+=cut
+
+sub recall {
+ my $wrap = eval { wrap shift, compile => 1 };
+ croak $@ if $@;
+ return $wrap->(@_);
+}
+
 =head1 EXPORT
 
-The functions L</flatten>, L</recall> and L</wrap> are only exported on request, either by providing their name or by the C<':funcs'> and C<':all'> tags.
+The functions L</flatten>, L</wrap> and L</recall> are only exported on request, either by providing their name or by the C<':funcs'> and C<':all'> tags.
 
 =cut
 
@@ -281,7 +255,7 @@ use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS/;
 
 @EXPORT             = ();
 %EXPORT_TAGS        = (
- 'funcs' =>  [ qw/flatten recall wrap/ ]
+ 'funcs' =>  [ qw/flatten wrap recall/ ]
 );
 @EXPORT_OK          = map { @$_ } values %EXPORT_TAGS;
 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
diff --git a/t/12-wrap.t b/t/11-wrap.t
similarity index 100%
rename from t/12-wrap.t
rename to t/11-wrap.t
diff --git a/t/11-recall.t b/t/12-recall.t
similarity index 100%
rename from t/11-recall.t
rename to t/12-recall.t