lib/constant.t

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