Add a perlmini.o and perlmini.c akin to opmini.o and opmini.c, for ./miniperl
[perl.git] / lib / constant.t
1 #!./perl -T
2
3 BEGIN {
4     if ($ENV{PERL_CORE}) {
5         chdir 't' if -d 't';
6         @INC = '../lib';
7     }
8 }
9
10 use warnings;
11 use vars qw{ @warnings $fagwoosh $putt $kloong};
12 BEGIN {                         # ...and save 'em for later
13     $SIG{'__WARN__'} = sub { push @warnings, @_ }
14 }
15 END { @warnings && print STDERR join "\n- ", "accumulated warnings:", @warnings }
16
17
18 use strict;
19 use Test::More tests => 95;
20 my $TB = Test::More->builder;
21
22 BEGIN { use_ok('constant'); }
23
24 use constant PI         => 4 * atan2 1, 1;
25
26 ok defined PI,                          'basic scalar constant';
27 is substr(PI, 0, 7), '3.14159',         '    in substr()';
28
29 sub deg2rad { PI * $_[0] / 180 }
30
31 my $ninety = deg2rad 90;
32
33 cmp_ok abs($ninety - 1.5707), '<', 0.0001, '    in math expression';
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
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?
45 my @undef = UNDEF1;
46 is @undef, 1;
47 is $undef[0], undef;
48
49 @undef = UNDEF2;
50 is @undef, 0;
51 @undef = UNDEF3;
52 is @undef, 0;
53 @undef = EMPTY;
54 is @undef, 0;
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
60 is COUNTDOWN, '54321';
61 my @cl = COUNTLIST;
62 is @cl, 5;
63 is COUNTDOWN, join '', @cl;
64 is COUNTLAST, 1;
65 is((COUNTLIST)[1], 4);
66
67 use constant ABC        => 'ABC';
68 is "abc${\( ABC )}abc", "abcABCabc";
69
70 use constant DEF        => 'D', 'E', chr ord 'F';
71 is "d e f @{[ DEF ]} d e f", "d e f D E F d e f";
72
73 use constant SINGLE     => "'";
74 use constant DOUBLE     => '"';
75 use constant BACK       => '\\';
76 my $tt = BACK . SINGLE . DOUBLE ;
77 is $tt, q(\\'");
78
79 use constant MESS       => q('"'\\"'"\\);
80 is MESS, q('"'\\"'"\\);
81 is length(MESS), 8;
82
83 use constant LEADING    => " \t1234";
84 cmp_ok LEADING, '==', 1234;
85 is LEADING, " \t1234";
86
87 use constant ZERO1      => 0;
88 use constant ZERO2      => 0.0;
89 use constant ZERO3      => '0.0';
90 is ZERO1, '0';
91 is ZERO2, '0';
92 is ZERO3, '0.0';
93
94 {
95     package Other;
96     use constant PI     => 3.141;
97 }
98
99 cmp_ok(abs(PI - 3.1416), '<', 0.0001);
100 is Other::PI, 3.141;
101
102 use constant E2BIG => $! = 7;
103 cmp_ok E2BIG, '==', 7;
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.
106 cmp_ok length(E2BIG), '>', 6;
107
108 is @warnings, 0 or diag join "\n- ", "unexpected warning:", @warnings;
109 @warnings = ();         # just in case
110 undef &PI;
111 ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or
112   diag join "\n", "unexpected warning", @warnings;
113 shift @warnings;
114
115 is @warnings, 0, "unexpected warning";
116
117 my $curr_test = $TB->current_test;
118 use constant CSCALAR    => \"ok 35\n";
119 use constant CHASH      => { foo => "ok 36\n" };
120 use constant CARRAY     => [ undef, "ok 37\n" ];
121 use constant CCODE      => sub { "ok $_[0]\n" };
122
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);
128
129 $TB->current_test($curr_test+4);
130
131 eval q{ CCODE->{foo} };
132 ok scalar($@ =~ /^Constant is not a HASH/);
133
134
135 # Allow leading underscore
136 use constant _PRIVATE => 47;
137 is _PRIVATE, 47;
138
139 # Disallow doubled leading underscore
140 eval q{
141     use constant __DISALLOWED => "Oops";
142 };
143 like $@, qr/begins with '__'/;
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
156 ok declared 'PI';
157 ok $constant::declared{'main::PI'};
158
159 ok !declared 'PIE';
160 ok !$constant::declared{'main::PIE'};
161
162 {
163     package Other;
164     use constant IN_OTHER_PACK => 42;
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'};
169 }
170
171 ok declared 'Other::IN_OTHER_PACK';
172 ok $constant::declared{'Other::IN_OTHER_PACK'};
173
174 @warnings = ();
175 eval q{
176     no warnings;
177     #local $^W if $] < 5.006;
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 ;
193     use constant 'UNITCHECK' => 1;
194 };
195
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/,
213    qr/^Constant name 'UNITCHECK' is a Perl keyword at/,
214 );
215
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
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
249 for my $idx (0..$#warnings) {
250     like $warnings[$idx], $Expected_Warnings[$idx];
251 }
252
253 @warnings = ();
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 },
262 };
263
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);
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 }
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
300     # empty prototypes are reported differently in different versions
301     my $no_proto = $] < 5.008004 ? "" : ": none";
302
303     is(scalar @warnings, 1, "1 warning");
304     like ($warnings[0], qr/^Prototype mismatch: sub main::zit$no_proto vs \(\)/,
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 }