| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 4 | chdir 't' if -d 't'; |
| 5 | @INC = '../lib'; |
| 6 | } |
| 7 | |
| 8 | use warnings; |
| 9 | use vars qw{ @warnings $fagwoosh $putt $kloong}; |
| 10 | BEGIN { # ...and save 'em for later |
| 11 | $SIG{'__WARN__'} = sub { push @warnings, @_ } |
| 12 | } |
| 13 | END { print STDERR @warnings } |
| 14 | |
| 15 | |
| 16 | use strict; |
| 17 | use Test::More tests => 95; |
| 18 | my $TB = Test::More->builder; |
| 19 | |
| 20 | BEGIN { use_ok('constant'); } |
| 21 | |
| 22 | use constant PI => 4 * atan2 1, 1; |
| 23 | |
| 24 | ok defined PI, 'basic scalar constant'; |
| 25 | is substr(PI, 0, 7), '3.14159', ' in substr()'; |
| 26 | |
| 27 | sub deg2rad { PI * $_[0] / 180 } |
| 28 | |
| 29 | my $ninety = deg2rad 90; |
| 30 | |
| 31 | cmp_ok abs($ninety - 1.5707), '<', 0.0001, ' in math expression'; |
| 32 | |
| 33 | use constant UNDEF1 => undef; # the right way |
| 34 | use constant UNDEF2 => ; # the weird way |
| 35 | use constant 'UNDEF3' ; # the 'short' way |
| 36 | use constant EMPTY => ( ) ; # the right way for lists |
| 37 | |
| 38 | is UNDEF1, undef, 'right way to declare an undef'; |
| 39 | is UNDEF2, undef, ' weird way'; |
| 40 | is UNDEF3, undef, ' short way'; |
| 41 | |
| 42 | # XXX Why is this way different than the other ones? |
| 43 | my @undef = UNDEF1; |
| 44 | is @undef, 1; |
| 45 | is $undef[0], undef; |
| 46 | |
| 47 | @undef = UNDEF2; |
| 48 | is @undef, 0; |
| 49 | @undef = UNDEF3; |
| 50 | is @undef, 0; |
| 51 | @undef = EMPTY; |
| 52 | is @undef, 0; |
| 53 | |
| 54 | use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5; |
| 55 | use constant COUNTLIST => reverse 1, 2, 3, 4, 5; |
| 56 | use constant COUNTLAST => (COUNTLIST)[-1]; |
| 57 | |
| 58 | is COUNTDOWN, '54321'; |
| 59 | my @cl = COUNTLIST; |
| 60 | is @cl, 5; |
| 61 | is COUNTDOWN, join '', @cl; |
| 62 | is COUNTLAST, 1; |
| 63 | is((COUNTLIST)[1], 4); |
| 64 | |
| 65 | use constant ABC => 'ABC'; |
| 66 | is "abc${\( ABC )}abc", "abcABCabc"; |
| 67 | |
| 68 | use constant DEF => 'D', 'E', chr ord 'F'; |
| 69 | is "d e f @{[ DEF ]} d e f", "d e f D E F d e f"; |
| 70 | |
| 71 | use constant SINGLE => "'"; |
| 72 | use constant DOUBLE => '"'; |
| 73 | use constant BACK => '\\'; |
| 74 | my $tt = BACK . SINGLE . DOUBLE ; |
| 75 | is $tt, q(\\'"); |
| 76 | |
| 77 | use constant MESS => q('"'\\"'"\\); |
| 78 | is MESS, q('"'\\"'"\\); |
| 79 | is length(MESS), 8; |
| 80 | |
| 81 | use constant TRAILING => '12 cats'; |
| 82 | { |
| 83 | no warnings 'numeric'; |
| 84 | cmp_ok TRAILING, '==', 12; |
| 85 | } |
| 86 | is TRAILING, '12 cats'; |
| 87 | |
| 88 | use constant LEADING => " \t1234"; |
| 89 | cmp_ok LEADING, '==', 1234; |
| 90 | is LEADING, " \t1234"; |
| 91 | |
| 92 | use constant ZERO1 => 0; |
| 93 | use constant ZERO2 => 0.0; |
| 94 | use constant ZERO3 => '0.0'; |
| 95 | is ZERO1, '0'; |
| 96 | is ZERO2, '0'; |
| 97 | is ZERO3, '0.0'; |
| 98 | |
| 99 | { |
| 100 | package Other; |
| 101 | use constant PI => 3.141; |
| 102 | } |
| 103 | |
| 104 | cmp_ok(abs(PI - 3.1416), '<', 0.0001); |
| 105 | is Other::PI, 3.141; |
| 106 | |
| 107 | use constant E2BIG => $! = 7; |
| 108 | cmp_ok E2BIG, '==', 7; |
| 109 | # This is something like "Arg list too long", but the actual message |
| 110 | # text may vary, so we can't test much better than this. |
| 111 | cmp_ok length(E2BIG), '>', 6; |
| 112 | |
| 113 | is @warnings, 0 or diag join "\n", "unexpected warning", @warnings; |
| 114 | @warnings = (); # just in case |
| 115 | undef &PI; |
| 116 | ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or |
| 117 | diag join "\n", "unexpected warning", @warnings; |
| 118 | shift @warnings; |
| 119 | |
| 120 | is @warnings, 0, "unexpected warning"; |
| 121 | |
| 122 | my $curr_test = $TB->current_test; |
| 123 | use constant CSCALAR => \"ok 37\n"; |
| 124 | use constant CHASH => { foo => "ok 38\n" }; |
| 125 | use constant CARRAY => [ undef, "ok 39\n" ]; |
| 126 | use constant CCODE => sub { "ok $_[0]\n" }; |
| 127 | |
| 128 | print ${+CSCALAR}; |
| 129 | print CHASH->{foo}; |
| 130 | print CARRAY->[1]; |
| 131 | print CCODE->($curr_test+4); |
| 132 | |
| 133 | $TB->current_test($curr_test+4); |
| 134 | |
| 135 | eval q{ CCODE->{foo} }; |
| 136 | ok scalar($@ =~ /^Constant is not a HASH/); |
| 137 | |
| 138 | |
| 139 | # Allow leading underscore |
| 140 | use constant _PRIVATE => 47; |
| 141 | is _PRIVATE, 47; |
| 142 | |
| 143 | # Disallow doubled leading underscore |
| 144 | eval q{ |
| 145 | use constant __DISALLOWED => "Oops"; |
| 146 | }; |
| 147 | like $@, qr/begins with '__'/; |
| 148 | |
| 149 | # Check on declared() and %declared. This sub should be EXACTLY the |
| 150 | # same as the one quoted in the docs! |
| 151 | sub declared ($) { |
| 152 | use constant 1.01; # don't omit this! |
| 153 | my $name = shift; |
| 154 | $name =~ s/^::/main::/; |
| 155 | my $pkg = caller; |
| 156 | my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; |
| 157 | $constant::declared{$full_name}; |
| 158 | } |
| 159 | |
| 160 | ok declared 'PI'; |
| 161 | ok $constant::declared{'main::PI'}; |
| 162 | |
| 163 | ok !declared 'PIE'; |
| 164 | ok !$constant::declared{'main::PIE'}; |
| 165 | |
| 166 | { |
| 167 | package Other; |
| 168 | use constant IN_OTHER_PACK => 42; |
| 169 | ::ok ::declared 'IN_OTHER_PACK'; |
| 170 | ::ok $constant::declared{'Other::IN_OTHER_PACK'}; |
| 171 | ::ok ::declared 'main::PI'; |
| 172 | ::ok $constant::declared{'main::PI'}; |
| 173 | } |
| 174 | |
| 175 | ok declared 'Other::IN_OTHER_PACK'; |
| 176 | ok $constant::declared{'Other::IN_OTHER_PACK'}; |
| 177 | |
| 178 | @warnings = (); |
| 179 | eval q{ |
| 180 | no warnings; |
| 181 | use warnings 'constant'; |
| 182 | use constant 'BEGIN' => 1 ; |
| 183 | use constant 'INIT' => 1 ; |
| 184 | use constant 'CHECK' => 1 ; |
| 185 | use constant 'END' => 1 ; |
| 186 | use constant 'DESTROY' => 1 ; |
| 187 | use constant 'AUTOLOAD' => 1 ; |
| 188 | use constant 'STDIN' => 1 ; |
| 189 | use constant 'STDOUT' => 1 ; |
| 190 | use constant 'STDERR' => 1 ; |
| 191 | use constant 'ARGV' => 1 ; |
| 192 | use constant 'ARGVOUT' => 1 ; |
| 193 | use constant 'ENV' => 1 ; |
| 194 | use constant 'INC' => 1 ; |
| 195 | use constant 'SIG' => 1 ; |
| 196 | }; |
| 197 | |
| 198 | is @warnings, 15 ; |
| 199 | my @Expected_Warnings = |
| 200 | ( |
| 201 | qr/^Constant name 'BEGIN' is a Perl keyword at/, |
| 202 | qr/^Constant subroutine BEGIN redefined at/, |
| 203 | qr/^Constant name 'INIT' is a Perl keyword at/, |
| 204 | qr/^Constant name 'CHECK' is a Perl keyword at/, |
| 205 | qr/^Constant name 'END' is a Perl keyword at/, |
| 206 | qr/^Constant name 'DESTROY' is a Perl keyword at/, |
| 207 | qr/^Constant name 'AUTOLOAD' is a Perl keyword at/, |
| 208 | qr/^Constant name 'STDIN' is forced into package main:: a/, |
| 209 | qr/^Constant name 'STDOUT' is forced into package main:: at/, |
| 210 | qr/^Constant name 'STDERR' is forced into package main:: at/, |
| 211 | qr/^Constant name 'ARGV' is forced into package main:: at/, |
| 212 | qr/^Constant name 'ARGVOUT' is forced into package main:: at/, |
| 213 | qr/^Constant name 'ENV' is forced into package main:: at/, |
| 214 | qr/^Constant name 'INC' is forced into package main:: at/, |
| 215 | qr/^Constant name 'SIG' is forced into package main:: at/, |
| 216 | ); |
| 217 | for my $idx (0..$#warnings) { |
| 218 | like $warnings[$idx], $Expected_Warnings[$idx]; |
| 219 | } |
| 220 | @warnings = (); |
| 221 | |
| 222 | |
| 223 | use constant { |
| 224 | THREE => 3, |
| 225 | FAMILY => [ qw( John Jane Sally ) ], |
| 226 | AGES => { John => 33, Jane => 28, Sally => 3 }, |
| 227 | RFAM => [ [ qw( John Jane Sally ) ] ], |
| 228 | SPIT => sub { shift }, |
| 229 | }; |
| 230 | |
| 231 | is @{+FAMILY}, THREE; |
| 232 | is @{+FAMILY}, @{RFAM->[0]}; |
| 233 | is FAMILY->[2], RFAM->[0]->[2]; |
| 234 | is AGES->{FAMILY->[1]}, 28; |
| 235 | is THREE**3, SPIT->(@{+FAMILY}**3); |
| 236 | |
| 237 | # Allow name of digits/underscores only if it begins with underscore |
| 238 | { |
| 239 | use warnings FATAL => 'constant'; |
| 240 | eval q{ |
| 241 | use constant _1_2_3 => 'allowed'; |
| 242 | }; |
| 243 | ok( $@ eq '' ); |
| 244 | } |
| 245 | |
| 246 | sub slotch (); |
| 247 | |
| 248 | { |
| 249 | my @warnings; |
| 250 | local $SIG{'__WARN__'} = sub { push @warnings, @_ }; |
| 251 | eval 'use constant slotch => 3; 1' or die $@; |
| 252 | |
| 253 | is ("@warnings", "", "No warnings if a prototype exists"); |
| 254 | |
| 255 | my $value = eval 'slotch'; |
| 256 | is ($@, ''); |
| 257 | is ($value, 3); |
| 258 | } |
| 259 | |
| 260 | sub zit; |
| 261 | |
| 262 | { |
| 263 | my @warnings; |
| 264 | local $SIG{'__WARN__'} = sub { push @warnings, @_ }; |
| 265 | eval 'use constant zit => 4; 1' or die $@; |
| 266 | |
| 267 | is(scalar @warnings, 1, "1 warning"); |
| 268 | like ($warnings[0], qr/^Prototype mismatch: sub main::zit: none vs \(\)/, |
| 269 | "about the prototype mismatch"); |
| 270 | |
| 271 | my $value = eval 'zit'; |
| 272 | is ($@, ''); |
| 273 | is ($value, 4); |
| 274 | } |
| 275 | |
| 276 | $fagwoosh = 'geronimo'; |
| 277 | $putt = 'leutwein'; |
| 278 | $kloong = 'schlozhauer'; |
| 279 | |
| 280 | { |
| 281 | my @warnings; |
| 282 | local $SIG{'__WARN__'} = sub { push @warnings, @_ }; |
| 283 | eval 'use constant fagwoosh => 5; 1' or die $@; |
| 284 | |
| 285 | is ("@warnings", "", "No warnings if the typeglob exists already"); |
| 286 | |
| 287 | my $value = eval 'fagwoosh'; |
| 288 | is ($@, ''); |
| 289 | is ($value, 5); |
| 290 | |
| 291 | my @value = eval 'fagwoosh'; |
| 292 | is ($@, ''); |
| 293 | is_deeply (\@value, [5]); |
| 294 | |
| 295 | eval 'use constant putt => 6, 7; 1' or die $@; |
| 296 | |
| 297 | is ("@warnings", "", "No warnings if the typeglob exists already"); |
| 298 | |
| 299 | @value = eval 'putt'; |
| 300 | is ($@, ''); |
| 301 | is_deeply (\@value, [6, 7]); |
| 302 | |
| 303 | eval 'use constant "klong"; 1' or die $@; |
| 304 | |
| 305 | is ("@warnings", "", "No warnings if the typeglob exists already"); |
| 306 | |
| 307 | $value = eval 'klong'; |
| 308 | is ($@, ''); |
| 309 | is ($value, undef); |
| 310 | |
| 311 | @value = eval 'klong'; |
| 312 | is ($@, ''); |
| 313 | is_deeply (\@value, []); |
| 314 | } |