From: Vincent Pit Date: Sun, 29 Jun 2008 15:52:12 +0000 (+0200) Subject: Importing Sub-Prototype-Util-0.06.tar.gz X-Git-Tag: v0.06^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Prototype-Util.git;a=commitdiff_plain;h=812065270f1262b670f91bc7de80f67c583a123e Importing Sub-Prototype-Util-0.06.tar.gz --- diff --git a/Changes b/Changes index 706657c..cb53632 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,8 @@ Revision history for Sub-Prototype-Util +0.06 2008-04-20 16:20 UTC + + Add : The wrap() function. + 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}. diff --git a/MANIFEST b/MANIFEST index d3d5726..6571dbe 100644 --- a/MANIFEST +++ b/MANIFEST @@ -8,6 +8,7 @@ t/00-load.t t/01-import.t t/10-flatten.t t/11-recall.t +t/12-wrap.t t/90-boilerplate.t t/91-pod.t t/92-pod-coverage.t diff --git a/META.yml b/META.yml index 435f53b..0bda0da 100644 --- a/META.yml +++ b/META.yml @@ -1,11 +1,11 @@ --- #YAML:1.0 name: Sub-Prototype-Util -version: 0.05 +version: 0.06 abstract: Prototype-related utility routines. license: perl author: - Vincent Pit -generated_by: ExtUtils::MakeMaker version 6.44 +generated_by: ExtUtils::MakeMaker version 6.42 distribution_type: module requires: Carp: 0 diff --git a/README b/README index 915c789..a9792c1 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ NAME Sub::Prototype::Util - Prototype-related utility routines. VERSION - Version 0.05 + Version 0.06 SYNOPSIS use Sub::Prototype::Util qw/flatten recall/; @@ -52,9 +52,43 @@ FUNCTIONS sub mygrep (&@) { recall { 'CORE::grep' => '\&@' }, @_ } # the prototypes are intentionally different + "wrap $name, %opts" + Generates a wrapper that does the same thing as "recall", but + specialized for a given function. This wrapper can be compiled once for + all to avoid calling "eval" at each run (like "recall" does). You can + still force the prototype by passing "{ $name => $proto }" as the first + argument. Others arguments are seen as key / value pairs and tune the + code generated by "wrap". Valid keys are : + + "ref => $func" + Specifies the function used in the generated code to test the + reference type of scalars. Defaults to 'ref'. You may also want to + use "Scalar::Util::reftype". + + "wrong_ref => $code" + The code executed when a reference of incorrect type is encountered. + The result of this snippet is also the result of the generated code, + hence it defaults to 'undef'. It's a good place to "croak" or "die" + too. + + "sub => $bool" + Encloses the code into a "sub { }" block. Default is true. + + "compile => $bool" + Makes "wrap" compile the code generated and return the resulting + code reference. Implies "sub => 1". Be careful that in this case + "ref" must be a fully qualified function name. Defaults to false. + + This is how you make your own "push" that pushes into array references : + + 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 + EXPORT - The functions "flatten" and "recall" are only exported on request, - either by providing their name or by the ':funcs' and ':all' tags. + The functions "flatten", "recall" and "wrap" are only exported on + request, either by providing their name or by the ':funcs' and ':all' + tags. DEPENDENCIES Carp, Exporter (core modules since perl 5), Scalar::Util (since 5.7.3). diff --git a/lib/Sub/Prototype/Util.pm b/lib/Sub/Prototype/Util.pm index 73a1a60..78182d3 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.05 +Version 0.06 =cut use vars qw/$VERSION/; -$VERSION = '0.05'; +$VERSION = '0.06'; =head1 SYNOPSIS @@ -41,6 +41,7 @@ They all handle C<5.10>'s C<_> prototype. =cut my %sigils = qw/SCALAR $ ARRAY @ HASH % GLOB * CODE &/; +my %reftypes = reverse %sigils; sub _check_ref { my ($a, $p) = @_; @@ -108,8 +109,8 @@ This allows you to recall into C and C by using the C<\&@ =cut -sub recall { - my $name = shift; +sub _check_name { + my $name = $_[0]; croak 'No subroutine specified' unless $name; my $proto; my $r = ref $name; @@ -122,6 +123,11 @@ sub recall { $name =~ s/^\s+//; $name =~ s/[\s\$\@\%\*\&;].*//; $proto = prototype $name unless $proto; + return $name, $proto; +} + +sub recall { + my ($name, $proto) = _check_name shift; my $call = $name . '('; my @cr; if (defined $proto) { @@ -154,9 +160,111 @@ sub recall { return @ret; } +=head2 C + +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 : + +=over 4 + +=item C<< ref => $func >> + +Specifies the function used in the generated code to test the reference type of scalars. Defaults to C<'ref'>. You may also want to use C. + +=item C<< wrong_ref => $code >> + +The code executed when a reference of incorrect type is encountered. The result of this snippet is also the result of the generated code, hence it defaults to C<'undef'>. It's a good place to C or C too. + +=item C<< sub => $bool >> + +Encloses the code into a C block. Default is true. + +=item C<< compile => $bool >> + +Makes L compile the code generated and return the resulting code reference. Implies C<< sub => 1 >>. Be careful that in this case C must be a fully qualified function name. Defaults to false. + +=back + +This is how you make your own C that pushes into array references : + + 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 + +=cut + +sub _wrap { + my ($name, $proto, $i, $args, $cr, $opts) = @_; + if ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])(.*)/g) { + my ($ref, $p) = ($1, $2); + $proto = $3; + $p = $1 if $p =~ /^\[([^\]]+)\]/; + if ($ref) { + if (length $p > 1) { + return 'my $r = ' . $opts->{ref} . '($_[' . $i . ']); ' + . join ' els', + map( { + "if (\$r eq '" . $reftypes{$_} ."') { " + . _wrap($name, $proto, ($i + 1), + $args . $_ . '{$_[' . $i . ']}, ', + $cr, $opts) + . ' }' + } split //, $p), + 'e { ' . $opts->{wrong_ref} . ' }' + } else { + $args .= $p . '{$_[' . $i . ']}, '; + } + } elsif ($p =~ /[\@\%]/) { + $args .= '@_[' . $i . '..$#_]'; + } elsif ($p =~ /\&/) { + my %h = do { my $c; map { $_ => $c++ } @$cr }; + my $j; + if (not exists $h{$i}) { + push @$cr, $i; + $j = $#{$cr}; + } else { + $j = int $h{$i}; + } + $args .= 'sub{&{$c[' . $j . ']}}, '; + } elsif ($p eq '_') { + $args .= '((@_ > ' . $i . ') ? $_[' . $i . '] : $_), '; + } else { + $args .= '$_[' . $i . '], '; + } + return _wrap($name, $proto, ($i + 1), $args, $cr, $opts); + } else { + $args =~ s/,\s*$//; + return $name . '(' . $args . ')'; + } +} + +sub wrap { + my ($name, $proto) = _check_name shift; + croak 'Optional arguments must be passed as key => value pairs' if @_ % 2; + my %opts = @_; + $opts{ref} ||= 'ref'; + $opts{sub} = 1 if not exists $opts{sub} or $opts{compile}; + $opts{wrong_ref} = 'undef' if not defined $opts{wrong_ref}; + my @cr; + my $call; + if (defined $proto) { + $call = _wrap $name, $proto, 0, '', \@cr, \%opts; + } else { + $call = _wrap $name, '', 0, '@_'; + } + if (@cr) { + $call = 'my @c; ' + . join('', map { 'push @c, $_[' . $_ . ']; ' } @cr) + . $call + } + $call = '{ ' . $call . ' }'; + $call = 'sub ' . $call if $opts{sub}; + $call = eval $call if $opts{compile}; + return $call; +} + =head1 EXPORT -The functions 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 @@ -166,7 +274,7 @@ use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS/; @EXPORT = (); %EXPORT_TAGS = ( - 'funcs' => [ qw/flatten recall/ ] + 'funcs' => [ qw/flatten recall wrap/ ] ); @EXPORT_OK = map { @$_ } values %EXPORT_TAGS; $EXPORT_TAGS{'all'} = [ @EXPORT_OK ]; diff --git a/t/01-import.t b/t/01-import.t index 30b94d2..ef63215 100644 --- a/t/01-import.t +++ b/t/01-import.t @@ -3,11 +3,11 @@ use strict; use warnings; -use Test::More tests => 2; +use Test::More tests => 3; require Sub::Prototype::Util; -for (qw/flatten recall/) { +for (qw/flatten recall wrap/) { eval { Sub::Prototype::Util->import($_) }; ok(!$@, 'import ' . $_); } diff --git a/t/12-wrap.t b/t/12-wrap.t new file mode 100644 index 0000000..5420606 --- /dev/null +++ b/t/12-wrap.t @@ -0,0 +1,126 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 7 + 6 + 3 + 1 + 6 + 1 + (($^V ge v5.10.0) ? 2 : 0); + +use Scalar::Util qw/set_prototype/; +use Sub::Prototype::Util qw/wrap/; + +eval { wrap undef }; +like($@, qr/^No\s+subroutine/, 'recall undef croaks'); +eval { wrap '' }; +like($@, qr/^No\s+subroutine/, 'recall "" croaks'); +eval { wrap \1 }; +like($@, qr/^Unhandled\s+SCALAR/, 'recall scalarref croaks'); +eval { wrap [ ] }; +like($@, qr/^Unhandled\s+ARRAY/, 'recall arrayref croaks'); +eval { wrap sub { } }; +like($@, qr/^Unhandled\s+CODE/, 'recall coderef croaks'); +eval { wrap { 'foo' => undef, 'bar' => undef } }; +like($@, qr!exactly\s+one\s+key/value\s+pair!, 'recall hashref with 2 pairs croaks'); +eval { wrap 'hlagh', qw/a b c/ }; +like($@, qr/^Optional\s+arguments/, 'recall takes options in a key => value list'); + +my $push_exp = '{ CORE::push(@{$_[0]}, @_[1..$#_]) }'; +my $push = wrap 'CORE::push'; +is($push, 'sub ' . $push_exp, 'wrap push as a sub (default)'); +$push = wrap 'CORE::push', sub => 1; +is($push, 'sub ' . $push_exp, 'wrap push as a sub'); +$push = wrap 'CORE::push', sub => 0; +is($push, $push_exp, 'wrap push as a raw string'); +$push = wrap 'CORE::push', compile => 1; +is(ref $push, 'CODE', 'wrap compiled push is a CODE reference'); +my @a = qw/a b/; +my $ret = $push->(\@a, 7 .. 12); +is_deeply(\@a, [ qw/a b/, 7 .. 12 ], 'wrap compiled push works'); +is($ret, 8, 'wrap compiled push returns the correct number of elements'); + +my $push2 = wrap { 'CORE::push' => '\@;$' }, compile => 1; +is(ref $push2, 'CODE', 'wrap compiled truncated push is a CODE reference'); +@a = qw/x y z/; +$ret = $push2->(\@a, 3 .. 5); +is_deeply(\@a, [ qw/x y z/, 3 ], 'wrap compiled truncated push works'); +is($ret, 4, 'wrap compiled truncated push returns the correct number of elements'); + +sub cb (\[$@]\[%&]&&); +my $cb = wrap 'main::cb', sub => 0, wrong_ref => 'die'; +my $x = ', sub{&{$c[0]}}, sub{&{$c[1]}}) '; +is($cb, + join('', q!{ my @c; push @c, $_[2]; push @c, $_[3]; !, + q!my $r = ref($_[0]); !, + q!if ($r eq 'SCALAR') { !, + q!my $r = ref($_[1]); !, + q!if ($r eq 'HASH') { !, + q!main::cb(${$_[0]}, %{$_[1]}! . $x, + q!} elsif ($r eq 'CODE') { !, + q!main::cb(${$_[0]}, &{$_[1]}! . $x, + q!} else { !, + q!die !, + q!} !, + q!} elsif ($r eq 'ARRAY') { !, + q!my $r = ref($_[1]); !, + q!if ($r eq 'HASH') { !, + q!main::cb(@{$_[0]}, %{$_[1]}! . $x, + q!} elsif ($r eq 'CODE') { !, + q!main::cb(@{$_[0]}, &{$_[1]}! . $x, + q!} else { !, + q!die !, + q!} !, + q!} else { !, + q!die !, + q!} }!), + 'callbacks'); + +sub myref ($) { ref $_[0] }; + +sub cat (\[$@]\[$@]) { + if (ref $_[0] eq 'SCALAR') { + if (ref $_[1] eq 'SCALAR') { + return ${$_[0]} . ${$_[1]}; + } elsif (ref $_[1] eq 'ARRAY') { + return ${$_[0]}, @{$_[1]}; + } + } elsif (ref $_[0] eq 'ARRAY') { + if (ref $_[1] eq 'SCALAR') { + return @{$_[0]}, ${$_[1]}; + } elsif (ref $_[1] eq 'ARRAY') { + return @{$_[0]}, @{$_[1]}; + } + } +} + +my $cat = wrap 'main::cat', ref => 'main::myref', wrong_ref => 'die "hlagh"', + sub => 1, compile => 1, +my @tests = ( + [ \'a', \'b', [ 'ab' ], 'scalar-scalar' ], + [ \'c', [ qw/d e/ ], [ qw/c d e/ ], 'scalar-array' ], + [ [ qw/f g/ ], \'h', [ qw/f g h/ ], 'array-scalar' ], + [ [ qw/i j/ ], [ qw/k l/ ], [ qw/i j k l/ ], 'array-array' ] +); +for (@tests) { + my $res = [ $cat->($_->[0], $_->[1]) ]; + is_deeply($res, $_->[2], 'cat ' . $_->[3]); +} +eval { $cat->({ foo => 1 }, [ 2 ] ) }; +like($@, qr/^hlagh\s+at/, 'wrong reference type 1'); +eval { $cat->(\1, sub { 2 } ) }; +like($@, qr/^hlagh\s+at/, 'wrong reference type 2'); + +sub noproto; +my $noproto_exp = '{ main::noproto(@_) }'; +my $noproto = wrap 'main::noproto', sub => 0; +is($noproto, $noproto_exp, 'no prototype'); + +sub myit { my $ar = shift; push @$ar, @_; }; +if ($^V ge v5.10.0) { + set_prototype \&myit, '\@$_'; + my $it = wrap 'main::myit', compile => 1; + my @a = qw/u v w/; + local $_ = 7; + $it->(\@a, 3, 4, 5); + is_deeply(\@a, [ qw/u v w/, 3, 4 ], '_ with arguments'); + $it->(\@a, 6); + is_deeply(\@a, [ qw/u v w/, 3, 4, 6, 7 ], '_ without arguments'); +}