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