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