Integrate stat.t from blead (suggested by Abe Timmerman), slightly modified
authorLeon Brocard <acme@astray.com>
Thu, 15 Jan 2004 17:04:55 +0000 (17:04 +0000)
committerLeon Brocard <acme@astray.com>
Thu, 15 Jan 2004 17:04:55 +0000 (17:04 +0000)
p4raw-id: //depot/maint-5.005/perl@22157

MANIFEST
t/op/stat.t
t/test.pl [new file with mode: 0644]

index 1e67e24..9efcac5 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1017,6 +1017,7 @@ t/pragma/strict.t See if strictures work
 t/pragma/subs.t                See if subroutine pseudo-importation works
 t/pragma/warn-1global  Tests of global warnings for warning.t
 t/pragma/warning.t     See if warning controls work
+t/test.pl               Testing framework
 taint.c                        Tainting code
 thrdvar.h              Per-thread variables
 thread.h               Threading header
index 2207b40..2e8f8bf 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';       # for which_perl() etc
 }
 
 use Config;
+use File::Spec;
+
+plan tests => 73;
 
-print "1..58\n";
+my $Perl = which_perl();
 
+$Is_Amiga   = $^O eq 'amigaos';
+$Is_Cygwin  = $^O eq 'cygwin';
+$Is_Darwin  = $^O eq 'darwin';
+$Is_Dos     = $^O eq 'dos';
+$Is_MacOS   = $^O eq 'MacOS';
+$Is_MPE     = $^O eq 'mpeix';
 $Is_MSWin32 = $^O eq 'MSWin32';
-$Is_Dos = $^O eq 'dos';
-$Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32;
-chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`));
+$Is_NetWare = $^O eq 'NetWare';
+$Is_OS2     = $^O eq 'os2';
+$Is_Solaris = $^O eq 'solaris';
+$Is_VMS     = $^O eq 'VMS';
+$Is_DGUX    = $^O eq 'dgux';
+$Is_MPRAS   = $^O =~ /svr4/ && -f '/etc/.relid';
+
+$Is_Dosish  = $Is_Dos || $Is_OS2 || $Is_MSWin32 || $Is_NetWare || $Is_Cygwin;
+
+$Is_UFS     = $Is_Darwin && (() = `df -t ufs .`) == 2;
+
+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';
+
+
+1 while unlink $tmpfile;
+open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!");
+close FOO;
 
-$DEV = `ls -l /dev` unless $Is_Dosish;
+open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!");
 
-unlink "Op.stat.tmp";
-open(FOO, ">Op.stat.tmp");
+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');
+}
+
+SKIP: {
+  skip "mtime and ctime not reliable", 2
+    if $Is_MSWin32 or $Is_NetWare or $Is_Cygwin or $Is_Dos or $Is_MacOS;
+
+  ok( $mtime,           'mtime' );
+  is( $mtime, $ctime,   'mtime == ctime' );
+}
 
-# hack to make Apollo update link count:
-$junk = `ls Op.stat.tmp` unless ($Is_MSWin32 || $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 "not ok 1\n";}
-if ($Is_MSWin32 || ($mtime && $mtime == $ctime)) {print "ok 2\n";}
-else {print "# |$mtime| vs |$ctime|\nnot ok 2\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;
+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};
+        skip "Cygwin9X fakes hard links by copying", 1
+          if $Config{myuname} =~ /^cygwin_(?:9\d|me)\b/i;
+
+        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;
+        # Win32 could pass $mtime test but as FAT and NTFS have
+        # no ctime concept $ctime is ALWAYS == $mtime
+        # expect netware to be the same ...
+        skip "No ctime concept on this OS", 2
+                                     if $Is_MSWin32 || 
+                                        ($Is_Darwin && $Is_UFS);
+
+        if( !ok($mtime, 'hard link mtime') ||
+            !isnt($mtime, $ctime, 'hard link ctime != mtime') ) {
+            print STDERR <<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.
+# Darwins UFS doesn't have a ctime concept, and thus is
+# expected to fail this test.
+DIAG
+        }
+    }
 
-if ($Is_Dosish) { unlink "Op.stat.tmp2" }
-else {
-    `rm -f Op.stat.tmp2;ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`;
 }
 
-($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
-    $blksize,$blocks) = stat('Op.stat.tmp');
+# truncate and touch $tmpfile.
+open(F, ">$tmpfile") || DIE("Can't open temp test file: $!");
+close F;
+
+ok(-z $tmpfile,     '-z on empty file');
+ok(! -s $tmpfile,   '   and -s');
+
+open(F, ">$tmpfile") || DIE("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;
 
-if ($Is_Dosish || $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
-       || ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime) # Solaris tmpfs bug
-       || $cwd =~ m#/afs/#
-       || $^O eq 'amigaos') {
-    print "ok 4 # skipped: different semantic of mtime/ctime\n";
+    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');
 }
-elsif (   ($mtime && $mtime != $ctime)  ) {
-    print "ok 4\n";
+
+
+
+
+# in ms windows, $tmpfile inherits owner uid from directory
+# not sure about os/2, but chown is harmless anyway
+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 || $Is_MacOS;
+
+    ok(-x $tmpfile,     '   -x');
 }
-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      :$mtime: should != :$ctime:\n";
-
-unlink "Op.stat.tmp";
-if ($Is_MSWin32) {  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";}
-
-$Is_MSWin32 ? `cmd /c echo hi > Op.stat.tmp` : `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';
-$olduid = $>;          # can't test -r if uid == 0
-$Is_MSWin32 ? `cmd /c echo hi > Op.stat.tmp` : `echo hi >Op.stat.tmp`;
-chmod 0,'Op.stat.tmp';
-eval '$> = 1;';                # so switch uid (may not be implemented)
-if (!$> || $Is_Dos || ! -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);
+ok(  -f $tmpfile,   '   -f');
+ok(! -d $tmpfile,   '   !-d');
+
+# Is this portable?
+ok(  -d $Curdir,          '-d cwd' );
+ok(! -f $Curdir,          '!-f cwd' );
 
