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