X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FSub%2FPrototype%2FUtil.pm;h=d549a1cc992e8ea86ceac04a35f89d11a7207098;hb=06a00e8349c4f0c7b7388af0dbfcd562721e8d43;hp=11eeb91395a79e2ad1db7a54ea992916075e194d;hpb=cdcb726f9c5b8e0414ea40052350331c72c637c8;p=perl%2Fmodules%2FSub-Prototype-Util.git

diff --git a/lib/Sub/Prototype/Util.pm b/lib/Sub/Prototype/Util.pm
index 11eeb91..d549a1c 100644
--- a/lib/Sub/Prototype/Util.pm
+++ b/lib/Sub/Prototype/Util.pm
@@ -22,14 +22,14 @@ $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 );
 
     my @flat = flatten '\@$;$', @args; # ('a', 'b', 'c', 1, { d => 2 })
     recall 'CORE::push', @args; # @a contains 'a', 'b', 'c', 1, { d => 2 }, undef, 3
-    my $splice = wrap 'CORE::splice', compile => 1;
+    my $splice = wrap 'CORE::splice';
     my @b = $splice->(\@a, 4, 2); # @a is now ('a', 'b', 'c', 1, 3) and @b is ({ d => 2 }, undef)
 
 =head1 DESCRIPTION
@@ -72,19 +72,23 @@ sub flatten {
   if ($1) {
    my $a = shift;
    my $r = _check_ref $a, $p;
-   my %deref = (
-    SCALAR => sub { push @args, $$a },
-    ARRAY  => sub { push @args, @$a },
-    HASH   => sub { push @args, %$a },
-    GLOB   => sub { push @args, *$a },
-    CODE   => sub { push @args, &$a }
-   );
-   $deref{$r}->();
+   push @args, $r eq 'SCALAR'
+               ? $$a
+               : ($r eq 'ARRAY'
+                  ? @$a
+                  : ($r eq 'HASH'
+                     ? %$a
+                     : ($r eq 'GLOB'
+                        ? *$a
+                        : &$a # _check_ref ensures this must be a code ref
+                       )
+                    )
+                 );
   } elsif ($p =~ /[\@\%]/) {
    push @args, @_;
    last;
-  } elsif ($p eq '_' && @_ == 0) {
-   push @args, $_;
+  } elsif ($p eq '_') {
+   shift; # without prototype, this argument wouldn't have been passed
   } else {
    push @args, shift;
   }
@@ -92,80 +96,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 :
+=head2 C<wrap $name, %opts>
 
-    sub mygrep (&@) { recall { 'CORE::grep' => '\&@' }, @_ } # the prototypes are intentionally different
+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>.
 
-=cut
+    my $a = [ 0 .. 2 ];
+    my $push = wrap 'CORE::push';
+    $push->($a, 3, 4); # returns 3 + 2 = 5 and $a now contains 0 .. 4
 
-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 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' => '\@$' }; # 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
 
@@ -183,23 +126,21 @@ Encloses the code into a C<sub { }> block. Default is true.
 
 =item C<< compile => $bool >>
 
-Makes L</wrap> compile the code generated and return the resulting code reference. Implies C<< sub => 1 >>. Be careful that in this case C<ref> must be a fully qualified function name. Defaults to false.
+Makes L</wrap> compile the code generated and return the resulting code reference. Be careful that in this case C<ref> must be a fully qualified function name. Defaults to true, but turned off when C<sub> is false.
 
 =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' => '\&@' };
+    sub mygrep (&@) { $grep->(@_) } # the prototypes are intentionally different
 
 =cut
 
 sub _wrap {
  my ($name, $proto, $i, $args, $cr, $opts) = @_;
- if ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])(.*)/g) {
+ while ($proto =~ s/(\\?)(\[[^\]]+\]|[^\];])//) {
   my ($ref, $p) = ($1, $2);
-  $proto = $3;
   $p = $1 if $p =~ /^\[([^\]]+)\]/;
   my $cur = '$_[' . $i . ']';
   if ($ref) {
@@ -234,11 +175,28 @@ sub _wrap {
   } else {
    $args .= $cur . ', ';
   }
-  return _wrap($name, $proto, ($i + 1), $args, $cr, $opts);
+  ++$i;
+ }
+ $args =~ s/,\s*$//;
+ return $name . '(' . $args . ')';
+}
+
+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 {
-  $args =~ s/,\s*$//;
-  return $name . '(' . $args . ')';
+  croak 'Unhandled ' . $r . ' reference as first argument';
  }
+ $name =~ s/^\s+//;
+ $name =~ s/[\s\$\@\%\*\&;].*//;
+ return $name, $proto;
 }
 
 sub wrap {
@@ -246,7 +204,8 @@ sub wrap {
  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
  my %opts = @_;
  $opts{ref}     ||= 'ref';
- $opts{sub}       = 1       if not exists $opts{sub} or $opts{compile};
+ $opts{sub}       = 1       if not defined $opts{sub};
+ $opts{compile}   = 1       if not defined $opts{compile} and $opts{sub};
  $opts{wrong_ref} = 'undef' if not defined $opts{wrong_ref};
  my @cr;
  my $call;
@@ -269,9 +228,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 };
+ 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 +258,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 ];
@@ -294,7 +271,7 @@ L<Carp>, L<Exporter> (core modules since perl 5), L<Scalar::Util> (since 5.7.3).
 
 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 
-You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
+You can contact me by mail or on C<irc.perl.org> (vincent).
 
 =head1 BUGS