Integrate mainline

p4raw-id: //depot/perlio@13532

5 files changed, 454 insertions, 302 deletions

diff --git a/t/op/chop.t b/t/op/chop.t
index e8b777eb6a..abb8aba732 100755
--- a/t/op/chop.t
+++ b/t/op/chop.t
@@ -1,18 +1,20 @@
 #!./perl
 
-print "1..41\n";
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+}
 
-# optimized
+plan tests => 47;
 
 $_ = 'abc';
 $c = do foo();
-if ($c . $_ eq 'cab') {print "ok 1\n";} else {print "not ok 1 $c$_\n";}
-
-# unoptimized
+is ($c . $_, 'cab', 'optimized');
 
 $_ = 'abc';
 $c = chop($_);
-if ($c . $_ eq 'cab') {print "ok 2\n";} else {print "not ok 2\n";}
+is ($c . $_ , 'cab', 'unoptimized');
 
 sub foo {
     chop;
@@ -21,108 +23,152 @@ sub foo {
 @foo = ("hi \n","there\n","!\n");
 @bar = @foo;
 chop(@bar);
-print join('',@bar) eq 'hi there!' ? "ok 3\n" : "not ok 3\n";
+is (join('',@bar), 'hi there!');
 
 $foo = "\n";
 chop($foo,@foo);
-print join('',$foo,@foo) eq 'hi there!' ? "ok 4\n" : "not ok 4\n";
+is (join('',$foo,@foo), 'hi there!');
 
 $_ = "foo\n\n";
-print chomp() == 1 ? "ok 5\n" : "not ok 5\n";
-print $_ eq "foo\n" ? "ok 6\n" : "not ok 6\n";
+$got = chomp();
+ok ($got == 1) or print "# got $got\n";
+is ($_, "foo\n");
 
 $_ = "foo\n";
-print chomp() == 1 ? "ok 7\n" : "not ok 7\n";
-print $_ eq "foo" ? "ok 8\n" : "not ok 8\n";
+$got = chomp();
+ok ($got == 1) or print "# got $got\n";
+is ($_, "foo");
 
 $_ = "foo";
-print chomp() == 0 ? "ok 9\n" : "not ok 9\n";
-print $_ eq "foo" ? "ok 10\n" : "not ok 10\n";
+$got = chomp();
+ok ($got == 0) or print "# got $got\n";
+is ($_, "foo");
 
 $_ = "foo";
 $/ = "oo";
-print chomp() == 2 ? "ok 11\n" : "not ok 11\n";
-print $_ eq "f" ? "ok 12\n" : "not ok 12\n";
+$got = chomp();
+ok ($got == 2) or print "# got $got\n";
+is ($_, "f");
 
 $_ = "bar";
 $/ = "oo";
-print chomp() == 0 ? "ok 13\n" : "not ok 13\n";
-print $_ eq "bar" ? "ok 14\n" : "not ok 14\n";
+$got = chomp();
+ok ($got == 0) or print "# got $got\n";
+is ($_, "bar");
 
 $_ = "f\n\n\n\n\n";
 $/ = "";
-print chomp() == 5 ? "ok 15\n" : "not ok 15\n";
-print $_ eq "f" ? "ok 16\n" : "not ok 16\n";
+$got = chomp();
+ok ($got == 5) or print "# got $got\n";
+is ($_, "f");
 
 $_ = "f\n\n";
 $/ = "";
-print chomp() == 2 ? "ok 17\n" : "not ok 17\n";
-print $_ eq "f" ? "ok 18\n" : "not ok 18\n";
+$got = chomp();
+ok ($got == 2) or print "# got $got\n";
+is ($_, "f");
 
 $_ = "f\n";
 $/ = "";
-print chomp() == 1 ? "ok 19\n" : "not ok 19\n";
-print $_ eq "f" ? "ok 20\n" : "not ok 20\n";
+$got = chomp();
+ok ($got == 1) or print "# got $got\n";
+is ($_, "f");
 
 $_ = "f";
 $/ = "";
-print chomp() == 0 ? "ok 21\n" : "not ok 21\n";
-print $_ eq "f" ? "ok 22\n" : "not ok 22\n";
+$got = chomp();
+ok ($got == 0) or print "# got $got\n";
+is ($_, "f");
 
 $_ = "xx";
 $/ = "xx";
-print chomp() == 2 ? "ok 23\n" : "not ok 23\n";
-print $_ eq "" ? "ok 24\n" : "not ok 24\n";
+$got = chomp();
+ok ($got == 2) or print "# got $got\n";
+is ($_, "");
 
 $_ = "axx";
 $/ = "xx";
-print chomp() == 2 ? "ok 25\n" : "not ok 25\n";
-print $_ eq "a" ? "ok 26\n" : "not ok 26\n";
+$got = chomp();
+ok ($got == 2) or print "# got $got\n";
+is ($_, "a");
 
 $_ = "axx";
 $/ = "yy";
-print chomp() == 0 ? "ok 27\n" : "not ok 27\n";
-print $_ eq "axx" ? "ok 28\n" : "not ok 28\n";
+$got = chomp();
+ok ($got == 0) or print "# got $got\n";
+is ($_, "axx");
 
 # This case once mistakenly behaved like paragraph mode.
 $_ = "ab\n";
 $/ = \3;
-print chomp() == 0 ? "ok 29\n" : "not ok 29\n";
-print $_ eq "ab\n" ? "ok 30\n" : "not ok 30\n";
+$got = chomp();
+ok ($got == 0) or print "# got $got\n";
+is ($_, "ab\n");
 
 # Go Unicode.
 
 $_ = "abc\x{1234}";
 chop;
-print $_ eq "abc" ? "ok 31\n" : "not ok 31\n";
+is ($_, "abc", "Go Unicode");
 
 $_ = "abc\x{1234}d";
 chop;
-print $_ eq "abc\x{1234}" ? "ok 32\n" : "not ok 32\n";
+is ($_, "abc\x{1234}");
 
 $_ = "\x{1234}\x{2345}";
 chop;
-print $_ eq "\x{1234}" ? "ok 33\n" : "not ok 33\n";
+is ($_, "\x{1234}");
 
 my @stuff = qw(this that);
-print chop(@stuff[0,1]) eq 't' ? "ok 34\n" : "not ok 34\n";
+is (chop(@stuff[0,1]), 't');
 
 # bug id 20010305.012
 @stuff = qw(ab cd ef);
-print chop(@stuff = @stuff) eq 'f' ? "ok 35\n" : "not ok 35\n";
+is (chop(@stuff = @stuff), 'f');
 
 @stuff = qw(ab cd ef);
-print chop(@stuff[0, 2]) eq 'f' ? "ok 36\n" : "not ok 36\n";
+is (chop(@stuff[0, 2]), 'f');
 
 my %stuff = (1..4);
-print chop(@stuff{1, 3}) eq '4' ? "ok 37\n" : "not ok 37\n";
+is (chop(@stuff{1, 3}), '4');
 
 # chomp should not stringify references unless it decides to modify them
 $_ = [];
 $/ = "\n";
-print chomp() == 0 ? "ok 38\n" : "not ok 38\n";
-print ref($_) eq "ARRAY" ? "ok 39\n" : "not ok 39\n";
+$got = chomp();
+ok ($got == 0) or print "# got $got\n";
+is (ref($_), "ARRAY", "chomp ref (modify)");
 
 $/ = ")";  # the last char of something like "ARRAY(0x80ff6e4)"
-print chomp() == 1 ? "ok 40\n" : "not ok 40\n";
-print !ref($_) ? "ok 41\n" : "not ok 41\n";
+$got = chomp();
+ok ($got == 1) or print "# got $got\n";
+ok (!ref($_), "chomp ref (no modify)");
+
+$/ = "\n";
+
+%chomp = ("One" => "One", "Two\n" => "Two", "" => "");
+%chop = ("One" => "On", "Two\n" => "Two", "" => "");
+
+foreach (keys %chomp) {
+  my $key = $_;
+  eval {chomp $_};
+  if ($@) {
+    my $err = $@;
+    $err =~ s/\n$//s;
+    fail ("\$\@ = \"$err\"");
+  } else {
+    is ($_, $chomp{$key}, "chomp hash key");
+  }
+}
+
+foreach (keys %chop) {
+  my $key = $_;
+  eval {chop $_};
+  if ($@) {
+    my $err = $@;
+    $err =~ s/\n$//s;
+    fail ("\$\@ = \"$err\"");
+  } else {
+    is ($_, $chop{$key}, "chop hash key");
+  }
+}
diff --git a/t/op/magic.t b/t/op/magic.t
index f9df5bdfe0..ede0b8b2ef 100755
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -134,9 +134,9 @@ ok((keys %h)[0] eq "foo\034bar", (keys %h)[0]);
 }
 
 # $?, $@, $$
-system qq[$PERL -e "exit(0)"];
+system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(0)"];
 ok $? == 0, $?;
-system qq[$PERL -e "exit(1)"];
+system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(1)"];
 ok $? != 0, $?;
 
 eval { die "foo\n" };
@@ -251,9 +251,11 @@ else {
 }
 
 {
-    local $SIG{'__WARN__'} = sub { print "# @_\nnot " };
+    my $ok = 1;
+    my $warn = '';
+    local $SIG{'__WARN__'} = sub { $ok = 0; $warn = join '', @_; };
     $! = undef;
-    ok 1;
+    ok($ok, $warn, $Is_VMS ? "'\$!=undef' does throw a warning" : '');
 }
 
 # test case-insignificance of %ENV (these tests must be enabled only
diff --git a/t/op/stat.t b/t/op/stat.t
index 57112369fc..4f16b702ea 100755
--- a/t/op/stat.t
+++ b/t/op/stat.t
@@ -1,287 +1,365 @@
 #!./perl
 
-# $RCSfile: stat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:28 $
-
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
+    require './test.pl';
 }
 
 use Config;
