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 { @warnings && print STDERR join "\n- ", "accumulated warnings:", @warnings }
  16
  17
  18 use strict;
  19 use Test::More tests => 95;
  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 LEADING    => " \t1234";
  84 cmp_ok LEADING, '==', 1234;
  85 is LEADING, " \t1234";
  86
  87 use constant ZERO1      => 0;
  88 use constant ZERO2      => 0.0;
  89 use constant ZERO3      => '0.0';
  90 is ZERO1, '0';
  91 is ZERO2, '0';
  92 is ZERO3, '0.0';
  93
  94 {
  95     package Other;
  96     use constant PI     => 3.141;
  97 }
  98
  99 cmp_ok(abs(PI - 3.1416), '<', 0.0001);
 100 is Other::PI, 3.141;
 101
 102 use constant E2BIG => $! = 7;
 103 cmp_ok E2BIG, '==', 7;
 104 # This is something like "Arg list too long", but the actual message
 105 # text may vary, so we can't test much better than this.
 106 cmp_ok length(E2BIG), '>', 6;
 107
 108 is @warnings, 0 or diag join "\n- ", "unexpected warning:", @warnings;
 109 @warnings = ();         # just in case
 110 undef &PI;
 111 ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or
 112   diag join "\n", "unexpected warning", @warnings;
 113 shift @warnings;
 114
 115 is @warnings, 0, "unexpected warning";
 116
 117 my $curr_test = $TB->current_test;
 118 use constant CSCALAR    => \"ok 35\n";
 119 use constant CHASH      => { foo => "ok 36\n" };
 120 use constant CARRAY     => [ undef, "ok 37\n" ];
 121 use constant CCODE      => sub { "ok $_[0]\n" };
 122
 123 my $output = $TB->output ;
 124 print $output ${+CSCALAR};
 125 print $output CHASH->{foo};
 126 print $output CARRAY->[1];
 127 print $output CCODE->($curr_test+4);
 128
 129 $TB->current_test($curr_test+4);
 130
 131 eval q{ CCODE->{foo} };
 132 ok scalar($@ =~ /^Constant is not a HASH/);
 133
 134
 135 # Allow leading underscore
 136 use constant _PRIVATE => 47;
 137 is _PRIVATE, 47;
 138
 139 # Disallow doubled leading underscore
 140 eval q{
 141     use constant __DISALLOWED => "Oops";
 142 };
 143 like $@, qr/begins with '__'/;
 144
 145 # Check on declared() and %declared. This sub should be EXACTLY the
 146 # same as the one quoted in the docs!
 147 sub declared ($) {
 148     use constant 1.01;              # don't omit this!
 149     my $name = shift;
 150     $name =~ s/^::/main::/;
 151     my $pkg = caller;
 152     my $full_name = $name =~ /::/ ? $name : "${pkg}::$name";
 153     $constant::declared{$full_name};
 154 }
 155
 156 ok declared 'PI';
 157 ok $constant::declared{'main::PI'};
 158
 159 ok !declared 'PIE';
 160 ok !$constant::declared{'main::PIE'};
 161
 162 {
 163     package Other;
 164     use constant IN_OTHER_PACK => 42;
 165     ::ok ::declared 'IN_OTHER_PACK';
 166     ::ok $constant::declared{'Other::IN_OTHER_PACK'};
 167     ::ok ::declared 'main::PI';
 168     ::ok $constant::declared{'main::PI'};
 169 }
 170
 171 ok declared 'Other::IN_OTHER_PACK';
 172 ok $constant::declared{'Other::IN_OTHER_PACK'};
 173
 174 @warnings = ();
 175 eval q{
 176     no warnings;
 177     #local $^W if $] < 5.006;
 178     use warnings 'constant';
 179     use constant 'BEGIN' => 1 ;
 180     use constant 'INIT' => 1 ;
 181     use constant 'CHECK' => 1 ;
 182     use constant 'END' => 1 ;
 183     use constant 'DESTROY' => 1 ;
 184     use constant 'AUTOLOAD' => 1 ;
 185     use constant 'STDIN' => 1 ;
 186     use constant 'STDOUT' => 1 ;
 187     use constant 'STDERR' => 1 ;
 188     use constant 'ARGV' => 1 ;
 189     use constant 'ARGVOUT' => 1 ;
 190     use constant 'ENV' => 1 ;
 191     use constant 'INC' => 1 ;
 192     use constant 'SIG' => 1 ;
 193     use constant 'UNITCHECK' => 1;
 194 };
 195
 196 my @Expected_Warnings =
 197   (
 198    qr/^Constant name 'BEGIN' is a Perl keyword at/,
 199    qr/^Constant subroutine BEGIN redefined at/,
 200    qr/^Constant name 'INIT' is a Perl keyword at/,
 201    qr/^Constant name 'CHECK' is a Perl keyword at/,
 202    qr/^Constant name 'END' is a Perl keyword at/,
 203    qr/^Constant name 'DESTROY' is a Perl keyword at/,
 204    qr/^Constant name 'AUTOLOAD' is a Perl keyword at/,
 205    qr/^Constant name 'STDIN' is forced into package main:: a/,
 206    qr/^Constant name 'STDOUT' is forced into package main:: at/,
 207    qr/^Constant name 'STDERR' is forced into package main:: at/,
 208    qr/^Constant name 'ARGV' is forced into package main:: at/,
 209    qr/^Constant name 'ARGVOUT' is forced into package main:: at/,
 210    qr/^Constant name 'ENV' is forced into package main:: at/,
 211    qr/^Constant name 'INC' is forced into package main:: at/,
 212    qr/^Constant name 'SIG' is forced into package main:: at/,
 213    qr/^Constant name 'UNITCHECK' is a Perl keyword at/,
 214 );
 215
 216 unless ($] > 5.009) {
 217     # Remove the UNITCHECK warning
 218     pop @Expected_Warnings;
 219     # But keep the count the same
 220     push @Expected_Warnings, qr/^$/;
 221     push @warnings, "";
 222 }
 223
 224 # when run under "make test"
 225 if (@warnings == 16) {
 226     push @warnings, "";
 227     push @Expected_Warnings, qr/^$/;
 228 }
 229 # when run directly: perl -wT -Ilib t/constant.t
 230 elsif (@warnings == 17) {
 231     splice @Expected_Warnings, 1, 0,
 232         qr/^Prototype mismatch: sub main::BEGIN \(\) vs none at/;
 233 }
 234 # when run directly under 5.6.2: perl -wT -Ilib t/constant.t
 235 elsif (@warnings == 15) {
 236     splice @Expected_Warnings, 1, 1;
 237     push @warnings, "", "";
 238     push @Expected_Warnings, qr/^$/, qr/^$/;
 239 }
 240 else {
 241     my $rule = " -" x 20;
 242     diag "/!\\ unexpected case: ", scalar @warnings, " warnings\n$rule\n";
 243     diag map { "  $_" } @warnings;
 244     diag $rule, $/;
 245 }
 246
 247 is @warnings, 17;
 248
 249 for my $idx (0..$#warnings) {
 250     like $warnings[$idx], $Expected_Warnings[$idx];
 251 }
 252
 253 @warnings = ();
 254
 255
 256 use constant {
 257         THREE  => 3,
 258         FAMILY => [ qw( John Jane Sally ) ],
 259         AGES   => { John => 33, Jane => 28, Sally => 3 },
 260         RFAM   => [ [ qw( John Jane Sally ) ] ],
 261         SPIT   => sub { shift },
 262 };
 263
 264 is @{+FAMILY}, THREE;
 265 is @{+FAMILY}, @{RFAM->[0]};
 266 is FAMILY->[2], RFAM->[0]->[2];
 267 is AGES->{FAMILY->[1]}, 28;
 268 is THREE**3, SPIT->(@{+FAMILY}**3);
 269
 270 # Allow name of digits/underscores only if it begins with underscore
 271 {
 272     use warnings FATAL => 'constant';
 273     eval q{
 274         use constant _1_2_3 => 'allowed';
 275     };
 276     ok( $@ eq '' );
 277 }
 278
 279 sub slotch ();
 280
 281 {
 282     my @warnings;
 283     local $SIG{'__WARN__'} = sub { push @warnings, @_ };
 284     eval 'use constant slotch => 3; 1' or die $@;
 285
 286     is ("@warnings", "", "No warnings if a prototype exists");
 287
 288     my $value = eval 'slotch';
 289     is ($@, '');
 290     is ($value, 3);
 291 }
 292
 293 sub zit;
 294
 295 {
 296     my @warnings;
 297     local $SIG{'__WARN__'} = sub { push @warnings, @_ };
 298     eval 'use constant zit => 4; 1' or die $@;
 299
 300     # empty prototypes are reported differently in different versions
 301     my $no_proto = $] < 5.008004 ? "" : ": none";
 302
 303     is(scalar @warnings, 1, "1 warning");
 304     like ($warnings[0], qr/^Prototype mismatch: sub main::zit$no_proto vs \(\)/,
 305           "about the prototype mismatch");
 306
 307     my $value = eval 'zit';
 308     is ($@, '');
 309     is ($value, 4);
 310 }
 311
 312 $fagwoosh = 'geronimo';
 313 $putt = 'leutwein';
 314 $kloong = 'schlozhauer';
 315
 316 {
 317     my @warnings;
 318     local $SIG{'__WARN__'} = sub { push @warnings, @_ };
 319     eval 'use constant fagwoosh => 5; 1' or die $@;
 320
 321     is ("@warnings", "", "No warnings if the typeglob exists already");
 322
 323     my $value = eval 'fagwoosh';
 324     is ($@, '');
 325     is ($value, 5);
 326
 327     my @value = eval 'fagwoosh';
 328     is ($@, '');
 329     is_deeply (\@value, [5]);
 330
 331     eval 'use constant putt => 6, 7; 1' or die $@;
 332
 333     is ("@warnings", "", "No warnings if the typeglob exists already");
 334
 335     @value = eval 'putt';
 336     is ($@, '');
 337     is_deeply (\@value, [6, 7]);
 338
 339     eval 'use constant "klong"; 1' or die $@;
 340
 341     is ("@warnings", "", "No warnings if the typeglob exists already");
 342
 343     $value = eval 'klong';
 344     is ($@, '');
 345     is ($value, undef);
 346
 347     @value = eval 'klong';
 348     is ($@, '');
 349     is_deeply (\@value, []);
 350 }