Revision history for Sub-Prototype-Util
+0.04 2008-04-09 13:25 UTC
+ + Fix : recall() should pass by reference as much as possible, or we
+ won't be able to apply it to functions that modify their
+ arguments (e.g. open()).
+ + Fix : our really doesn't exist in 5.005.
+
0.03 2008-04-06 22:20 UTC
+ Fix : our doesn't exist in 5.005 (sigh).
+ Fix : '_' prototype should use the current argument when it's
--- #YAML:1.0
name: Sub-Prototype-Util
-version: 0.03
+version: 0.04
abstract: Prototype-related utility routines.
license: perl
author:
Sub::Prototype::Util - Prototype-related utility routines.
VERSION
- Version 0.03
+ Version 0.04
SYNOPSIS
use Sub::Prototype::Util qw/flatten recall/;
=head1 VERSION
-Version 0.03
+Version 0.04
=cut
use vars qw/$VERSION/;
-$VERSION = '0.03';
+$VERSION = '0.04';
=head1 SYNOPSIS
=cut
sub recall {
- my ($name, @a) = @_;
+ my $name = shift;
croak 'Wrong subroutine name' unless $name;
$name =~ s/^\s+//;
$name =~ s/[\s\$\@\%\*\&;].*//;
my $proto = prototype $name;
my @args;
+ my @cr;
if (defined $proto) {
my $i = 0;
while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
my $p = $2;
if ($1) {
- my $r = _check_ref $a[$i], $p;
- push @args, join '', $sigils{$r}, '{$a[', $i, ']}';
+ my $r = _check_ref $_[$i], $p;
+ push @args, join '', $sigils{$r}, '{$_[', $i, ']}';
} elsif ($p =~ /[\@\%]/) {
- push @args, join '', '@a[', $i, '..', (@a - 1), ']';
+ push @args, join '', '@_[', $i, '..', (@_ - 1), ']';
last;
} elsif ($p =~ /\&/) {
- push @args, 'sub{&{$a[' . $i . ']}}';
- } elsif ($p eq '_' && $i >= @a) {
+ push @cr, $_[$i];
+ push @args, 'sub{&{$cr[' . $#cr . ']}}';
+ } elsif ($p eq '_' && $i >= @_) {
push @args, '$_';
} else {
- push @args, '$a[' . $i . ']';
+ push @args, '$_[' . $i . ']';
}
++$i;
}
} else {
- @args = map '$a[' . $_ . ']', 0 .. @a - 1;
+ @args = map '$_[' . $_ . ']', 0 .. @_ - 1;
}
my @ret = eval $name . '(' . join(',', @args) . ');';
croak $@ if $@;
use base qw/Exporter/;
-our @EXPORT = ();
-our %EXPORT_TAGS = (
+use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS/;
+
+@EXPORT = ();
+%EXPORT_TAGS = (
'funcs' => [ qw/flatten recall/ ]
);
-our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
+@EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
=head1 DEPENDENCIES
use strict;
use warnings;
-use Test::More tests => 3 + 12 + (($^V ge v5.10.0) ? 4 : 0);
+use Test::More tests => 3 + 14 + (($^V ge v5.10.0) ? 4 : 0);
use Scalar::Util qw/set_prototype/;
use Sub::Prototype::Util qw/recall/;
like($@, qr/^Undefined\s+subroutine/, 'recall <unknown> croaks');
sub noproto { $_[1], $_[0] }
-sub mytrunc ($;$) { $_[1], $_[0] };
-sub mygrep1 (&@) { grep { $_[0]->() } @_[1 .. $#_] };
-sub mygrep2 (\&@) { grep { $_[0]->() } @_[1 .. $#_] };
+sub mytrunc ($;$) { $_[1], $_[0] }
+sub mygrep1 (&@) { grep { $_[0]->() } @_[1 .. $#_] }
+sub mygrep2 (\&@) { grep { $_[0]->() } @_[1 .. $#_] }
+sub modify ($) { my $old = $_[0]; $_[0] = 5; $old }
+
my $t = [ 1, 2, 3, 4 ];
my $g = [ sub { $_ > 2 }, 1 .. 5 ];
+
my @tests = (
[ 'main::noproto', 'no prototype', $t, $t, [ 2, 1 ] ],
[ 'CORE::push', 'push', [ [ 1, 2 ], 3, 5 ], [ [ 1, 2, 3, 5 ], 3, 5 ], [ 4 ] ],
[ 'main::mytrunc', 'truncate 2', $t, $t, [ 2, 1 ] ],
[ 'main::mygrep1', 'grep1', $g, $g, [ 3 .. 5 ] ],
[ 'main::mygrep2', 'grep2', $g, $g, [ 3 .. 5 ] ],
+ [ 'main::modify', 'modify arguments', [ 1 ], [ 5 ], [ 1 ] ],
);
+
sub myit { push @{$_[0]->[2]}, 3; return 4 };
if ($^V ge v5.10.0) {
set_prototype \&myit, '_';