11 use vars qw{ @warnings $fagwoosh $putt $kloong};
12 BEGIN { # ...and save 'em for later
13 $SIG{'__WARN__'} = sub { push @warnings, @_ }
15 END { @warnings && print STDERR join "\n- ", "accumulated warnings:", @warnings }
19 use Test::More tests => 95;
20 my $TB = Test::More->builder;
22 BEGIN { use_ok('constant'); }
24 use constant PI => 4 * atan2 1, 1;
26 ok defined PI, 'basic scalar constant';
27 is substr(PI, 0, 7), '3.14159', ' in substr()';
29 sub deg2rad { PI * $_[0] / 180 }
31 my $ninety = deg2rad 90;
33 cmp_ok abs($ninety - 1.5707), '<', 0.0001, ' in math expression';
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
40 is UNDEF1, undef, 'right way to declare an undef';
41 is UNDEF2, undef, ' weird way';
42 is UNDEF3, undef, ' short way';
44 # XXX Why is this way different than the other ones?
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];
60 is COUNTDOWN, '54321';
63 is COUNTDOWN, join '', @cl;
65 is((COUNTLIST)[1], 4);
67 use constant ABC => 'ABC';
68 is "abc${\( ABC )}abc", "abcABCabc";
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";
73 use constant SINGLE => "'";
74 use constant DOUBLE => '"';
75 use constant BACK => '\\';
76 my $tt = BACK . SINGLE . DOUBLE ;
79 use constant MESS => q('"'\\"'"\\);
80 is MESS, q('"'\\"'"\\);
83 use constant LEADING => " \t1234";
84 cmp_ok LEADING, '==', 1234;
85 is LEADING, " \t1234";
87 use constant ZERO1 => 0;
88 use constant ZERO2 => 0.0;
89 use constant ZERO3 => '0.0';
96 use constant PI => 3.141;
99 cmp_ok(abs(PI - 3.1416), '<', 0.0001);
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;
108 is @warnings, 0 or diag join "\n- ", "unexpected warning:", @warnings;
109 @warnings = (); # just in case
111 ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or
112 diag join "\n", "unexpected warning", @warnings;
115 is @warnings, 0, "unexpected warning";
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" };
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);
129 $TB->current_test($curr_test+4);
131 eval q{ CCODE->{foo} };
132 ok scalar($@ =~ /^Constant is not a HASH/);
135 # Allow leading underscore
136 use constant _PRIVATE => 47;
139 # Disallow doubled leading underscore
141 use constant __DISALLOWED => "Oops";
143 like $@, qr/begins with '__'/;
145 # Check on declared() and %declared. This sub should be EXACTLY the
146 # same as the one quoted in the docs!
148 use constant 1.01; # don't omit this!
150 $name =~ s/^::/main::/;
152 my $full_name = $name =~ /::/ ? $name : "${pkg}::$name";
153 $constant::declared{$full_name};
157 ok $constant::declared{'main::PI'};
160 ok !$constant::declared{'main::PIE'};
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'};
171 ok declared 'Other::IN_OTHER_PACK';
172 ok $constant::declared{'Other::IN_OTHER_PACK'};
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;
196 my @Expected_Warnings =
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/,
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/^$/;
224 # when run under "make test"
225 if (@warnings == 16) {
227 push @Expected_Warnings, qr/^$/;
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/;
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/^$/;
241 my $rule = " -" x 20;
242 diag "/!\\ unexpected case: ", scalar @warnings, " warnings\n$rule\n";
243 diag map { " $_" } @warnings;
249 for my $idx (0..$#warnings) {
250 like $warnings[$idx], $Expected_Warnings[$idx];
258 FAMILY => [ qw( John Jane Sally ) ],
259 AGES => { John => 33, Jane => 28, Sally => 3 },
260 RFAM => [ [ qw( John Jane Sally ) ] ],
261 SPIT => sub { shift },
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);
270 # Allow name of digits/underscores only if it begins with underscore
272 use warnings FATAL => 'constant';
274 use constant _1_2_3 => 'allowed';
283 local $SIG{'__WARN__'} = sub { push @warnings, @_ };
284 eval 'use constant slotch => 3; 1' or die $@;
286 is ("@warnings", "", "No warnings if a prototype exists");
288 my $value = eval 'slotch';
297 local $SIG{'__WARN__'} = sub { push @warnings, @_ };
298 eval 'use constant zit => 4; 1' or die $@;
300 # empty prototypes are reported differently in different versions
301 my $no_proto = $] < 5.008004 ? "" : ": none";
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");
307 my $value = eval 'zit';
312 $fagwoosh = 'geronimo';
314 $kloong = 'schlozhauer';
318 local $SIG{'__WARN__'} = sub { push @warnings, @_ };
319 eval 'use constant fagwoosh => 5; 1' or die $@;
321 is ("@warnings", "", "No warnings if the typeglob exists already");
323 my $value = eval 'fagwoosh';
327 my @value = eval 'fagwoosh';
329 is_deeply (\@value, [5]);
331 eval 'use constant putt => 6, 7; 1' or die $@;
333 is ("@warnings", "", "No warnings if the typeglob exists already");
335 @value = eval 'putt';
337 is_deeply (\@value, [6, 7]);
339 eval 'use constant "klong"; 1' or die $@;
341 is ("@warnings", "", "No warnings if the typeglob exists already");
343 $value = eval 'klong';
347 @value = eval 'klong';
349 is_deeply (\@value, []);