1#!./perl 2 3# Testing the : prototype(..) attribute 4 5 6BEGIN { 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} 12use warnings; 13 14plan tests => 48; 15 16my @warnings; 17my ($attrs, $ret) = ("", ""); 18sub 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;'; 22is $ret, "bad", "Prototype is set to \"bad\""; 23is $attrs, "dummy1", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; 24like shift @warnings, qr/Illegal character in prototype for Q::A : bar/, 25 "First warning is bad prototype - bar"; 26like shift @warnings, qr/Illegal character in prototype for Q::A : bad/, 27 "Second warning is bad prototype - bad"; 28like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::A/, 29 "Third warning is Prototype overridden"; 30is @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;'; 45is $ret, "bad", "Declaring with prototype(..) after definition doesn't change the prototype"; 46is $attrs, "dummy3", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; 47like shift @warnings, qr/Illegal character in prototype for Q::B : ignored/, 48 "Shifting off warning for the 'ignored' prototype"; 49like shift @warnings, qr/Illegal character in prototype for Q::B : baz/, 50 "Attempting to redeclare triggers Illegal character warning"; 51like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/, 52 "Shifting off Prototype overridden warning"; 53like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/, 54 "Attempting to redeclare triggers prototype mismatch warning against first prototype"; 55is @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;'; 59is $ret, "baz", "Redefining with prototype(..) changes the prototype"; 60is $attrs, "dummy4", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; 61is &Q::B, 5, "Function successfully redefined"; 62like shift @warnings, qr/Illegal character in prototype for Q::B : ignored/, 63 "Attempting to redeclare triggers Illegal character warning"; 64like shift @warnings, qr/Illegal character in prototype for Q::B : baz/, 65 "Attempting to redeclare triggers Illegal character warning"; 66like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/, 67 "Shifting off Prototype overridden warning"; 68like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/, 69 "Attempting to redeclare triggers prototype mismatch warning"; 70like shift @warnings, qr/Subroutine B redefined/, 71 "Only other warning is subroutine redefinition"; 72is @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;'; 76is $ret, "\$\$\$", "Last prototype declared wins"; 77like shift @warnings, qr/Attribute prototype\(\$\$\$\) discards earlier prototype attribute in same sub/, 78 "Multiple prototype declarations warns"; 79is @warnings, 0, "No more warnings"; 80 81# Use attributes 82eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(new)";'; 83$ret = prototype \&Q::B; 84is $ret, "new", "use attributes also sets the prototype"; 85like shift @warnings, qr/Prototype mismatch: sub Q::B \(baz\) vs \(new\)/, 86 "Prototype mismatch warning triggered"; 87is @warnings, 0, "No more warnings"; 88 89eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(\$\$~";'; 90$ret = prototype \&Q::B; 91is $ret, "new", "A malformed prototype doesn't reset it"; 92like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked"; 93is @warnings, 0, "Malformed prototype isn't just a warning"; 94 95eval 'use attributes __PACKAGE__, \&foo, "prototype($$\x{100}";'; 96$ret = prototype \&Q::B; 97is $ret, "new", "A malformed prototype doesn't reset it"; 98like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked"; 99is @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: 136