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