+use File::Spec;
+
+plan tests => 69;
 
-print "1..59\n";
+my $Perl = which_perl;
 
+$Is_Amiga   = $^O eq 'amigaos';
+$Is_Cygwin  = $^O eq 'cygwin';
+$Is_Dos     = $^O eq 'dos';
+$Is_MPE     = $^O eq 'mpeix';
 $Is_MSWin32 = $^O eq 'MSWin32';
 $Is_NetWare = $^O eq 'NetWare';
-$Is_Dos = $^O eq 'dos';
-$Is_Cygwin = $^O eq 'cygwin';
-$Is_MPE = $^O eq 'mpeix';
-$Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32 || $Is_NetWare || $Is_Cygwin;
-chop($cwd = (($Is_MSWin32 || $Is_NetWare) ? `cd` : `pwd`));
-
-$DEV = `ls -l /dev` unless $Is_Dosish or $Is_Cygwin;
-
-unlink "Op.stat.tmp";
-if (open(FOO, ">Op.stat.tmp")) {
-  # hack to make Apollo update link count:
-  $junk = `ls Op.stat.tmp` unless ($Is_MSWin32 || $Is_NetWare || $Is_Dos);
-
-  ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
-   $blksize,$blocks) = stat(FOO);
-  if ($nlink == 1) {
-    print "ok 1\n";
-  }
-  else {
-    print "# res=$res, nlink=$nlink.\nnot ok 1\n";
-  }
-  if ($Is_MSWin32 or $Is_NetWare or $Is_Cygwin or $Is_Dos || ($mtime && $mtime == $ctime)) {
-    print "ok 2\n";
-  }
-  else {
-    print "# |$mtime| vs |$ctime|\nnot ok 2\n";
-  }
-
-  my $funky_FAT_timestamps = $Is_Cygwin;
-
-  sleep 3 if $funky_FAT_timestamps;
-
-  print FOO "Now is the time for all good men to come to.\n";
-  close(FOO);
-
-  sleep 2 unless $funky_FAT_timestamps;
-
-} else {
-  print "# open failed: $!\nnot ok 1\nnot ok 2\n";
-}
+$Is_OS2     = $^O eq 'os2';
+$Is_Solaris = $^O eq 'solaris';
+$Is_VMS     = $^O eq 'VMS';
 
