=head1 VERSION
-Version 0.03
+Version 0.05
=cut
use vars qw/$VERSION/;
-$VERSION = '0.03';
+$VERSION = '0.05';
=head1 SYNOPSIS
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 :
+
+ sub mygrep (&@) { recall { 'CORE::grep' => '\&@' }, @_ } # the prototypes are intentionally different
+
=cut
sub recall {
- my ($name, @a) = @_;
- croak 'Wrong subroutine name' unless $name;
+ my $name = shift;
+ croak 'No subroutine specified' unless $name;
+ my $proto;
+ my $r = ref $name;
+ if ($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) {
+ croak 'Unhandled ' . $r . ' reference as first argument';
+ }
$name =~ s/^\s+//;
$name =~ s/[\s\$\@\%\*\&;].*//;
- my $proto = prototype $name;
- my @args;
+ $proto = prototype $name unless $proto;
+ my $call = $name . '(';
+ 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;
+ $call .= $sigils{$r} . '{$_[' . $i . ']},';
} elsif ($p =~ /[\@\%]/) {
- push @args, join '', '@a[', $i, '..', (@a - 1), ']';
+ $call .= '@_[' . $i . '..' . (@_ - 1) . ']';
last;
} elsif ($p =~ /\&/) {
- push @args, 'sub{&{$a[' . $i . ']}}';
- } elsif ($p eq '_' && $i >= @a) {
- push @args, '$_';
+ push @cr, $_[$i];
+ $call .= 'sub{&{$cr[' . $#cr . ']}},';
+ } elsif ($p eq '_' && $i >= @_) {
+ $call .= '$_,';
} else {
- push @args, '$a[' . $i . ']';
+ $call .= '$_[' . $i . '],';
}
++$i;
}
+ $call =~ s/,$//;
} else {
- @args = map '$a[' . $_ . ']', 0 .. @a - 1;
+ $call .= join ',', map '$_[' . $_ . ']', 0 .. @_ - 1;
}
- my @ret = eval $name . '(' . join(',', @args) . ');';
+ $call .= ');';
+ my @ret = eval $call;
croak $@ if $@;
return @ret;
}
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