Sub::Prototype::Util - Prototype-related utility routines.
VERSION
- Version 0.05
+ Version 0.06
SYNOPSIS
use Sub::Prototype::Util qw/flatten recall/;
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).
=head1 VERSION
-Version 0.05
+Version 0.06
=cut
use vars qw/$VERSION/;
-$VERSION = '0.05';
+$VERSION = '0.06';
=head1 SYNOPSIS
=cut
my %sigils = qw/SCALAR $ ARRAY @ HASH % GLOB * CODE &/;
+my %reftypes = reverse %sigils;
sub _check_ref {
my ($a, $p) = @_;
=cut
-sub recall {
- my $name = shift;
+sub _check_name {
+ my $name = $_[0];
croak 'No subroutine specified' unless $name;
my $proto;
my $r = ref $name;
$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) {
return @ret;
}
+=head2 C<wrap $name, %opts>
+
+Generates a wrapper that does the same thing as L</recall>, but specialized for a given function. This wrapper can be compiled once for all to avoid calling C<eval> at each run (like L</recall> 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</wrap>. 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<Scalar::Util::reftype>.
+
+=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<croak> or C<die> too.
+
+=item C<< sub => $bool >>
+
+Encloses the code into a C<sub { }> block. Default is true.
+
+=item C<< compile => $bool >>
+
+Makes L</wrap> compile the code generated and return the resulting code reference. Implies C<< sub => 1 >>. Be careful that in this case C<ref> must be a fully qualified function name. Defaults to false.
+
+=back
+
+This is how you make your own C<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
+
+=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</flatten> and L</recall> are only exported on request, either by providing their name or by the C<':funcs'> and C<':all'> tags.
+The functions L</flatten>, L</recall> and L</wrap> are only exported on request, either by providing their name or by the C<':funcs'> and C<':all'> tags.
=cut
@EXPORT = ();
%EXPORT_TAGS = (
- 'funcs' => [ qw/flatten recall/ ]
+ 'funcs' => [ qw/flatten recall wrap/ ]
);
@EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
--- /dev/null
+#!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');
+}
projects / perl / modules / Sub-Prototype-Util.git / commitdiff