This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a5ffb2ccbe681d6394530d584472e76f0bc6f9cb
[perl5.git] / 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 @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);