=head1 VERSION
-Version 0.06
+Version 0.08
=cut
use vars qw/$VERSION/;
-$VERSION = '0.06';
+$VERSION = '0.08';
=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
croak 'No subroutine specified' unless $name;
my $proto;
my $r = ref $name;
- if ($r eq 'HASH') {
+ 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;
- } elsif (length $r) {
+ } else {
croak 'Unhandled ' . $r . ' reference as first argument';
}
$name =~ s/^\s+//;
$name =~ s/[\s\$\@\%\*\&;].*//;
- $proto = prototype $name unless $proto;
return $name, $proto;
}
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;
}