1#!./perl -T 2 3use warnings; 4use vars qw{ @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 => 105; 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 95use constant E2BIG => $! = 7; 96cmp_ok E2BIG, '==', 7; 97# This is something like "Arg list too long", but the actual message 98# text may vary, so we can't test much better than this. 99cmp_ok length(E2BIG), '>', 6; 100 101is @warnings, 0 or diag join "\n- ", "unexpected warning:", @warnings; 102@warnings = (); # just in case 103undef &PI; 104ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or 105 diag join "\n", "unexpected warning", @warnings; 106shift @warnings; 107 108is @warnings, 0, "unexpected warning"; 109 110my $curr_test = $TB->current_test; 111use constant CSCALAR => \"ok 35\n"; 112use constant CHASH => { foo => "ok 36\n" }; 113use constant CARRAY => [ undef, "ok 37\n" ]; 114use constant CCODE => sub { "ok $_[0]\n" }; 115 116my $output = $TB->output ; 117print $output ${+CSCALAR}; 118print $output CHASH->{foo}; 119print $output CARRAY->[1]; 120print $output CCODE->($curr_test+4); 121 122$TB->current_test($curr_test+4); 123 124eval q{ CCODE->{foo} }; 125ok scalar($@ =~ /^Constant is not a HASH/); 126 127 128# Allow leading underscore 129use constant _PRIVATE => 47; 130is _PRIVATE, 47; 131 132# Disallow doubled leading underscore 133eval q{ 134 use constant __DISALLOWED => "Oops"; 135}; 136like $@, qr/begins with '__'/; 137 138# Check on declared() and %declared. This sub should be EXACTLY the 139# same as the one quoted in the docs! 140sub declared ($) { 141 use constant 1.01; # don't omit this! 142 my $name = shift; 143 $name =~ s/^::/main::/; 144 my $pkg = caller; 145 my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; 146 $constant::declared{$full_name}; 147} 148 149ok declared 'PI'; 150ok $constant::declared{'main::PI'}; 151 152ok !declared 'PIE'; 153ok !$constant::declared{'main::PIE'}; 154 155{ 156 package Other; 157 use constant IN_OTHER_PACK => 42; 158 ::ok ::declared 'IN_OTHER_PACK'; 159 ::ok $constant::declared{'Other::IN_OTHER_PACK'}; 160 ::ok ::declared 'main::PI'; 161 ::ok $constant::declared{'main::PI'}; 162} 163 164ok declared 'Other::IN_OTHER_PACK'; 165ok $constant::declared{'Other::IN_OTHER_PACK'}; 166 167@warnings = (); 168eval q{ 169 no warnings; 170 use warnings 'constant'; 171 use constant 'BEGIN' => 1 ; 172 use constant 'INIT' => 1 ; 173 use constant 'CHECK' => 1 ; 174 use constant 'END' => 1 ; 175 use constant 'DESTROY' => 1 ; 176 use constant 'AUTOLOAD' => 1 ; 177 use constant 'STDIN' => 1 ; 178 use constant 'STDOUT' => 1 ; 179 use constant 'STDERR' => 1 ; 180 use constant 'ARGV' => 1 ; 181 use constant 'ARGVOUT' => 1 ; 182 use constant 'ENV' => 1 ; 183 use constant 'INC' => 1 ; 184 use constant 'SIG' => 1 ; 185 use constant 'UNITCHECK' => 1; 186}; 187 188my @Expected_Warnings = 189 ( 190 qr/^Constant name 'BEGIN' is a Perl keyword at/, 191 qr/^Constant subroutine BEGIN redefined at/, 192 qr/^Constant name 'INIT' is a Perl keyword at/, 193 qr/^Constant name 'CHECK' is a Perl keyword at/, 194 qr/^Constant name 'END' is a Perl keyword at/, 195 qr/^Constant name 'DESTROY' is a Perl keyword at/, 196 qr/^Constant name 'AUTOLOAD' is a Perl keyword at/, 197 qr/^Constant name 'STDIN' is forced into package main:: a/, 198 qr/^Constant name 'STDOUT' is forced into package main:: at/, 199 qr/^Constant name 'STDERR' is forced into package main:: at/, 200 qr/^Constant name 'ARGV' is forced into package main:: at/, 201 qr/^Constant name 'ARGVOUT' is forced into package main:: at/, 202 qr/^Constant name 'ENV' is forced into package main:: at/, 203 qr/^Constant name 'INC' is forced into package main:: at/, 204 qr/^Constant name 'SIG' is forced into package main:: at/, 205 qr/^Constant name 'UNITCHECK' is a Perl keyword at/, 206); 207 208unless ($] > 5.009) { 209 # Remove the UNITCHECK warning 210 pop @Expected_Warnings; 211 # But keep the count the same 212 push @Expected_Warnings, qr/^$/; 213 push @warnings, ""; 214} 215 216# when run under "make test" 217if (@warnings == 16) { 218 push @warnings, ""; 219 push @Expected_Warnings, qr/^$/; 220} 221# when run directly: perl -wT -Ilib t/constant.t 222elsif (@warnings == 17) { 223 splice @Expected_Warnings, 1, 0, 224 qr/^Prototype mismatch: sub main::BEGIN \(\) vs none at/; 225} 226# when run directly under 5.6.2: perl -wT -Ilib t/constant.t 227elsif (@warnings == 15) { 228 splice @Expected_Warnings, 1, 1; 229 push @warnings, "", ""; 230 push @Expected_Warnings, qr/^$/, qr/^$/; 231} 232else { 233 my $rule = " -" x 20; 234 diag "/!\\ unexpected case: ", scalar @warnings, " warnings\n$rule\n"; 235 diag map { " $_" } @warnings; 236 diag $rule, $/; 237} 238 239is @warnings, 17; 240 241for my $idx (0..$#warnings) { 242 like $warnings[$idx], $Expected_Warnings[$idx]; 243} 244 245@warnings = (); 246 247 248use constant { 249 THREE => 3, 250 FAMILY => [ qw( John Jane Sally ) ], 251 AGES => { John => 33, Jane => 28, Sally => 3 }, 252 RFAM => [ [ qw( John Jane Sally ) ] ], 253 SPIT => sub { shift }, 254}; 255 256is @{+FAMILY}, THREE; 257is @{+FAMILY}, @{RFAM->[0]}; 258is FAMILY->[2], RFAM->[0]->[2]; 259is AGES->{FAMILY->[1]}, 28; 260is THREE**3, SPIT->(@{+FAMILY}**3); 261 262# Allow name of digits/underscores only if it begins with underscore 263{ 264 use warnings FATAL => 'constant'; 265 eval q{ 266 use constant _1_2_3 => 'allowed'; 267 }; 268 ok( $@ eq '' ); 269} 270 271sub slotch (); 272 273{ 274 my @warnings; 275 local $SIG{'__WARN__'} = sub { push @warnings, @_ }; 276 eval 'use constant slotch => 3; 1' or die $@; 277 278 is ("@warnings", "", "No warnings if a prototype exists"); 279 280 my $value = eval 'slotch'; 281 is ($@, ''); 282 is ($value, 3); 283} 284 285sub zit; 286 287{ 288 my @warnings; 289 local $SIG{'__WARN__'} = sub { push @warnings, @_ }; 290 eval 'use constant zit => 4; 1' or die $@; 291 292 # empty prototypes are reported differently in different versions 293 my $no_proto = $] < 5.008004 ? "" : ": none"; 294 295 is(scalar @warnings, 1, "1 warning"); 296 like ($warnings[0], qr/^Prototype mismatch: sub main::zit$no_proto vs \(\)/, 297 "about the prototype mismatch"); 298 299 my $value = eval 'zit'; 300 is ($@, ''); 301 is ($value, 4); 302} 303 304$fagwoosh = 'geronimo'; 305$putt = 'leutwein'; 306$kloong = 'schlozhauer'; 307 308{ 309 my @warnings; 310 local $SIG{'__WARN__'} = sub { push @warnings, @_ }; 311 eval 'use constant fagwoosh => 5; 1' or die $@; 312 313 is ("@warnings", "", "No warnings if the typeglob exists already"); 314 315 my $value = eval 'fagwoosh'; 316 is ($@, ''); 317 is ($value, 5); 318 319 my @value = eval 'fagwoosh'; 320 is ($@, ''); 321 is_deeply (\@value, [5]); 322 323 eval 'use constant putt => 6, 7; 1' or die $@; 324 325 is ("@warnings", "", "No warnings if the typeglob exists already"); 326 327 @value = eval 'putt'; 328 is ($@, ''); 329 is_deeply (\@value, [6, 7]); 330 331 eval 'use constant "klong"; 1' or die $@; 332 333 is ("@warnings", "", "No warnings if the typeglob exists already"); 334 335 $value = eval 'klong'; 336 is ($@, ''); 337 is ($value, undef); 338 339 @value = eval 'klong'; 340 is ($@, ''); 341 is_deeply (\@value, []); 342} 343 344{ 345 local $SIG{'__WARN__'} = sub { die "WARNING: $_[0]" }; 346 eval 'use constant undef, 5; 1'; 347 like $@, qr/\ACan't use undef as constant name at /; 348} 349 350# Constants created by "use constant" should be read-only 351 352# This test will not test what we are trying to test if this glob entry 353# exists already, so test that, too. 354ok !exists $::{immutable}; 355eval q{ 356 use constant immutable => 23987423874; 357 for (immutable) { eval { $_ = 22 } } 358 like $@, qr/^Modification of a read-only value attempted at /, 359 'constant created in empty stash slot is immutable'; 360 eval { for (immutable) { ${\$_} = 432 } }; 361 SKIP: { 362 require Config; 363 if ($Config::Config{useithreads}) { 364 skip "fails under threads", 1 if $] < 5.019003; 365 } 366 like $@, qr/^Modification of a read-only value attempted at /, 367 '... and immutable through refgen, too'; 368 } 369}; 370() = \&{"immutable"}; # reify 371eval 'for (immutable) { $_ = 42 }'; 372like $@, qr/^Modification of a read-only value attempted at /, 373 '... and after reification'; 374 375# Use an existing stash element this time. 376# This next line is sufficient to trigger a different code path in 377# constant.pm. 378() = \%::existing_stash_entry; 379use constant existing_stash_entry => 23987423874; 380for (existing_stash_entry) { eval { $_ = 22 } } 381like $@, qr/^Modification of a read-only value attempted at /, 382 'constant created in existing stash slot is immutable'; 383eval { for (existing_stash_entry) { ${\$_} = 432 } }; 384SKIP: { 385 if ($Config::Config{useithreads}) { 386 skip "fails under threads", 1 if $] < 5.019003; 387 } 388 like $@, qr/^Modification of a read-only value attempted at /, 389 '... and immutable through refgen, too'; 390} 391 392# Test that list constants are also immutable. This only works under 393# 5.19.3 and later. 394SKIP: { 395 skip "fails under 5.19.2 and earlier", 3 if $] < 5.019003; 396 local $TODO = "disabled for now; breaks CPAN; see perl #119045"; 397 use constant constant_list => 1..2; 398 for (constant_list) { 399 my $num = $_; 400 eval { $_++ }; 401 like $@, qr/^Modification of a read-only value attempted at /, 402 "list constant has constant elements ($num)"; 403 } 404 undef $TODO; 405 # Whether values are modifiable or no, modifying them should not affect 406 # future return values. 407 my @values; 408 for(1..2) { 409 for ((constant_list)[0]) { 410 push @values, $_; 411 eval {$_++}; 412 } 413 } 414 is $values[1], $values[0], 415 'modifying list const elements does not affect future retavls'; 416} 417