1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
keys %Config; # Silence warning
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
}
}
BEGIN {
require Scalar::Util;
if (grep { /set_prototype/ } @Scalar::Util::EXPORT_FAIL) {
print "1..0\n";
$skip=1;
}
}
eval <<'EOT' unless $skip;
use Scalar::Util qw(set_prototype);
print "1..13\n";
$test = 0;
sub proto_is ($$) {
$proto = prototype shift;
$expected = shift;
if (defined $expected) {
print "# Got $proto, expected $expected\nnot " if $expected ne $proto;
}
else {
print "# Got $proto, expected undef\nnot " if defined $proto;
}
print "ok ", ++$test, "\n";
}
sub f { }
proto_is 'f' => undef;
$r = set_prototype(\&f,'$');
proto_is 'f' => '$';
print "not " unless ref $r eq "CODE" and $r == \&f;
print "ok ", ++$test, " - return value\n";
set_prototype(\&f,undef);
proto_is 'f' => undef;
set_prototype(\&f,'');
proto_is 'f' => '';
sub g (@) { }
proto_is 'g' => '@';
set_prototype(\&g,undef);
proto_is 'g' => undef;
sub non_existent;
proto_is 'non_existent' => undef;
set_prototype(\&non_existent,'$$$');
proto_is 'non_existent' => '$$$';
sub forward_decl ($$$$);
proto_is 'forward_decl' => '$$$$';
set_prototype(\&forward_decl,'\%');
proto_is 'forward_decl' => '\%';
eval { &set_prototype( 'f', '' ); };
print "not " unless $@ =~ /^set_prototype: not a reference/;
print "ok ", ++$test, " - error msg\n";
eval { &set_prototype( \'f', '' ); };
print "not " unless $@ =~ /^set_prototype: not a subroutine reference/;
print "ok ", ++$test, " - error msg\n";
EOT
|
