-#!./perl
+#!./perl -T
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
}
use warnings;
-use vars qw{ @warnings };
+use vars qw{ @warnings $fagwoosh $putt $kloong};
BEGIN { # ...and save 'em for later
$SIG{'__WARN__'} = sub { push @warnings, @_ }
}
-END { print @warnings }
+END { @warnings && print STDERR join "\n- ", "accumulated warnings:", @warnings }
use strict;
-use Test::More tests => 74;
+use Test::More tests => 95;
my $TB = Test::More->builder;
BEGIN { use_ok('constant'); }
-sub test ($$;$) {
- my($num, $bool, $diag) = @_;
- if ($bool) {
- print "ok $num\n";
- return;
- }
- print "not ok $num\n";
- return unless defined $diag;
- $diag =~ s/\Z\n?/\n/; # unchomp
- print map "# $num : $_", split m/^/m, $diag;
-}
-
use constant PI => 4 * atan2 1, 1;
ok defined PI, 'basic scalar constant';
is MESS, q('"'\\"'"\\);
is length(MESS), 8;
-use constant TRAILING => '12 cats';
-{
- no warnings 'numeric';
- cmp_ok TRAILING, '==', 12;
-}
-is TRAILING, '12 cats';
-
use constant LEADING => " \t1234";
cmp_ok LEADING, '==', 1234;
is LEADING, " \t1234";
# text may vary, so we can't test much better than this.
cmp_ok length(E2BIG), '>', 6;
-is @warnings, 0 or diag join "\n", "unexpected warning", @warnings;
+is @warnings, 0 or diag join "\n- ", "unexpected warning:", @warnings;
@warnings = (); # just in case
undef Π
ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or
is @warnings, 0, "unexpected warning";
my $curr_test = $TB->current_test;
-use constant CSCALAR => \"ok 37\n";
-use constant CHASH => { foo => "ok 38\n" };
-use constant CARRAY => [ undef, "ok 39\n" ];
+use constant CSCALAR => \"ok 35\n";
+use constant CHASH => { foo => "ok 36\n" };
+use constant CARRAY => [ undef, "ok 37\n" ];
use constant CCODE => sub { "ok $_[0]\n" };
-print ${+CSCALAR};
-print CHASH->{foo};
-print CARRAY->[1];
-print CCODE->($curr_test+4);
+my $output = $TB->output ;
+print $output ${+CSCALAR};
+print $output CHASH->{foo};
+print $output CARRAY->[1];
+print $output CCODE->($curr_test+4);
$TB->current_test($curr_test+4);
@warnings = ();
eval q{
no warnings;
+ #local $^W if $] < 5.006;
use warnings 'constant';
use constant 'BEGIN' => 1 ;
use constant 'INIT' => 1 ;
use constant 'ENV' => 1 ;
use constant 'INC' => 1 ;
use constant 'SIG' => 1 ;
+ use constant 'UNITCHECK' => 1;
};
-is @warnings, 15 ;
my @Expected_Warnings =
(
qr/^Constant name 'BEGIN' is a Perl keyword at/,
qr/^Constant name 'ENV' is forced into package main:: at/,
qr/^Constant name 'INC' is forced into package main:: at/,
qr/^Constant name 'SIG' is forced into package main:: at/,
+ qr/^Constant name 'UNITCHECK' is a Perl keyword at/,
);
+
+unless ($] > 5.009) {
+ # Remove the UNITCHECK warning
+ pop @Expected_Warnings;
+ # But keep the count the same
+ push @Expected_Warnings, qr/^$/;
+ push @warnings, "";
+}
+
+# when run under "make test"
+if (@warnings == 16) {
+ push @warnings, "";
+ push @Expected_Warnings, qr/^$/;
+}
+# when run directly: perl -wT -Ilib t/constant.t
+elsif (@warnings == 17) {
+ splice @Expected_Warnings, 1, 0,
+ qr/^Prototype mismatch: sub main::BEGIN \(\) vs none at/;
+}
+# when run directly under 5.6.2: perl -wT -Ilib t/constant.t
+elsif (@warnings == 15) {
+ splice @Expected_Warnings, 1, 1;
+ push @warnings, "", "";
+ push @Expected_Warnings, qr/^$/, qr/^$/;
+}
+else {
+ my $rule = " -" x 20;
+ diag "/!\\ unexpected case: ", scalar @warnings, " warnings\n$rule\n";
+ diag map { " $_" } @warnings;
+ diag $rule, $/;
+}
+
+is @warnings, 17;
+
for my $idx (0..$#warnings) {
like $warnings[$idx], $Expected_Warnings[$idx];
}
+
@warnings = ();
is FAMILY->[2], RFAM->[0]->[2];
is AGES->{FAMILY->[1]}, 28;
is THREE**3, SPIT->(@{+FAMILY}**3);
+
+# Allow name of digits/underscores only if it begins with underscore
+{
+ use warnings FATAL => 'constant';
+ eval q{
+ use constant _1_2_3 => 'allowed';
+ };
+ ok( $@ eq '' );
+}
+
+sub slotch ();
+
+{
+ my @warnings;
+ local $SIG{'__WARN__'} = sub { push @warnings, @_ };
+ eval 'use constant slotch => 3; 1' or die $@;
+
+ is ("@warnings", "", "No warnings if a prototype exists");
+
+ my $value = eval 'slotch';
+ is ($@, '');
+ is ($value, 3);
+}
+
+sub zit;
+
+{
+ my @warnings;
+ local $SIG{'__WARN__'} = sub { push @warnings, @_ };
+ eval 'use constant zit => 4; 1' or die $@;
+
+ # empty prototypes are reported differently in different versions
+ my $no_proto = $] < 5.008004 ? "" : ": none";
+
+ is(scalar @warnings, 1, "1 warning");
+ like ($warnings[0], qr/^Prototype mismatch: sub main::zit$no_proto vs \(\)/,
+ "about the prototype mismatch");
+
+ my $value = eval 'zit';
+ is ($@, '');
+ is ($value, 4);
+}
+
+$fagwoosh = 'geronimo';
+$putt = 'leutwein';
+$kloong = 'schlozhauer';
+
+{
+ my @warnings;
+ local $SIG{'__WARN__'} = sub { push @warnings, @_ };
+ eval 'use constant fagwoosh => 5; 1' or die $@;
+
+ is ("@warnings", "", "No warnings if the typeglob exists already");
+
+ my $value = eval 'fagwoosh';
+ is ($@, '');
+ is ($value, 5);
+
+ my @value = eval 'fagwoosh';
+ is ($@, '');
+ is_deeply (\@value, [5]);
+
+ eval 'use constant putt => 6, 7; 1' or die $@;
+
+ is ("@warnings", "", "No warnings if the typeglob exists already");
+
+ @value = eval 'putt';
+ is ($@, '');
+ is_deeply (\@value, [6, 7]);
+
+ eval 'use constant "klong"; 1' or die $@;
+
+ is ("@warnings", "", "No warnings if the typeglob exists already");
+
+ $value = eval 'klong';
+ is ($@, '');
+ is ($value, undef);
+
+ @value = eval 'klong';
+ is ($@, '');
+ is_deeply (\@value, []);
+}