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 'UNITCHECK' => 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
 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 'UNITCHECK' 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 );
 222
 223 # when run under "make test"
 224 if (@warnings == 16) {
 225     push @warnings, "";
 226     push @Expected_Warnings, qr/^$/;
 227 }
 228 # when run directly: perl -wT -Ilib t/constant.t
 229 elsif (@warnings == 17) {
 230     splice @Expected_Warnings, 1, 0,
 231         qr/^Prototype mismatch: sub main::BEGIN \(\) vs none at/;
 232 }
 233 # when run directly under 5.6.2: perl -wT -Ilib t/constant.t
 234 elsif (@warnings == 15) {
 235     splice @Expected_Warnings, 1, 1;
 236     push @warnings, "", "";
 237     push @Expected_Warnings, qr/^$/, qr/^$/;
 238 }
 239 else {
 240     my $rule = " -" x 20;
 241     diag "/!\\ unexpected case: ", scalar @warnings, " warnings\n$rule\n";
 242     diag map { "  $_" } @warnings;
 243     diag $rule, $/;
 244 }
 245
 246 is @warnings, 17;
 247
 248 for my $idx (0..$#warnings) {
 249     like $warnings[$idx], $Expected_Warnings[$idx];
 250 }
 251
 252 @warnings = ();
 253
 254
 255 use constant {
 256         THREE  => 3,
 257         FAMILY => [ qw( John Jane Sally ) ],
 258         AGES   => { John => 33, Jane => 28, Sally => 3 },
 259         RFAM   => [ [ qw( John Jane Sally ) ] ],
 260         SPIT   => sub { shift },
 261 };
 262
 263 is @{+FAMILY}, THREE;
 264 is @{+FAMILY}, @{RFAM->[0]};
 265 is FAMILY->[2], RFAM->[0]->[2];
 266 is AGES->{FAMILY->[1]}, 28;
 267 is THREE**3, SPIT->(@{+FAMILY}**3);
 268
 269 # Allow name of digits/underscores only if it begins with underscore
 270 {
 271     use warnings FATAL => 'constant';
 272     eval q{
 273         use constant _1_2_3 => 'allowed';
 274     };
 275     ok( $@ eq '' );
 276 }
 277
 278 sub slotch ();
 279
 280 {
 281     my @warnings;
 282     local $SIG{'__WARN__'} = sub { push @warnings, @_ };
 283     eval 'use constant slotch => 3; 1' or die $@;
 284
 285     is ("@warnings", "", "No warnings if a prototype exists");
 286
 287     my $value = eval 'slotch';
 288     is ($@, '');
 289     is ($value, 3);
 290 }
 291
 292 sub zit;
 293
 294 {
 295     my @warnings;
 296     local $SIG{'__WARN__'} = sub { push @warnings, @_ };
 297     eval 'use constant zit => 4; 1' or die $@;
 298
 299     # empty prototypes are reported differently in different versions
 300     my $no_proto = $] < 5.008 ? "" : ": none";
 301
 302     is(scalar @warnings, 1, "1 warning");
 303     like ($warnings[0], qr/^Prototype mismatch: sub main::zit$no_proto vs \(\)/,
 304           "about the prototype mismatch");
 305
 306     my $value = eval 'zit';
 307     is ($@, '');
 308     is ($value, 4);
 309 }
 310
 311 $fagwoosh = 'geronimo';
 312 $putt = 'leutwein';
 313 $kloong = 'schlozhauer';
 314
 315 {
 316     my @warnings;
 317     local $SIG{'__WARN__'} = sub { push @warnings, @_ };
 318     eval 'use constant fagwoosh => 5; 1' or die $@;
 319
 320     is ("@warnings", "", "No warnings if the typeglob exists already");
 321
 322     my $value = eval 'fagwoosh';
 323     is ($@, '');
 324     is ($value, 5);
 325
 326     my @value = eval 'fagwoosh';
 327     is ($@, '');
 328     is_deeply (\@value, [5]);
 329
 330     eval 'use constant putt => 6, 7; 1' or die $@;
 331
 332     is ("@warnings", "", "No warnings if the typeglob exists already");
 333
 334     @value = eval 'putt';
 335     is ($@, '');
 336     is_deeply (\@value, [6, 7]);
 337
 338     eval 'use constant "klong"; 1' or die $@;
 339
 340     is ("@warnings", "", "No warnings if the typeglob exists already");
 341
 342     $value = eval 'klong';
 343     is ($@, '');
 344     is ($value, undef);
 345
 346     @value = eval 'klong';
 347     is ($@, '');
 348     is_deeply (\@value, []);
 349 }