lib/constant.t

   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];