6 files changed, 68 insertions, 7 deletions

diff --git a/contrib/perl5/t/pragma/constant.t b/contrib/perl5/t/pragma/constant.t
index 0b58bae..5b63dfa 100755
--- a/contrib/perl5/t/pragma/constant.t
+++ b/contrib/perl5/t/pragma/constant.t
@@ -14,7 +14,7 @@ END { print @warnings }
 
 ######################### We start with some black magic to print on failure.
 
-BEGIN { $| = 1; print "1..39\n"; }
+BEGIN { $| = 1; print "1..46\n"; }
 END {print "not ok 1\n" unless $loaded;}
 use constant;
 $loaded = 1;
@@ -139,3 +139,19 @@ test 37, @warnings &&
 
 test 38, @warnings == 0, "unexpected warning";
 test 39, $^W & 1, "Who disabled the warnings?";
+
+use constant CSCALAR	=> \"ok 40\n";
+use constant CHASH	=> { foo => "ok 41\n" };
+use constant CARRAY	=> [ undef, "ok 42\n" ];
+use constant CPHASH	=> [ { foo => 1 }, "ok 43\n" ];
+use constant CCODE	=> sub { "ok $_[0]\n" };
+
+print ${+CSCALAR};
+print CHASH->{foo};
+print CARRAY->[1];
+print CPHASH->{foo};
+eval q{ CPHASH->{bar} };
+test 44, scalar($@ =~ /^No such array/);
+print CCODE->(45);
+eval q{ CCODE->{foo} };
+test 46, scalar($@ =~ /^Constant is not a HASH/);
diff --git a/contrib/perl5/t/pragma/locale.t b/contrib/perl5/t/pragma/locale.t
index 00baa66..7e3df8c 100755
--- a/contrib/perl5/t/pragma/locale.t
+++ b/contrib/perl5/t/pragma/locale.t
@@ -23,6 +23,9 @@ eval {
 # and mingw32 uses said silly CRT
 $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i;
 
+# 103 (the last test) may fail but that is okay.
+# (It indicates something broken in the environment, not Perl)
+# Therefore .. only until 102, not 103.
 print "1..", ($have_setlocale ? 102 : 98), "\n";
 
 use vars qw($a
@@ -404,6 +407,7 @@ print "ok 101\n";
 
 # Test for read-onlys.
 
+print "# testing 102\n";
 {
     no locale;
     $a = "qwerty";
@@ -419,7 +423,7 @@ print "ok 102\n";
 # Thanks to Hallvard Furuseth <h.b.furuseth@usit.uio.no>
 # for inventing a way to test for ordering consistency
 # without requiring any particular order.
-# ++$jhi;#@iki.fi
+# <jhi@iki.fi>
 
 print "# testing 103\n";
 {
diff --git a/contrib/perl5/t/pragma/overload.t b/contrib/perl5/t/pragma/overload.t
index afba8a3..0682266 100755
--- a/contrib/perl5/t/pragma/overload.t
+++ b/contrib/perl5/t/pragma/overload.t
@@ -694,5 +694,17 @@ test($c, "bareword");	# 135
   test( scalar ($seven =~ /i/), '1')
 }
 
+{
+  package sorting;
+  use overload 'cmp' => \&comp;
+  sub new { my ($p, $v) = @_; bless \$v, $p }
+  sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y }
+}
+{
+  my @arr = map sorting->new($_), 0..12;
+  my @sorted1 = sort @arr;
+  my @sorted2 = map $$_, @sorted1;
+  test "@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3';
+}
 # Last test is:
-sub last {173}
+sub last {174}
diff --git a/contrib/perl5/t/pragma/subs.t b/contrib/perl5/t/pragma/subs.t
index 680564f..6ebbf78 100755
--- a/contrib/perl5/t/pragma/subs.t
+++ b/contrib/perl5/t/pragma/subs.t
@@ -55,7 +55,9 @@ for (@prgs){
     # allow expected output to be written as if $prog is on STDIN
     $results =~ s/tmp\d+/-/g;
     $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
-    $results =~ s/Syntax/syntax/;  # non-standard yacc
+# bison says 'parse error' instead of 'syntax error',
+# various yaccs may or may not capitalize 'syntax'.
+    $results =~ s/^(syntax|parse) error/syntax error/mig;
     $expected =~ s/\n+$//;
     my $prefix = ($results =~ s/^PREFIX\n//) ;
     if ( $results =~ s/^SKIPPED\n//) {
diff --git a/contrib/perl5/t/pragma/warn-1global b/contrib/perl5/t/pragma/warn-1global
index 07b5bc8..a7ca607 100644
--- a/contrib/perl5/t/pragma/warn-1global
+++ b/contrib/perl5/t/pragma/warn-1global
@@ -12,12 +12,14 @@ EXPECT
 $a =+ 3 ;
 EXPECT
 Reversed += operator at - line 3.
+Name "main::a" used only once: possible typo at - line 3.
 ########
 #! perl -w
 # warnable code, warnings enabled via #! line
 $a =+ 3 ;
 EXPECT
 Reversed += operator at - line 3.
+Name "main::a" used only once: possible typo at - line 3.
 ########
 
 # warnable code, warnings enabled via compile time $^W
@@ -25,6 +27,7 @@ BEGIN { $^W = 1 }
 $a =+ 3 ;
 EXPECT
 Reversed += operator at - line 4.
+Name "main::a" used only once: possible typo at - line 4.
 ########
 
 # compile-time warnable code, warnings enabled via runtime $^W
@@ -149,3 +152,8 @@ Use of uninitialized value at - line 5.
 -e undef
 EXPECT
 Use of uninitialized value at - line 2.
+########
+BEGIN { $^W = 1 }
+for (@{[0]}) { "$_" }		# check warning isn't duplicated
+EXPECT
+Useless use of string in void context at - line 2.
diff --git a/contrib/perl5/t/pragma/warning.t b/contrib/perl5/t/pragma/warning.t
index fa0301e..35d9d48 100755
--- a/contrib/perl5/t/pragma/warning.t
+++ b/contrib/perl5/t/pragma/warning.t
@@ -4,11 +4,12 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     $ENV{PERL5LIB} = '../lib';
+    require Config; import Config;
 }
 
 $| = 1;
 
-my $Is_VMS = $^O eq 'VMS';
+my $Is_VMS     = $^O eq 'VMS';
 my $Is_MSWin32 = $^O eq 'MSWin32';
 my $tmpfile = "tmp0000";
 my $i = 0 ;
@@ -19,6 +20,8 @@ my @prgs = () ;
 
 foreach (sort glob("pragma/warn-*")) {
 
+    next if /\.orig$/ ;
+
     next if /(~|\.orig)$/;
 
     open F, "<$_" or die "Cannot open $_: $!\n" ;
@@ -76,13 +79,29 @@ for (@prgs){
     # allow expected output to be written as if $prog is on STDIN
     $results =~ s/tmp\d+/-/g;
     $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
+# bison says 'parse error' instead of 'syntax error',
+# various yaccs may or may not capitalize 'syntax'.
+    $results =~ s/^(syntax|parse) error/syntax error/mig;
     $expected =~ s/\n+$//;
     my $prefix = ($results =~ s/^PREFIX\n//) ;
+    # any special options? (OPTIONS foo bar zap)
+    my $option_regex = 0;
+    if ($expected =~ s/^OPTIONS? (.+)\n//) {
+	foreach my $option (split(' ', $1)) {
+	    if ($option eq 'regex') { # allow regular expressions
+		$option_regex = 1;
+	    } else {
+		die "$0: Unknown OPTION '$option'\n";
+	    }
+	}
+    }
     if ( $results =~ s/^SKIPPED\n//) {
 	print "$results\n" ;
     }
-    elsif (($prefix and $results !~ /^\Q$expected/) or
-	   (!$prefix and $results ne $expected)){
+    elsif (($prefix  && (( $option_regex && $results !~ /^$expected/) ||
+			 (!$option_regex && $results !~ /^\Q$expected/))) or
+	   (!$prefix && (( $option_regex && $results !~ /^$expected/) ||
+			 (!$option_regex && $results ne $expected)))) {
         print STDERR "PROG: $switch\n$prog\n";
         print STDERR "EXPECTED:\n$expected\n";
         print STDERR "GOT:\n$results\n";