| 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 { print STDERR @warnings } |
| 16 | |
| 17 | |
| 18 | use strict; |
| 19 | use Test::More tests => 97; |
| 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 TRAILING => '12 cats'; |
| 84 | { |
| 85 | local $^W; |
| 86 | cmp_ok TRAILING, '==', 12; |
| 87 | } |
| 88 | is TRAILING, '12 cats'; |
| 89 | |
| 90 | use constant LEADING => " \t1234"; |
| 91 | cmp_ok LEADING, '==', 1234; |
| 92 | is LEADING, " \t1234"; |
| 93 | |
| 94 | use constant ZERO1 => 0; |
| 95 | use constant ZERO2 => 0.0; |
| 96 | use constant ZERO3 => '0.0'; |
| 97 | is ZERO1, '0'; |
| 98 | is ZERO2, '0'; |
| 99 | is ZERO3, '0.0'; |
| 100 | |
| 101 | { |
| 102 | package Other; |
| 103 | use constant PI => 3.141; |
| 104 | } |
| 105 | |
| 106 | cmp_ok(abs(PI - 3.1416), '<', 0.0001); |
| 107 | is Other::PI, 3.141; |
| 108 | |
| 109 | use constant E2BIG => $! = 7; |
| 110 | cmp_ok E2BIG, '==', 7; |
| 111 | # This is something like "Arg list too long", but the actual message |
| 112 | # text may vary, so we can't test much better than this. |
| 113 | cmp_ok length(E2BIG), '>', 6; |
| 114 | |
| 115 | is @warnings, 0 or diag join "\n", "unexpected warning", @warnings; |
| 116 | @warnings = (); # just in case |
| 117 | undef &PI; |
| 118 | ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or |
| 119 | diag join "\n", "unexpected warning", @warnings; |
| 120 | shift @warnings; |
| 121 | |
| 122 | is @warnings, 0, "unexpected warning"; |
| 123 | |
| 124 | my $curr_test = $TB->current_test; |
| 125 | use constant CSCALAR => \"ok 37\n"; |
| 126 | use constant CHASH => { foo => "ok 38\n" }; |
| 127 | use constant CARRAY => [ undef, "ok 39\n" ]; |
| 128 | use constant CCODE => sub { "ok $_[0]\n" }; |
| 129 | |
| 130 | my $output = $TB->output ; |
| 131 | print $output ${+CSCALAR}; |
| 132 | print $output CHASH->{foo}; |
| 133 | print $output CARRAY->[1]; |
| 134 | print $output CCODE->($curr_test+4); |
| 135 | |
| 136 | $TB->current_test($curr_test+4); |
| 137 | |
| 138 | eval q{ CCODE->{foo} }; |
| 139 | ok scalar($@ =~ /^Constant is not a HASH/); |
| 140 | |
| 141 | |
| 142 | # Allow leading underscore |
| 143 | use constant _PRIVATE => 47; |
| 144 | is _PRIVATE, 47; |
| 145 | |
| 146 | # Disallow doubled leading underscore |
| 147 | eval q{ |
| 148 | use constant __DISALLOWED => "Oops"; |
| 149 | }; |
| 150 | like $@, qr/begins with '__'/; |
| 151 | |
| 152 | # Check on declared() and %declared. This sub should be EXACTLY the |
| 153 | # same as the one quoted in the docs! |
| 154 | sub declared ($) { |
| 155 | use constant 1.01; # don't omit this! |
| 156 | my $name = shift; |
| 157 | $name =~ s/^::/main::/; |
| 158 | my $pkg = caller; |
| 159 | my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; |
| 160 | $constant::declared{$full_name}; |
| 161 | } |
| 162 | |
| 163 | ok declared 'PI'; |
| 164 | ok $constant::declared{'main::PI'}; |
| 165 | |
| 166 | ok !declared 'PIE'; |
| 167 | ok !$constant::declared{'main::PIE'}; |
| 168 | |
| 169 | { |
| 170 | package Other; |
| 171 | use constant IN_OTHER_PACK => 42; |
| 172 | ::ok ::declared 'IN_OTHER_PACK'; |
| 173 | ::ok $constant::declared{'Other::IN_OTHER_PACK'}; |
| 174 | ::ok ::declared 'main::PI'; |
| 175 | ::ok $constant::declared{'main::PI'}; |
| 176 | } |
| 177 | |
| 178 | ok declared 'Other::IN_OTHER_PACK'; |
| 179 | ok $constant::declared{'Other::IN_OTHER_PACK'}; |
| 180 | |
| 181 | @warnings = (); |
| 182 | eval q{ |
| 183 | no warnings; |
| 184 | #local $^W if $] < 5.006; |
| 185 | use warnings 'constant'; |
| 186 | use constant 'BEGIN' => 1 ; |
| 187 | use constant 'INIT' => 1 ; |
| 188 | use constant 'CHECK' => 1 ; |
| 189 | use constant 'END' => 1 ; |
| 190 | use constant 'DESTROY' => 1 ; |
| 191 | use constant 'AUTOLOAD' => 1 ; |
| 192 | use constant 'STDIN' => 1 ; |
| 193 | use constant 'STDOUT' => 1 ; |
| 194 | use constant 'STDERR' => 1 ; |
| 195 | use constant 'ARGV' => 1 ; |
| 196 | use constant 'ARGVOUT' => 1 ; |
| 197 | use constant 'ENV' => 1 ; |
| 198 | use constant 'INC' => 1 ; |
| 199 | use constant 'SIG' => 1 ; |
| 200 | use constant 'UNITCHECK' => 1; |
| 201 | }; |
| 202 | |
| 203 | my @Expected_Warnings = |
| 204 | ( |
| 205 | qr/^Constant name 'BEGIN' is a Perl keyword at/, |
| 206 | qr/^Constant subroutine BEGIN redefined at/, |
| 207 | qr/^Constant name 'INIT' is a Perl keyword at/, |
| 208 | qr/^Constant name 'CHECK' is a Perl keyword at/, |
| 209 | qr/^Constant name 'END' is a Perl keyword at/, |
| 210 | qr/^Constant name 'DESTROY' is a Perl keyword at/, |
| 211 | qr/^Constant name 'AUTOLOAD' is a Perl keyword at/, |
| 212 | qr/^Constant name 'STDIN' is forced into package main:: a/, |
| 213 | qr/^Constant name 'STDOUT' is forced into package main:: at/, |
| 214 | qr/^Constant name 'STDERR' is forced into package main:: at/, |
| 215 | qr/^Constant name 'ARGV' is forced into package main:: at/, |
| 216 | qr/^Constant name 'ARGVOUT' is forced into package main:: at/, |
| 217 | qr/^Constant name 'ENV' is forced into package main:: at/, |
| 218 | qr/^Constant name 'INC' is forced into package main:: at/, |
| 219 | qr/^Constant name 'SIG' is forced into package main:: at/, |
| 220 | qr/^Constant name 'UNITCHECK' is a Perl keyword at/, |
| 221 | ); |
| 222 | |
| 223 | unless ($] > 5.009) { |
| 224 | # Remove the UNITCHECK warning |
| 225 | pop @Expected_Warnings; |
| 226 | # But keep the count the same |
| 227 | push @Expected_Warnings, qr/^$/; |
| 228 | push @warnings, ""; |
| 229 | } |
| 230 | |
| 231 | # when run under "make test" |
| 232 | if (@warnings == 16) { |
| 233 | push @warnings, ""; |
| 234 | push @Expected_Warnings, qr/^$/; |
| 235 | } |
| 236 | # when run directly: perl -wT -Ilib t/constant.t |
| 237 | elsif (@warnings == 17) { |
| 238 | splice @Expected_Warnings, 1, 0, |
| 239 | qr/^Prototype mismatch: sub main::BEGIN \(\) vs none at/; |
| 240 | } |
| 241 | # when run directly under 5.6.2: perl -wT -Ilib t/constant.t |
| 242 | elsif (@warnings == 15) { |
| 243 | splice @Expected_Warnings, 1, 1; |
| 244 | push @warnings, "", ""; |
| 245 | push @Expected_Warnings, qr/^$/, qr/^$/; |
| 246 | } |
| 247 | else { |
| 248 | my $rule = " -" x 20; |
| 249 | diag "/!\\ unexpected case: ", scalar @warnings, " warnings\n$rule\n"; |
| 250 | diag map { " $_" } @warnings; |
| 251 | diag $rule, $/; |
| 252 | } |
| 253 | |
| 254 | is @warnings, 17; |
| 255 | |
| 256 | for my $idx (0..$#warnings) { |
| 257 | like $warnings[$idx], $Expected_Warnings[$idx]; |
| 258 | } |
| 259 | |
| 260 | @warnings = (); |
| 261 | |
| 262 | |
| 263 | use constant { |
| 264 | THREE => 3, |
| 265 | FAMILY => [ qw( John Jane Sally ) ], |
| 266 | AGES => { John => 33, Jane => 28, Sally => 3 }, |
| 267 | RFAM => [ [ qw( John Jane Sally ) ] ], |
| 268 | SPIT => sub { shift }, |
| 269 | }; |
| 270 | |
| 271 | is @{+FAMILY}, THREE; |
| 272 | is @{+FAMILY}, @{RFAM->[0]}; |
| 273 | is FAMILY->[2], RFAM->[0]->[2]; |
| 274 | is AGES->{FAMILY->[1]}, 28; |
| 275 | is THREE**3, SPIT->(@{+FAMILY}**3); |
| 276 | |
| 277 | # Allow name of digits/underscores only if it begins with underscore |
| 278 | { |
| 279 | use warnings FATAL => 'constant'; |
| 280 | eval q{ |
| 281 | use constant _1_2_3 => 'allowed'; |
| 282 | }; |
| 283 | ok( $@ eq '' ); |
| 284 | } |
| 285 | |
| 286 | sub slotch (); |
| 287 | |
| 288 | { |
| 289 | my @warnings; |
| 290 | local $SIG{'__WARN__'} = sub { push @warnings, @_ }; |
| 291 | eval 'use constant slotch => 3; 1' or die $@; |
| 292 | |
| 293 | is ("@warnings", "", "No warnings if a prototype exists"); |
| 294 | |
| 295 | my $value = eval 'slotch'; |
| 296 | is ($@, ''); |
| 297 | is ($value, 3); |
| 298 | } |
| 299 | |
| 300 | sub zit; |
| 301 | |
| 302 | { |
| 303 | my @warnings; |
| 304 | local $SIG{'__WARN__'} = sub { push @warnings, @_ }; |
| 305 | eval 'use constant zit => 4; 1' or die $@; |
| 306 | |
| 307 | # empty prototypes are reported differently in different versions |
| 308 | my $no_proto = $] < 5.008004 ? "" : ": none"; |
| 309 | |
| 310 | is(scalar @warnings, 1, "1 warning"); |
| 311 | like ($warnings[0], qr/^Prototype mismatch: sub main::zit$no_proto vs \(\)/, |
| 312 | "about the prototype mismatch"); |
| 313 | |
| 314 | my $value = eval 'zit'; |
| 315 | is ($@, ''); |
| 316 | is ($value, 4); |
| 317 | } |
| 318 | |
| 319 | $fagwoosh = 'geronimo'; |
| 320 | $putt = 'leutwein'; |
| 321 | $kloong = 'schlozhauer'; |
| 322 | |
| 323 | { |
| 324 | my @warnings; |
| 325 | local $SIG{'__WARN__'} = sub { push @warnings, @_ }; |
| 326 | eval 'use constant fagwoosh => 5; 1' or die $@; |
| 327 | |
| 328 | is ("@warnings", "", "No warnings if the typeglob exists already"); |
| 329 | |
| 330 | my $value = eval 'fagwoosh'; |
| 331 | is ($@, ''); |
| 332 | is ($value, 5); |
| 333 | |
| 334 | my @value = eval 'fagwoosh'; |
| 335 | is ($@, ''); |
| 336 | is_deeply (\@value, [5]); |
| 337 | |
| 338 | eval 'use constant putt => 6, 7; 1' or die $@; |
| 339 | |
| 340 | is ("@warnings", "", "No warnings if the typeglob exists already"); |
| 341 | |
| 342 | @value = eval 'putt'; |
| 343 | is ($@, ''); |
| 344 | is_deeply (\@value, [6, 7]); |
| 345 | |
| 346 | eval 'use constant "klong"; 1' or die $@; |
| 347 | |
| 348 | is ("@warnings", "", "No warnings if the typeglob exists already"); |
| 349 | |
| 350 | $value = eval 'klong'; |
| 351 | is ($@, ''); |
| 352 | is ($value, undef); |
| 353 | |
| 354 | @value = eval 'klong'; |
| 355 | is ($@, ''); |
| 356 | is_deeply (\@value, []); |
| 357 | } |