| 1 | #!./perl |
| 2 | |
| 3 | # Testing the : prototype(..) attribute |
| 4 | |
| 5 | |
| 6 | BEGIN { |
| 7 | chdir 't' if -d 't'; |
| 8 | require './test.pl'; |
| 9 | set_up_inc('../lib'); |
| 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(..)"; |
| 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/, |
| 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(..)"; |
| 38 | like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::B/, |
| 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(..)"; |
| 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/, |
| 50 | "Attempting to redeclare triggers Illegal character warning"; |
| 51 | like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/, |
| 52 | "Shifting off Prototype overridden warning"; |
| 53 | like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/, |
| 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"; |
| 62 | like shift @warnings, qr/Illegal character in prototype for Q::B : ignored/, |
| 63 | "Attempting to redeclare triggers Illegal character warning"; |
| 64 | like shift @warnings, qr/Illegal character in prototype for Q::B : baz/, |
| 65 | "Attempting to redeclare triggers Illegal character warning"; |
| 66 | like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/, |
| 67 | "Shifting off Prototype overridden warning"; |
| 68 | like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/, |
| 69 | "Attempting to redeclare triggers prototype mismatch warning"; |
| 70 | like shift @warnings, qr/Subroutine B redefined/, |
| 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"; |
| 77 | like shift @warnings, qr/Attribute prototype\(\$\$\$\) discards earlier prototype attribute in same sub/, |
| 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"; |
| 85 | like shift @warnings, qr/Prototype mismatch: sub Q::B \(baz\) vs \(new\)/, |
| 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"; |
| 92 | like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked"; |
| 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"; |
| 98 | like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked"; |
| 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. |
| 111 | like shift @warnings, qr/Illegal character in prototype for \? : bar/, |
| 112 | "(anon) bar triggers illegal proto warnings"; |
| 113 | like shift @warnings, qr/Illegal character in prototype for Q::__ANON__ : baz/, |
| 114 | "(anon) baz triggers illegal proto warnings"; |
| 115 | like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in Q::__ANON__/, |
| 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"; |
| 126 | like shift @warnings, qr/Illegal character in prototype for foo : bar/, |
| 127 | "(lexical) bar triggers illegal proto warnings"; |
| 128 | like shift @warnings, qr/Illegal character in prototype for foo : baz/, |
| 129 | "(lexical) baz triggers illegal proto warnings"; |
| 130 | like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in foo/, |
| 131 | "(lexical) overridden warning triggered in anonymous sub"; |
| 132 | is @warnings, 0, "No more warnings"; |
| 133 | } |
| 134 | |
| 135 | # ex: set ts=8 sts=4 sw=4 et: |