1#!./perl -T 2 3use warnings; 4our ( @warnings, $fagwoosh, $putt, $kloong ); 5BEGIN { # ...and save 'em for later 6 $SIG{'__WARN__'} = sub { push @warnings, @_ } 7} 8END { @warnings && print STDERR join "\n- ", "accumulated warnings:", @warnings } 9 10 11use strict; 12use Test::More tests => 109; 13my $TB = Test::More->builder; 14 15BEGIN { use_ok('constant'); } 16 17use constant PI => 4 * atan2 1, 1; 18 19ok defined PI, 'basic scalar constant'; 20is substr(PI, 0, 7), '3.14159', ' in substr()'; 21 22sub deg2rad { PI * $_[0] / 180 } 23 24my $ninety = deg2rad 90; 25 26cmp_ok abs($ninety - 1.5707), '<', 0.0001, ' in math expression'; 27 28use constant UNDEF1 => undef; # the right way 29use constant UNDEF2 => ; # the weird way 30use constant 'UNDEF3' ; # the 'short' way 31use constant EMPTY => ( ) ; # the right way for lists 32 33is UNDEF1, undef, 'right way to declare an undef'; 34is UNDEF2, undef, ' weird way'; 35is UNDEF3, undef, ' short way'; 36 37# XXX Why is this way different than the other ones? 38my @undef = UNDEF1; 39is @undef, 1; 40is $undef[0], undef; 41 42@undef = UNDEF2; 43is @undef, 0; 44@undef = UNDEF3; 45is @undef, 0; 46@undef = EMPTY; 47is @undef, 0; 48 49use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5; 50use constant COUNTLIST => reverse 1, 2, 3, 4, 5; 51use constant COUNTLAST => (COUNTLIST)[-1]; 52 53is COUNTDOWN, '54321'; 54my @cl = COUNTLIST; 55is @cl, 5; 56is COUNTDOWN, join '', @cl; 57is COUNTLAST, 1; 58is((COUNTLIST)[1], 4); 59 60use constant ABC => 'ABC'; 61is "abc${\( ABC )}abc", "abcABCabc"; 62 63use constant DEF => 'D', 'E', chr ord 'F'; 64is "d e f @{[ DEF ]} d e f", "d e f D E F d e f"; 65 66use constant SINGLE => "'"; 67use constant DOUBLE => '"'; 68use constant BACK => '\\'; 69my $tt = BACK . SINGLE . DOUBLE ; 70is $tt, q(\\'"); 71 72use constant MESS => q('"'\\"'"\\); 73is MESS, q('"'\\"'"\\); 74is length(MESS), 8; 75 76use constant LEADING => " \t1234"; 77cmp_ok LEADING, '==', 1234; 78is LEADING, " \t1234"; 79 80use constant ZERO1 => 0; 81use constant ZERO2 => 0.0; 82use constant ZERO3 => '0.0'; 83is ZERO1, '0'; 84is ZERO2, '0'; 85is ZERO3, '0.0'; 86 87{ 88 package Other; 89 use constant PI => 3.141; 90} 91 92cmp_ok(abs(PI - 3.1416), '<', 0.0001); 93is Other::PI, 3.141; 94 95# Test that constant.pm can create a dualvar out of $! 96use constant A_DUALVAR_CONSTANT => $! = 7; 97cmp_ok A_DUALVAR_CONSTANT, '==', 7; 98# Make sure we have an error message string. It does not 99# matter that 7 means different things on different platforms. 100# If this test fails, then either constant.pm or $! is broken: 101cmp_ok length(A_DUALVAR_CONSTANT), '>', 6; 102 103is @warnings, 0 or diag join "\n- ", "unexpected warning:", @warnings; 104@warnings = (); # just in case 105undef &PI; 106ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or 107 diag join "\n", "unexpected warning", @warnings; 108shift @warnings; 109 110is @warnings, 0, "unexpected warning"; 111 112my $curr_test = $TB->current_test; 113use constant CSCALAR => \"ok 35\n"; 114use constant CHASH => { foo => "ok 36\n" }; 115use constant CARRAY => [ undef, "ok 37\n" ]; 116use constant CCODE => sub { "ok $_[0]\n" }; 117 118my $output = $TB->output ; 119print $output ${+CSCALAR}; 120print $output CHASH->{foo}; 121print $output CARRAY->[1]; 122print $output CCODE->($curr_test+4); 123 124$TB->current_test($curr_test+4); 125 126eval q{ CCODE->{foo} }; 127ok scalar($@ =~ /^Constant is not a HASH|Not a HASH reference/); 128 129 130# Allow leading underscore 131use constant _PRIVATE => 47; 132is _PRIVATE, 47; 133 134# Disallow doubled leading underscore 135eval q{ 136 use constant __DISALLOWED => "Oops"; 137}; 138like $@, qr/begins with '__'/; 139 140# Check on declared() and %declared. This sub should be EXACTLY the 141# same as the one quoted in the docs! 142sub declared ($) { 143 use constant 1.01; # don't omit this! 144 my $name = shift; 145 $name =~ s/^::/main::/; 146 my $pkg = caller; 147 my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; 148 $constant::declared{$full_name}; 149} 150 151ok declared 'PI'; 152ok $constant::declared{'main::PI'}; 153 154ok !declared 'PIE'; 155ok !$constant::declared{'main::PIE'}; 156 157{ 158 package Other; 159 use constant IN_OTHER_PACK => 42; 160 ::ok ::declared 'IN_OTHER_PACK'; 161 ::ok $constant::declared{'Other::IN_OTHER_PACK'}; 162 ::ok ::declared 'main::PI'; 163 ::ok $constant::declared{'main::PI'}; 164} 165 166ok declared 'Other::IN_OTHER_PACK'; 167ok $constant::declared{'Other::IN_OTHER_PACK'}; 168 169@warnings = (); 170eval q{ 171 no warnings; 172 use warnings 'constant'; 173 use constant 'BEGIN' => 1 ; 174 use constant 'INIT' => 1 ; 175 use constant 'CHECK' => 1 ; 176 use constant 'END' => 1 ; 177 use constant 'DESTROY' => 1 ; 178 use constant 'AUTOLOAD' => 1 ; 179 use constant 'STDIN' => 1 ; 180 use constant 'STDOUT' => 1 ; 181 use constant 'STDERR' => 1 ; 182 use constant 'ARGV' => 1 ; 183 use constant 'ARGVOUT' => 1 ; 184 use constant 'ENV' => 1 ; 185 use constant 'INC' => 1 ; 186 use constant 'SIG' => 1 ; 187 use constant 'UNITCHECK' => 1; 188}; 189 190my @Expected_Warnings = 191 ( 192 qr/^Constant name 'BEGIN' is a Perl keyword at/, 193 qr/^Constant subroutine BEGIN redefined at/, 194 qr/^Constant name 'INIT' is a Perl keyword at/, 195 qr/^Constant name 'CHECK' is a Perl keyword at/, 196 qr/^Constant name 'END' is a Perl keyword at/, 197 qr/^Constant name 'DESTROY' is a Perl keyword at/, 198 qr/^Constant name 'AUTOLOAD' is a Perl keyword at/, 199 qr/^Constant name 'STDIN' is forced into package main:: a/, 200 qr/^Constant name 'STDOUT' is forced into package main:: at/, 201 qr/^Constant name 'STDERR' is forced into package main:: at/, 202 qr/^Constant name 'ARGV' is forced into package main:: at/, 203 qr/^Constant name 'ARGVOUT' is forced into package main:: at/, 204 qr/^Constant name 'ENV' is forced into package main:: at/, 205 qr/^Constant name 'INC' is forced into package main:: at/, 206 qr/^Constant name 'SIG' is forced into package main:: at/, 207 qr/^Constant name 'UNITCHECK' is a Perl keyword at/, 208); 209 210unless ($] > 5.009) { 211 # Remove the UNITCHECK warning 212 pop @Expected_Warnings; 213 # But keep the count the same 214 push @Expected_Warnings, qr/^$/; 215 push @warnings, ""; 216} 217 218# when run under "make test" 219if (@warnings == 16) { 220 push @warnings, ""; 221 push @Expected_Warnings, qr/^$/; 222} 223# when run directly: perl -wT -Ilib t/constant.t 224elsif (@warnings == 17) { 225 splice @Expected_Warnings, 1, 0, 226 qr/^Prototype mismatch: sub main::BEGIN \(\) vs none at/; 227} 228# when run directly under 5.6.2: perl -wT -Ilib t/constant.t 229elsif (@warnings == 15) { 230 splice @Expected_Warnings, 1, 1; 231 push @warnings, "", ""; 232 push @Expected_Warnings, qr/^$/, qr/^$/; 233} 234else { 235 my $rule = " -" x 20; 236 diag "/!\\ unexpected case: ", scalar @warnings, " warnings\n$rule\n"; 237 diag map { " $_" } @warnings; 238 diag $rule, $/; 239} 240 241is @warnings, 17; 242 243for my $idx (0..$#warnings) { 244 like $warnings[$idx], $Expected_Warnings[$idx]; 245} 246 247@warnings = (); 248 249 250use constant { 251 THREE => 3, 252 FAMILY => [ qw( John Jane Sally ) ], 253 AGES => { John => 33, Jane => 28, Sally => 3 }, 254 RFAM => [ [ qw( John Jane Sally ) ] ], 255 SPIT => sub { shift }, 256}; 257 258is @{+FAMILY}, THREE; 259is @{+FAMILY}, @{RFAM->[0]}; 260is FAMILY->[2], RFAM->[0]->[2]; 261is AGES->{FAMILY->[1]}, 28; 262is THREE**3, SPIT->(@{+FAMILY}**3); 263 264# Allow name of digits/underscores only if it begins with underscore 265{ 266 use warnings FATAL => 'constant'; 267 eval q{ 268 use constant _1_2_3 => 'allowed'; 269 }; 270 ok( $@ eq '' ); 271} 272 273sub slotch (); 274 275{ 276 my @warnings; 277 local $SIG{'__WARN__'} = sub { push @warnings, @_ }; 278 eval 'use constant slotch => 3; 1' or die $@; 279 280 is ("@warnings", "", "No warnings if a prototype exists"); 281 282 my $value = eval 'slotch'; 283 is ($@, ''); 284 is ($value, 3); 285} 286 287sub zit; 288 289{ 290 my @warnings; 291 local $SIG{'__WARN__'} = sub { push @warnings, @_ }; 292 eval 'use constant zit => 4; 1' or die $@; 293 294 # empty prototypes are reported differently in different versions 295 my $no_proto = $] < 5.008004 ? "" : ": none"; 296 297 is(scalar @warnings, 1, "1 warning"); 298 like ($warnings[0], qr/^Prototype mismatch: sub main::zit$no_proto vs \(\)/, 299 "about the prototype mismatch"); 300 301 my $value = eval 'zit'; 302 is ($@, ''); 303 is ($value, 4); 304} 305 306$fagwoosh = 'geronimo'; 307$putt = 'leutwein'; 308$kloong = 'schlozhauer'; 309 310{ 311 my @warnings; 312 local $SIG{'__WARN__'} = sub { push @warnings, @_ }; 313 eval 'use constant fagwoosh => 5; 1' or die $@; 314 315 is ("@warnings", "", "No warnings if the typeglob exists already"); 316 317 my $value = eval 'fagwoosh'; 318 is ($@, ''); 319 is ($value, 5); 320 321 my @value = eval 'fagwoosh'; 322 is ($@, ''); 323 is_deeply (\@value, [5]); 324 325 eval 'use constant putt => 6, 7; 1' or die $@; 326 327 is ("@warnings", "", "No warnings if the typeglob exists already"); 328 329 @value = eval 'putt'; 330 is ($@, ''); 331 is_deeply (\@value, [6, 7]); 332 333 eval 'use constant "klong"; 1' or die $@; 334 335 is ("@warnings", "", "No warnings if the typeglob exists already"); 336 337 $value = eval 'klong'; 338 is ($@, ''); 339 is ($value, undef); 340 341 @value = eval 'klong'; 342 is ($@, ''); 343 is_deeply (\@value, []); 344} 345 346{ 347 local $SIG{'__WARN__'} = sub { die "WARNING: $_[0]" }; 348 eval 'use constant undef, 5; 1'; 349 like $@, qr/\ACan't use undef as constant name at /; 350} 351 352# Constants created by "use constant" should be read-only 353 354# This test will not test what we are trying to test if this glob entry 355# exists already, so test that, too. 356ok !exists $::{immutable}; 357eval q{ 358 use constant immutable => 23987423874; 359 for (immutable) { eval { $_ = 22 } } 360 like $@, qr/^Modification of a read-only value attempted at /, 361 'constant created in empty stash slot is immutable'; 362 eval { for (immutable) { ${\$_} = 432 } }; 363 SKIP: { 364 require Config; 365 if ($Config::Config{useithreads}) { 366 skip "fails under threads", 1 if $] < 5.019003; 367 } 368 like $@, qr/^Modification of a read-only value attempted at /, 369 '... and immutable through refgen, too'; 370 } 371}; 372() = \&{"immutable"}; # reify 373eval 'for (immutable) { $_ = 42 }'; 374like $@, qr/^Modification of a read-only value attempted at /, 375 '... and after reification'; 376 377# Use an existing stash element this time. 378# This next line is sufficient to trigger a different code path in 379# constant.pm. 380() = \%::existing_stash_entry; 381use constant existing_stash_entry => 23987423874; 382for (existing_stash_entry) { eval { $_ = 22 } } 383like $@, qr/^Modification of a read-only value attempted at /, 384 'constant created in existing stash slot is immutable'; 385eval { for (existing_stash_entry) { ${\$_} = 432 } }; 386SKIP: { 387 if ($Config::Config{useithreads}) { 388 skip "fails under threads", 1 if $] < 5.019003; 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.3 and later. 396SKIP: { 397 skip "fails under 5.19.2 and earlier", 3 if $] < 5.019003; 398 local $TODO = "disabled for now; breaks CPAN; see perl #119045"; 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 undef $TODO; 407 # Whether values are modifiable or no, modifying them should not affect 408 # future return values. 409 my @values; 410 for(1..2) { 411 for ((constant_list)[0]) { 412 push @values, $_; 413 eval {$_++}; 414 } 415 } 416 is $values[1], $values[0], 417 'modifying list const elements does not affect future retavls'; 418} 419 420use constant { "tahi" => 1, "rua::rua" => 2, "toru'toru" => 3 }; 421use constant "wha::wha" => 4; 422is tahi, 1, 'unqualified constant declared with constants in other pkgs'; 423is rua::rua, 2, 'constant declared with ::'; 424is toru::toru, 3, "constant declared with '"; 425is wha::wha, 4, 'constant declared by itself with ::'; 426