Commit | Line | Data |
---|---|---|
eedb00fa PM |
1 | #!./perl |
2 | ||
3 | # Testing the : prototype(..) attribute | |
4 | ||
5 | ||
6 | BEGIN { | |
7 | chdir 't' if -d 't'; | |
8 | @INC = '../lib'; | |
9 | require './test.pl'; | |
10 | skip_all_if_miniperl("miniperl can't load attributes"); | |
11 | } | |
12 | use warnings; | |
13 | ||
14 | plan tests => 48; | |
15 | ||
16 | my @warnings; | |
17 | my ($attrs, $ret) = ("", ""); | |
18 | sub Q::MODIFY_CODE_ATTRIBUTES { my ($name, $ref, @attrs) = @_; $attrs = "@attrs";return;} | |
19 | $SIG{__WARN__} = sub { push @warnings, shift;}; | |
20 | ||
21 | $ret = eval 'package Q; sub A(bar) : prototype(bad) : dummy1 {} prototype \&A;'; | |
22 | is $ret, "bad", "Prototype is set to \"bad\""; | |
23 | is $attrs, "dummy1", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; | |
aaa63dae | 24 | like shift @warnings, qr/Illegal character in prototype for Q::A : bar/, |
eedb00fa | 25 | "First warning is bad prototype - bar"; |
aaa63dae | 26 | like shift @warnings, qr/Illegal character in prototype for Q::A : bad/, |
eedb00fa | 27 | "Second warning is bad prototype - bad"; |
aaa63dae | 28 | like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::A/, |
eedb00fa PM |
29 | "Third warning is Prototype overridden"; |
30 | is @warnings, 0, "No more warnings"; | |
31 | ||
32 | # The override warning should not be hidden by no warnings (similar to prototype changed warnings) | |
33 | { | |
34 | no warnings 'illegalproto'; | |
35 | $ret = eval 'package Q; sub B(bar) : prototype(bad) dummy2 {4} prototype \&B;'; | |
36 | is $ret, "bad", "Prototype is set to \"bad\""; | |
37 | is $attrs, "dummy2", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; | |
aaa63dae | 38 | like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::B/, |
eedb00fa PM |
39 | "First warning is Prototype overridden"; |
40 | is @warnings, 0, "No more warnings"; | |
41 | } | |
42 | ||
43 | # Redeclaring a sub with a prototype attribute ignores it | |
44 | $ret = eval 'package Q; sub B(ignored) : prototype(baz) : dummy3; prototype \&B;'; | |
45 | is $ret, "bad", "Declaring with prototype(..) after definition doesn't change the prototype"; | |
46 | is $attrs, "dummy3", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; | |
aaa63dae | 47 | like shift @warnings, qr/Illegal character in prototype for Q::B : ignored/, |
eedb00fa | 48 | "Shifting off warning for the 'ignored' prototype"; |
aaa63dae | 49 | like shift @warnings, qr/Illegal character in prototype for Q::B : baz/, |
eedb00fa | 50 | "Attempting to redeclare triggers Illegal character warning"; |
aaa63dae | 51 | like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/, |
eedb00fa | 52 | "Shifting off Prototype overridden warning"; |
aaa63dae | 53 | like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/, |
eedb00fa PM |
54 | "Attempting to redeclare triggers prototype mismatch warning against first prototype"; |
55 | is @warnings, 0, "No more warnings"; | |
56 | ||
57 | # Confirm redifining with a prototype attribute takes it | |
58 | $ret = eval 'package Q; sub B(ignored) : prototype(baz) dummy4 {5}; prototype \&B;'; | |
59 | is $ret, "baz", "Redefining with prototype(..) changes the prototype"; | |
60 | is $attrs, "dummy4", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; | |
61 | is &Q::B, 5, "Function successfully redefined"; | |
aaa63dae | 62 | like shift @warnings, qr/Illegal character in prototype for Q::B : ignored/, |
eedb00fa | 63 | "Attempting to redeclare triggers Illegal character warning"; |
aaa63dae | 64 | like shift @warnings, qr/Illegal character in prototype for Q::B : baz/, |
eedb00fa | 65 | "Attempting to redeclare triggers Illegal character warning"; |
aaa63dae | 66 | like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/, |
eedb00fa | 67 | "Shifting off Prototype overridden warning"; |
aaa63dae | 68 | like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/, |
eedb00fa | 69 | "Attempting to redeclare triggers prototype mismatch warning"; |
aaa63dae | 70 | like shift @warnings, qr/Subroutine B redefined/, |
eedb00fa PM |
71 | "Only other warning is subroutine redefinition"; |
72 | is @warnings, 0, "No more warnings"; | |
73 | ||
74 | # Multiple prototype declarations only takes the last one | |
75 | $ret = eval 'package Q; sub dummy6 : prototype($$) : prototype($$$) {}; prototype \&dummy6;'; | |
76 | is $ret, "\$\$\$", "Last prototype declared wins"; | |
aaa63dae | 77 | like shift @warnings, qr/Attribute prototype\(\$\$\$\) discards earlier prototype attribute in same sub/, |
eedb00fa PM |
78 | "Multiple prototype declarations warns"; |
79 | is @warnings, 0, "No more warnings"; | |
80 | ||
81 | # Use attributes | |
82 | eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(new)";'; | |
83 | $ret = prototype \&Q::B; | |
84 | is $ret, "new", "use attributes also sets the prototype"; | |
aaa63dae | 85 | like shift @warnings, qr/Prototype mismatch: sub Q::B \(baz\) vs \(new\)/, |
eedb00fa PM |
86 | "Prototype mismatch warning triggered"; |
87 | is @warnings, 0, "No more warnings"; | |
88 | ||
89 | eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(\$\$~";'; | |
90 | $ret = prototype \&Q::B; | |
91 | is $ret, "new", "A malformed prototype doesn't reset it"; | |
aaa63dae | 92 | like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked"; |
eedb00fa PM |
93 | is @warnings, 0, "Malformed prototype isn't just a warning"; |
94 | ||
95 | eval 'use attributes __PACKAGE__, \&foo, "prototype($$\x{100}";'; | |
96 | $ret = prototype \&Q::B; | |
97 | is $ret, "new", "A malformed prototype doesn't reset it"; | |
aaa63dae | 98 | like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked"; |
eedb00fa PM |
99 | is @warnings, 0, "Malformed prototype isn't just a warning"; |
100 | ||
101 | # Anonymous subs (really just making sure they don't crash, since the prototypes | |
102 | # themselves aren't much use) | |
103 | { | |
104 | is eval 'package Q; my $a = sub(bar) : prototype(baz) {}; 1;', 1, | |
105 | "Sanity checking that eval of anonymous sub didn't croak"; | |
106 | # The fact that the name is '?' in the first case | |
107 | # and __ANON__ in the second is due to toke.c temporarily setting | |
108 | # the name to '?' before calling the proto check, despite setting | |
109 | # it to the real name very shortly after. | |
110 | # In short - if this test breaks, just change the test. | |
aaa63dae | 111 | like shift @warnings, qr/Illegal character in prototype for \? : bar/, |
eedb00fa | 112 | "(anon) bar triggers illegal proto warnings"; |
aaa63dae | 113 | like shift @warnings, qr/Illegal character in prototype for Q::__ANON__ : baz/, |
eedb00fa | 114 | "(anon) baz triggers illegal proto warnings"; |
aaa63dae | 115 | like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in Q::__ANON__/, |
eedb00fa PM |
116 | "(anon) overridden warning triggered in anonymous sub"; |
117 | is @warnings, 0, "No more warnings"; | |
118 | } | |
119 | ||
120 | # Testing lexical subs | |
121 | { | |
122 | use feature "lexical_subs"; | |
123 | no warnings "experimental::lexical_subs"; | |
124 | $ret = eval 'my sub foo(bar) : prototype(baz) {}; prototype \&foo;'; | |
125 | is $ret, "baz", "my sub foo honors the prototype attribute"; | |
aaa63dae | 126 | like shift @warnings, qr/Illegal character in prototype for foo : bar/, |
eedb00fa | 127 | "(lexical) bar triggers illegal proto warnings"; |
aaa63dae | 128 | like shift @warnings, qr/Illegal character in prototype for foo : baz/, |
eedb00fa | 129 | "(lexical) baz triggers illegal proto warnings"; |
aaa63dae | 130 | like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in foo/, |
eedb00fa PM |
131 | "(lexical) overridden warning triggered in anonymous sub"; |
132 | is @warnings, 0, "No more warnings"; | |
133 | } | |
134 | ||
135 | # Local variables: | |
136 | # indent-tabs-mode: nil | |
137 | # End: | |
138 | # | |
139 | # ex: set ts=8 sts=4 sw=4 et: |