-if ($Is_Dosish || $Is_MPE) { unlink "Op.stat.tmp2"}
-else {
-    `rm -f Op.stat.tmp2;ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`;
-}
+$Is_Dosish  = $Is_Dos || $Is_OS2 || $Is_MSWin32 || $Is_NetWare || $Is_Cygwin;
+
+my($DEV, $INO, $MODE, $NLINK, $UID, $GID, $RDEV, $SIZE,
+   $ATIME, $MTIME, $CTIME, $BLKSIZE, $BLOCKS) = (0..12);
+
+my $Curdir = File::Spec->curdir;
+
+
+my $tmpfile = 'Op_stat.tmp';
+my $tmpfile_link = $tmpfile.'2';
+
+
+unlink $tmpfile;
+open(FOO, ">$tmpfile") || BAILOUT("Can't open temp test file: $!");
+close FOO;
+
+open(FOO, ">$tmpfile") || BAILOUT("Can't open temp test file: $!");
 
-($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
-    $blksize,$blocks) = stat('Op.stat.tmp');
-
-if ($Is_Dosish || $Is_MPE || $Config{dont_use_nlink})
-    {print "ok 3 # skipped: no link count\n";} 
-elsif ($nlink == 2)
-    {print "ok 3\n";} 
-else {print "# \$nlink is |$nlink|\nnot ok 3\n";}
-
-if (   $Is_Dosish || $Is_MPE
-        # Solaris tmpfs bug
-	|| ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime && $^O eq 'solaris')
-    || $cwd =~ m#$Config{'afsroot'}/#
-	|| $^O eq 'amigaos') {
-    print "ok 4 # skipped: different semantic of mtime/ctime\n";
+my($nlink, $mtime, $ctime) = (stat(FOO))[$NLINK, $MTIME, $CTIME];
+SKIP: {
+    skip "No link count", 1 if $Is_VMS;
+
+    is($nlink, 1, 'nlink on regular file');
 }
-elsif (   ($mtime && $mtime != $ctime)  ) {
-    print "ok 4\n";
+
+SKIP: {
+  skip "mtime and ctime not reliable", 2 
+    if $Is_MSWin32 or $Is_NetWare or $Is_Cygwin or $Is_Dos;
+
+  ok( $mtime,           'mtime' );
+  is( $mtime, $ctime,   'mtime == ctime' );
 }
-else {
-    print "not ok 4\n";
-    print "#4 If test op/stat.t fails test 4, check if you are on a tmpfs\n";
-    print "#4 of some sort.  Building in /tmp sometimes has this problem.\n";
-    print "#4 Also building on the ClearCase VOBS filesystem may cause this failure.\n";
+
+
+# Cygwin seems to have a 3 second granularity on its timestamps.
+my $funky_FAT_timestamps = $Is_Cygwin;
+sleep 3 if $funky_FAT_timestamps;
+
+print FOO "Now is the time for all good men to come to.\n";
+close(FOO);
+
+sleep 2 unless $funky_FAT_timestamps;
+
+
+SKIP: {
+    unlink $tmpfile_link;
+    my $lnk_result = eval { link $tmpfile, $tmpfile_link };
+    skip "link() unimplemented", 6 if $@ =~ /unimplemented/;
+
+    is( $@, '',         'link() implemented' );
+    ok( $lnk_result,    'linked tmp testfile' );
+    ok( chmod(0644, $tmpfile),             'chmoded tmp testfile' );
+
+    my($nlink, $mtime, $ctime) = (stat($tmpfile))[$NLINK, $MTIME, $CTIME];
+
+    SKIP: {
+        skip "No link count", 1 if $Config{dont_use_nlink};
+        is($nlink, 2,     'Link count on hard linked file' );
+    }
+
+    SKIP: {
+        my $cwd = File::Spec->rel2abs($Curdir);
+        skip "Solaris tmpfs has different mtime/ctime link semantics", 2 
+                                     if $Is_Solaris and $cwd =~ m#^/tmp# and 
+                                        $mtime && $mtime == $ctime;
+        skip "AFS has different mtime/ctime link semantics", 2
+                                     if $cwd =~ m#$Config{'afsroot'}/#;
+        skip "AmigaOS has different mtime/ctime link semantics", 2
+                                     if $Is_Amiga;
+
+        if( !ok($mtime, 'hard link mtime') ||
+            !isnt($mtime, $ctime, 'hard link ctime != mtime') ) {
+            print <<DIAG;
+# Check if you are on a tmpfs of some sort.  Building in /tmp sometimes 
+# has this problem.  Also building on the ClearCase VOBS filesystem may 
+# cause this failure.
+DIAG
+        }
+    }
+
 }
-print "#4	:$mtime: should != :$ctime:\n";
-
-unlink "Op.stat.tmp" or print "# unlink failed: $!\n";
-if ($Is_MSWin32 || $Is_NetWare) {  open F, '>Op.stat.tmp' and close F }
-else             { `touch Op.stat.tmp` }
-
-if (-z 'Op.stat.tmp') {print "ok 5\n";} else {print "not ok 5\n";}
-if (! -s 'Op.stat.tmp') {print "ok 6\n";} else {print "not ok 6\n";}
-
-`echo hi >Op.stat.tmp`;
-if (! -z 'Op.stat.tmp') {print "ok 7\n";} else {print "not ok 7\n";}
-if (-s 'Op.stat.tmp') {print "ok 8\n";} else {print "not ok 8\n";}
-
-unlink 'Op.stat.tmp' or print "# unlink failed: $!\n";
-$olduid = $>;		# can't test -r if uid == 0
-`echo hi >Op.stat.tmp`;
-chmod 0,'Op.stat.tmp';
-eval '$> = 1;';		# so switch uid (may not be implemented)
-if (!$> || $Is_Dos || $Is_Cygwin || ! -r 'Op.stat.tmp') {print "ok 9\n";} else {print "not ok 9\n";}
-if (!$> || ! -w 'Op.stat.tmp') {print "ok 10\n";} else {print "not ok 10\n";}
-eval '$> = $olduid;';		# switch uid back (may not be implemented)
-print "# olduid=$olduid, newuid=$>\n" unless ($> == $olduid);
-
-if (! -x 'Op.stat.tmp') {print "ok 11\n";}
-else                    {print "not ok 11\n";}
-
-foreach ((12,13,14,15,16,17)) {
-    print "ok $_\n";		#deleted tests
+
+# truncate and touch $tmpfile.
+open(F, ">$tmpfile") || BAILOUT("Can't open temp test file: $!");
+close F;
+
+ok(-z $tmpfile,     '-z on empty file');
+ok(! -s $tmpfile,   '   and -s');
+
+open(F, ">$tmpfile") || BAILOUT("Can't open temp test file: $!");
+print F "hi\n";
+close F;
+
+ok(! -z $tmpfile,   '-z on non-empty file');
+ok(-s $tmpfile,     '   and -s');
+
+
+# Strip all access rights from the file.
+ok( chmod(0000, $tmpfile),     'chmod 0000' );
+
+SKIP: {
+    skip "-r, -w and -x have different meanings on VMS", 3 if $Is_VMS;
+
+    SKIP: {
+        # Going to try to switch away from root.  Might not work.
+        my $olduid = $>;
+        eval { $> = 1; };
+        skip "Can't test -r or -w meaningfully if you're superuser", 2 
+          if $> == 0;
+
+        SKIP: {
+            skip "Can't test -r meaningfully?", 1 if $Is_Dos || $Is_Cygwin;
+            ok(!-r $tmpfile,    "   -r");
+        }
+
+        ok(!-w $tmpfile,    "   -w");
+
+        # switch uid back (may not be implemented)
+        eval { $> = $olduid; };
+    }
+
+    ok(! -x $tmpfile,   '   -x');
 }
 
-# in ms windows, Op.stat.tmp inherits owner uid from directory
+
+
+
+# in ms windows, $tmpfile inherits owner uid from directory
 # not sure about os/2, but chown is harmless anyway
-eval { chown $>,'Op.stat.tmp'; 1 } or print "# $@" ;
-chmod 0700,'Op.stat.tmp';
-if (-r 'Op.stat.tmp') {print "ok 18\n";} else {print "not ok 18\n";}
-if (-w 'Op.stat.tmp') {print "ok 19\n";} else {print "not ok 19\n";}
-if ($Is_Dosish) {print "ok 20 # skipped: -x by extension\n";} 
-elsif (-x 'Op.stat.tmp') {print "ok 20\n";} 
-else {print "not ok 20\n";}
-
-if (-f 'Op.stat.tmp') {print "ok 21\n";} else {print "not ok 21\n";}
-if (! -d 'Op.stat.tmp') {print "ok 22\n";} else {print "not ok 22\n";}
-
-if (-d '.') {print "ok 23\n";} else {print "not ok 23\n";}
-if (! -f '.') {print "ok 24\n";} else {print "not ok 24\n";}
-
-if (!$Is_Dosish and `ls -l perl` =~ /^l.*->/) {
-    if (-l 'perl') {print "ok 25\n";} else {print "not ok 25\n";}
+eval { chown $>,$tmpfile; 1 } or print "# $@" ;
+
+ok(chmod(0700,$tmpfile),    'chmod 0700');
+ok(-r $tmpfile,     '   -r');
+ok(-w $tmpfile,     '   -w');
+
+SKIP: {
+    skip "-x simply determins if a file ends in an executable suffix", 1
+      if $Is_Dosish;
+
+    ok(-x $tmpfile,     '   -x');
 }
-else {
-    print "ok 25\n";
+
+ok(  -f $tmpfile,   '   -f');
+ok(! -d $tmpfile,   '   !-d');
+
+# Is this portable?
+ok(  -d $Curdir,          '-d cwd' );
+ok(! -f $Curdir,          '!-f cwd' );
+
+
+SKIP: {
+    unlink($tmpfile_link);
+    my $symlink_rslt = eval { symlink $tmpfile, $tmpfile_link };
+    skip "symlink not implemented", 3 if $@ =~ /unimplemented/;
+
+    is( $@, '',     'symlink() implemented' );
+    ok( $symlink_rslt,      'symlink() ok' );
+    ok(-l $tmpfile_link,    '-l');
 }
 
-if (-o 'Op.stat.tmp') {print "ok 26\n";} else {print "not ok 26\n";}
-
-if (-e 'Op.stat.tmp') {print "ok 27\n";} else {print "not ok 27\n";}
-unlink 'Op.stat.tmp2';
-if (! -e 'Op.stat.tmp2') {print "ok 28\n";} else {print "not ok 28\n";}
-
-if ($Is_MSWin32 || $Is_NetWare || $Is_Dos)
-    {print "ok 29\n";}
-elsif ($DEV !~ /\nc.* (\S+)\n/)
-    {print "ok 29\n";}
-elsif (-c "/dev/$1")
-    {print "ok 29\n";}
-else
-    {print "not ok 29\n";}
-if (! -c '.') {print "ok 30\n";} else {print "not ok 30\n";}
-
-if ($Is_MSWin32 || $Is_NetWare || $Is_Dos)
-    {print "ok 31\n";}
-elsif ($DEV !~ /\ns.* (\S+)\n/)
-    {print "ok 31\n";}
-elsif (-S "/dev/$1")
-    {print "ok 31\n";}
-else
-    {print "not ok 31\n";}
-if (! -S '.') {print "ok 32\n";} else {print "not ok 32\n";}
-
-if ($Is_MSWin32 || $Is_NetWare || $Is_Dos)
-    {print "ok 33\n";}
-elsif ($DEV !~ /\nb.* (\S+)\n/)
-    {print "ok 33\n";}
-elsif (-b "/dev/$1")
-    {print "ok 33\n";}
-else
-    {print "not ok 33\n";}
-if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";}
-
-if ($Is_MPE or $^O eq 'amigaos' or $Is_Dosish or $Is_Cygwin) {
-  print "ok 35 # skipped: no -u\n"; goto tty_test;
+ok(-o $tmpfile,     '-o');
+
+ok(-e $tmpfile,     '-e');
+
+unlink($tmpfile_link);
+ok(! -e $tmpfile_link,  '   -e on unlinked file');
+
+SKIP: {
+    skip "No character, socket or block special files", 3
+      if $Is_MSWin32 || $Is_NetWare || $Is_Dos;
+    skip "/dev isn't available to test against", 3
+      unless -d '/dev' && -r '/dev' && -x '/dev';
+
+    my $LS  = $Config{d_readlink} ? "ls -lL" : "ls -l"; 
+    my $CMD = "$LS /dev";
+    my $DEV = qx($CMD);
+
+    skip "$CMD failed", 3 if $DEV eq '';
+
+    my @DEV = do { my $dev; opendir($dev, "/dev") ? readdir($dev) : () };
+
+    skip "opendir failed: $!", 3 if @DEV == 0;
+
+    # /dev/stdout might be either character special or a named pipe,
+    # depending on which OS and how are you running the test, so let's
+    # censor that one away.
+    $DEV =~ s{^[cp].+?\bstdout$}{}m;
+    @DEV = grep { ! m{\bstdout$} } @DEV;
+
+    my $try = sub {
+	my @c1 = eval qq[\$DEV =~ /^$_[0]/mg];
+	my @c2 = eval qq[grep { $_[1] "/dev/\$_" } \@DEV];
+	my $c1 = scalar @c1;
+	my $c2 = scalar @c2;
+	is($c1, $c2, "ls and $_[1] agreeing on /dev ($c1 $c2)");
+    };
+
+    $try->('b', '-b');
+    $try->('c', '-c');
+    $try->('s', '-S');
 }
 
-$cnt = $uid = 0;
-
-die "Can't run op/stat.t test 35 without pwd working" unless $cwd;
-my @bin = grep {-d && -r && -x} ($^O eq 'machten' ?
-                                 qw(/usr/bin /bin) :
-                                 qw(/sbin /usr/sbin /bin /usr/bin));
-unless (@bin) { print ("not ok 35\n"), goto tty_test; }
-for my $bin (@bin) {
-    opendir BIN, $bin or die "Can't opendir $bin: $!";
-    while (defined($_ = readdir BIN)) {
-        $_ = "$bin/$_";
-        $cnt++;
-        $uid++ if -u;
-        last if $uid && $uid < $cnt;
+ok(! -b $Curdir,    '!-b cwd');
+ok(! -c $Curdir,    '!-c cwd');
+ok(! -S $Curdir,    '!-S cwd');
+
+SKIP: {
+    skip "No setuid", 3 if $Is_MPE or $Is_Amiga or $Is_Dosish or $Is_Cygwin;
+
+    my($cnt, $uid);
+    $cnt = $uid = 0;
+
+    # Find a set of directories that's very likely to have setuid files
+    # but not likely to be *all* setuid files.
+    my @bin = grep {-d && -r && -x} qw(/sbin /usr/sbin /bin /usr/bin);
+    skip "Can't find a setuid file to test with", 3 unless @bin;
+
+    for my $bin (@bin) {
+        opendir BIN, $bin or die "Can't opendir $bin: $!";
+        while (defined($_ = readdir BIN)) {
+            $_ = "$bin/$_";
+            $cnt++;
+            $uid++ if -u;
+            last if $uid && $uid < $cnt;
+        }
+    }
+    closedir BIN;
+
+    if( !isnt($cnt, 0,    'found some programs') ||
+        !isnt($uid, 0,    'found some setuid programs') ||
+        !ok($uid < $cnt,  "  they're not all setuid") )
+    {
+        print <<DIAG;
+# The above two tests assume that at least one of these directories
+# are readable, executable and contain at least one setuid file
+# (but aren't all setuid).
+#   @bin
+DIAG
     }
 }
-closedir BIN;
-
-# I suppose this is going to fail somewhere...
-if ($uid > 0 && $uid < $cnt)
-    {print "ok 35\n";}
-else
-    {print "not ok 35 \n# ($uid $cnt)\n";}
 
-tty_test:
 
 # To assist in automated testing when a controlling terminal (/dev/tty)
 # may not be available (at, cron  rsh etc), the PERL_SKIP_TTY_TEST env var
 # can be set to skip the tests that need a tty.
-unless($ENV{PERL_SKIP_TTY_TEST}) {
-    if ($Is_MSWin32 || $Is_NetWare) {
-	print "ok 36 # Skip: $^O\n";
-	print "ok 37 # Skip: $^O\n";
+SKIP: {
+    skip "These tests require a TTY", 4 if $ENV{PERL_SKIP_TTY_TEST};
+
+    my $TTY = $^O eq 'rhapsody' ? "/dev/ttyp0" : "/dev/tty";
+
+    SKIP: {
+        skip "Test uses unixisms", 2 if $Is_MSWin32 || $Is_NetWare;
+        skip "No TTY to test -t with", 2 unless -e $TTY;
+
+        open(TTY, $TTY) || 
+          warn "Can't open $TTY--run t/TEST outside of make.\n";
+        ok(-t TTY,  '-t');
+        ok(-c TTY,  'tty is -c');
+        close(TTY);
     }
-    else {
-	my $TTY = $^O eq 'rhapsody' ? "/dev/ttyp0" : "/dev/tty";
-	if (defined $TTY) {
-	    unless (open(TTY, $TTY)) {
-		print STDERR "Can't open $TTY--run t/TEST outside of make.\n";
-	    }
-	    if (-t TTY) {print "ok 36\n";} else {print "not ok 36\n";}
-	    if (-c TTY) {print "ok 37\n";} else {print "not ok 37\n";}
-	    close(TTY);
-	} else { # if some platform completely undefines $TTY
-	    print "ok 36 # skipped\n";
-	    print "ok 37 # skipped\n";
-	}
+    ok(! -t TTY,    '!-t on closed TTY filehandle');
+
+    {
+        local $TODO = 'STDIN not a tty when output is to pipe' if $Is_VMS;
+        ok(-t,          '-t on STDIN');
     }
-    if (! -t TTY) {print "ok 38\n";} else {print "not ok 38\n";}
-    if (-t)       {print "ok 39\n";} else {print "not ok 39\n";}
 }
-else {
-    for (36..39) { print "ok $_ # Skip: PERL_SKIP_TTY_TEST\n" }
+
+my $Null = File::Spec->devnull;
+SKIP: {
+    skip "No null device to test with", 1 unless -e $Null;
+
+    open(NULL, $Null) or BAIL_OUT("Can't open $Null: $!");
+    ok(! -t NULL,   'null device is not a TTY');
+    close(NULL);
 }
-open(null,"/dev/null");
-if (! -t null || -e '/xenix' || $^O eq 'machten' || $Is_MSWin32 || $Is_NetWare)
-	{print "ok 40\n";} else {print "not ok 40\n";}
-close(null);
+
 
 # These aren't strictly "stat" calls, but so what?
 
-if (-T 'op/stat.t') {print "ok 41\n";} else {print "not ok 41\n";}
-if (! -B 'op/stat.t') {print "ok 42\n";} else {print "not ok 42\n";}
+ok(-T 'op/stat.t',      '-T');
+ok(! -B 'op/stat.t',    '!-B');
 
-if (-B './perl' || -B './perl.exe') {print "ok 43\n";} else {print "not ok 43\n";}
-if (! -T './perl' && ! -T './perl.exe') {print "ok 44\n";} else {print "not ok 44\n";}
+ok(-B $Perl,      '-B');
+ok(! -T $Perl,    '!-T');
 
 open(FOO,'op/stat.t');
-eval { -T FOO; };
-if ($@ =~ /not implemented/) {
-    print "# $@";
-    for (45 .. 54) {
-	print "ok $_\n";
-    }
-}
-else {
-    if (-T FOO) {print "ok 45\n";} else {print "not ok 45\n";}
-    if (! -B FOO) {print "ok 46\n";} else {print "not ok 46\n";}
+SKIP: {
+    eval { -T FOO; };
+    skip "-T/B on filehandle not implemented", 15 if $@ =~ /not implemented/;
+
+    is( $@, '',     '-T on filehandle causes no errors' );
+
+    ok(-T FOO,      '   -T');
+    ok(! -B FOO,    '   !-B');
+
     $_ = <FOO>;
-    if (/perl/) {print "ok 47\n";} else {print "not ok 47\n";}
-    if (-T FOO) {print "ok 48\n";} else {print "not ok 48\n";}
-    if (! -B FOO) {print "ok 49\n";} else {print "not ok 49\n";}
+    ok(/perl/,      'after readline');
+    ok(-T FOO,      '   still -T');
+    ok(! -B FOO,    '   still -B');
     close(FOO);
 
     open(FOO,'op/stat.t');
     $_ = <FOO>;
-    if (/perl/) {print "ok 50\n";} else {print "not ok 50\n";}
-    if (-T FOO) {print "ok 51\n";} else {print "not ok 51\n";}
-    if (! -B FOO) {print "ok 52\n";} else {print "not ok 52\n";}
-    seek(FOO,0,0);
-    if (-T FOO) {print "ok 53\n";} else {print "not ok 53\n";}
-    if (! -B FOO) {print "ok 54\n";} else {print "not ok 54\n";}
+    ok(/perl/,      'reopened and after readline');
+    ok(-T FOO,      '   still -T');
+    ok(! -B FOO,    '   still !-B');
+
+    ok(seek(FOO,0,0),   'after seek');
+    ok(-T FOO,          '   still -T');
+    ok(! -B FOO,        '   still !-B');
+
+    # It's documented this way in perlfunc *shrug*
+    () = <FOO>;
+    ok(eof FOO,         'at EOF');
+    ok(-T FOO,          '   still -T');
+    ok(-B FOO,          '   now -B');
 }
 close(FOO);
 
-if (-T '/dev/null') {print "ok 55\n";} else {print "not ok 55\n";}
-if (-B '/dev/null') {print "ok 56\n";} else {print "not ok 56\n";}
+
+SKIP: {
+    skip "No null device to test with", 2 unless -e $Null;
+
+    ok(-T $Null,  'null device is -T');
+    ok(-B $Null,  '    and -B');
+}
+
 
 # and now, a few parsing tests:
-$_ = 'Op.stat.tmp';
-if (-f) {print "ok 57\n";} else {print "not ok 57\n";}
-if (-f()) {print "ok 58\n";} else {print "not ok 58\n";}
+$_ = $tmpfile;
+ok(-f,      'bare -f   uses $_');
+ok(-f(),    '     -f() "');
 
-unlink 'Op.stat.tmp' or print "# unlink failed: $!\n";
+unlink $tmpfile or print "# unlink failed: $!\n";
 
 # bug id 20011101.069
 my @r = \stat(".");
-if (@r == 13) { print "ok 59\n" } else { print "not ok 59\n" }
+is(scalar @r, 13,   'stat returns full 13 elements');
+
diff --git a/t/run/switches.t b/t/run/switches.t
index 04b9630622..67331b63cd 100644
--- a/t/run/switches.t
+++ b/t/run/switches.t
@@ -11,6 +11,10 @@ require "./test.pl";
 
 plan(tests => 14);
 
+# due to a bug in VMS's piping which makes it impossible for runperl()
+# to emulate echo -n, these tests almost totally fail.
+$TODO = "runperl() unable to emulate echo -n due to pipe bug" if $^O eq 'VMS';
+
 my $r;
 my @tmpfiles = ();
 END { unlink @tmpfiles }
@@ -63,6 +67,8 @@ is( $r, 'abc-def--ghi-jkl-mno--pq-/', '-0777 (slurp mode)' );
 
 my $filename = 'swctest.tmp';
 SKIP: {
+    local $TODO = '';   # this one works on VMS
+
     open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" );
     print $f <<'SWTEST';
 BEGIN { print "block 1\n"; }
@@ -122,7 +128,7 @@ SWTEST
 	progfile    => $filename,
 	args	    => [ '-x=foo' ],
     );
-    is( $r, 'foo', '-s on the #! line' );
+    is( $r, 'foo', '-s on the shebang line' );
     push @tmpfiles, $filename;
 }
 
@@ -151,7 +157,11 @@ SWTESTPM
 	switches    => [ '-mswtest' ],
 	prog	    => '1',
     );
-    is( $r, '', '-m' );
+
+    {
+        local $TODO = '';  # this one works on VMS
+        is( $r, '', '-m' );
+    }
     $r = runperl(
 	switches    => [ '-mswtest=foo,bar' ],
 	prog	    => '1',
diff --git a/t/test.pl b/t/test.pl
index ac6bbb7938..c5259de2e3 100644
--- a/t/test.pl
+++ b/t/test.pl
@@ -41,6 +41,8 @@ sub _ok {
     # VMS will avenge.
     my $out;
     if ($name) {
+        # escape out '#' or it will interfere with '# skip' and such
+        $name =~ s/#/\\#/g;
 	$out = $pass ? "ok $test - $name" : "not ok $test - $name";
     } else {
 	$out = $pass ? "ok $test" : "not ok $test";
@@ -265,31 +267,45 @@ sub BAILOUT {
 
 # A way to display scalars containing control characters and Unicode.
 sub display {
-    join("", map { $_ > 255 ? sprintf("\\x{%x}", $_) : chr($_) =~ /[[:cntrl:]]/ ? sprintf("\\%03o", $_) : chr($_) } unpack("U*", $_[0]));
+    map { join("", map { $_ > 255 ? sprintf("\\x{%x}", $_) : chr($_) =~ /[[:cntrl:]]/ ? sprintf("\\%03o", $_) : chr($_) } unpack("U*", $_)) } @_;
 }
 
 
 # A somewhat safer version of the sometimes wrong $^X.
-BEGIN: {
-    eval {
-        require File::Spec;
-        require Config;
-        Config->import;
-    };
-    warn "test.pl had problems loading other modules: $@" if $@;
-}
-
-# We do this at compile time before the test might have chdir'd around
-# and make sure its absolute in case they do later.
-my $Perl = $^X;
-$Perl = File::Spec->rel2abs(File::Spec->catfile(File::Spec->curdir(), $Perl))
-               if $^X eq "perl$Config{_exe}";
-warn "Can't generate which_perl from $^X" unless -f $Perl;
-
-# For subcommands to use.
-$ENV{PERLEXE} = $Perl;
-
+my $Perl;
 sub which_perl {
+    unless (defined $Perl) {
+	$Perl = $^X;
+	
+	my $exe;
+	eval "require Config; Config->import";
+	if ($@) {
+	    warn "test.pl had problems loading Config: $@";
+	    $exe = '';
+	} else {
+	    $exe = $Config{_exe};
+	}
+	
+	# This doesn't absolutize the path: beware of future chdirs().
+	# We could do File::Spec->abs2rel() but that does getcwd()s,
+	# which is a bit heavyweight to do here.
+	
+	if ($Perl =~ /^perl\Q$exe\E$/i) {
+	    my $perl = "perl$exe";
+	    eval "require File::Spec";
+	    if ($@) {
+		warn "test.pl had problems loading File::Spec: $@";
+		$Perl = "./$perl";
+	    } else {
+		$Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
+	    }
+	}
+	
+	warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
+	
+	# For subcommands to use.
+	$ENV{PERLEXE} = $Perl;
+    }
     return $Perl;
 }