Jakub Wilk is now a Perl author.
[perl.git] / t / op / attrproto.t
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: