t/op/attrproto.t

3 # Testing the : prototype(..) attribute
21 $ret = eval 'package Q; sub A(bar) : prototype(bad) : dummy1 {} prototype \&A;';
23 is $attrs, "dummy1", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
24 like shift @warnings, qr/Illegal character in prototype for Q::A : bar/,
25     "First warning is bad prototype - bar";
26 like shift @warnings, qr/Illegal character in prototype for Q::A : bad/,
27     "Second warning is bad prototype - bad";
28 like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::A/,
32 # The override warning should not be hidden by no warnings (similar to prototype changed warnings)
35     $ret = eval 'package Q; sub B(bar) : prototype(bad) dummy2 {4} prototype \&B;';
37     is $attrs, "dummy2", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
38     like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::B/,
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(..)";
47 like shift @warnings, qr/Illegal character in prototype for Q::B : ignored/,
48     "Shifting off warning for the 'ignored' prototype";
49 like shift @warnings, qr/Illegal character in prototype for Q::B : baz/,
51 like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/,
54     "Attempting to redeclare triggers prototype mismatch warning against first prototype";
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(..)";
62 like shift @warnings, qr/Illegal character in prototype for Q::B : ignored/,
64 like shift @warnings, qr/Illegal character in prototype for Q::B : baz/,
66 like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/,
69     "Attempting to redeclare triggers prototype mismatch warning";
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";
77 like shift @warnings, qr/Attribute prototype\(\$\$\$\) discards earlier prototype attribute in same sub/,
78     "Multiple prototype declarations warns";
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";
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";
92 like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked";
93 is @warnings, 0, "Malformed prototype isn't just a warning";
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";
98 like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked";
99 is @warnings, 0, "Malformed prototype isn't just a warning";
104     is eval 'package Q; my $a = sub(bar) : prototype(baz) {}; 1;', 1,
111     like shift @warnings, qr/Illegal character in prototype for \? : bar/,
113     like shift @warnings, qr/Illegal character in prototype for Q::__ANON__ : baz/,
115     like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in Q::__ANON__/,
124     $ret = eval 'my sub foo(bar) : prototype(baz) {}; prototype \&foo;';
125     is $ret, "baz", "my sub foo honors the prototype attribute";
126     like shift @warnings, qr/Illegal character in prototype for foo : bar/,
128     like shift @warnings, qr/Illegal character in prototype for foo : baz/,
130     like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in foo/,