From: Vincent Pit <vince@profvince.com>
Date: Sun, 29 Jun 2008 15:52:14 +0000 (+0200)
Subject: Importing Sub-Prototype-Util-0.07.tar.gz
X-Git-Tag: v0.07^0
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Prototype-Util.git;a=commitdiff_plain;h=bddf69cf5d7e479af6e609e493f344c3b191e69a

Importing Sub-Prototype-Util-0.07.tar.gz
---

diff --git a/Changes b/Changes
index cb53632..cd1307f 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,10 @@
 Revision history for Sub-Prototype-Util
 
+0.07    2008-04-21 09:00 UTC
+        + Add : Forward eval() errors when compiling in wrap().
+        + Add : Talk about wrap() in the synopsis and samples/try.pl.
+        + Fix : t/12-wrap.t failures with 5.6.x.
+
 0.06    2008-04-20 16:20 UTC
         + Add : The wrap() function.
 
diff --git a/META.yml b/META.yml
index 0bda0da..796b2c7 100644
--- a/META.yml
+++ b/META.yml
@@ -1,6 +1,6 @@
 --- #YAML:1.0
 name:                Sub-Prototype-Util
-version:             0.06
+version:             0.07
 abstract:            Prototype-related utility routines.
 license:             perl
 author:              
diff --git a/README b/README
index a9792c1..4ff0b74 100644
--- a/README
+++ b/README
@@ -2,16 +2,18 @@ NAME
     Sub::Prototype::Util - Prototype-related utility routines.
 
 VERSION
-    Version 0.06
+    Version 0.07
 
 SYNOPSIS
-        use Sub::Prototype::Util qw/flatten recall/;
+        use Sub::Prototype::Util qw/flatten recall wrap/;
 
         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 @b = $splice->(\@a, 4, 2); # @a is now ('a', 'b', 'c', 1, 3) and @b is ({ d => 2 }, undef)
 
 DESCRIPTION
     Prototypes are evil, but sometimes you just have to bear with them,
diff --git a/lib/Sub/Prototype/Util.pm b/lib/Sub/Prototype/Util.pm
index 78182d3..531cdae 100644
--- a/lib/Sub/Prototype/Util.pm
+++ b/lib/Sub/Prototype/Util.pm
@@ -12,23 +12,25 @@ Sub::Prototype::Util - Prototype-related utility routines.
 
 =head1 VERSION
 
-Version 0.06
+Version 0.07
 
 =cut
 
 use vars qw/$VERSION/;
 
-$VERSION = '0.06';
+$VERSION = '0.07';
 
 =head1 SYNOPSIS
 
-    use Sub::Prototype::Util qw/flatten recall/;
+    use Sub::Prototype::Util qw/flatten recall wrap/;
 
     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 @b = $splice->(\@a, 4, 2); # @a is now ('a', 'b', 'c', 1, 3) and @b is ({ d => 2 }, undef)
 
 =head1 DESCRIPTION
 
@@ -198,20 +200,21 @@ sub _wrap {
   my ($ref, $p) = ($1, $2);
   $proto = $3;
   $p = $1 if $p =~ /^\[([^\]]+)\]/;
+  my $cur = '$_[' . $i . ']';
   if ($ref) {
    if (length $p > 1) {
-    return 'my $r = ' . $opts->{ref} . '($_[' . $i . ']); ' 
+    return 'my $r = ' . $opts->{ref} . '(' . $cur . '); ' 
            . join ' els',
               map( {
                "if (\$r eq '" . $reftypes{$_} ."') { "
                . _wrap($name, $proto, ($i + 1),
-                              $args . $_ . '{$_[' . $i . ']}, ',
+                              $args . $_ . '{' . $cur . '}, ',
                               $cr, $opts)
                . ' }'
               } split //, $p),
               'e { ' . $opts->{wrong_ref} . ' }'
    } else {
-    $args .= $p . '{$_[' . $i . ']}, ';
+    $args .= $p . '{' . $cur . '}, ';
    }
   } elsif ($p =~ /[\@\%]/) {
    $args .= '@_[' . $i . '..$#_]';
@@ -226,9 +229,9 @@ sub _wrap {
    }
    $args .= 'sub{&{$c[' . $j . ']}}, ';
   } elsif ($p eq '_') {
-   $args .= '((@_ > ' . $i . ') ? $_[' . $i . '] : $_), ';
+   $args .= '((@_ > ' . $i . ') ? ' . $cur . ' : $_), ';
   } else {
-   $args .= '$_[' . $i . '], ';
+   $args .= $cur . ', ';
   }
   return _wrap($name, $proto, ($i + 1), $args, $cr, $opts);
  } else {
@@ -258,7 +261,10 @@ sub wrap {
  }
  $call = '{ ' . $call . ' }';
  $call = 'sub ' . $call if $opts{sub};
- $call = eval $call     if $opts{compile};
+ if ($opts{compile}) {
+  $call = eval $call;
+  croak $@ if $@;
+ }
  return $call;
 }
 
