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
CommitLineData
54310121
PP
1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
20822f61 5 @INC = '../lib';
54310121
PP
6}
7
9f1b1f2d 8use warnings;
69e7dc3c 9use vars qw{ @warnings $fagwoosh $putt $kloong};
54310121
PP
10BEGIN { # ...and save 'em for later
11 $SIG{'__WARN__'} = sub { push @warnings, @_ }
12}
803b07a7 13END { print STDERR @warnings }
54310121 14
54310121
PP
15
16use strict;
69e7dc3c 17use Test::More tests => 95;
10a0e555
HS
18my $TB = Test::More->builder;
19
20BEGIN { use_ok('constant'); }
54310121 21
54310121
PP
22use constant PI => 4 * atan2 1, 1;
23
10a0e555
HS
24ok defined PI, 'basic scalar constant';
25is substr(PI, 0, 7), '3.14159', ' in substr()';
54310121
PP
26
27sub deg2rad { PI * $_[0] / 180 }
28
29my $ninety = deg2rad 90;
30
10a0e555 31cmp_ok abs($ninety - 1.5707), '<', 0.0001, ' in math expression';
54310121
PP
32
33use constant UNDEF1 => undef; # the right way
34use constant UNDEF2 => ; # the weird way
35use constant 'UNDEF3' ; # the 'short' way
36use constant EMPTY => ( ) ; # the right way for lists
37
10a0e555
HS
38is UNDEF1, undef, 'right way to declare an undef';
39is UNDEF2, undef, ' weird way';
40is UNDEF3, undef, ' short way';
41
42# XXX Why is this way different than the other ones?
54310121 43my @undef = UNDEF1;
10a0e555
HS
44is @undef, 1;
45is $undef[0], undef;
46
54310121 47@undef = UNDEF2;
10a0e555 48is @undef, 0;
54310121 49@undef = UNDEF3;
10a0e555 50is @undef, 0;
54310121 51@undef = EMPTY;
10a0e555 52is @undef, 0;
54310121
PP
53
54use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5;
55use constant COUNTLIST => reverse 1, 2, 3, 4, 5;
56use constant COUNTLAST => (COUNTLIST)[-1];
57
10a0e555 58is COUNTDOWN, '54321';
54310121 59my @cl = COUNTLIST;
10a0e555
HS
60is @cl, 5;
61is COUNTDOWN, join '', @cl;
62is COUNTLAST, 1;
63is((COUNTLIST)[1], 4);
54310121
PP
64
65use constant ABC => 'ABC';
10a0e555 66is "abc${\( ABC )}abc", "abcABCabc";
54310121 67
9d116dd7 68use constant DEF => 'D', 'E', chr ord 'F';
10a0e555 69is "d e f @{[ DEF ]} d e f", "d e f D E F d e f";
54310121
PP
70
71use constant SINGLE => "'";
72use constant DOUBLE => '"';
73use constant BACK => '\\';
74my $tt = BACK . SINGLE . DOUBLE ;
10a0e555 75is $tt, q(\\'");
54310121
PP
76
77use constant MESS => q('"'\\"'"\\);
10a0e555
HS
78is MESS, q('"'\\"'"\\);
79is length(MESS), 8;
54310121
PP
80
81use constant TRAILING => '12 cats';
82{
d3a7d8c7 83 no warnings 'numeric';
10a0e555 84 cmp_ok TRAILING, '==', 12;
54310121 85}
10a0e555 86is TRAILING, '12 cats';
54310121 87
c1b0f331 88use constant LEADING => " \t1234";
10a0e555
HS
89cmp_ok LEADING, '==', 1234;
90is LEADING, " \t1234";
54310121
PP
91
92use constant ZERO1 => 0;
93use constant ZERO2 => 0.0;
94use constant ZERO3 => '0.0';
10a0e555
HS
95is ZERO1, '0';
96is ZERO2, '0';
97is ZERO3, '0.0';
54310121
PP
98
99{
100 package Other;
101 use constant PI => 3.141;
102}
103
10a0e555
HS
104cmp_ok(abs(PI - 3.1416), '<', 0.0001);
105is Other::PI, 3.141;
54310121
PP
106
107use constant E2BIG => $! = 7;
10a0e555 108cmp_ok E2BIG, '==', 7;
54310121
PP
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.
10a0e555 111cmp_ok length(E2BIG), '>', 6;
54310121 112
10a0e555 113is @warnings, 0 or diag join "\n", "unexpected warning", @warnings;
54310121
PP
114@warnings = (); # just in case
115undef &PI;
10a0e555
HS
116ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or
117 diag join "\n", "unexpected warning", @warnings;
118shift @warnings;
54310121 119
10a0e555 120is @warnings, 0, "unexpected warning";
779c5bc9 121
10a0e555
HS
122my $curr_test = $TB->current_test;
123use constant CSCALAR => \"ok 37\n";
124use constant CHASH => { foo => "ok 38\n" };
125use constant CARRAY => [ undef, "ok 39\n" ];
779c5bc9
GS
126use constant CCODE => sub { "ok $_[0]\n" };
127
128print ${+CSCALAR};
129print CHASH->{foo};
130print CARRAY->[1];
10a0e555
HS
131print CCODE->($curr_test+4);
132
133$TB->current_test($curr_test+4);
134
779c5bc9 135eval q{ CCODE->{foo} };
10a0e555
HS
136ok scalar($@ =~ /^Constant is not a HASH/);
137
83763826
GS
138
139# Allow leading underscore
140use constant _PRIVATE => 47;
10a0e555 141is _PRIVATE, 47;
83763826
GS
142
143# Disallow doubled leading underscore
144eval q{
145 use constant __DISALLOWED => "Oops";
146};
10a0e555 147like $@, qr/begins with '__'/;
83763826
GS
148
149# Check on declared() and %declared. This sub should be EXACTLY the
150# same as the one quoted in the docs!
151sub 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
10a0e555
HS
160ok declared 'PI';
161ok $constant::declared{'main::PI'};
83763826 162
10a0e555
HS
163ok !declared 'PIE';
164ok !$constant::declared{'main::PIE'};
83763826
GS
165
166{
167 package Other;
168 use constant IN_OTHER_PACK => 42;
10a0e555
HS
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'};
83763826
GS
173}
174
10a0e555
HS
175ok declared 'Other::IN_OTHER_PACK';
176ok $constant::declared{'Other::IN_OTHER_PACK'};
d3a7d8c7
GS
177
178@warnings = ();
179eval q{
9f1b1f2d 180 no warnings;
d3a7d8c7
GS
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 ;
d3a7d8c7
GS
196};
197
10a0e555
HS
198is @warnings, 15 ;
199my @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);
217for my $idx (0..$#warnings) {
218 like $warnings[$idx], $Expected_Warnings[$idx];
219}
d3a7d8c7 220@warnings = ();
c7206c54
CT
221
222
223use 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 },
c7206c54
CT
229};
230
10a0e555
HS
231is @{+FAMILY}, THREE;
232is @{+FAMILY}, @{RFAM->[0]};
233is FAMILY->[2], RFAM->[0]->[2];
234is AGES->{FAMILY->[1]}, 28;
235is THREE**3, SPIT->(@{+FAMILY}**3);
5b673cda
AS
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}
69e7dc3c
NC
245
246sub 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
260sub 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}