X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/10a0e555f3acbb17b8816ba5ce3d985544996d47..f85893a12feb8ca0f4e9b625542f3ff2920ac00c:/lib/constant.t

diff --git a/lib/constant.t b/lib/constant.t
index a5ffb2c..f5bb2e6 100644
--- a/lib/constant.t
+++ b/lib/constant.t
@@ -1,36 +1,26 @@
-#!./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 { print STDERR @warnings }
 
 
 use strict;
-use Test::More tests => 74;
+use Test::More tests => 97;
 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';
@@ -92,7 +82,7 @@ is length(MESS), 8;
 
 use constant TRAILING	=> '12 cats';
 {
-    no warnings 'numeric';
+    local $^W;
     cmp_ok TRAILING, '==', 12;
 }
 is TRAILING, '12 cats';
@@ -137,10 +127,11 @@ use constant CHASH	=> { foo => "ok 38\n" };
 use constant CARRAY	=> [ undef, "ok 39\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);
 
@@ -190,10 +181,12 @@ ok $constant::declared{'Other::IN_OTHER_PACK'};
 @warnings = ();
 eval q{
     no warnings;
+    #local $^W if $] < 5.006;
     use warnings 'constant';
     use constant 'BEGIN' => 1 ;
     use constant 'INIT' => 1 ;
     use constant 'CHECK' => 1 ;
+    use constant 'UNITCHECK' => 1;
     use constant 'END' => 1 ;
     use constant 'DESTROY' => 1 ;
     use constant 'AUTOLOAD' => 1 ;
@@ -207,13 +200,13 @@ eval q{
     use constant 'SIG' => 1 ;
 };
 
-is @warnings, 15 ;
 my @Expected_Warnings = 
   (
    qr/^Constant name 'BEGIN' is a Perl keyword at/,
    qr/^Constant subroutine BEGIN redefined at/,
    qr/^Constant name 'INIT' is a Perl keyword at/,
    qr/^Constant name 'CHECK' is a Perl keyword at/,
+   qr/^Constant name 'UNITCHECK' is a Perl keyword at/,
    qr/^Constant name 'END' is a Perl keyword at/,
    qr/^Constant name 'DESTROY' is a Perl keyword at/,
    qr/^Constant name 'AUTOLOAD' is a Perl keyword at/,
@@ -226,9 +219,36 @@ my @Expected_Warnings =
    qr/^Constant name 'INC' is forced into package main:: at/,
    qr/^Constant name 'SIG' is forced into package main:: at/,
 );
+
+# 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 = ();
 
 
@@ -245,3 +265,85 @@ is @{+FAMILY}, @{RFAM->[0]};
 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.008 ? "" : ": 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, []);
+}