Commit | Line | Data |
---|---|---|
89a5757c BF |
1 | #!./perl |
2 | ||
3 | # Regression tests for attributes.pm and the C< : attrs> syntax. | |
4 | ||
5 | BEGIN { | |
6 | chdir 't' if -d 't'; | |
89a5757c | 7 | require './test.pl'; |
624c42e2 | 8 | set_up_inc('../lib'); |
89a5757c BF |
9 | skip_all_if_miniperl("miniperl can't load attributes"); |
10 | } | |
11 | ||
12 | use utf8; | |
13 | use open qw( :utf8 :std ); | |
14 | use warnings; | |
15 | use feature 'unicode_strings'; | |
16 | ||
17 | $SIG{__WARN__} = sub { die @_ }; | |
18 | ||
19 | sub eval_ok ($;$) { | |
20 | eval shift; | |
21 | is( $@, '', @_); | |
22 | } | |
23 | ||
20e5bab4 | 24 | fresh_perl_is 'use attributes; print "ok"', 'ok', {}, |
89a5757c BF |
25 | 'attributes.pm can load without warnings.pm already loaded'; |
26 | ||
27 | eval 'sub è1 ($) : plùgh ;'; | |
28 | like $@, qr/^Invalid CODE attributes?: ["']?plùgh["']? at/; | |
29 | ||
30 | eval 'sub ɛ2 ($) : plǖgh(0,0) xyzzy ;'; | |
31 | like $@, qr/^Invalid CODE attributes: ["']?plǖgh\(0,0\)["']? /; | |
32 | ||
33 | eval 'my ($x,$y) : plǖgh;'; | |
34 | like $@, qr/^Invalid SCALAR attribute: ["']?plǖgh["']? at/; | |
35 | ||
36 | # bug #16080 | |
37 | eval '{my $x : plǖgh}'; | |
38 | like $@, qr/^Invalid SCALAR attribute: ["']?plǖgh["']? at/; | |
39 | eval '{my ($x,$y) : plǖgh(})}'; | |
92e8e650 | 40 | like $@, qr/^Invalid SCALAR attribute: ["']?plǖgh\(\}\)["']? at/; |
89a5757c BF |
41 | |
42 | # More syntax tests from the attributes manpage | |
43 | eval 'my $x : Şʨᚻ(10,ᕘ(7,3)) : 에ㄒ펜ሲ;'; | |
44 | like $@, qr/^Invalid SCALAR attributes: ["']?Şʨᚻ\(10,ᕘ\(7,3\)\) : 에ㄒ펜ሲ["']? at/; | |
45 | eval q/my $x : Ugļᑈ('\(") :받;/; | |
46 | like $@, qr/^Invalid SCALAR attributes: ["']?Ugļᑈ\('\\\("\) : 받["']? at/; | |
47 | eval 'my $x : Şʨᚻ(10,ᕘ();'; | |
48 | like $@, qr/^Unterminated attribute parameter in attribute list at/; | |
49 | eval q/my $x : Ugļᑈ('(');/; | |
50 | like $@, qr/^Unterminated attribute parameter in attribute list at/; | |
51 | ||
52 | sub A::MODIFY_SCALAR_ATTRIBUTES { return } | |
53 | eval 'my A $x : plǖgh;'; | |
54 | like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plǖgh["']? at/; | |
55 | ||
56 | eval 'my A $x : plǖgh plover;'; | |
57 | like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plǖgh["']? /; | |
58 | ||
59 | no warnings 'reserved'; | |
60 | eval 'my A $x : plǖgh;'; | |
61 | is $@, ''; | |
62 | ||
63 | eval 'package Càt; my Càt @socks;'; | |
aaa63dae | 64 | is $@, ''; |
89a5757c BF |
65 | |
66 | eval 'my Càt %nap;'; | |
aaa63dae | 67 | is $@, ''; |
89a5757c BF |
68 | |
69 | sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } | |
70 | sub X::ᕘ { 1 } | |
71 | *Y::bar = \&X::ᕘ; | |
72 | *Y::bar = \&X::ᕘ; # second time for -w | |
73 | eval 'package Z; sub Y::bar : ᕘ'; | |
74 | like $@, qr/^X at /; | |
75 | ||
76 | # Begin testing attributes that tie | |
77 | ||
78 | { | |
79 | package Ttìè; | |
80 | sub DESTROY {} | |
81 | sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; } | |
82 | sub FETCH { ${$_[0]} } | |
83 | sub STORE { | |
84 | ::pass; | |
85 | ${$_[0]} = $_[1]*2; | |
86 | } | |
87 | package Tlòòp; | |
88 | sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttìè', -1; (); } | |
89 | } | |
90 | ||
91 | eval_ok ' | |
92 | package Tlòòp; | |
93 | for my $i (0..2) { | |
94 | my $x : TìèLòòp = $i; | |
95 | $x != $i*2 and ::is $x, $i*2; | |
96 | } | |
97 | '; | |
98 | ||
99 | # bug #15898 | |
100 | eval 'our ${""} : ᕘ = 1'; | |
101 | like $@, qr/Can't declare scalar dereference in "our"/; | |
102 | eval 'my $$ᕘ : bar = 1'; | |
103 | like $@, qr/Can't declare scalar dereference in "my"/; | |
104 | ||
105 | ||
106 | # this will segfault if it fails | |
107 | sub PVBM () { 'ᕘ' } | |
108 | { my $dummy = index 'ᕘ', PVBM } | |
109 | ||
110 | ok !defined(eval 'attributes::get(\PVBM)'), | |
111 | 'PVBMs don\'t segfault attributes::get'; | |
112 | ||
113 | { | |
114 | # [perl #49472] Attributes + Unknown Error | |
115 | eval ' | |
116 | use strict; | |
117 | sub MODIFY_CODE_ATTRIBUTE{} | |
118 | sub f:Blah {$nosuchvar}; | |
119 | '; | |
120 | ||
121 | my $err = $@; | |
122 | like ($err, qr/Global symbol "\$nosuchvar" requires /, 'perl #49472'); | |
123 | } | |
124 | ||
125 | # Test that code attributes always get applied to the same CV that | |
126 | # we're left with at the end (bug#66970). | |
127 | { | |
128 | package bug66970; | |
129 | our $c; | |
130 | sub MODIFY_CODE_ATTRIBUTES { $c = $_[1]; () } | |
131 | $c=undef; eval 'sub t0 :ᕘ'; | |
132 | main::ok $c == \&{"t0"}; | |
133 | $c=undef; eval 'sub t1 :ᕘ { }'; | |
134 | main::ok $c == \&{"t1"}; | |
135 | $c=undef; eval 'sub t2'; | |
136 | our $t2a = \&{"t2"}; | |
137 | $c=undef; eval 'sub t2 :ᕘ'; | |
138 | main::ok $c == \&{"t2"} && $c == $t2a; | |
139 | $c=undef; eval 'sub t3'; | |
140 | our $t3a = \&{"t3"}; | |
141 | $c=undef; eval 'sub t3 :ᕘ { }'; | |
142 | main::ok $c == \&{"t3"} && $c == $t3a; | |
143 | $c=undef; eval 'sub t4 :ᕘ'; | |
144 | our $t4a = \&{"t4"}; | |
145 | our $t4b = $c; | |
146 | $c=undef; eval 'sub t4 :ᕘ'; | |
147 | main::ok $c == \&{"t4"} && $c == $t4b && $c == $t4a; | |
148 | $c=undef; eval 'sub t5 :ᕘ'; | |
149 | our $t5a = \&{"t5"}; | |
150 | our $t5b = $c; | |
151 | $c=undef; eval 'sub t5 :ᕘ { }'; | |
152 | main::ok $c == \&{"t5"} && $c == $t5b && $c == $t5a; | |
153 | } | |
154 | ||
155 | # [perl #68560] Calling closure prototypes (only accessible via :attr) | |
156 | { | |
157 | package brength; | |
158 | my $proto; | |
159 | sub MODIFY_CODE_ATTRIBUTES { $proto = $_[1]; _: } | |
160 | eval q{ | |
161 | my $x; | |
162 | () = sub :a0 { $x }; | |
163 | }; | |
164 | package main; | |
165 | eval { $proto->() }; # used to crash in pp_entersub | |
166 | like $@, qr/^Closure prototype called/, | |
167 | "Calling closure proto with (no) args"; | |
168 | eval { () = &$proto }; # used to crash in pp_leavesub | |
169 | like $@, qr/^Closure prototype called/, | |
170 | 'Calling closure proto with no @_ that returns a lexical'; | |
171 | } | |
172 | ||
173 | # [perl #68658] Attributes on stately variables | |
174 | { | |
175 | package thwext; | |
176 | sub MODIFY_SCALAR_ATTRIBUTES { () } | |
177 | my $i = 0; | |
178 | my $x_values = ''; | |
179 | eval 'sub ᕘ { use 5.01; state $x :A0 = $i++; $x_values .= $x }'; | |
180 | ᕘ(); ᕘ(); | |
181 | package main; | |
182 | is $x_values, '00', 'state with attributes'; | |
183 | } | |
184 | ||
185 | { | |
186 | package 닌g난ㄬ; | |
187 | sub MODIFY_SCALAR_ATTRIBUTES{} | |
188 | sub MODIFY_ARRAY_ATTRIBUTES{ } | |
189 | sub MODIFY_HASH_ATTRIBUTES{ } | |
190 | my ($cows, @go, %bong) : テa퐅Š = qw[ jibber jabber joo ]; | |
191 | ::is $cows, 'jibber', 'list assignment to scalar with attrs'; | |
192 | ::is "@go", 'jabber joo', 'list assignment to array with attrs'; | |
193 | } | |
194 | ||
195 | done_testing(); |