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.
--- #YAML:1.0
name: Sub-Prototype-Util
-version: 0.06
+version: 0.07
abstract: Prototype-related utility routines.
license: perl
author:
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,
=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
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 . '..$#_]';
}
$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 {
}
$call = '{ ' . $call . ' }';
$call = 'sub ' . $call if $opts{sub};
- $call = eval $call if $opts{compile};
+ if ($opts{compile}) {
+ $call = eval $call;
+ croak $@ if $@;
+ }
return $call;
}
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);
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);
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/;
q!} }!),
'callbacks');
-sub myref ($) { ref $_[0] };
+sub myref { ref $_[0] };
sub cat (\[$@]\[$@]) {
if (ref $_[0] eq 'SCALAR') {
}
}
-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(@_) }';
$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');