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