Integrate with Sarathy.

p4raw-id: //depot/cfgperl@5717

15 files changed, 125 insertions, 75 deletions

diff --git a/t/io/open.t b/t/io/open.t
index 531fc85ce3..30db5988b6 100755
--- a/t/io/open.t
+++ b/t/io/open.t
@@ -1,8 +1,13 @@
 #!./perl
 
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, '../lib';
+}    
+
 # $RCSfile$    
 $|  = 1;
-$^W = 1;
+use warnings;
 $Is_VMS = $^O eq 'VMS';
 
 print "1..66\n";
diff --git a/t/lib/fields.t b/t/lib/fields.t
index 310967fcbe..7709ee5177 100755
--- a/t/lib/fields.t
+++ b/t/lib/fields.t
@@ -15,6 +15,7 @@ BEGIN {
 }
 
 use strict;
+use warnings;
 use vars qw($DEBUG);
 
 package B1;
diff --git a/t/lib/parsewords.t b/t/lib/parsewords.t
index 86323b6fc6..2c936f121f 100755
--- a/t/lib/parsewords.t
+++ b/t/lib/parsewords.t
@@ -5,6 +5,7 @@ BEGIN {
     unshift @INC, '../lib';
 }
 
+use warnings;
 use Text::ParseWords;
 
 print "1..18\n";
@@ -17,15 +18,15 @@ print "ok 2\n";
 print "not " if $words[2] ne 'zoo';
 print "ok 3\n";
 
-# Gonna get some undefined things back
-local($^W) = 0;
+{
+  # Gonna get some undefined things back
+  no warnings 'uninitialized' ;
 
-# Test quotewords() with other parameters and null last field
-@words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:');
-print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;);
-print "ok 4\n";
-
-$^W = 1;
+  # Test quotewords() with other parameters and null last field
+  @words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:');
+  print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;);
+  print "ok 4\n";
+}
 
 # Test $keep eq 'delimiters' and last field zero
 @words = quotewords('\s+', 'delimiters', '4 3 2 1 0');
@@ -71,29 +72,30 @@ print "ok 11\n";
 print "not " if (@words);
 print "ok 12\n";
 
-# Gonna get some more undefined things back
-$^W = 0;
+{
+  # Gonna get some more undefined things back
+  no warnings 'uninitialized' ;
 
-@words = nested_quotewords('s+', 0, $string);
-print "not " if (@words);
-print "ok 13\n";
+  @words = nested_quotewords('s+', 0, $string);
+  print "not " if (@words);
+  print "ok 13\n";
 
-# Now test empty fields
-$result = join('|', parse_line(':', 0, 'foo::0:"":::'));
-print "not " unless ($result eq 'foo||0||||');
-print "ok 14\n";
+  # Now test empty fields
+  $result = join('|', parse_line(':', 0, 'foo::0:"":::'));
+  print "not " unless ($result eq 'foo||0||||');
+  print "ok 14\n";
 
-# Test for 0 in quotes without $keep
-$result = join('|', parse_line(':', 0, ':"0":'));
-print "not " unless ($result eq '|0|');
-print "ok 15\n";
+  # Test for 0 in quotes without $keep
+  $result = join('|', parse_line(':', 0, ':"0":'));
+  print "not " unless ($result eq '|0|');
+  print "ok 15\n";
 
-# Test for \001 in quoted string
-$result = join('|', parse_line(':', 0, ':"' . "\001" . '":'));
-print "not " unless ($result eq "|\1|");
-print "ok 16\n";
+  # Test for \001 in quoted string
+  $result = join('|', parse_line(':', 0, ':"' . "\001" . '":'));
+  print "not " unless ($result eq "|\1|");
+  print "ok 16\n";
 
-$^W = 1;
+}
 
 # Now test perlish single quote behavior
 $Text::ParseWords::PERL_SINGLE_QUOTE = 1;
diff --git a/t/op/assignwarn.t b/t/op/assignwarn.t
index 00f7abbf67..b95cec51a1 100755
--- a/t/op/assignwarn.t
+++ b/t/op/assignwarn.t
@@ -12,8 +12,8 @@ BEGIN {
 }
 
 use strict;
