From: Vincent Pit Date: Sun, 29 Jun 2008 15:52:10 +0000 (+0200) Subject: Importing Sub-Prototype-Util-0.05.tar.gz X-Git-Tag: v0.05^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Prototype-Util.git;a=commitdiff_plain;h=29d3a214c70390edd665985eddfb42ff7e29a02a Importing Sub-Prototype-Util-0.05.tar.gz --- diff --git a/Changes b/Changes index cd90ae3..706657c 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,9 @@ Revision history for Sub-Prototype-Util +0.05 2008-04-15 09:45 UTC + + Add : You can now specify which prototype to use with recall(). This + is needed to be able to recall into CORE::{grep,map}. + 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 diff --git a/META.yml b/META.yml index 7300b25..435f53b 100644 --- a/META.yml +++ b/META.yml @@ -1,11 +1,11 @@ --- #YAML:1.0 name: Sub-Prototype-Util -version: 0.04 +version: 0.05 abstract: Prototype-related utility routines. license: perl author: - Vincent Pit -generated_by: ExtUtils::MakeMaker version 6.42 +generated_by: ExtUtils::MakeMaker version 6.44 distribution_type: module requires: Carp: 0 diff --git a/README b/README index 2971b31..915c789 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ NAME Sub::Prototype::Util - Prototype-related utility routines. VERSION - Version 0.04 + Version 0.05 SYNOPSIS use Sub::Prototype::Util qw/flatten recall/; @@ -40,6 +40,18 @@ FUNCTIONS 3". This is especially needed for core functions because you can't "goto" into them. + You can also force the use of a specific prototype. In this case, $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 "CORE::grep" and "CORE::map" by using the + "\&@" prototype : + + sub mygrep (&@) { recall { 'CORE::grep' => '\&@' }, @_ } # the prototypes are intentionally different + EXPORT The functions "flatten" and "recall" are only exported on request, either by providing their name or by the ':funcs' and ':all' tags. diff --git a/lib/Sub/Prototype/Util.pm b/lib/Sub/Prototype/Util.pm index 5c0c04e..73a1a60 100644 --- a/lib/Sub/Prototype/Util.pm +++ b/lib/Sub/Prototype/Util.pm @@ -12,13 +12,13 @@ Sub::Prototype::Util - Prototype-related utility routines. =head1 VERSION -Version 0.04 +Version 0.05 =cut use vars qw/$VERSION/; -$VERSION = '0.04'; +$VERSION = '0.05'; =head1 SYNOPSIS @@ -98,15 +98,31 @@ Calls the function C<$name> with the prototyped argument list C<@args>. That is, 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 + =cut sub recall { my $name = shift; - croak 'Wrong subroutine name' unless $name; + 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; @@ -114,24 +130,26 @@ sub recall { my $p = $2; if ($1) { my $r = _check_ref $_[$i], $p; - push @args, join '', $sigils{$r}, '{$_[', $i, ']}'; + $call .= $sigils{$r} . '{$_[' . $i . ']},'; } elsif ($p =~ /[\@\%]/) { - push @args, join '', '@_[', $i, '..', (@_ - 1), ']'; + $call .= '@_[' . $i . '..' . (@_ - 1) . ']'; last; } elsif ($p =~ /\&/) { push @cr, $_[$i]; - push @args, 'sub{&{$cr[' . $#cr . ']}}'; + $call .= 'sub{&{$cr[' . $#cr . ']}},'; } elsif ($p eq '_' && $i >= @_) { - push @args, '$_'; + $call .= '$_,'; } else { - push @args, '$_[' . $i . ']'; + $call .= '$_[' . $i . '],'; } ++$i; } + $call =~ s/,$//; } else { - @args = map '$_[' . $_ . ']', 0 .. @_ - 1; + $call .= join ',', map '$_[' . $_ . ']', 0 .. @_ - 1; } - my @ret = eval $name . '(' . join(',', @args) . ');'; + $call .= ');'; + my @ret = eval $call; croak $@ if $@; return @ret; } diff --git a/t/11-recall.t b/t/11-recall.t index 0c48dbb..10c479c 100644 --- a/t/11-recall.t +++ b/t/11-recall.t @@ -3,15 +3,23 @@ use strict; use warnings; -use Test::More tests => 3 + 14 + (($^V ge v5.10.0) ? 4 : 0); +use Test::More tests => 7 + 18 + (($^V ge v5.10.0) ? 4 : 0); use Scalar::Util qw/set_prototype/; use Sub::Prototype::Util qw/recall/; eval { recall undef }; -like($@, qr/^Wrong\s+subroutine/, 'recall undef croaks'); +like($@, qr/^No\s+subroutine/, 'recall undef croaks'); eval { recall '' }; -like($@, qr/^Wrong\s+subroutine/, 'recall "" croaks'); +like($@, qr/^No\s+subroutine/, 'recall "" croaks'); +eval { recall \1 }; +like($@, qr/^Unhandled\s+SCALAR/, 'recall scalarref croaks'); +eval { recall [ ] }; +like($@, qr/^Unhandled\s+ARRAY/, 'recall arrayref croaks'); +eval { recall sub { } }; +like($@, qr/^Unhandled\s+CODE/, 'recall coderef croaks'); +eval { recall { 'foo' => undef, 'bar' => undef } }; +like($@, qr!exactly\s+one\s+key/value\s+pair!, 'recall hashref with 2 pairs croaks'); eval { recall 'hlagh' }; like($@, qr/^Undefined\s+subroutine/, 'recall croaks'); @@ -22,11 +30,14 @@ sub mygrep2 (\&@) { grep { $_[0]->() } @_[1 .. $#_] } sub modify ($) { my $old = $_[0]; $_[0] = 5; $old } my $t = [ 1, 2, 3, 4 ]; +my $m = [ sub { $_ + 10 }, 1 .. 5 ]; 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 ] ], + [ { 'CORE::push' => undef }, 'push', [ [ 1, 2 ], 3, 5 ], [ [ 1, 2, 3, 5 ], 3, 5 ], [ 4 ] ], + [ { 'CORE::push' => '\@$' }, 'push just one', [ [ 1, 2 ], 3, 5 ], [ [ 1, 2, 3 ], 3, 5 ], [ 3 ] ], + [ { 'CORE::map' => '\&@' }, 'map', $m, $m, [ 11 .. 15 ] ], [ 'main::mytrunc', 'truncate 1', [ 1 ], [ 1 ], [ undef, 1 ] ], [ 'main::mytrunc', 'truncate 2', $t, $t, [ 2, 1 ] ], [ 'main::mygrep1', 'grep1', $g, $g, [ 3 .. 5 ] ],