| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 4 | chdir 't' if -d 't'; |
| 5 | @INC = '../lib'; |
| 6 | } |
| 7 | |
| 8 | use warnings; |
| 9 | use vars qw{ @warnings }; |
| 10 | BEGIN { # ...and save 'em for later |
| 11 | $SIG{'__WARN__'} = sub { push @warnings, @_ } |
| 12 | } |
| 13 | END { print @warnings } |
| 14 | |
| 15 | ######################### We start with some black magic to print on failure. |
| 16 | |
| 17 | BEGIN { $| = 1; print "1..82\n"; } |
| 18 | END {print "not ok 1\n" unless $loaded;} |
| 19 | use constant 1.01; |
| 20 | $loaded = 1; |
| 21 | #print "# Version: $constant::VERSION\n"; |
| 22 | print "ok 1\n"; |
| 23 | |
| 24 | ######################### End of black magic. |
| 25 | |
| 26 | use strict; |
| 27 | |
| 28 | sub 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 | |
| 40 | use constant PI => 4 * atan2 1, 1; |
| 41 | |
| 42 | test 2, substr(PI, 0, 7) eq '3.14159'; |
| 43 | test 3, defined PI; |
| 44 | |
| 45 | sub deg2rad { PI * $_[0] / 180 } |
| 46 | |
| 47 | my $ninety = deg2rad 90; |
| 48 | |
| 49 | test 4, $ninety > 1.5707; |
| 50 | test 5, $ninety < 1.5708; |
| 51 | |
| 52 | use constant UNDEF1 => undef; # the right way |
| 53 | use constant UNDEF2 => ; # the weird way |
| 54 | use constant 'UNDEF3' ; # the 'short' way |
| 55 | use constant EMPTY => ( ) ; # the right way for lists |
| 56 | |
| 57 | test 6, not defined UNDEF1; |
| 58 | test 7, not defined UNDEF2; |
| 59 | test 8, not defined UNDEF3; |
| 60 | my @undef = UNDEF1; |
| 61 | test 9, @undef == 1; |
| 62 | test 10, not defined $undef[0]; |
| 63 | @undef = UNDEF2; |
| 64 | test 11, @undef == 0; |
| 65 | @undef = UNDEF3; |
| 66 | test 12, @undef == 0; |
| 67 | @undef = EMPTY; |
| 68 | test 13, @undef == 0; |
| 69 | |
| 70 | use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5; |
| 71 | use constant COUNTLIST => reverse 1, 2, 3, 4, 5; |
| 72 | use constant COUNTLAST => (COUNTLIST)[-1]; |
| 73 | |
| 74 | test 14, COUNTDOWN eq '54321'; |
| 75 | my @cl = COUNTLIST; |
| 76 | test 15, @cl == 5; |
| 77 | test 16, COUNTDOWN eq join '', @cl; |
| 78 | test 17, COUNTLAST == 1; |
| 79 | test 18, (COUNTLIST)[1] == 4; |
| 80 | |
| 81 | use constant ABC => 'ABC'; |
| 82 | test 19, "abc${\( ABC )}abc" eq "abcABCabc"; |
| 83 | |
| 84 | use constant DEF => 'D', 'E', chr ord 'F'; |
| 85 | test 20, "d e f @{[ DEF ]} d e f" eq "d e f D E F d e f"; |
| 86 | |
| 87 | use constant SINGLE => "'"; |
| 88 | use constant DOUBLE => '"'; |
| 89 | use constant BACK => '\\'; |
| 90 | my $tt = BACK . SINGLE . DOUBLE ; |
| 91 | test 21, $tt eq q(\\'"); |
| 92 | |
| 93 | use constant MESS => q('"'\\"'"\\); |
| 94 | test 22, MESS eq q('"'\\"'"\\); |
| 95 | test 23, length(MESS) == 8; |
| 96 | |
| 97 | use constant TRAILING => '12 cats'; |
| 98 | { |
| 99 | no warnings 'numeric'; |
| 100 | test 24, TRAILING == 12; |
| 101 | } |
| 102 | test 25, TRAILING eq '12 cats'; |
| 103 | |
| 104 | use constant LEADING => " \t1234"; |
| 105 | test 26, LEADING == 1234; |
| 106 | test 27, LEADING eq " \t1234"; |
| 107 | |
| 108 | use constant ZERO1 => 0; |
| 109 | use constant ZERO2 => 0.0; |
| 110 | use constant ZERO3 => '0.0'; |
| 111 | test 28, ZERO1 eq '0'; |
| 112 | test 29, ZERO2 eq '0'; |
| 113 | test 30, ZERO3 eq '0.0'; |
| 114 | |
| 115 | { |
| 116 | package Other; |
| 117 | use constant PI => 3.141; |
| 118 | } |
| 119 | |
| 120 | test 31, (PI > 3.1415 and PI < 3.1416); |
| 121 | test 32, Other::PI == 3.141; |
| 122 | |
| 123 | use constant E2BIG => $! = 7; |
| 124 | test 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. |
| 127 | test 34, length(E2BIG) > 6; |
| 128 | test 35, index(E2BIG, " ") > 0; |
| 129 | |
| 130 | test 36, @warnings == 0, join "\n", "unexpected warning", @warnings; |
| 131 | @warnings = (); # just in case |
| 132 | undef &PI; |
| 133 | test 37, @warnings && |
| 134 | ($warnings[0] =~ /Constant sub.* undefined/), |
| 135 | shift @warnings; |
| 136 | |
| 137 | test 38, @warnings == 0, "unexpected warning"; |
| 138 | test 39, 1; |
| 139 | |
| 140 | use constant CSCALAR => \"ok 40\n"; |
| 141 | use constant CHASH => { foo => "ok 41\n" }; |
| 142 | use constant CARRAY => [ undef, "ok 42\n" ]; |
| 143 | use constant CPHASH => [ { foo => 1 }, "ok 43\n" ]; |
| 144 | use constant CCODE => sub { "ok $_[0]\n" }; |
| 145 | |
| 146 | print ${+CSCALAR}; |
| 147 | print CHASH->{foo}; |
| 148 | print CARRAY->[1]; |
| 149 | print CPHASH->{foo}; |
| 150 | eval q{ CPHASH->{bar} }; |
| 151 | test 44, scalar($@ =~ /^No such pseudo-hash field/); |
| 152 | print CCODE->(45); |
| 153 | eval q{ CCODE->{foo} }; |
| 154 | test 46, scalar($@ =~ /^Constant is not a HASH/); |
| 155 | |
| 156 | # Allow leading underscore |
| 157 | use constant _PRIVATE => 47; |
| 158 | test 47, _PRIVATE == 47; |
| 159 | |
| 160 | # Disallow doubled leading underscore |
| 161 | eval q{ |
| 162 | use constant __DISALLOWED => "Oops"; |
| 163 | }; |
| 164 | test 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! |
| 168 | sub 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 | |
| 177 | test 49, declared 'PI'; |
| 178 | test 50, $constant::declared{'main::PI'}; |
| 179 | |
| 180 | test 51, !declared 'PIE'; |
| 181 | test 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 | |
| 192 | test 57, declared 'Other::IN_OTHER_PACK'; |
| 193 | test 58, $constant::declared{'Other::IN_OTHER_PACK'}; |
| 194 | |
| 195 | @warnings = (); |
| 196 | eval 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 | |
| 215 | test 59, @warnings == 15 ; |
| 216 | test 60, (shift @warnings) =~ /^Constant name 'BEGIN' is a Perl keyword at/; |
| 217 | shift @warnings; #Constant subroutine BEGIN redefined at |
| 218 | test 61, (shift @warnings) =~ /^Constant name 'INIT' is a Perl keyword at/; |
| 219 | test 62, (shift @warnings) =~ /^Constant name 'CHECK' is a Perl keyword at/; |
| 220 | test 63, (shift @warnings) =~ /^Constant name 'END' is a Perl keyword at/; |
| 221 | test 64, (shift @warnings) =~ /^Constant name 'DESTROY' is a Perl keyword at/; |
| 222 | test 65, (shift @warnings) =~ /^Constant name 'AUTOLOAD' is a Perl keyword at/; |
| 223 | test 66, (shift @warnings) =~ /^Constant name 'STDIN' is forced into package main:: a/; |
| 224 | test 67, (shift @warnings) =~ /^Constant name 'STDOUT' is forced into package main:: at/; |
| 225 | test 68, (shift @warnings) =~ /^Constant name 'STDERR' is forced into package main:: at/; |
| 226 | test 69, (shift @warnings) =~ /^Constant name 'ARGV' is forced into package main:: at/; |
| 227 | test 70, (shift @warnings) =~ /^Constant name 'ARGVOUT' is forced into package main:: at/; |
| 228 | test 71, (shift @warnings) =~ /^Constant name 'ENV' is forced into package main:: at/; |
| 229 | test 72, (shift @warnings) =~ /^Constant name 'INC' is forced into package main:: at/; |
| 230 | test 73, (shift @warnings) =~ /^Constant name 'SIG' is forced into package main:: at/; |
| 231 | @warnings = (); |
| 232 | |
| 233 | |
| 234 | use 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 | |
| 243 | test 74, @{+FAMILY} == THREE; |
| 244 | test 75, @{+FAMILY} == @{RFAM->[0]}; |
| 245 | test 76, FAMILY->[2] eq RFAM->[0]->[2]; |
| 246 | test 77, AGES->{FAMILY->[1]} == 28; |
| 247 | test 78, PHFAM->{John} == AGES->{John}; |
| 248 | test 79, PHFAM->[3] == AGES->{FAMILY->[2]}; |
| 249 | test 80, @{+PHFAM} == SPIT->(THREE+1); |
| 250 | test 81, THREE**3 eq SPIT->(@{+FAMILY}**3); |
| 251 | test 82, AGES->{FAMILY->[THREE-1]} == PHFAM->[THREE]; |