6 use Test::More tests => 7 + 6 + 3 + 1 + 6 + 1 + (("$]" >= 5.010) ? 2 : 0) + 1;
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 = "$]" >= 5.013007 ? '{ CORE::push($_[0], @_[1..$#_]) }'
35 : '{ CORE::push(@{$_[0]}, @_[1..$#_]) }';
36 my $push = wrap 'CORE::push', compile => 0;
37 is($push, 'sub ' . $push_exp, 'wrap push as a sub (default)');
38 $push = wrap 'CORE::push', sub => 1, compile => 0;
39 is($push, 'sub ' . $push_exp, 'wrap push as a sub');
40 $push = wrap 'CORE::push', sub => 0;
41 is($push, $push_exp, 'wrap push as a raw string');
42 $push = wrap 'CORE::push';
43 is(ref $push, 'CODE', 'wrap compiled push is a CODE reference');
45 my $ret = $push->(\@a, 7 .. 12);
46 is_deeply(\@a, [ qw<a b>, 7 .. 12 ], 'wrap compiled push works');
47 is($ret, 8, 'wrap compiled push returns the correct number of elements');
49 my $push2 = wrap { 'CORE::push' => '\@;$' };
50 is(ref $push2, 'CODE', 'wrap compiled truncated push is a CODE reference');
52 $ret = $push2->(\@a, 3 .. 5);
53 is_deeply(\@a, [ qw<x y z>, 3 ], 'wrap compiled truncated push works');
54 is($ret, 4, 'wrap compiled truncated push returns the correct number of elements');
56 sub cb (\[$@]\[%&]&&);
57 my $cb = wrap 'main::cb', sub => 0, wrong_ref => 'die';
58 my $x = ', sub{&{$c[0]}}, sub{&{$c[1]}}) ';
60 join('', q!{ my @c = @_[2, 3]; !,
61 q!my $r = ref($_[0]); !,
62 q!if ($r eq 'SCALAR') { !,
63 q!my $r = ref($_[1]); !,
64 q!if ($r eq 'HASH') { !,
65 q!main::cb(${$_[0]}, %{$_[1]}! . $x,
66 q!} elsif ($r eq 'CODE') { !,
67 q!main::cb(${$_[0]}, &{$_[1]}! . $x,
71 q!} elsif ($r eq 'ARRAY') { !,
72 q!my $r = ref($_[1]); !,
73 q!if ($r eq 'HASH') { !,
74 q!main::cb(@{$_[0]}, %{$_[1]}! . $x,
75 q!} elsif ($r eq 'CODE') { !,
76 q!main::cb(@{$_[0]}, &{$_[1]}! . $x,
85 sub myref { ref $_[0] };
87 sub cat (\[$@]\[$@]) {
88 if (ref $_[0] eq 'SCALAR') {
89 if (ref $_[1] eq 'SCALAR') {
90 return ${$_[0]} . ${$_[1]};
91 } elsif (ref $_[1] eq 'ARRAY') {
92 return ${$_[0]}, @{$_[1]};
94 } elsif (ref $_[0] eq 'ARRAY') {
95 if (ref $_[1] eq 'SCALAR') {
96 return @{$_[0]}, ${$_[1]};
97 } elsif (ref $_[1] eq 'ARRAY') {
98 return @{$_[0]}, @{$_[1]};
104 skip 'perl 5.8.x is needed to test execution of \[$@] prototypes' => 6
107 my $cat = wrap 'main::cat', ref => 'main::myref',
109 wrong_ref => 'die "hlagh"',
111 [ \'a', \'b', [ 'ab' ], 'scalar-scalar' ],
112 [ \'c', [ qw<d e> ], [ qw<c d e> ], 'scalar-array' ],
113 [ [ qw<f g> ], \'h', [ qw<f g h> ], 'array-scalar' ],
114 [ [ qw<i j> ], [ qw<k l> ], [ qw<i j k l> ], 'array-array' ]
117 my $res = [ $cat->($_->[0], $_->[1]) ];
118 is_deeply($res, $_->[2], 'cat ' . $_->[3]);
120 eval { $cat->({ foo => 1 }, [ 2 ] ) };
121 like($@, qr/^hlagh\s+at/, 'wrong reference type 1');
122 eval { $cat->(\1, sub { 2 } ) };
123 like($@, qr/^hlagh\s+at/, 'wrong reference type 2');
127 my $noproto_exp = '{ main::noproto(@_) }';
128 my $noproto = wrap 'main::noproto', sub => 0;
129 is($noproto, $noproto_exp, 'no prototype');
131 sub myit { my $ar = shift; push @$ar, @_; };
133 Scalar::Util::set_prototype(\&myit, '\@$_');
134 my $it = wrap 'main::myit';
138 is_deeply(\@a, [ qw<u v w>, 3, 4 ], '_ with arguments');
140 is_deeply(\@a, [ qw<u v w>, 3, 4, 6, 7 ], '_ without arguments');
143 sub myshift (;\@) { shift @{$_[0]} }
145 eval { wrap { 'main::dummy' => '\[@%]' }, ref => 'main::myshift' };
146 like $@, qr/to main::myshift must be array \([\w ]+\) at \Q$0\E line \d+/,
147 'invalid eval code croaks';