6 use Test::More tests => 7 + 6 + 3 + 1 + 6 + 1 + (($^V ge v5.10.0) ? 2 : 0) + 1;
8 use Scalar::Util qw<set_prototype>;
9 use Sub::Prototype::Util qw<wrap>;
14 return qr/^$msg.*?at\s+\Q$0\E\s+line\s+\d+/;
18 like $@, exception('No subroutine'), 'recall undef croaks';
20 like $@, exception('No subroutine'), 'recall "" croaks';
22 like $@, exception('Unhandled SCALAR'), 'recall scalarref croaks';
24 like $@, exception('Unhandled ARRAY'), 'recall arrayref croaks';
25 eval { wrap sub { } };
26 like $@, exception('Unhandled CODE'), 'recall coderef croaks';
27 eval { wrap { 'foo' => undef, 'bar' => undef } };
28 like $@, qr!exactly\s+one\s+key/value\s+pair!,
29 'recall hashref with 2 pairs croaks';
30 eval { wrap 'hlagh', qw<a b c> };
31 like $@, exception('Optional arguments'),
32 'recall takes options in a key => value list';
34 my $push_exp = '{ CORE::push(@{$_[0]}, @_[1..$#_]) }';
35 my $push = wrap 'CORE::push', compile => 0;
36 is($push, 'sub ' . $push_exp, 'wrap push as a sub (default)');
37 $push = wrap 'CORE::push', sub => 1, compile => 0;
38 is($push, 'sub ' . $push_exp, 'wrap push as a sub');
39 $push = wrap 'CORE::push', sub => 0;
40 is($push, $push_exp, 'wrap push as a raw string');
41 $push = wrap 'CORE::push';
42 is(ref $push, 'CODE', 'wrap compiled push is a CODE reference');
44 my $ret = $push->(\@a, 7 .. 12);
45 is_deeply(\@a, [ qw<a b>, 7 .. 12 ], 'wrap compiled push works');
46 is($ret, 8, 'wrap compiled push returns the correct number of elements');
48 my $push2 = wrap { 'CORE::push' => '\@;$' };
49 is(ref $push2, 'CODE', 'wrap compiled truncated push is a CODE reference');
51 $ret = $push2->(\@a, 3 .. 5);
52 is_deeply(\@a, [ qw<x y z>, 3 ], 'wrap compiled truncated push works');
53 is($ret, 4, 'wrap compiled truncated push returns the correct number of elements');
55 sub cb (\[$@]\[%&]&&);
56 my $cb = wrap 'main::cb', sub => 0, wrong_ref => 'die';
57 my $x = ', sub{&{$c[0]}}, sub{&{$c[1]}}) ';
59 join('', q!{ my @c = @_[2, 3]; !,
60 q!my $r = ref($_[0]); !,
61 q!if ($r eq 'SCALAR') { !,
62 q!my $r = ref($_[1]); !,
63 q!if ($r eq 'HASH') { !,
64 q!main::cb(${$_[0]}, %{$_[1]}! . $x,
65 q!} elsif ($r eq 'CODE') { !,
66 q!main::cb(${$_[0]}, &{$_[1]}! . $x,
70 q!} elsif ($r eq 'ARRAY') { !,
71 q!my $r = ref($_[1]); !,
72 q!if ($r eq 'HASH') { !,
73 q!main::cb(@{$_[0]}, %{$_[1]}! . $x,
74 q!} elsif ($r eq 'CODE') { !,
75 q!main::cb(@{$_[0]}, &{$_[1]}! . $x,
84 sub myref { ref $_[0] };
86 sub cat (\[$@]\[$@]) {
87 if (ref $_[0] eq 'SCALAR') {
88 if (ref $_[1] eq 'SCALAR') {
89 return ${$_[0]} . ${$_[1]};
90 } elsif (ref $_[1] eq 'ARRAY') {
91 return ${$_[0]}, @{$_[1]};
93 } elsif (ref $_[0] eq 'ARRAY') {
94 if (ref $_[1] eq 'SCALAR') {
95 return @{$_[0]}, ${$_[1]};
96 } elsif (ref $_[1] eq 'ARRAY') {
97 return @{$_[0]}, @{$_[1]};
103 skip 'perl 5.8.x is needed to test execution of \[$@] prototypes' => 6
106 my $cat = wrap 'main::cat', ref => 'main::myref',
108 wrong_ref => 'die "hlagh"',
110 [ \'a', \'b', [ 'ab' ], 'scalar-scalar' ],
111 [ \'c', [ qw<d e> ], [ qw<c d e> ], 'scalar-array' ],
112 [ [ qw<f g> ], \'h', [ qw<f g h> ], 'array-scalar' ],
113 [ [ qw<i j> ], [ qw<k l> ], [ qw<i j k l> ], 'array-array' ]
116 my $res = [ $cat->($_->[0], $_->[1]) ];
117 is_deeply($res, $_->[2], 'cat ' . $_->[3]);
119 eval { $cat->({ foo => 1 }, [ 2 ] ) };
120 like($@, qr/^hlagh\s+at/, 'wrong reference type 1');
121 eval { $cat->(\1, sub { 2 } ) };
122 like($@, qr/^hlagh\s+at/, 'wrong reference type 2');
126 my $noproto_exp = '{ main::noproto(@_) }';
127 my $noproto = wrap 'main::noproto', sub => 0;
128 is($noproto, $noproto_exp, 'no prototype');
130 sub myit { my $ar = shift; push @$ar, @_; };
131 if ($^V ge v5.10.0) {
132 set_prototype \&myit, '\@$_';
133 my $it = wrap 'main::myit';
137 is_deeply(\@a, [ qw<u v w>, 3, 4 ], '_ with arguments');
139 is_deeply(\@a, [ qw<u v w>, 3, 4, 6, 7 ], '_ without arguments');
142 eval { wrap { 'main::dummy' => '\[@%]' }, ref => 'shift' };
144 qr/to\s+shift\s+must\s+be\s+array +\([\w ]+\) +at\s+\Q$0\E\s+line\s+\d+/,
145 'invalid eval code croaks';