diff --git a/samples/try.pl b/samples/try.pl
index c9fbe07..250ff60 100755
--- a/samples/try.pl
+++ b/samples/try.pl
@@ -7,7 +7,7 @@ use Data::Dumper;
 
 use lib qw{blib/lib};
 
-use Sub::Prototype::Util qw/flatten recall/;
+use Sub::Prototype::Util qw/flatten recall wrap/;
 
 my @a = qw/a b c/;
 print "At the beginning, \@a contains :\n", Dumper(\@a);
@@ -21,3 +21,8 @@ print "When flatten with prototype $proto, this gives :\n", Dumper(\@flat);
 
 recall 'CORE::push', @args; # @a contains 'a', 'b', 'c', 1, { d => 2 }, undef, 3
 print "After recalling CORE::push with \@args, \@a contains :\n", Dumper(\@a);
+
+my $splice = wrap 'CORE::splice', compile => 1;
+my @b = $splice->(\@a, 4, 2);
+print "After calling wrapped splice with \@a, it contains :\n", Dumper(\@a);
+print "What was returned :\n", Dumper(\@b);
diff --git a/t/12-wrap.t b/t/12-wrap.t
index 5420606..e50efc5 100644
--- a/t/12-wrap.t
+++ b/t/12-wrap.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 7 + 6 + 3 + 1 + 6 + 1 + (($^V ge v5.10.0) ? 2 : 0);
+use Test::More tests => 7 + 6 + 3 + 1 + 6 + 1 + (($^V ge v5.10.0) ? 2 : 0) + 1;
 
 use Scalar::Util qw/set_prototype/;
 use Sub::Prototype::Util qw/wrap/;
@@ -73,7 +73,7 @@ is($cb,
             q!} }!),
     'callbacks');
 
-sub myref ($) { ref $_[0] };
+sub myref { ref $_[0] };
 
 sub cat (\[$@]\[$@]) {
  if (ref $_[0] eq 'SCALAR') {
@@ -91,22 +91,27 @@ sub cat (\[$@]\[$@]) {
  }
 }
 
-my $cat = wrap 'main::cat', ref => 'main::myref', wrong_ref => 'die "hlagh"',
-                            sub => 1, compile => 1,
-my @tests = (
- [ \'a',        \'b',        [ 'ab' ],        'scalar-scalar' ],
- [ \'c',        [ qw/d e/ ], [ qw/c d e/ ],   'scalar-array' ],
- [ [ qw/f g/ ], \'h',        [ qw/f g h/ ],   'array-scalar' ],
- [ [ qw/i j/ ], [ qw/k l/ ], [ qw/i j k l/ ], 'array-array' ]
-);
-for (@tests) {
- my $res = [ $cat->($_->[0], $_->[1]) ];
- is_deeply($res, $_->[2], 'cat ' . $_->[3]);
+SKIP: {
+ skip 'perl 5.8.x is needed to test execution of \[$@] prototypes' => 6
+   if $^V lt v5.8.0;
+
+ my $cat = wrap 'main::cat', ref => 'main::myref', wrong_ref => 'die "hlagh"',
+                             sub => 1, compile => 1;
+ my @tests = (
+  [ \'a',        \'b',        [ 'ab' ],        'scalar-scalar' ],
+  [ \'c',        [ qw/d e/ ], [ qw/c d e/ ],   'scalar-array' ],
+  [ [ qw/f g/ ], \'h',        [ qw/f g h/ ],   'array-scalar' ],
+  [ [ qw/i j/ ], [ qw/k l/ ], [ qw/i j k l/ ], 'array-array' ]
+ );
+ for (@tests) {
+  my $res = [ $cat->($_->[0], $_->[1]) ];
+  is_deeply($res, $_->[2], 'cat ' . $_->[3]);
+ }
+ eval { $cat->({ foo => 1 }, [ 2 ] ) };
+ like($@, qr/^hlagh\s+at/, 'wrong reference type 1');
+ eval { $cat->(\1, sub { 2 } ) };
+ like($@, qr/^hlagh\s+at/, 'wrong reference type 2');
 }
-eval { $cat->({ foo => 1 }, [ 2 ] ) };
-like($@, qr/^hlagh\s+at/, 'wrong reference type 1');
-eval { $cat->(\1, sub { 2 } ) };
-like($@, qr/^hlagh\s+at/, 'wrong reference type 2');
 
 sub noproto;
 my $noproto_exp = '{ main::noproto(@_) }';
@@ -124,3 +129,6 @@ if ($^V ge v5.10.0) {
  $it->(\@a, 6);
  is_deeply(\@a, [ qw/u v w/, 3, 4, 6, 7 ], '_ without arguments');
 }
+
+eval { wrap { 'main::dummy' => '\[@%]' }, ref => 'shift', compile => 1 };
+like($@, qr/to\s+shift\s+must\s+be\s+array/, 'invalid eval code croaks');