This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline
authorNick Ing-Simmons <nik@tiuk.ti.com>
Sat, 8 Dec 2001 14:11:12 +0000 (14:11 +0000)
committerNick Ing-Simmons <nik@tiuk.ti.com>
Sat, 8 Dec 2001 14:11:12 +0000 (14:11 +0000)
p4raw-id: //depot/perlio@13532

Changes
doop.c
patchlevel.h
pod/perluniintro.pod
t/op/chop.t
t/op/magic.t
t/op/stat.t
t/run/switches.t
t/test.pl

diff --git a/Changes b/Changes
index 1a4aed4..a1acafc 100644 (file)
--- a/Changes
+++ b/Changes
@@ -31,6 +31,184 @@ or any other branch.
 Version v5.7.2         Development release working toward v5.8
 --------------
 ____________________________________________________________________________
+[ 13519] By: jhi                                   on 2001/12/07  15:32:58
+        Log: Missing ).
+     Branch: perl
+          ! t/test.pl
+____________________________________________________________________________
+[ 13518] By: jhi                                   on 2001/12/07  15:24:32
+        Log: Allow several arguments to display().
+     Branch: perl
+          ! t/test.pl
+____________________________________________________________________________
+[ 13517] By: jhi                                   on 2001/12/07  15:19:20
+        Log: /dev/stdout could be either a character special file
+             or a named pipe, so let's pretend it doesn't exist.
+     Branch: perl
+          ! t/op/stat.t
+____________________________________________________________________________
+[ 13513] By: jhi                                   on 2001/12/07  14:58:06
+        Log: Add display() for displaying icky scalars.
+     Branch: perl
+          ! t/test.pl
+____________________________________________________________________________
+[ 13511] By: jhi                                   on 2001/12/07  14:40:58
+        Log: Subject: [ID 20011207.001] documentation bug for waitpid
+             From: Jan-Pieter Cornet <john@pc.xs4all.nl>
+             Date: Fri, 7 Dec 2001 12:44:56 +0100
+             Message-Id: <200112071144.MAA12790@pc.xs4all.nl>
+     Branch: perl
+          ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 13510] By: jhi                                   on 2001/12/07  14:38:39
+        Log: gcc version matching didn't.
+     Branch: perl
+          ! hints/linux.sh
+____________________________________________________________________________
+[ 13509] By: jhi                                   on 2001/12/07  14:21:33
+        Log: Subject: HP renamed their servers              
+             From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+             Date: Fri, 07 Dec 2001 12:07:22 +0100
+             Message-Id: <20011207120501.E16F.H.M.BRAND@hccnet.nl>
+     Branch: perl
+          ! README.hpux
+____________________________________________________________________________
+[ 13508] By: jhi                                   on 2001/12/07  14:01:41
+        Log: Subject: Re: [patch pod/perlport.pod] wrong escape
+             From: Ronald J Kimball <rjk@linguist.Thayer.dartmouth.edu>
+             Date: Fri, 7 Dec 2001 00:24:55 -0500
+             Message-ID: <20011207002455.D529632@linguist.thayer.dartmouth.edu>
+     Branch: perl
+          ! pod/perlport.pod
+____________________________________________________________________________
+[ 13507] By: jhi                                   on 2001/12/07  03:07:03
+        Log: Subject: [PATCH t/op/exec.t t/base/lex.t] Test For Echo, take 2
+             From: Michael G Schwern <schwern@pobox.com> 
+             Date: Thu, 6 Dec 2001 22:56:34 -0500
+             Message-ID: <20011207035634.GO22648@blackrider>
+     Branch: perl
+          ! t/base/lex.t t/op/exec.t
+____________________________________________________________________________
+[ 13506] By: jhi                                   on 2001/12/07  03:05:38
+        Log: Subject: [PATCH t/test.pl ...] which_perl for safer $^Xing
+             From: Michael G Schwern <schwern@pobox.com>
+             Date: Thu, 6 Dec 2001 22:45:44 -0500
+             Message-ID: <20011207034544.GN22648@blackrider>
+             
+             (plus op/ref tweak)
+     Branch: perl
+          ! t/comp/script.t t/io/open.t t/op/ref.t t/op/stat.t
+          ! t/run/kill_perl.t t/test.pl
+____________________________________________________________________________
+[ 13505] By: jhi                                   on 2001/12/07  01:30:25
+        Log: Upgrade to Math::BigInt 1.48.
+     Branch: perl
+          + lib/Math/BigInt/t/bare_mbi.t t/lib/Math/BigInt/BareCalc.pm
+          ! MANIFEST lib/Math/BigFloat.pm lib/Math/BigInt.pm
+          ! lib/Math/BigInt/Calc.pm lib/Math/BigInt/t/bigfltpm.inc
+          ! lib/Math/BigInt/t/bigfltpm.t lib/Math/BigInt/t/bigintc.t
+          ! lib/Math/BigInt/t/bigintpm.inc lib/Math/BigInt/t/bigintpm.t
+          ! lib/Math/BigInt/t/sub_mbf.t lib/Math/BigInt/t/sub_mbi.t
+          ! t/lib/Math/BigFloat/Subclass.pm t/lib/Math/BigInt/Subclass.pm
+____________________________________________________________________________
+[ 13504] By: jhi                                   on 2001/12/07  00:56:58
+        Log: Mention also perl56delta in case somone is upgrading from
+             Perl 5.005_03.
+     Branch: perl
+          ! pod/perldelta.pod
+____________________________________________________________________________
+[ 13503] By: jhi                                   on 2001/12/07  00:46:55
+        Log: Subject: [PATCH t/base/lex.t, term.t] Purging echo from base tests
+             From: Michael G Schwern <schwern@pobox.com>
+             Date: Thu, 6 Dec 2001 15:15:28 -0500
+             Message-ID: <20011206201528.GF16414@blackrider>
+             
+             (just the term.t, not the lex.t)
+             
+             Subject: [PATCH t/comp/script.t] Elimininating needless logic, runs from t/ now
+             From: Michael G Schwern <schwern@pobox.com>
+             Date: Thu, 6 Dec 2001 15:22:22 -0500
+             Message-ID: <20011206202222.GG16414@blackrider>
+             
+             Subject: [PATCH t/run/kill_perl.t] Eliminationg needless $^X logic
+             From: Michael G Schwern <schwern@pobox.com>
+             Date: Thu, 6 Dec 2001 15:31:58 -0500
+             Message-ID: <20011206203158.GI16414@blackrider>
+             
+             Subject: [PATCH t/io/open.t t/test.pl] Cleanup and echo purge
+             From: Michael G Schwern <schwern@pobox.com>
+             Date: Thu, 6 Dec 2001 17:38:55 -0500
+             Message-ID: <20011206223855.GC22648@blackrider>
+     Branch: perl
+          ! t/base/term.t t/comp/script.t t/io/open.t t/run/kill_perl.t
+          ! t/test.pl
+____________________________________________________________________________
+[ 13502] By: jhi                                   on 2001/12/06  22:15:49
+        Log: Update the thr5005 situation.
+     Branch: perl
+          ! pod/perldelta.pod
+____________________________________________________________________________
+[ 13501] By: jhi                                   on 2001/12/06  22:06:28
+        Log: perldelta borrowings from perl561delta.
+     Branch: perl
+          ! pod/perldelta.pod
+____________________________________________________________________________
+[ 13500] By: jhi                                   on 2001/12/06  21:21:59
+        Log: Add the 5.6.1 perldelta as perl561delta.
+             (Makes it easier to steal stuff for perldelta :-)
+     Branch: perl
+          + pod/perl561delta.pod
+          ! MANIFEST pod/buildtoc.PL pod/perl.pod pod/perltoc.pod
+____________________________________________________________________________
+[ 13499] By: jhi                                   on 2001/12/06  20:46:04
+        Log: Retract #13496 for now.
+     Branch: perl
+          ! t/base/lex.t t/base/term.t
+____________________________________________________________________________
+[ 13498] By: jhi                                   on 2001/12/06  20:16:04
+        Log: Subject: [PATCH per@13492] (was Re: [PATCH perl@13462]] VMS-only File::Spec->canonpath fix)
+             From: "Craig A. Berry" <craigberry@mac.com>
+             Date: Thu, 6 Dec 2001 14:54:36 -0600
+             Message-Id: <a05101000b8358a58eb28@[172.16.52.1]>
+     Branch: perl
+          ! vms/ext/filespec.t
+____________________________________________________________________________
+[ 13496] By: jhi                                   on 2001/12/06  19:47:53
+        Log: (retracted by #13499)
+             
+             Subject: [PATCH t/base/lex.t, term.t] Purging echo from base tests
+             From: Michael G Schwern <schwern@pobox.com>
+             Date: Thu, 6 Dec 2001 15:15:28 -0500
+             Message-ID: <20011206201528.GF16414@blackrider>
+     Branch: perl
+          ! t/base/lex.t t/base/term.t
+____________________________________________________________________________
+[ 13495] By: jhi                                   on 2001/12/06  17:56:15
+        Log: Subject: [PATCH t/op/stat.t] VMS has no link count
+             From: Michael G Schwern <schwern@pobox.com>
+             Date: Thu, 6 Dec 2001 13:54:48 -0500
+             Message-ID: <20011206185448.GC16414@blackrider>
+     Branch: perl
+          ! t/op/stat.t
+____________________________________________________________________________
+[ 13494] By: jhi                                   on 2001/12/06  17:54:14
+        Log: The #4 has nothing to do with Unicode.
+     Branch: perl
+          ! t/op/tr.t
+____________________________________________________________________________
+[ 13493] By: jhi                                   on 2001/12/06  17:52:43
+        Log: Subject: [PATCH t/op/tr.t] Cleanup and more counting tests
+             From: Michael G Schwern <schwern@pobox.com>
+             Date: Thu, 6 Dec 2001 13:45:48 -0500
+             Message-ID: <20011206184548.GB16414@blackrider>
+     Branch: perl
+          ! t/op/tr.t
+____________________________________________________________________________
+[ 13492] By: jhi                                   on 2001/12/06  15:47:08
+        Log: Update Changes.
+     Branch: perl
+          ! Changes patchlevel.h
+____________________________________________________________________________
 [ 13491] By: jhi                                   on 2001/12/06  15:43:22
         Log: Subject: [PATCH Perl@13462, on top of prev. multiplicity patch] MY_RAND workaround update
              From: lane@DUPHY4.Physics.Drexel.Edu (Charles Lane)
diff --git a/doop.c b/doop.c
index bc77201..9f0fa64 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -950,8 +950,14 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
             do_chop(astr,hv_iterval(hv,entry));
         return;
     }