+use warnings;
 
-$^W = 1;
 my $warn = "";
 $SIG{q(__WARN__)} = sub { print $warn; $warn .= join("",@_) };
 
diff --git a/t/op/gv.t b/t/op/gv.t
index ee7978e046..04905cd400 100755
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -4,6 +4,13 @@
 # various typeglob tests
 #
 
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, '../lib';
+}   
+
+use warnings;
+
 print "1..30\n";
 
 # type coersion on assignment
@@ -62,7 +69,7 @@ if (defined $baa) {
 #        fact that %X::Y:: is stored in %X:: isn't documented.
 #        (I hope.)
 
-{ package Foo::Bar; $test=1; }
+{ package Foo::Bar; no warnings 'once'; $test=1; }
 print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n";
 print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n";
 
@@ -77,7 +84,7 @@ print +($foo || @foo || %foo) ? "not ok" : "ok", " 14\n";
 {
     my $msg;
     local $SIG{__WARN__} = sub { $msg = $_[0] };
-    local $^W = 1;
+    use warnings;
     *foo = 'bar';
     print $msg ? "not ok" : "ok", " 15\n";
     *foo = undef;
diff --git a/t/op/hashwarn.t b/t/op/hashwarn.t
index 0b6f10feee..9182273ec3 100755
--- a/t/op/hashwarn.t
+++ b/t/op/hashwarn.t
@@ -6,12 +6,11 @@ BEGIN {
 }
 
 use strict;
+use warnings;
 
 use vars qw{ @warnings };
 
 BEGIN {
-    $^W |= 1;		# Insist upon warnings
-    # ...and save 'em as we go
     $SIG{'__WARN__'} = sub { push @warnings, @_ };
     $| = 1;
     print "1..9\n";
diff --git a/t/op/magic.t b/t/op/magic.t
index 0d5190a2bb..7739276056 100755
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -1,13 +1,14 @@
 #!./perl
 
 BEGIN {
-    $^W = 1;
     $| = 1;
     chdir 't' if -d 't';
     unshift @INC, '../lib';
     $SIG{__WARN__} = sub { die "Dying on warning: ", @_ };
 }
 
+use warnings;
+
 sub ok {
     my ($n, $result, $info) = @_;
     if ($result) {
diff --git a/t/op/pack.t b/t/op/pack.t
index 09c566e92f..b336cb549c 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -98,7 +98,7 @@ print((unpack("p",pack("p",$test)) == $test ? "ok " : "not ok "),$test++,"\n");
 # temps
 sub foo { my $a = "a"; return $a . $a++ . $a++ }
 {
-  local $^W = 1;
+  use warnings;
   my $last = $test;
   local $SIG{__WARN__} = sub {
 	print "ok ",$test++,"\n" if $_[0] =~ /temporary val/
diff --git a/t/op/pat.t b/t/op/pat.t
index 1434af1f06..188a3a3b13 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -573,8 +573,8 @@ sub must_warn_pat {
 
 sub must_warn {
     my ($warn_pat, $code) = @_;
-    local $^W; local %SIG;
-    eval 'BEGIN { $^W = 1; $SIG{__WARN__} = $warn_pat };' . $code;
+    local %SIG;
+    eval 'BEGIN { use warnings; $SIG{__WARN__} = $warn_pat };' . $code;
     print "ok $test\n";
     $test++;
 }
diff --git a/t/op/sort.t b/t/op/sort.t
index 6e3d2ca8e0..794b1f2a6c 100755
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -4,13 +4,17 @@ BEGIN {
     chdir 't' if -d 't';
     unshift @INC, '../lib';
 }
+use warnings;
 print "1..49\n";
 
 # XXX known to leak scalars
-$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
+{
+  no warnings 'uninitialized';
+  $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
+}
 
-sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
-sub backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 }
+sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
+sub Backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 }
 
 my $upperfirst = 'A' lt 'a';
 
@@ -36,12 +40,12 @@ $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
 print "# 1: x = '$x', expected = '$expected'\n";
 print ($x eq $expected ? "ok 1\n" : "not ok 1\n");
 
-$x = join('', sort( backwards @harry));
+$x = join('', sort( Backwards @harry));
 $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
 print "# 2: x = '$x', expected = '$expected'\n";
 print ($x eq $expected ? "ok 2\n" : "not ok 2\n");
 
-$x = join('', sort( backwards_stacked @harry));
+$x = join('', sort( Backwards_stacked @harry));
 $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
 print "# 3: x = '$x', expected = '$expected'\n";
 print ($x eq $expected ? "ok 3\n" : "not ok 3\n");
@@ -77,13 +81,13 @@ print ("@b" eq "4 3 2 1" ? "ok 9\n" : "not ok 9 (@b)\n");
 @b = sort {$a <=> $b;} @a;
 print ("@b" eq "2 3 4 10" ? "ok 10\n" : "not ok 10 (@b)\n");
 
-$sub = 'backwards';
+$sub = 'Backwards';
 $x = join('', sort $sub @harry);
 $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
 print "# 11: x = $x, expected = '$expected'\n";
 print ($x eq $expected ? "ok 11\n" : "not ok 11\n");
 
-$sub = 'backwards_stacked';
+$sub = 'Backwards_stacked';
 $x = join('', sort $sub @harry);
 $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
 print "# 12: x = $x, expected = '$expected'\n";
@@ -107,33 +111,38 @@ print "# x = '@b'\n";
 print ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\n");
 print "# x = '@b'\n";
 
-$^W = 0;
 # redefining sort sub inside the sort sub should fail
 sub twoface { *twoface = sub { $a <=> $b }; &twoface }
 eval { @b = sort twoface 4,1,3,2 };
 print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n");
 
 # redefining sort subs outside the sort should not fail
-eval { *twoface = sub { &backwards } };
+eval { no warnings 'redefine'; *twoface = sub { &Backwards } };
 print $@ ? "not ok 18\n" : "ok 18\n";
 
 eval { @b = sort twoface 4,1,3,2 };
 print ("@b" eq '4 3 2 1' ? "ok 19\n" : "not ok 19 |@b|\n");
 
-*twoface = sub { *twoface = *backwards; $a <=> $b };
+{
+  no warnings 'redefine';
+  *twoface = sub { *twoface = *Backwards; $a <=> $b };
+}
 eval { @b = sort twoface 4,1 };
 print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n");
 
-*twoface = sub {
+{
+  no warnings 'redefine';
+  *twoface = sub {
                  eval 'sub twoface { $a <=> $b }';
 		 die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n");
 		 $a <=> $b;
 	       };
+}
 eval { @b = sort twoface 4,1 };
 print $@ ? "$@" : "not ok 21\n";
 
 eval <<'CODE';
-    my @result = sort main'backwards 'one', 'two';
+    my @result = sort main'Backwards 'one', 'two';
 CODE
 print $@ ? "not ok 22\n# $@" : "ok 22\n";
 
@@ -144,10 +153,10 @@ CODE
 print $@ ? "not ok 23\n# $@" : "ok 23\n";
 
 {
-  my $sortsub = \&backwards;
-  my $sortglob = *backwards;
-  my $sortglobr = \*backwards;
-  my $sortname = 'backwards';
+  my $sortsub = \&Backwards;
+  my $sortglob = *Backwards;
+  my $sortglobr = \*Backwards;
+  my $sortname = 'Backwards';
   @b = sort $sortsub 4,1,3,2;
   print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n");
   @b = sort $sortglob 4,1,3,2;
@@ -159,10 +168,10 @@ print $@ ? "not ok 23\n# $@" : "ok 23\n";
 }
 
 {
-  my $sortsub = \&backwards_stacked;
-  my $sortglob = *backwards_stacked;
-  my $sortglobr = \*backwards_stacked;
-  my $sortname = 'backwards_stacked';
+  my $sortsub = \&Backwards_stacked;
+  my $sortglob = *Backwards_stacked;
+  my $sortglobr = \*Backwards_stacked;
+  my $sortname = 'Backwards_stacked';
   @b = sort $sortsub 4,1,3,2;
   print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n");
   @b = sort $sortglob 4,1,3,2;
@@ -174,10 +183,10 @@ print $@ ? "not ok 23\n# $@" : "ok 23\n";
 }
 
 {
-  local $sortsub = \&backwards;
-  local $sortglob = *backwards;
-  local $sortglobr = \*backwards;
-  local $sortname = 'backwards';
+  local $sortsub = \&Backwards;
+  local $sortglob = *Backwards;
+  local $sortglobr = \*Backwards;
+  local $sortname = 'Backwards';
   @b = sort $sortsub 4,1,3,2;
   print ("@b" eq '4 3 2 1' ? "ok 32\n" : "not ok 32 |@b|\n");
   @b = sort $sortglob 4,1,3,2;
@@ -189,10 +198,10 @@ print $@ ? "not ok 23\n# $@" : "ok 23\n";
 }
 
 {
-  local $sortsub = \&backwards_stacked;
-  local $sortglob = *backwards_stacked;
-  local $sortglobr = \*backwards_stacked;
-  local $sortname = 'backwards_stacked';
+  local $sortsub = \&Backwards_stacked;
+  local $sortglob = *Backwards_stacked;
+  local $sortglobr = \*Backwards_stacked;
+  local $sortname = 'Backwards_stacked';
   @b = sort $sortsub 4,1,3,2;
   print ("@b" eq '4 3 2 1' ? "ok 36\n" : "not ok 36 |@b|\n");
   @b = sort $sortglob 4,1,3,2;
@@ -249,6 +258,6 @@ package Foo;
 print ("@b" eq '1996 255 90 19 5' ? "ok 48\n" : "not ok 48\n");
 print "# x = '@b'\n";
 
-@b = sort main::backwards_stacked @a;
+@b = sort main::Backwards_stacked @a;
 print ("@b" eq '90 5 255 1996 19' ? "ok 49\n" : "not ok 49\n");
 print "# x = '@b'\n";
diff --git a/t/op/sprintf.t b/t/op/sprintf.t
index 70e55cb6cb..4d54d2c317 100755
--- a/t/op/sprintf.t
+++ b/t/op/sprintf.t
@@ -2,9 +2,14 @@
 
 # $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $
 
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, '../lib';
+}   
+use warnings;
+
 print "1..4\n";
 
-$^W = 1;
 $SIG{__WARN__} = sub {
     if ($_[0] =~ /^Invalid conversion/) {
 	$w++;
diff --git a/t/pod/testp2pt.pl b/t/pod/testp2pt.pl
index 22bbaf8247..2ff8aa427a 100644
--- a/t/pod/testp2pt.pl
+++ b/t/pod/testp2pt.pl
@@ -44,13 +44,12 @@ sub catfile(@) { File::Spec->catfile(@_); }
 my $INSTDIR = abs_path(dirname $0);
 $INSTDIR = VMS::Filespec::unixpath($INSTDIR) if $^O eq 'VMS';
 $INSTDIR =~ s#/$## if $^O eq 'VMS';
-$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'xtra');
 $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'pod');
 $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 't');
 my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'),
+                   catfile($INSTDIR, 'scripts'),
                    catfile($INSTDIR, 'pod'),
-                   catfile($INSTDIR, 't', 'pod'),
-                   catfile($INSTDIR, 't', 'pod', 'xtra')
+                   catfile($INSTDIR, 't', 'pod')
                  );
 
 ## Find the path to the file to =include
@@ -100,6 +99,10 @@ sub command {
     print $out_fh "###### end =include $incbase #####\n"    if ($incdebug);
 }
 
+sub begin_input {
+   $_[0]->{_INFILE} = VMS::Filespec::unixify($_[0]->{_INFILE}) if $^O eq 'VMS';
+}
+
 sub podinc2plaintext( $ $ ) {
     my ($infile, $outfile) = @_;
     local $_;
diff --git a/t/pod/testpchk.pl b/t/pod/testpchk.pl
index 640226bde7..94c0c10fe5 100644
--- a/t/pod/testpchk.pl
+++ b/t/pod/testpchk.pl
@@ -10,6 +10,7 @@ BEGIN {
    import TestCompare;
    my $PARENTDIR = dirname $THISDIR;
    push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR);
+   require VMS::Filespec if $^O eq 'VMS';
 }
 
 use Pod::Checker;
@@ -30,7 +31,20 @@ sub stripname( $ ) {
 }
 
 sub msgcmp( $ $ ) {
+   ## filter out platform-dependent aspects of error messages
    my ($line1, $line2) = @_;
+   for ($line1, $line2) {
+      if ( /^#*\s*(\S.*?)\s+(?:has \d+\s*)?pod syntax (?:error|OK)/ ) {
+          my $fname = $1;
+          s/^#*\s*//  if ($^O eq 'MacOS');
+          s/^\s*\Q$fname\E/stripname($fname)/e;
+      }
+      elsif ( /^#*\s*\*+\s*(?:ERROR|Unterminated)/ ) {
+          s/^#*\s*//  if ($^O eq 'MacOS');
+          s/of file\s+(\S.*?)\s*$/"of file ".stripname($1)/e;
+          s/at\s+(\S.*?)\s+line/"at ".stripname($1)." line"/e;
+      }
+   }
    return $line1 ne $line2;
 }
 
@@ -51,6 +65,11 @@ sub testpodcheck( @ ) {
 
    print "# Running podchecker for '$testname'...\n";
    ## Compare the output against the expected result
+   if ($^O eq 'VMS') {
+      for ($infile, $outfile, $cmpfile) {
+         $_ = VMS::Filespec::unixify($_)  unless  ref;
+      }
+   }
    podchecker($infile, $outfile);
    if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) {
        $different = "$outfile is different from $cmpfile";
diff --git a/t/pragma/constant.t b/t/pragma/constant.t
index 443bcf6423..6438332cff 100755
--- a/t/pragma/constant.t
+++ b/t/pragma/constant.t
@@ -5,7 +5,7 @@ BEGIN {
     unshift @INC, '../lib' if -d '../lib';
 }
 
-BEGIN {$^W |= 1}		# Insist upon warnings
+use warnings;
 use vars qw{ @warnings };
 BEGIN {				# ...and save 'em for later
     $SIG{'__WARN__'} = sub { push @warnings, @_ }
@@ -135,7 +135,7 @@ test 37, @warnings &&
     shift @warnings;
 
 test 38, @warnings == 0, "unexpected warning";
-test 39, $^W & 1, "Who disabled the warnings?";
+test 39, 1;
 
 use constant CSCALAR	=> \"ok 40\n";
 use constant CHASH	=> { foo => "ok 41\n" };
@@ -194,7 +194,7 @@ test 58, $constant::declared{'Other::IN_OTHER_PACK'};
 
 @warnings = ();
 eval q{
-{
+    no warnings;
     use warnings 'constant';
     use constant 'BEGIN' => 1 ;
     use constant 'INIT' => 1 ;
@@ -210,7 +210,6 @@ eval q{
     use constant 'ENV' => 1 ;
     use constant 'INC' => 1 ;
     use constant 'SIG' => 1 ;
-}
 };
 
 test 59, @warnings == 14 ;
diff --git a/t/pragma/locale.t b/t/pragma/locale.t
index 6265ccef1f..414ceffe96 100755
--- a/t/pragma/locale.t
+++ b/t/pragma/locale.t
@@ -52,7 +52,7 @@ sub ok {
 # even the default locale will taint under 'use locale'.
 
 sub is_tainted { # hello, camel two.
-    local $^W;	# no warnings 'undef'
+    no warnings 'uninitialized' ;
     my $dummy;
     not eval { $dummy = join("", @_), kill 0; 1 }
 }
@@ -582,9 +582,9 @@ foreach $Locale (@Locale) {
     tryneoalpha($Locale, 104, $c eq $d); 
 
     {
+	use warnings;
 	my $w = 0;
 	local $SIG{__WARN__} = sub { $w++ };
-	local $^W = 1;
 
 	# the == (among other ops) used to warn for locales
 	# that had something else than "." as the radix character