-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
+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');
 }
 
-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";}
+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", 6
+      if $Is_MSWin32 || $Is_NetWare || $Is_Dos;
+    skip "/dev isn't available to test against", 6
+      unless -d '/dev' && -r '/dev' && -x '/dev';
+    skip "Skipping; unexpected ls output in MP-RAS", 6
+      if $Is_MPRAS;
+
+    my $LS  = $Config{d_readlink} ? "ls -lL" : "ls -l";
+    my $CMD = "$LS /dev 2>/dev/null";
+    my $DEV = qx($CMD);
+
+    skip "$CMD failed", 6 if $DEV eq '';
+
+    my @DEV = do { opendir(DEV, "/dev") ? readdir(DEV) : () };
 
-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";}
+    skip "opendir failed: $!", 6 if @DEV == 0;
 
-if (-d '.') {print "ok 23\n";} else {print "not ok 23\n";}
-if (! -f '.') {print "ok 24\n";} else {print "not ok 24\n";}
+    # /dev/stdout might be either character special or a named pipe,
+    # or a symlink, or a socket, depending on which OS and how are
+    # you running the test, so let's censor that one away.
+    # Similar remarks hold for stderr.
+    $DEV =~ s{^[cpls].+?\sstdout$}{}m;
+    @DEV =  grep { $_ ne 'stdout' } @DEV;
+    $DEV =~ s{^[cpls].+?\sstderr$}{}m;
+    @DEV =  grep { $_ ne 'stderr' } @DEV;
+
+    # /dev/printer is also naughty: in IRIX it shows up as
+    # Srwx-----, not srwx------.
+    $DEV =~ s{^.+?\sprinter$}{}m;
+    @DEV =  grep { $_ ne 'printer' } @DEV;
+
+    # If running as root, we will see .files in the ls result,
+    # and readdir() will see them always.  Potential for conflict,
+    # so let's weed them out.
+    $DEV =~ s{^.+?\s\..+?$}{}m;
+    @DEV =  grep { ! m{^\..+$} } @DEV;
+
+    # Irix ls -l marks sockets with 'S' while 's' is a 'XENIX semaphore'.
+    if ($^O eq 'irix') {
+        $DEV =~ s{^S(.+?)}{s$1}mg;
+    }
+
+    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)");
+    };
+
+SKIP: {
+    skip("DG/UX ls -L broken", 3) if $Is_DGUX;
+
+    $try->('b', '-b');
+    $try->('c', '-c');
+    $try->('s', '-S');
 
-if (!$Is_Dosish and `ls -l perl` =~ /^l.*->/) {
-    if (-l 'perl') {print "ok 25\n";} else {print "not ok 25\n";}
 }
-else {
-    print "ok 25\n";
+
+ok(! -b $Curdir,    '!-b cwd');
+ok(! -c $Curdir,    '!-c cwd');
+ok(! -S $Curdir,    '!-S cwd');
+
 }
 
-if (-o 'Op.stat.tmp') {print "ok 26\n";} else {print "not ok 26\n";}
+SKIP: {
+    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 (-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";}
+    skip "No setuid programs", 3 if $uid == 0;
 
-if ($Is_MSWin32 || $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";}
+    isnt($cnt, 0,    'found some programs');
+    isnt($uid, 0,    '  found some setuid programs');
+    ok($uid < $cnt,  "    they're not all setuid");
+}
 
-if ($Is_MSWin32 || $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_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 ($^O eq 'amigaos' or $Is_Dosish) {
-  print "ok 35 # skipped: no -u\n"; goto tty_test;
-}
-
-$cnt = $uid = 0;
-
-die "Can't run op/stat.t test 35 without pwd working" unless $cwd;
-($bin) = grep {-d} ($^O eq 'machten' ? qw(/usr/bin /bin) : qw(/bin /usr/bin))
-    or print ("not ok 35\n"), goto tty_test;
-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;
-
-# 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) {
-       print "ok 36\n";
-       print "ok 37\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 {
-       unless (open(tty,"/dev/tty")) {
-           print STDERR "Can't open /dev/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);
+    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 {
-    print "ok 36\n";
-    print "ok 37\n";
-    print "ok 38\n";
-    print "ok 39\n";
+
+my $Null = File::Spec->devnull;
+SKIP: {
+    skip "No null device to test with", 1 unless -e $Null;
+    skip "We know Win32 thinks '$Null' is a TTY", 1 if $Is_MSWin32;
+
+    open(NULL, $Null) or DIE("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)
-       {print "ok 40\n";} else {print "not ok 40\n";}
-close(null);
+
 
 # These aren't strictly "stat" calls, but so what?
+my $statfile = File::Spec->catfile($Curdir, 'op', 'stat.t');
+ok(  -T $statfile,    '-T');
+ok(! -B $statfile,    '!-B');
 
-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";}
+SKIP: {
+     skip("DG/UX", 1) if $Is_DGUX;
+ok(-B $Perl,      '-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(! -T $Perl,    '!-T');
+
+open(FOO,$statfile);
+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');
 
-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";}
     $_ = <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";}
+    like($_, qr/perl/, 'after readline');
+    ok(-T FOO,      '   still -T');
+    ok(! -B FOO,    '   still -B');
     close(FOO);
 
-    open(FOO,'op/stat.t');
+    open(FOO,$statfile);
     $_ = <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";}
+    like($_, qr/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";}
 
-# 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";}
+SKIP: {
+    skip "No null device to test with", 2 unless -e $Null;
 
-unlink 'Op.stat.tmp';
+    ok(-T $Null,  'null device is -T');
+    ok(-B $Null,  '    and -B');
+}
+
+
+# and now, a few parsing tests:
+$_ = $tmpfile;
+ok(-f,      'bare -f   uses $_');
+ok(-f(),    '     -f() "');
+
+unlink $tmpfile or print "# unlink failed: $!\n";
+
+print "# Zzz...\n";
+sleep(3);
+my $f = 'tstamp.tmp';
+unlink $f;
+ok (open(S, "> $f"), 'can create tmp file');
+close S or die;
+my @a = stat $f;
+print "# time=$^T, stat=(@a)\n";
+my @b = (-M _, -A _, -C _);
+print "# -MAC=(@b)\n";
+ok( (-M _) < 0, 'negative -M works');
+ok( (-A _) < 0, 'negative -A works');
+ok( (-C _) < 0, 'negative -C works');
+ok(unlink($f), 'unlink tmp file');
+
+END {
+    1 while unlink $tmpfile;
+}
diff --git a/t/test.pl b/t/test.pl
new file mode 100644 (file)
index 0000000..9d930c5
--- /dev/null
+++ b/t/test.pl
@@ -0,0 +1,611 @@
+#
+# t/test.pl - most of Test::More functionality without the fuss
+#
+
+$Level = 1;
+my $test = 1;
+my $planned;
+
+$TODO = 0;
+$NO_ENDING = 0;
+
+sub plan {
+    my $n;
+    if (@_ == 1) {
+       $n = shift;
+    } else {
+       my %plan = @_;
+       $n = $plan{tests}; 
+    }
+    print STDOUT "1..$n\n";
+    $planned = $n;
+}
+
+END {
+    my $ran = $test - 1;
+    if (!$NO_ENDING && defined $planned && $planned != $ran) {
+        print STDERR "# Looks like you planned $planned tests but ran $ran.\n";
+    }
+}
+
+# Use this instead of "print STDERR" when outputing failure diagnostic 
+# messages
+sub _diag {
+    return unless @_;
+    my @mess = map { /^#/ ? "$_\n" : "# $_\n" } 
+               map { split /\n/ } @_;
+    my $fh = $TODO ? *STDOUT : *STDERR;
+    print $fh @mess;
+
+}
+
+sub skip_all {
+    if (@_) {
+       print STDOUT "1..0 # Skipped: @_\n";
+    } else {
+       print STDOUT "1..0\n";
+    }
+    exit(0);
+}
+
+sub _ok {
+    my ($pass, $where, $name, @mess) = @_;
+    # Do not try to microoptimize by factoring out the "not ".
+    # VMS will avenge.
+    my $out = pass ? "ok $test" : "not ok $test";
+
+    $out .= " # TODO $TODO" if $TODO;
+    print STDOUT "$out\n";
+
+    unless ($pass) {
+       _diag "# Failed $where\n";
+    }
+
+    # Ensure that the message is properly escaped.
+    _diag @mess;
+
+    $test++;
+
+    return $pass;
+}
+
+sub _where {
+    my @caller = caller($Level);
+    return "at $caller[1] line $caller[2]";
+}
+
+# DON'T use this for matches. Use like() instead.
+sub ok ($@) {
+    my ($pass, $name, @mess) = @_;
+    _ok($pass, _where(), $name, @mess);
+}
+
+sub _q {
+    my $x = shift;
+    return 'undef' unless defined $x;
+    my $q = $x;
+    $q =~ s/\\/\\\\/;
+    $q =~ s/'/\\'/;
+    return "'$q'";
+}
+
+sub _qq {
+    my $x = shift;
+    return defined $x ? '"' . display ($x) . '"' : 'undef';
+};
+
+# keys are the codes \n etc map to, values are 2 char strings such as \n
+my %backslash_escape;
+foreach my $x (split //, 'nrtfa\\\'"') {
+    $backslash_escape{ord eval "\"\\$x\""} = "\\$x";
+}
+# A way to display scalars containing control characters and Unicode.
+# Trying to avoid setting $_, or relying on local $_ to work.
+sub display {
+    my @result;
+    foreach my $x (@_) {
+        if (defined $x and not ref $x) {
+            my $y = '';
+            foreach my $c (unpack("U*", $x)) {
+                if ($c > 255) {
+                    $y .= sprintf "\\x{%x}", $c;
+                } elsif ($backslash_escape{$c}) {
+                    $y .= $backslash_escape{$c};
+                } else {
+                    my $z = chr $c; # Maybe we can get away with a literal...
+                    $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/;
+                    $y .= $z;
+                }
+            }
+            $x = $y;
+        }
+        return $x unless wantarray;
+        push @result, $x;
+    }
+    return @result;
+}
+
+sub is ($$@) {
+    my ($got, $expected, $name, @mess) = @_;
+
+    my $pass;
+    if( !defined $got || !defined $expected ) {
+        # undef only matches undef
+        $pass = !defined $got && !defined $expected;
+    }
+    else {
+        $pass = $got eq $expected;
+    }
+
+    unless ($pass) {
+       unshift(@mess, "#      got "._q($got)."\n",
+                      "# expected "._q($expected)."\n");
+    }
+    _ok($pass, _where(), $name, @mess);
+}
+
+sub isnt ($$@) {
+    my ($got, $isnt, $name, @mess) = @_;
+
+    my $pass;
+    if( !defined $got || !defined $isnt ) {
+        # undef only matches undef
+        $pass = defined $got || defined $isnt;
+    }
+    else {
+        $pass = $got ne $isnt;
+    }
+
+    unless( $pass ) {
+        unshift(@mess, "# it should not be "._q($got)."\n",
+                       "# but it is.\n");
+    }
+    _ok($pass, _where(), $name, @mess);
+}
+
+sub cmp_ok ($$$@) {
+    my($got, $type, $expected, $name, @mess) = @_;
+
+    my $pass;
+    {
+        local $^W = 0;
+        local($@,$!);   # don't interfere with $@
+                        # eval() sometimes resets $!
+        $pass = eval "\$got $type \$expected";
+    }
+    unless ($pass) {
+        # It seems Irix long doubles can have 2147483648 and 2147483648
+        # that stringify to the same thing but are acutally numerically
+        # different. Display the numbers if $type isn't a string operator,
+        # and the numbers are stringwise the same.
+        # (all string operators have alphabetic names, so tr/a-z// is true)
+        # This will also show numbers for some uneeded cases, but will
+        # definately be helpful for things such as == and <= that fail
+        if ($got eq $expected and $type !~ tr/a-z//) {
+            unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
+        }
+        unshift(@mess, "#      got "._q($got)."\n",
+                       "# expected $type "._q($expected)."\n");
+    }
+    _ok($pass, _where(), $name, @mess);
+}
+
+# Check that $got is within $range of $expected
+# if $range is 0, then check it's exact
+# else if $expected is 0, then $range is an absolute value
+# otherwise $range is a fractional error.
+# Here $range must be numeric, >= 0
+# Non numeric ranges might be a useful future extension. (eg %)
+sub within ($$$@) {
+    my ($got, $expected, $range, $name, @mess) = @_;
+    my $pass;
+    if (!defined $got or !defined $expected or !defined $range) {
+        # This is a fail, but doesn't need extra diagnostics
+    } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) {
+        # This is a fail
+        unshift @mess, "# got, expected and range must be numeric\n";
+    } elsif ($range < 0) {
+        # This is also a fail
+        unshift @mess, "# range must not be negative\n";
+    } elsif ($range == 0) {
+        # Within 0 is ==
+        $pass = $got == $expected;
+    } elsif ($expected == 0) {
+        # If expected is 0, treat range as absolute
+        $pass = ($got <= $range) && ($got >= - $range);
+    } else {
+        my $diff = $got - $expected;
+        $pass = abs ($diff / $expected) < $range;
+    }
+    unless ($pass) {
+        if ($got eq $expected) {
+            unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
+        }
+       unshift@mess, "#      got "._q($got)."\n",
+                     "# expected "._q($expected)." (within "._q($range).")\n";
+    }
+    _ok($pass, _where(), $name, @mess);
+}
+
+# Note: this isn't quite as fancy as Test::More::like().
+sub like ($$@) {
+    my ($got, $expected, $name, @mess) = @_;
+    my $pass;
+    if (ref $expected eq 'Regexp') {
+       $pass = $got =~ $expected;
+       unless ($pass) {
+           unshift(@mess, "#      got '$got'\n",
+                          "# expected /$expected/\n");
+       }
+    } else {
+       $pass = $got =~ /$expected/;
+       unless ($pass) {
+           unshift(@mess, "#      got '$got'\n",
+                          "# expected /$expected/\n");
+       }
+    }
+    _ok($pass, _where(), $name, @mess);
+}
+
+sub pass {
+    _ok(1, '', @_);
+}
+
+sub fail {
+    _ok(0, _where(), @_);
+}
+
+sub curr_test {
+    $test = shift if @_;
+    return $test;
+}
+
+sub next_test {
+  $test++;
+}
+
+# Note: can't pass multipart messages since we try to
+# be compatible with Test::More::skip().
+sub skip {
+    my $why = shift;
+    my $n    = @_ ? shift : 1;
+    for (1..$n) {
+        print STDOUT "ok $test # skip: $why\n";
+        $test++;
+    }
+    local $^W = 0;
+    last SKIP;
+}
+
+sub eq_array {
+    my ($ra, $rb) = @_;
+    return 0 unless $#$ra == $#$rb;
+    for my $i (0..$#$ra) {
+       return 0 unless $ra->[$i] eq $rb->[$i];
+    }
+    return 1;
+}
+
+sub eq_hash {
+  my ($orig, $suspect) = @_;
+  my $fail;
+  while (my ($key, $value) = each %$suspect) {
+    # Force a hash recompute if this perl's internals can cache the hash key.
+    $key = "" . $key;
+    if (exists $orig->{$key}) {
+      if ($orig->{$key} ne $value) {
+        print STDOUT "# key ", _qq($key), " was ", _qq($orig->{$key}),
+                     " now ", _qq($value), "\n";
+        $fail = 1;
+      }
+    } else {
+      print STDOUT "# key ", _qq($key), " is ", _qq($value), 
+                   ", not in original.\n";
+      $fail = 1;
+    }
+  }
+  foreach (keys %$orig) {
+    # Force a hash recompute if this perl's internals can cache the hash key.
+    $_ = "" . $_;
+    next if (exists $suspect->{$_});
+    print STDOUT "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
+    $fail = 1;
+  }
+  !$fail;
+}
+
+sub require_ok ($) {
+    my ($require) = @_;
+    eval <<REQUIRE_OK;
+require $require;
+REQUIRE_OK
+    _ok(!$@, _where(), "require $require");
+}
+
+sub use_ok ($) {
+    my ($use) = @_;
+    eval <<USE_OK;
+use $use;
+USE_OK
+    _ok(!$@, _where(), "use $use");
+}
+
+# runperl - Runs a separate perl interpreter.
+# Arguments :
+#   switches => [ command-line switches ]
+#   nolib    => 1 # don't use -I../lib (included by default)
+#   prog     => one-liner (avoid quotes)
+#   progs    => [ multi-liner (avoid quotes) ]
+#   progfile => perl script
+#   stdin    => string to feed the stdin
+#   stderr   => redirect stderr to stdout
+#   args     => [ command-line arguments to the perl program ]
+#   verbose  => print the command line
+
+my $is_mswin    = $^O eq 'MSWin32';
+my $is_netware  = $^O eq 'NetWare';
+my $is_macos    = $^O eq 'MacOS';
+my $is_vms      = $^O eq 'VMS';
+
+sub _quote_args {
+    my ($runperl, $args) = @_;
+
+    foreach (@$args) {
+       # In VMS protect with doublequotes because otherwise
+       # DCL will lowercase -- unless already doublequoted.
+       $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0;
+       $$runperl .= ' ' . $_;
+    }
+}
+
+sub _create_runperl { # Create the string to qx in runperl().
+    my %args = @_;
+    my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
+    unless ($args{nolib}) {
+       if ($is_macos) {
+           $runperl .= ' -I::lib';
+           # Use UNIX style error messages instead of MPW style.
+           $runperl .= ' -MMac::err=unix' if $args{stderr};
+       }
+       else {
+           $runperl .= ' "-I../lib"'; # doublequotes because of VMS
+       }
+    }
+    if ($args{switches}) {
+       local $Level = 2;
+       die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where()
+           unless ref $args{switches} eq "ARRAY";
+       _quote_args(\$runperl, $args{switches});
+    }
+    if (defined $args{prog}) {
+       die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where()
+           if defined $args{progs};
+        $args{progs} = [$args{prog}]
+    }
+    if (defined $args{progs}) {
+       die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where()
+           unless ref $args{progs} eq "ARRAY";
+        foreach my $prog (@{$args{progs}}) {
+            if ($is_mswin || $is_netware || $is_vms) {
+                $runperl .= qq ( -e "$prog" );
+            }
+            else {
+                $runperl .= qq ( -e '$prog' );
+            }
+        }
+    } elsif (defined $args{progfile}) {
+       $runperl .= qq( "$args{progfile}");
+    }
+    if (defined $args{stdin}) {
+       # so we don't try to put literal newlines and crs onto the
+       # command line.
+       $args{stdin} =~ s/\n/\\n/g;
+       $args{stdin} =~ s/\r/\\r/g;
+
+       if ($is_mswin || $is_netware || $is_vms) {
+           $runperl = qq{$^X -e "print qq(} .
+               $args{stdin} . q{)" | } . $runperl;
+       }
+       elsif ($is_macos) {
+           # MacOS can only do two processes under MPW at once;
+           # the test itself is one; we can't do two more, so
+           # write to temp file
+           my $stdin = qq{$^X -e 'print qq(} . $args{stdin} . qq{)' > teststdin; };
+           if ($args{verbose}) {
+               my $stdindisplay = $stdin;
+               $stdindisplay =~ s/\n/\n\#/g;
+               print STDERR "# $stdindisplay\n";
+           }
+           `$stdin`;
+           $runperl .= q{ < teststdin };
+       }
+       else {
+           $runperl = qq{$^X -e 'print qq(} .
+               $args{stdin} . q{)' | } . $runperl;
+       }
+    }
+    if (defined $args{args}) {
+       _quote_args(\$runperl, $args{args});
+    }
+    $runperl .= ' 2>&1'          if  $args{stderr} && !$is_macos;
+    $runperl .= " \xB3 Dev:Null" if !$args{stderr} &&  $is_macos;
+    if ($args{verbose}) {
+       my $runperldisplay = $runperl;
+       $runperldisplay =~ s/\n/\n\#/g;
+       print STDERR "# $runperldisplay\n";
+    }
+    return $runperl;
+}
+
+sub runperl {
+    my $runperl = &_create_runperl;
+    my $result = `$runperl`;
+    $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
+    return $result;
+}
+
+*run_perl = \&runperl; # Nice alias.
+
+sub DIE {
+    print STDERR "# @_\n";
+    exit 1;
+}
+
+# A somewhat safer version of the sometimes wrong $^X.
+my $Perl;
+sub which_perl {
+    unless (defined $Perl) {
+       $Perl = $^X;
+       
+       # VMS should have 'perl' aliased properly
+       return $Perl if $^O eq 'VMS';
+
+       my $exe;
+       eval "require Config; Config->import";
+       if ($@) {
+           warn "test.pl had problems loading Config: $@";
+           $exe = '';
+       } else {
+           $exe = $Config{_exe};
+       }
+       $exe = '' unless defined $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);
+           }
+       }
+
+       # Build up the name of the executable file from the name of
+       # the command.
+
+       if ($Perl !~ /\Q$exe\E$/i) {
+           $Perl .= $exe;
+       }
+
+       warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
+       
+       # For subcommands to use.
+       $ENV{PERLEXE} = $Perl;
+    }
+    return $Perl;
+}
+
+sub unlink_all {
+    foreach my $file (@_) {
+        1 while unlink $file;
+        print STDERR "# Couldn't unlink '$file': $!\n" if -f $file;
+    }
+}
+
+
+my $tmpfile = "misctmp000";
+1 while -f ++$tmpfile;
+END { unlink_all $tmpfile }
+
+#
+# _fresh_perl
+#
+# The $resolve must be a subref that tests the first argument
+# for success, or returns the definition of success (e.g. the
+# expected scalar) if given no arguments.
+#
+
+sub _fresh_perl {
+    my($prog, $resolve, $runperl_args, $name) = @_;
+
+    $runperl_args ||= {};
+    $runperl_args->{progfile} = $tmpfile;
+    $runperl_args->{stderr} = 1;
+
+    open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
+
+    # VMS adjustments
+    if( $^O eq 'VMS' ) {
+        $prog =~ s#/dev/null#NL:#;
+
+        # VMS file locking 
+        $prog =~ s{if \(-e _ and -f _ and -r _\)}
+                  {if (-e _ and -f _)}
+    }
+
+    print TEST $prog, "\n";
+    close TEST or die "Cannot close $tmpfile: $!";
+
+    my $results = runperl(%$runperl_args);
+    my $status = $?;
+
+    # Clean up the results into something a bit more predictable.
+    $results =~ s/\n+$//;
+    $results =~ s/at\s+misctmp\d+\s+line/at - line/g;
+    $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g;
+
+    # bison says 'parse error' instead of 'syntax error',
+    # various yaccs may or may not capitalize 'syntax'.
+    $results =~ s/^(syntax|parse) error/syntax error/mig;
+
+    if ($^O eq 'VMS') {
+        # some tests will trigger VMS messages that won't be expected
+        $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
+
+        # pipes double these sometimes
+        $results =~ s/\n\n/\n/g;
+    }
+
+    my $pass = $resolve->($results);
+    unless ($pass) {
+        _diag "# PROG: \n$prog\n";
+        _diag "# EXPECTED:\n", $resolve->(), "\n";
+        _diag "# GOT:\n$results\n";
+        _diag "# STATUS: $status\n";
+    }
+
+    # Use the first line of the program as a name if none was given
+    unless( $name ) {
+        ($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
+        $name .= '...' if length $first_line > length $name;
+    }
+
+    _ok($pass, _where(), "fresh_perl - $name");
+}
+
+#
+# fresh_perl_is
+#
+# Combination of run_perl() and is().
+#
+
+sub fresh_perl_is {
+    my($prog, $expected, $runperl_args, $name) = @_;
+    local $Level = 2;
+    _fresh_perl($prog,
+               sub { @_ ? $_[0] eq $expected : $expected },
+               $runperl_args, $name);
+}
+
+#
+# fresh_perl_like
+#
+# Combination of run_perl() and like().
+#
+
+sub fresh_perl_like {
+    my($prog, $expected, $runperl_args, $name) = @_;
+    local $Level = 2;
+    _fresh_perl($prog,
+               sub { @_ ?
+                         $_[0] =~ (ref $expected ? $expected : /$expected/) :
+                         $expected },
+               $runperl_args, $name);
+}
+
+1;