-    else if (SvREADONLY(sv))
-       Perl_croak(aTHX_ PL_no_modify);
+    else if (SvREADONLY(sv)) {
+        if (SvFAKE(sv)) {
+            /* SV is copy-on-write */
+           sv_force_normal_flags(sv, 0);
+        }
+        if (SvREADONLY(sv))
+            Perl_croak(aTHX_ PL_no_modify);
+    }
     s = SvPV(sv, len);
     if (len && !SvPOK(sv))
        s = SvPV_force(sv, len);
@@ -1020,8 +1026,14 @@ Perl_do_chomp(pTHX_ register SV *sv)
             count += do_chomp(hv_iterval(hv,entry));
         return count;
     }
-    else if (SvREADONLY(sv))
-       Perl_croak(aTHX_ PL_no_modify);
+    else if (SvREADONLY(sv)) {
+        if (SvFAKE(sv)) {
+            /* SV is copy-on-write */
+           sv_force_normal_flags(sv, 0);
+        }
+        if (SvREADONLY(sv))
+            Perl_croak(aTHX_ PL_no_modify);
+    }
     s = SvPV(sv, len);
     if (s && len) {
        s += --len;
index 640501c..5456c15 100644 (file)
@@ -70,7 +70,7 @@
 #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
 static char    *local_patches[] = {
         NULL
-       ,"DEVEL13491"
+       ,"DEVEL13519"
        ,NULL
 };
 
index 7714d13..41d27ca 100644 (file)
@@ -274,8 +274,8 @@ the C<open> pragma; see L<open>:
 
 With the C<open> pragma you can use the C<:locale> discipline
 
-    $ENV{LANG} = 'ru_RU.KOI8-R';
-    # the :locale will probe the locale environment variables like LANG
+    $ENV{LC_ALL} = $ENV{LANG} = 'ru_RU.KOI8-R';
+    # the :locale will probe the locale environment variables like LC_ALL
     use open OUT => ':locale'; # russki parusski
     open(O, ">koi8");
     print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
@@ -303,10 +303,10 @@ streams, use explicit disciplines directly in the C<open()> call.
 You can switch encodings on an already opened stream by using
 C<binmode()>, see L<perlfunc/binmode>.
 
-The C<:locale> does not currently work with C<open()> and
-C<binmode()>, only with the C<open> pragma.  The C<:utf8> and
-C<:encoding(...)> do work with all of C<open()>, C<binmode()>,
-and the C<open> pragma.
+The C<:locale> does not currently (as of Perl 5.8.0) work with
+C<open()> and C<binmode()>, only with the C<open> pragma.  The
+C<:utf8> and C<:encoding(...)> do work with all of C<open()>,
+C<binmode()>, and the C<open> pragma.
 
 Similarly, you may use these I/O disciplines on input streams to
 automatically convert data from the specified encoding when it is
@@ -345,6 +345,27 @@ If you run this code twice, the contents of the F<file> will be twice
 UTF-8 encoded.  A C<use open ':utf8'> would have avoided the bug, or
 explicitly opening also the F<file> for input as UTF-8.
 
+=head2 Displaying Unicode As Text
+
+Sometimes you might want to display Perl scalars containing Unicode as
+simple ASCII (or EBCDIC) text.  The following subroutine will convert
+its argument so that Unicode characters with code points greater than
+255 are displayed as "\x{...}", control characters (like "\n") are
+displayed as "\x..", and the rest of the characters as themselves.
+
+sub nice_string {
+   join("",
+       map { $_ > 255 ?                        # if wide character...
+                 sprintf("\\x{%x}", $_) :      # \x{...}
+                 chr($_) =~ /[[:cntrl:]]/ ?    # else if control character ...
+                     sprintf("\\x%02x", $_) :  # \x..
+                      chr($_) }                        # else as themselves
+            unpack("U*", $_[0]));              # unpack Unicode characters
+}
+
+For example, C<nice_string("foo\x{100}bar\n")> will return
+C<"foo\x{100}bar\x0a">.
+
 =head2 Special Cases
 
 =over 4
index e8b777e..abb8aba 100755 (executable)
@@ -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");
+  }
+}
index f9df5bd..ede0b8b 100755 (executable)
@@ -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
index 5711236..4f16b70 100755 (executable)
 #!./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');
+
index 04b9630..67331b6 100644 (file)
@@ -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',
index ac6bbb7..c5259de 100644 (file)
--- 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;
 }