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
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
#!./perl
# Testing the : prototype(..) attribute
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
skip_all_if_miniperl("miniperl can't load attributes");
}
use warnings;
plan tests => 48;
my @warnings;
my ($attrs, $ret) = ("", "");
sub Q::MODIFY_CODE_ATTRIBUTES { my ($name, $ref, @attrs) = @_; $attrs = "@attrs";return;}
$SIG{__WARN__} = sub { push @warnings, shift;};
$ret = eval 'package Q; sub A(bar) : prototype(bad) : dummy1 {} prototype \&A;';
is $ret, "bad", "Prototype is set to \"bad\"";
is $attrs, "dummy1", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
like shift @warnings, "Illegal character in prototype for Q::A : bar",
"First warning is bad prototype - bar";
like shift @warnings, "Illegal character in prototype for Q::A : bad",
"Second warning is bad prototype - bad";
like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::A',
"Third warning is Prototype overridden";
is @warnings, 0, "No more warnings";
# The override warning should not be hidden by no warnings (similar to prototype changed warnings)
{
no warnings 'illegalproto';
$ret = eval 'package Q; sub B(bar) : prototype(bad) dummy2 {4} prototype \&B;';
is $ret, "bad", "Prototype is set to \"bad\"";
is $attrs, "dummy2", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::B',
"First warning is Prototype overridden";
is @warnings, 0, "No more warnings";
}
# Redeclaring a sub with a prototype attribute ignores it
$ret = eval 'package Q; sub B(ignored) : prototype(baz) : dummy3; prototype \&B;';
is $ret, "bad", "Declaring with prototype(..) after definition doesn't change the prototype";
is $attrs, "dummy3", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
like shift @warnings, "Illegal character in prototype for Q::B : ignored",
"Shifting off warning for the 'ignored' prototype";
like shift @warnings, "Illegal character in prototype for Q::B : baz",
"Attempting to redeclare triggers Illegal character warning";
like shift @warnings, 'Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B',
"Shifting off Prototype overridden warning";
like shift @warnings, 'Prototype mismatch: sub Q::B \(bad\) vs \(baz\)',
"Attempting to redeclare triggers prototype mismatch warning against first prototype";
is @warnings, 0, "No more warnings";
# Confirm redifining with a prototype attribute takes it
$ret = eval 'package Q; sub B(ignored) : prototype(baz) dummy4 {5}; prototype \&B;';
is $ret, "baz", "Redefining with prototype(..) changes the prototype";
is $attrs, "dummy4", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
is &Q::B, 5, "Function successfully redefined";
like shift @warnings, "Illegal character in prototype for Q::B : ignored",
"Attempting to redeclare triggers Illegal character warning";
like shift @warnings, "Illegal character in prototype for Q::B : baz",
"Attempting to redeclare triggers Illegal character warning";
like shift @warnings, 'Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B',
"Shifting off Prototype overridden warning";
like shift @warnings, 'Prototype mismatch: sub Q::B \(bad\) vs \(baz\)',
"Attempting to redeclare triggers prototype mismatch warning";
like shift @warnings, 'Subroutine B redefined',
"Only other warning is subroutine redefinition";
is @warnings, 0, "No more warnings";
# Multiple prototype declarations only takes the last one
$ret = eval 'package Q; sub dummy6 : prototype($$) : prototype($$$) {}; prototype \&dummy6;';
is $ret, "\$\$\$", "Last prototype declared wins";
like shift @warnings, 'Attribute prototype\(\$\$\$\) discards earlier prototype attribute in same sub',
"Multiple prototype declarations warns";
is @warnings, 0, "No more warnings";
# Use attributes
eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(new)";';
$ret = prototype \&Q::B;
is $ret, "new", "use attributes also sets the prototype";
like shift @warnings, 'Prototype mismatch: sub Q::B \(baz\) vs \(new\)',
"Prototype mismatch warning triggered";
is @warnings, 0, "No more warnings";
eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(\$\$~";';
$ret = prototype \&Q::B;
is $ret, "new", "A malformed prototype doesn't reset it";
like $@, "Unterminated attribute parameter in attribute list", "Malformed prototype croaked";
is @warnings, 0, "Malformed prototype isn't just a warning";
eval 'use attributes __PACKAGE__, \&foo, "prototype($$\x{100}";';
$ret = prototype \&Q::B;
is $ret, "new", "A malformed prototype doesn't reset it";
like $@, "Unterminated attribute parameter in attribute list", "Malformed prototype croaked";
is @warnings, 0, "Malformed prototype isn't just a warning";
# Anonymous subs (really just making sure they don't crash, since the prototypes
# themselves aren't much use)
{
is eval 'package Q; my $a = sub(bar) : prototype(baz) {}; 1;', 1,
"Sanity checking that eval of anonymous sub didn't croak";
# The fact that the name is '?' in the first case
# and __ANON__ in the second is due to toke.c temporarily setting
# the name to '?' before calling the proto check, despite setting
# it to the real name very shortly after.
# In short - if this test breaks, just change the test.
like shift @warnings, 'Illegal character in prototype for \? : bar',
"(anon) bar triggers illegal proto warnings";
like shift @warnings, "Illegal character in prototype for Q::__ANON__ : baz",
"(anon) baz triggers illegal proto warnings";
like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in Q::__ANON__',
"(anon) overridden warning triggered in anonymous sub";
is @warnings, 0, "No more warnings";
}
# Testing lexical subs
{
use feature "lexical_subs";
no warnings "experimental::lexical_subs";
$ret = eval 'my sub foo(bar) : prototype(baz) {}; prototype \&foo;';
is $ret, "baz", "my sub foo honors the prototype attribute";
like shift @warnings, 'Illegal character in prototype for foo : bar',
"(lexical) bar triggers illegal proto warnings";
like shift @warnings, "Illegal character in prototype for foo : baz",
"(lexical) baz triggers illegal proto warnings";
like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in foo',
"(lexical) overridden warning triggered in anonymous sub";
is @warnings, 0, "No more warnings";
}
# Local variables:
# indent-tabs-mode: nil
# End:
#
# ex: set ts=8 sts=4 sw=4 et:
|
