Commit | Line | Data |
6515510f |
1 | #!./perl -T |
54310121 |
2 | |
3 | BEGIN { |
6515510f |
4 | if ($ENV{PERL_CORE}) { |
5 | chdir 't' if -d 't'; |
6 | @INC = '../lib'; |
7 | } |
54310121 |
8 | } |
9 | |
9f1b1f2d |
10 | use warnings; |
69e7dc3c |
11 | use vars qw{ @warnings $fagwoosh $putt $kloong}; |
54310121 |
12 | BEGIN { # ...and save 'em for later |
13 | $SIG{'__WARN__'} = sub { push @warnings, @_ } |
14 | } |
d9696651 |
15 | END { @warnings && print STDERR join "\n- ", "accumulated warnings:", @warnings } |
54310121 |
16 | |
54310121 |
17 | |
18 | use strict; |
d9696651 |
19 | use Test::More tests => 95; |
10a0e555 |
20 | my $TB = Test::More->builder; |
21 | |
22 | BEGIN { use_ok('constant'); } |
54310121 |
23 | |
54310121 |
24 | use constant PI => 4 * atan2 1, 1; |
25 | |
10a0e555 |
26 | ok defined PI, 'basic scalar constant'; |
27 | is substr(PI, 0, 7), '3.14159', ' in substr()'; |
54310121 |
28 | |
29 | sub deg2rad { PI * $_[0] / 180 } |
30 | |
31 | my $ninety = deg2rad 90; |
32 | |
10a0e555 |
33 | cmp_ok abs($ninety - 1.5707), '<', 0.0001, ' in math expression'; |
54310121 |
34 | |
35 | use constant UNDEF1 => undef; # the right way |
36 | use constant UNDEF2 => ; # the weird way |
37 | use constant 'UNDEF3' ; # the 'short' way |
38 | use constant EMPTY => ( ) ; # the right way for lists |
39 | |
10a0e555 |
40 | is UNDEF1, undef, 'right way to declare an undef'; |
41 | is UNDEF2, undef, ' weird way'; |
42 | is UNDEF3, undef, ' short way'; |
43 | |
44 | # XXX Why is this way different than the other ones? |
54310121 |
45 | my @undef = UNDEF1; |
10a0e555 |
46 | is @undef, 1; |
47 | is $undef[0], undef; |
48 | |
54310121 |
49 | @undef = UNDEF2; |
10a0e555 |
50 | is @undef, 0; |
54310121 |
51 | @undef = UNDEF3; |
10a0e555 |
52 | is @undef, 0; |
54310121 |
53 | @undef = EMPTY; |
10a0e555 |
54 | is @undef, 0; |
54310121 |
55 | |
56 | use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5; |
57 | use constant COUNTLIST => reverse 1, 2, 3, 4, 5; |
58 | use constant COUNTLAST => (COUNTLIST)[-1]; |
59 | |
10a0e555 |
60 | is COUNTDOWN, '54321'; |
54310121 |
61 | my @cl = COUNTLIST; |
10a0e555 |
62 | is @cl, 5; |
63 | is COUNTDOWN, join '', @cl; |
64 | is COUNTLAST, 1; |
65 | is((COUNTLIST)[1], 4); |
54310121 |
66 | |
67 | use constant ABC => 'ABC'; |
10a0e555 |
68 | is "abc${\( ABC )}abc", "abcABCabc"; |
54310121 |
69 | |
9d116dd7 |
70 | use constant DEF => 'D', 'E', chr ord 'F'; |
10a0e555 |
71 | is "d e f @{[ DEF ]} d e f", "d e f D E F d e f"; |
54310121 |
72 | |
73 | use constant SINGLE => "'"; |
74 | use constant DOUBLE => '"'; |
75 | use constant BACK => '\\'; |
76 | my $tt = BACK . SINGLE . DOUBLE ; |
10a0e555 |
77 | is $tt, q(\\'"); |
54310121 |
78 | |
79 | use constant MESS => q('"'\\"'"\\); |
10a0e555 |
80 | is MESS, q('"'\\"'"\\); |
81 | is length(MESS), 8; |
54310121 |
82 | |
c1b0f331 |
83 | use constant LEADING => " \t1234"; |
10a0e555 |
84 | cmp_ok LEADING, '==', 1234; |
85 | is LEADING, " \t1234"; |
54310121 |
86 | |
87 | use constant ZERO1 => 0; |
88 | use constant ZERO2 => 0.0; |
89 | use constant ZERO3 => '0.0'; |
10a0e555 |
90 | is ZERO1, '0'; |
91 | is ZERO2, '0'; |
92 | is ZERO3, '0.0'; |
54310121 |
93 | |
94 | { |
95 | package Other; |
96 | use constant PI => 3.141; |
97 | } |
98 | |
10a0e555 |
99 | cmp_ok(abs(PI - 3.1416), '<', 0.0001); |
100 | is Other::PI, 3.141; |
54310121 |
101 | |
102 | use constant E2BIG => $! = 7; |
10a0e555 |
103 | cmp_ok E2BIG, '==', 7; |
54310121 |
104 | # This is something like "Arg list too long", but the actual message |
105 | # text may vary, so we can't test much better than this. |
10a0e555 |
106 | cmp_ok length(E2BIG), '>', 6; |
54310121 |
107 | |
d9696651 |
108 | is @warnings, 0 or diag join "\n- ", "unexpected warning:", @warnings; |
54310121 |
109 | @warnings = (); # just in case |
110 | undef &PI; |
10a0e555 |
111 | ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or |
112 | diag join "\n", "unexpected warning", @warnings; |
113 | shift @warnings; |
54310121 |
114 | |
10a0e555 |
115 | is @warnings, 0, "unexpected warning"; |
779c5bc9 |
116 | |
10a0e555 |
117 | my $curr_test = $TB->current_test; |
d9696651 |
118 | use constant CSCALAR => \"ok 35\n"; |
119 | use constant CHASH => { foo => "ok 36\n" }; |
120 | use constant CARRAY => [ undef, "ok 37\n" ]; |
779c5bc9 |
121 | use constant CCODE => sub { "ok $_[0]\n" }; |
122 | |
6515510f |
123 | my $output = $TB->output ; |
124 | print $output ${+CSCALAR}; |
125 | print $output CHASH->{foo}; |
126 | print $output CARRAY->[1]; |
127 | print $output CCODE->($curr_test+4); |
10a0e555 |
128 | |
129 | $TB->current_test($curr_test+4); |
130 | |
779c5bc9 |
131 | eval q{ CCODE->{foo} }; |
10a0e555 |
132 | ok scalar($@ =~ /^Constant is not a HASH/); |
133 | |
83763826 |
134 | |
135 | # Allow leading underscore |
136 | use constant _PRIVATE => 47; |
10a0e555 |
137 | is _PRIVATE, 47; |
83763826 |
138 | |
139 | # Disallow doubled leading underscore |
140 | eval q{ |
141 | use constant __DISALLOWED => "Oops"; |
142 | }; |
10a0e555 |
143 | like $@, qr/begins with '__'/; |
83763826 |
144 | |
145 | # Check on declared() and %declared. This sub should be EXACTLY the |
146 | # same as the one quoted in the docs! |
147 | sub declared ($) { |
148 | use constant 1.01; # don't omit this! |
149 | my $name = shift; |
150 | $name =~ s/^::/main::/; |
151 | my $pkg = caller; |
152 | my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; |
153 | $constant::declared{$full_name}; |
154 | } |
155 | |
10a0e555 |
156 | ok declared 'PI'; |
157 | ok $constant::declared{'main::PI'}; |
83763826 |
158 | |
10a0e555 |
159 | ok !declared 'PIE'; |
160 | ok !$constant::declared{'main::PIE'}; |
83763826 |
161 | |
162 | { |
163 | package Other; |
164 | use constant IN_OTHER_PACK => 42; |
10a0e555 |
165 | ::ok ::declared 'IN_OTHER_PACK'; |
166 | ::ok $constant::declared{'Other::IN_OTHER_PACK'}; |
167 | ::ok ::declared 'main::PI'; |
168 | ::ok $constant::declared{'main::PI'}; |
83763826 |
169 | } |
170 | |
10a0e555 |
171 | ok declared 'Other::IN_OTHER_PACK'; |
172 | ok $constant::declared{'Other::IN_OTHER_PACK'}; |
d3a7d8c7 |
173 | |
174 | @warnings = (); |
175 | eval q{ |
9f1b1f2d |
176 | no warnings; |
6515510f |
177 | #local $^W if $] < 5.006; |
d3a7d8c7 |
178 | use warnings 'constant'; |
179 | use constant 'BEGIN' => 1 ; |
180 | use constant 'INIT' => 1 ; |
181 | use constant 'CHECK' => 1 ; |
182 | use constant 'END' => 1 ; |
183 | use constant 'DESTROY' => 1 ; |
184 | use constant 'AUTOLOAD' => 1 ; |
185 | use constant 'STDIN' => 1 ; |
186 | use constant 'STDOUT' => 1 ; |
187 | use constant 'STDERR' => 1 ; |
188 | use constant 'ARGV' => 1 ; |
189 | use constant 'ARGVOUT' => 1 ; |
190 | use constant 'ENV' => 1 ; |
191 | use constant 'INC' => 1 ; |
192 | use constant 'SIG' => 1 ; |
83b99c4f |
193 | use constant 'UNITCHECK' => 1; |
d3a7d8c7 |
194 | }; |
195 | |
10a0e555 |
196 | my @Expected_Warnings = |
197 | ( |
198 | qr/^Constant name 'BEGIN' is a Perl keyword at/, |
199 | qr/^Constant subroutine BEGIN redefined at/, |
200 | qr/^Constant name 'INIT' is a Perl keyword at/, |
201 | qr/^Constant name 'CHECK' is a Perl keyword at/, |
202 | qr/^Constant name 'END' is a Perl keyword at/, |
203 | qr/^Constant name 'DESTROY' is a Perl keyword at/, |
204 | qr/^Constant name 'AUTOLOAD' is a Perl keyword at/, |
205 | qr/^Constant name 'STDIN' is forced into package main:: a/, |
206 | qr/^Constant name 'STDOUT' is forced into package main:: at/, |
207 | qr/^Constant name 'STDERR' is forced into package main:: at/, |
208 | qr/^Constant name 'ARGV' is forced into package main:: at/, |
209 | qr/^Constant name 'ARGVOUT' is forced into package main:: at/, |
210 | qr/^Constant name 'ENV' is forced into package main:: at/, |
211 | qr/^Constant name 'INC' is forced into package main:: at/, |
212 | qr/^Constant name 'SIG' is forced into package main:: at/, |
83b99c4f |
213 | qr/^Constant name 'UNITCHECK' is a Perl keyword at/, |
10a0e555 |
214 | ); |
6515510f |
215 | |
83b99c4f |
216 | unless ($] > 5.009) { |
217 | # Remove the UNITCHECK warning |
218 | pop @Expected_Warnings; |
219 | # But keep the count the same |
220 | push @Expected_Warnings, qr/^$/; |
221 | push @warnings, ""; |
222 | } |
223 | |
6515510f |
224 | # when run under "make test" |
225 | if (@warnings == 16) { |
226 | push @warnings, ""; |
227 | push @Expected_Warnings, qr/^$/; |
228 | } |
229 | # when run directly: perl -wT -Ilib t/constant.t |
230 | elsif (@warnings == 17) { |
231 | splice @Expected_Warnings, 1, 0, |
232 | qr/^Prototype mismatch: sub main::BEGIN \(\) vs none at/; |
233 | } |
234 | # when run directly under 5.6.2: perl -wT -Ilib t/constant.t |
235 | elsif (@warnings == 15) { |
236 | splice @Expected_Warnings, 1, 1; |
237 | push @warnings, "", ""; |
238 | push @Expected_Warnings, qr/^$/, qr/^$/; |
239 | } |
240 | else { |
241 | my $rule = " -" x 20; |
242 | diag "/!\\ unexpected case: ", scalar @warnings, " warnings\n$rule\n"; |
243 | diag map { " $_" } @warnings; |
244 | diag $rule, $/; |
245 | } |
246 | |
247 | is @warnings, 17; |
248 | |
10a0e555 |
249 | for my $idx (0..$#warnings) { |
250 | like $warnings[$idx], $Expected_Warnings[$idx]; |
251 | } |
6515510f |
252 | |
d3a7d8c7 |
253 | @warnings = (); |
c7206c54 |
254 | |
255 | |
256 | use constant { |
257 | THREE => 3, |
258 | FAMILY => [ qw( John Jane Sally ) ], |
259 | AGES => { John => 33, Jane => 28, Sally => 3 }, |
260 | RFAM => [ [ qw( John Jane Sally ) ] ], |
261 | SPIT => sub { shift }, |
c7206c54 |
262 | }; |
263 | |
10a0e555 |
264 | is @{+FAMILY}, THREE; |
265 | is @{+FAMILY}, @{RFAM->[0]}; |
266 | is FAMILY->[2], RFAM->[0]->[2]; |
267 | is AGES->{FAMILY->[1]}, 28; |
268 | is THREE**3, SPIT->(@{+FAMILY}**3); |
5b673cda |
269 | |
270 | # Allow name of digits/underscores only if it begins with underscore |
271 | { |
272 | use warnings FATAL => 'constant'; |
273 | eval q{ |
274 | use constant _1_2_3 => 'allowed'; |
275 | }; |
276 | ok( $@ eq '' ); |
277 | } |
69e7dc3c |
278 | |
279 | sub slotch (); |
280 | |
281 | { |
282 | my @warnings; |
283 | local $SIG{'__WARN__'} = sub { push @warnings, @_ }; |
284 | eval 'use constant slotch => 3; 1' or die $@; |
285 | |
286 | is ("@warnings", "", "No warnings if a prototype exists"); |
287 | |
288 | my $value = eval 'slotch'; |
289 | is ($@, ''); |
290 | is ($value, 3); |
291 | } |
292 | |
293 | sub zit; |
294 | |
295 | { |
296 | my @warnings; |
297 | local $SIG{'__WARN__'} = sub { push @warnings, @_ }; |
298 | eval 'use constant zit => 4; 1' or die $@; |
299 | |
6515510f |
300 | # empty prototypes are reported differently in different versions |
13e592d2 |
301 | my $no_proto = $] < 5.008004 ? "" : ": none"; |
6515510f |
302 | |
69e7dc3c |
303 | is(scalar @warnings, 1, "1 warning"); |
6515510f |
304 | like ($warnings[0], qr/^Prototype mismatch: sub main::zit$no_proto vs \(\)/, |
69e7dc3c |
305 | "about the prototype mismatch"); |
306 | |
307 | my $value = eval 'zit'; |
308 | is ($@, ''); |
309 | is ($value, 4); |
310 | } |
311 | |
312 | $fagwoosh = 'geronimo'; |
313 | $putt = 'leutwein'; |
314 | $kloong = 'schlozhauer'; |
315 | |
316 | { |
317 | my @warnings; |
318 | local $SIG{'__WARN__'} = sub { push @warnings, @_ }; |
319 | eval 'use constant fagwoosh => 5; 1' or die $@; |
320 | |
321 | is ("@warnings", "", "No warnings if the typeglob exists already"); |
322 | |
323 | my $value = eval 'fagwoosh'; |
324 | is ($@, ''); |
325 | is ($value, 5); |
326 | |
327 | my @value = eval 'fagwoosh'; |
328 | is ($@, ''); |
329 | is_deeply (\@value, [5]); |
330 | |
331 | eval 'use constant putt => 6, 7; 1' or die $@; |
332 | |
333 | is ("@warnings", "", "No warnings if the typeglob exists already"); |
334 | |
335 | @value = eval 'putt'; |
336 | is ($@, ''); |
337 | is_deeply (\@value, [6, 7]); |
338 | |
339 | eval 'use constant "klong"; 1' or die $@; |
340 | |
341 | is ("@warnings", "", "No warnings if the typeglob exists already"); |
342 | |
343 | $value = eval 'klong'; |
344 | is ($@, ''); |
345 | is ($value, undef); |
346 | |
347 | @value = eval 'klong'; |
348 | is ($@, ''); |
349 | is_deeply (\@value, []); |
350 | } |