From: Vincent Pit Date: Sun, 2 Nov 2008 16:30:26 +0000 (+0100) Subject: Make compile => 1 the default for wrap() X-Git-Tag: v0.09~16 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Prototype-Util.git;a=commitdiff_plain;h=4e977a0b1db65e44cf4c6184792208a7930c34f4 Make compile => 1 the default for wrap() --- diff --git a/lib/Sub/Prototype/Util.pm b/lib/Sub/Prototype/Util.pm index b78f396..91520b8 100644 --- a/lib/Sub/Prototype/Util.pm +++ b/lib/Sub/Prototype/Util.pm @@ -29,7 +29,7 @@ $VERSION = '0.08'; my @flat = flatten '\@$;$', @args; # ('a', 'b', 'c', 1, { d => 2 }) recall 'CORE::push', @args; # @a contains 'a', 'b', 'c', 1, { d => 2 }, undef, 3 - my $splice = wrap 'CORE::splice', compile => 1; + my $splice = wrap 'CORE::splice'; my @b = $splice->(\@a, 4, 2); # @a is now ('a', 'b', 'c', 1, 3) and @b is ({ d => 2 }, undef) =head1 DESCRIPTION @@ -97,12 +97,12 @@ sub flatten { 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>. my $a = [ 0 .. 2 ]; - my $push = wrap 'CORE::push', compile => 1; + my $push = wrap 'CORE::push'; $push->($a, 3, 4); # returns 3 + 2 = 5 and $a now contains 0 .. 4 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. - my $push = wrap { 'CORE::push' => '\@$' }, compile => 1; # only pushes 1 arg + my $push = wrap { 'CORE::push' => '\@$' }; # only pushes 1 arg Others arguments are seen as key / value pairs that are meant to tune the code generated by L. Valid keys are : @@ -122,13 +122,13 @@ 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. +Makes L compile the code generated and return the resulting code reference. Be careful that in this case C must be a fully qualified function name. Defaults to true, but turned off when C is false. =back For example, this allows you to recall into C and C by using the C<\&@> prototype : - my $grep = wrap { 'CORE::grep' => '\&@' }, compile => 1; + my $grep = wrap { 'CORE::grep' => '\&@' }; sub mygrep (&@) { $grep->(@_) } # the prototypes are intentionally different =cut @@ -202,7 +202,8 @@ sub wrap { 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{sub} = 1 if not defined $opts{sub}; + $opts{compile} = 1 if not defined $opts{compile} and $opts{sub}; $opts{wrong_ref} = 'undef' if not defined $opts{wrong_ref}; my @cr; my $call; @@ -238,7 +239,7 @@ If you plan to recall several times, consider using L instead. =cut sub recall { - my $wrap = eval { wrap shift, compile => 1 }; + my $wrap = eval { wrap shift }; croak $@ if $@; return $wrap->(@_); } diff --git a/samples/try.pl b/samples/try.pl index 250ff60..57477fe 100755 --- a/samples/try.pl +++ b/samples/try.pl @@ -22,7 +22,7 @@ print "When flatten with prototype $proto, this gives :\n", Dumper(\@flat); recall 'CORE::push', @args; # @a contains 'a', 'b', 'c', 1, { d => 2 }, undef, 3 print "After recalling CORE::push with \@args, \@a contains :\n", Dumper(\@a); -my $splice = wrap 'CORE::splice', compile => 1; +my $splice = wrap 'CORE::splice'; my @b = $splice->(\@a, 4, 2); print "After calling wrapped splice with \@a, it contains :\n", Dumper(\@a); print "What was returned :\n", Dumper(\@b); diff --git a/t/11-wrap.t b/t/11-wrap.t index e50efc5..47fd20e 100644 --- a/t/11-wrap.t +++ b/t/11-wrap.t @@ -24,20 +24,20 @@ 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'; +my $push = wrap 'CORE::push', compile => 0; is($push, 'sub ' . $push_exp, 'wrap push as a sub (default)'); -$push = wrap 'CORE::push', sub => 1; +$push = wrap 'CORE::push', sub => 1, compile => 0; 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; +$push = wrap 'CORE::push'; 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; +my $push2 = wrap { 'CORE::push' => '\@;$' }; is(ref $push2, 'CODE', 'wrap compiled truncated push is a CODE reference'); @a = qw/x y z/; $ret = $push2->(\@a, 3 .. 5); @@ -95,8 +95,9 @@ SKIP: { skip 'perl 5.8.x is needed to test execution of \[$@] prototypes' => 6 if $^V lt v5.8.0; - my $cat = wrap 'main::cat', ref => 'main::myref', wrong_ref => 'die "hlagh"', - sub => 1, compile => 1; + my $cat = wrap 'main::cat', ref => 'main::myref', + sub => 1, + wrong_ref => 'die "hlagh"', my @tests = ( [ \'a', \'b', [ 'ab' ], 'scalar-scalar' ], [ \'c', [ qw/d e/ ], [ qw/c d e/ ], 'scalar-array' ], @@ -121,7 +122,7 @@ 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 $it = wrap 'main::myit'; my @a = qw/u v w/; local $_ = 7; $it->(\@a, 3, 4, 5); @@ -130,5 +131,5 @@ if ($^V ge v5.10.0) { is_deeply(\@a, [ qw/u v w/, 3, 4, 6, 7 ], '_ without arguments'); } -eval { wrap { 'main::dummy' => '\[@%]' }, ref => 'shift', compile => 1 }; +eval { wrap { 'main::dummy' => '\[@%]' }, ref => 'shift' }; like($@, qr/to\s+shift\s+must\s+be\s+array/, 'invalid eval code croaks');