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
1 #!./perl -T
2
3 use warnings;
4 use vars qw{ @warnings $fagwoosh $putt $kloong};
5 BEGIN {                         # ...and save 'em for later
6     $SIG{'__WARN__'} = sub { push @warnings, @_ }
7 }
8 END { @warnings && print STDERR join "\n- ", "accumulated warnings:", @warnings }
9
10
11 use strict;
12 use Test::More tests => 104;
13 my $TB = Test::More->builder;
14
15 BEGIN { use_ok('constant'); }
16
17 use constant PI         => 4 * atan2 1, 1;
18
19 ok defined PI,                          'basic scalar constant';
20 is substr(PI, 0, 7), '3.14159',         '    in substr()';
21
22 sub deg2rad { PI * $_[0] / 180 }
23
24 my $ninety = deg2rad 90;
25
26 cmp_ok abs($ninety - 1.5707), '<', 0.0001, '    in math expression';
27
28 use constant UNDEF1     => undef;       # the right way
29 use constant UNDEF2     =>      ;       # the weird way
30 use constant 'UNDEF3'           ;       # the 'short' way
31 use constant EMPTY      => ( )  ;       # the right way for lists
32
33 is UNDEF1, undef,       'right way to declare an undef';
34 is UNDEF2, undef,       '    weird way';
35 is UNDEF3, undef,       '    short way';
36
37 # XXX Why is this way different than the other ones?
38 my @undef = UNDEF1;
39 is @undef, 1;
40 is $undef[0], undef;
41
42 @undef = UNDEF2;
43 is @undef, 0;
44 @undef = UNDEF3;
45 is @undef, 0;
46 @undef = EMPTY;
47 is @undef, 0;
48
49 use constant COUNTDOWN  => scalar reverse 1, 2, 3, 4, 5;
50 use constant COUNTLIST  => reverse 1, 2, 3, 4, 5;
51 use constant COUNTLAST  => (COUNTLIST)[-1];
52
53 is COUNTDOWN, '54321';
54 my @cl = COUNTLIST;
55 is @cl, 5;
56 is COUNTDOWN, join '', @cl;
57 is COUNTLAST, 1;
58 is((COUNTLIST)[1], 4);
59
60 use constant ABC        => 'ABC';
61 is "abc${\( ABC )}abc", "abcABCabc";
62
63 use constant DEF        => 'D', 'E', chr ord 'F';
64 is "d e f @{[ DEF ]} d e f", "d e f D E F d e f";
65
66 use constant SINGLE     => "'";
67 use constant DOUBLE     => '"';
68 use constant BACK       => '\\';
69 my $tt = BACK . SINGLE . DOUBLE ;
70 is $tt, q(\\'");
71
72 use constant MESS       => q('"'\\"'"\\);
73 is MESS, q('"'\\"'"\\);
74 is length(MESS), 8;
75
76 use constant LEADING    => " \t1234";
77 cmp_ok LEADING, '==', 1234;
78 is LEADING, " \t1234";
79
80 use constant ZERO1      => 0;
81 use constant ZERO2      => 0.0;
82 use constant ZERO3      => '0.0';
83 is ZERO1, '0';
84 is ZERO2, '0';
85 is ZERO3, '0.0';
86
87 {
88     package Other;
89     use constant PI     => 3.141;
90 }
91
92 cmp_ok(abs(PI - 3.1416), '<', 0.0001);
93 is Other::PI, 3.141;
94
95 use constant E2BIG => $! = 7;
96 cmp_ok E2BIG, '==', 7;
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.
99 cmp_ok length(E2BIG), '>', 6;
100
101 is @warnings, 0 or diag join "\n- ", "unexpected warning:", @warnings;
102 @warnings = ();         # just in case
103 undef &PI;
104 ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or
105   diag join "\n", "unexpected warning", @warnings;
106 shift @warnings;
107
108 is @warnings, 0, "unexpected warning";
109
110 my $curr_test = $TB->current_test;
111 use constant CSCALAR    => \"ok 35\n";
112 use constant CHASH      => { foo => "ok 36\n" };
113 use constant CARRAY     => [ undef, "ok 37\n" ];
114 use constant CCODE      => sub { "ok $_[0]\n" };
115
116 my $output = $TB->output ;
117 print $output ${+CSCALAR};
118 print $output CHASH->{foo};
119 print $output CARRAY->[1];
120 print $output CCODE->($curr_test+4);
121
122 $TB->current_test($curr_test+4);
123
124 eval q{ CCODE->{foo} };
125 ok scalar($@ =~ /^Constant is not a HASH/);
126
127
128 # Allow leading underscore
129 use constant _PRIVATE => 47;
130 is _PRIVATE, 47;
131
132 # Disallow doubled leading underscore
133 eval q{
134     use constant __DISALLOWED => "Oops";
135 };
136 like $@, qr/begins with '__'/;
137
138 # Check on declared() and %declared. This sub should be EXACTLY the
139 # same as the one quoted in the docs!
140 sub 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
149 ok declared 'PI';
150 ok $constant::declared{'main::PI'};
151
152 ok !declared 'PIE';
153 ok !$constant::declared{'main::PIE'};
154
155 {
156     package Other;
157     use constant IN_OTHER_PACK => 42;
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'};
162 }
163
164 ok declared 'Other::IN_OTHER_PACK';
165 ok $constant::declared{'Other::IN_OTHER_PACK'};
166
167 @warnings = ();
168 eval q{
169     no warnings;
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 ;
185     use constant 'UNITCHECK' => 1;
186 };
187
188 my @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/,
205    qr/^Constant name 'UNITCHECK' is a Perl keyword at/,
206 );
207
208 unless ($] > 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
216 # when run under "make test"
217 if (@warnings == 16) {
218     push @warnings, "";
219     push @Expected_Warnings, qr/^$/;
220 }
221 # when run directly: perl -wT -Ilib t/constant.t
222 elsif (@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
227 elsif (@warnings == 15) {
228     splice @Expected_Warnings, 1, 1;
229     push @warnings, "", "";
230     push @Expected_Warnings, qr/^$/, qr/^$/;
231 }
232 else {
233     my $rule = " -" x 20;
234     diag "/!\\ unexpected case: ", scalar @warnings, " warnings\n$rule\n";
235     diag map { "  $_" } @warnings;
236     diag $rule, $/;
237 }
238
239 is @warnings, 17;
240
241 for my $idx (0..$#warnings) {
242     like $warnings[$idx], $Expected_Warnings[$idx];
243 }
244
245 @warnings = ();
246
247
248 use 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 },
254 };
255
256 is @{+FAMILY}, THREE;
257 is @{+FAMILY}, @{RFAM->[0]};
258 is FAMILY->[2], RFAM->[0]->[2];
259 is AGES->{FAMILY->[1]}, 28;
260 is THREE**3, SPIT->(@{+FAMILY}**3);
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 }
270
271 sub 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
285 sub zit;
286
287 {
288     my @warnings;
289     local $SIG{'__WARN__'} = sub { push @warnings, @_ };
290     eval 'use constant zit => 4; 1' or die $@;
291
292     # empty prototypes are reported differently in different versions
293     my $no_proto = $] < 5.008004 ? "" : ": none";
294
295     is(scalar @warnings, 1, "1 warning");
296     like ($warnings[0], qr/^Prototype mismatch: sub main::zit$no_proto vs \(\)/,
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 }
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 }
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.
354 ok !exists $::{immutable};
355 eval 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;
366         }
367         like $@, qr/^Modification of a read-only value attempted at /,
368             '... and immutable through refgen, too';
369     }
370 };
371 () = \&{"immutable"}; # reify
372 eval 'for (immutable) { $_ = 42 }';
373 like $@, 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;
380 use constant existing_stash_entry => 23987423874;
381 for (existing_stash_entry) { eval { $_ = 22 } }
382 like $@, qr/^Modification of a read-only value attempted at /,
383     'constant created in existing stash slot is immutable';
384 eval { for (existing_stash_entry) { ${\$_} = 432 } };
385 SKIP: {
386     local $TODO;
387     if ($Config::Config{useithreads}) {
388         skip "fails under threads", 1 if $] < 5.019001;
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
395 # 5.19.2 and later (er, except it doesn’t work under that version yet,
396 # either, hence the to-do status).
397 SKIP: {
398     skip "fails under 5.19.1 and earlier", 2 if $] < 5.019002;
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 }