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