X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Prototype-Util.git;a=blobdiff_plain;f=lib%2FSub%2FPrototype%2FUtil.pm;h=b78f396adcfa24ff67492fe13d81a281d70b91a1;hp=68ac767034d309c575945a2fb85a893e8a91d53a;hb=f88d790683ee83e8225ee6b0bcb783260347c814;hpb=8c3d123a078fe87b9b1b20fce287044d3f7f62db
diff --git a/lib/Sub/Prototype/Util.pm b/lib/Sub/Prototype/Util.pm
index 68ac767..b78f396 100644
--- a/lib/Sub/Prototype/Util.pm
+++ b/lib/Sub/Prototype/Util.pm
@@ -22,7 +22,7 @@ $VERSION = '0.08';
=head1 SYNOPSIS
- use Sub::Prototype::Util qw/flatten recall wrap/;
+ use Sub::Prototype::Util qw/flatten wrap recall/;
my @a = qw/a b c/;
my @args = ( \@a, 1, { d => 2 }, undef, 3 );
@@ -92,80 +92,19 @@ sub flatten {
return @args;
}
-=head2 C
-
-Calls the function C<$name> with the prototyped argument list C<@args>. That is, C<@args> should be what C<@_> is when you define a subroutine with the same prototype as C<$name>. For example,
-
- my $a = [ ];
- recall 'CORE::push', $a, 1, 2, 3;
-
-will call C and so fill the arrayref C<$a> with C<1, 2, 3>. This is especially needed for core functions because you can't C 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 and C by using the C<\&@> prototype :
-
- sub mygrep (&@) { recall { 'CORE::grep' => '\&@' }, @_ } # the prototypes are intentionally different
+=head2 C
-=cut
+Generates a wrapper that calls the function C<$name> with a prototyped argument list. That is, the wrapper's arguments should be what C<@_> is when you define a subroutine with the same prototype as C<$name>.
-sub _check_name {
- my $name = $_[0];
- croak 'No subroutine specified' unless $name;
- my $proto;
- my $r = ref $name;
- 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;
- } else {
- croak 'Unhandled ' . $r . ' reference as first argument';
- }
- $name =~ s/^\s+//;
- $name =~ s/[\s\$\@\%\*\&;].*//;
- return $name, $proto;
-}
+ my $a = [ 0 .. 2 ];
+ my $push = wrap 'CORE::push', compile => 1;
+ $push->($a, 3, 4); # returns 3 + 2 = 5 and $a now contains 0 .. 4
-sub recall {
- my ($name, $proto) = _check_name shift;
- my $call = $name . '(';
- my @cr;
- if (defined $proto) {
- my $i = 0;
- while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
- my $p = $2;
- if ($1) {
- my $r = _check_ref $_[$i], $p;
- $call .= $sigils{$r} . '{$_[' . $i . ']},';
- } elsif ($p =~ /[\@\%]/) {
- $call .= '@_[' . $i . '..' . (@_ - 1) . ']';
- last;
- } elsif ($p =~ /\&/) {
- push @cr, $_[$i];
- $call .= 'sub{&{$cr[' . $#cr . ']}},';
- } elsif ($p eq '_' && $i >= @_) {
- $call .= '$_,';
- } else {
- $call .= '$_[' . $i . '],';
- }
- ++$i;
- }
- $call =~ s/,$//;
- } else {
- $call .= join ',', map '$_[' . $_ . ']', 0 .. @_ - 1;
- }
- $call .= ');';
- my @ret = eval $call;
- croak $@ if $@;
- return @ret;
-}
+You can 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.
-=head2 C
+ my $push = wrap { 'CORE::push' => '\@$' }, compile => 1; # only pushes 1 arg
-Generates a wrapper that does the same thing as L, but specialized for a given function. This wrapper can be compiled once for all to avoid calling C at each run (like L does). You can still force the prototype by passing C<< { $name => $proto } >> as the first argument. Others arguments are seen as key / value pairs and tune the code generated by L. Valid keys are :
+Others arguments are seen as key / value pairs that are meant to tune the code generated by L. Valid keys are :
=over 4
@@ -187,11 +126,10 @@ Makes L compile the code generated and return the resulting code referenc
=back
-This is how you make your own C that pushes into array references :
+For example, this allows you to recall into C and C by using the C<\&@> prototype :
- my @a = (0 .. 2);
- my $push = wrap 'CORE::push', compile => 1;
- $push->(\@a, 3 .. 7); # returns 3 + 5 = 8, and @a now contains 0 .. 7
+ my $grep = wrap { 'CORE::grep' => '\&@' }, compile => 1;
+ sub mygrep (&@) { $grep->(@_) } # the prototypes are intentionally different
=cut
@@ -241,6 +179,24 @@ sub _wrap {
}
}
+sub _check_name {
+ my $name = $_[0];
+ croak 'No subroutine specified' unless $name;
+ my $proto;
+ my $r = ref $name;
+ 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;
+ } else {
+ croak 'Unhandled ' . $r . ' reference as first argument';
+ }
+ $name =~ s/^\s+//;
+ $name =~ s/[\s\$\@\%\*\&;].*//;
+ return $name, $proto;
+}
+
sub wrap {
my ($name, $proto) = _check_name shift;
croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
@@ -269,9 +225,27 @@ sub wrap {
return $call;
}
+=head2 C
+
+Calls the function C<$name> with the prototyped argument list C<@args>. That is, C<@args> should be what C<@_> is when you define a subroutine with the same prototype as C<$name>. You can still force the prototype by passing C<< { $name => $proto } >> as the first argument.
+
+ my $a = [ ];
+ recall { 'CORE::push' => '\@$' }, $a, 1, 2, 3; # $a just contains 1
+
+It's implemented in terms of L, and hence calls C at each run.
+If you plan to recall several times, consider using L instead.
+
+=cut
+
+sub recall {
+ my $wrap = eval { wrap shift, compile => 1 };
+ croak $@ if $@;
+ return $wrap->(@_);
+}
+
=head1 EXPORT
-The functions L, L and L are only exported on request, either by providing their name or by the C<':funcs'> and C<':all'> tags.
+The functions L, L and L are only exported on request, either by providing their name or by the C<':funcs'> and C<':all'> tags.
=cut
@@ -281,7 +255,7 @@ use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS/;
@EXPORT = ();
%EXPORT_TAGS = (
- 'funcs' => [ qw/flatten recall wrap/ ]
+ 'funcs' => [ qw/flatten wrap recall/ ]
);
@EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];