From de5a37b24d3c405a83300dc0afd66334b549f88c Mon Sep 17 00:00:00 2001 From: "Michael G. Schwern" Date: Tue, 4 Dec 2001 21:22:05 -0500 Subject: [PATCH] stat.t portability, the LAST VMS exception! Message-ID: <20011205022205.F14333@blackrider> p4raw-id: //depot/perl@13470 --- t/op/stat.t | 150 +++++++++++++++++++++++++++++++++++------------------------ vms/test.com | 14 +----- 2 files changed, 91 insertions(+), 73 deletions(-) diff --git a/t/op/stat.t b/t/op/stat.t index e60d410..3d4a95b 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -7,8 +7,9 @@ BEGIN { } use Config; +use File::Spec; -plan tests => 63; +plan tests => 73; $Is_Amiga = $^O eq 'amigaos'; $Is_Cygwin = $^O eq 'cygwin'; @@ -18,25 +19,25 @@ $Is_MSWin32 = $^O eq 'MSWin32'; $Is_NetWare = $^O eq 'NetWare'; $Is_OS2 = $^O eq 'os2'; $Is_Solaris = $^O eq 'solaris'; +$Is_VMS = $^O eq 'VMS'; $Is_Dosish = $Is_Dos || $Is_OS2 || $Is_MSWin32 || $Is_NetWare || $Is_Cygwin; -chop($cwd = (($Is_MSWin32 || $Is_NetWare) ? `cd` : `pwd`)); - -$Dev_list = `ls -l /dev` unless $Is_Dosish or $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 = 'Op_stat.tmp'; my $tmpfile_link = $tmpfile.'2'; unlink $tmpfile; open(FOO, ">$tmpfile") || BAILOUT("Can't open temp test file: $!"); +close FOO; -# hack to make Apollo update link count: -$junk = `ls $tmpfile` unless ($Is_MSWin32 || $Is_NetWare || $Is_Dos); +open(FOO, ">$tmpfile") || BAILOUT("Can't open temp test file: $!"); my($nlink, $mtime, $ctime) = (stat(FOO))[$NLINK, $MTIME, $CTIME]; is($nlink, 1, 'nlink on regular file'); @@ -62,10 +63,11 @@ sleep 2 unless $funky_FAT_timestamps; SKIP: { unlink $tmpfile_link; + my $lnk_result = eval { link $tmpfile, $tmpfile_link }; + skip "link() unimplemented", 6 if $@ =~ /unimplemented/; - skip "No hard links", 5 if $Is_Dosish || $Is_MPE; - - ok( link($tmpfile, $tmpfile_link), 'linked tmp testfile' ); + 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]; @@ -76,6 +78,7 @@ SKIP: { } 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; @@ -115,23 +118,30 @@ ok(-s $tmpfile, ' and -s'); ok( chmod(0000, $tmpfile), 'chmod 0000' ); 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 "-r, -w and -x have different meanings on VMS", 3 if $Is_VMS; SKIP: { - skip "Can't test -r meaningfully?", 1 if $Is_Dos || $Is_Cygwin; - ok(!-r $tmpfile, " -r"); - } + # 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"); + ok(!-w $tmpfile, " -w"); - # switch uid back (may not be implemented) - eval { $> = $olduid; }; + # switch uid back (may not be implemented) + eval { $> = $olduid; }; + } + + ok(! -x $tmpfile, ' -x'); } -ok(! -x $tmpfile, ' -x'); + # in ms windows, $tmpfile inherits owner uid from directory @@ -153,53 +163,60 @@ ok( -f $tmpfile, ' -f'); ok(! -d $tmpfile, ' !-d'); # Is this portable? -ok( -d '.', '-d cwd' ); -ok(! -f '.', '!-f cwd' ); +ok( -d $Curdir, '-d cwd' ); +ok(! -f $Curdir, '!-f cwd' ); + SKIP: { - skip "Test uses unixisms", 1 if $Is_Dosish; - skip "perl not a symlink", 1 unless `ls -l perl` =~ /^l.*->/; + unlink($tmpfile_link); + my $symlink_rslt = eval { symlink $tmpfile, $tmpfile_link }; + skip "symlink not implemented", 3 if $@ =~ /unimplemented/; - ok(-l 'perl', '-l'); + is( $@, '', 'symlink() implemented' ); + ok( $symlink_rslt, 'symlink() ok' ); + ok(-l $tmpfile_link, '-l'); } ok(-o $tmpfile, '-o'); ok(-e $tmpfile, '-e'); -ok(unlink($tmpfile_link), 'unlink'); + +unlink($tmpfile_link); ok(! -e $tmpfile_link, ' -e on unlinked file'); SKIP: { - skip "No character special files", 1 + skip "No character, socket or block special files", 7 if $Is_MSWin32 || $Is_NetWare || $Is_Dos; - skip "No character special files to test against", 1 - if $Dev_list !~ /\nc.* (\S+)\n/; + skip "/dev/ isn't available to test against", 7 + unless -d '/dev/' && -r '/dev/' && -x '/dev/'; + + opendir DEV, "/dev/" or BAILOUT("Can't open /dev/: $!"); + my($cnt, $char, $sock, $block); + $cnt = $char = $sock = $block = 0; + foreach (readdir DEV) { + my $file = "/dev/$_"; + $cnt++; + $char++ if -c $file; + $sock++ if -S $file; + $block++ if -b $file; + } - ok(-c "/dev/$1", '-c'); + isnt( $cnt, 0, 'Found some files in /dev/ to test against' ); + isnt( $char, 0, ' and some character special files' ); + isnt( $sock, 0, ' and some socket files' ); + isnt( $block, 0, ' and some block special files' ); + ok( $char < $cnt, " they're not all character special" ); + ok( $sock < $cnt, " they're not all sockets" ); + ok( $block < $cnt, " they're not all block special" ); } -ok(! -c '.', '!-c cwd'); -SKIP: { - skip "No socket files", 1 if $Is_MSWin32 || $Is_NetWare || $Is_Dos; - skip "No socket files to test against", 1 - if $Dev_list !~ /\ns.* (\S+)\n/; +ok(! -c $Curdir, '!-c cwd'); +ok(! -S $Curdir, '!-S cwd'); +ok(! -b $Curdir, '!-b cwd'); - ok(-S "/dev/$1", '-S'); -} -ok(! -S '.', '!-S cwd'); SKIP: { - skip "No block files", 1 if $Is_MSWin32 || $Is_NetWare || $Is_Dos; - skip "No block files to test against", 1 - if $Dev_list !~ /\nb.* (\S+)\n/; - - ok(-b "/dev/$1", '-b'); -} - -ok(! -b '.', '!-b cwd'); - -SKIP: { - skip "No setuid", 2 if $Is_MPE or $Is_Amiga or $Is_Dosish or $Is_Cygwin; + skip "No setuid", 3 if $Is_MPE or $Is_Amiga or $Is_Dosish or $Is_Cygwin; my($cnt, $uid); $cnt = $uid = 0; @@ -207,7 +224,7 @@ SKIP: { # 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", 2 unless @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: $!"; @@ -220,7 +237,8 @@ SKIP: { } closedir BIN; - if( !isnt($uid, 0, 'found some setuid programs') || + if( !isnt($cnt, 0, 'found some programs') || + !isnt($uid, 0, 'found some setuid programs') || !ok($uid < $cnt, " they're not all setuid") ) { print <devnull; SKIP: { - skip "No /dev/null to test with", 1 unless -e '/dev/null'; + skip "No null device to test with", 1 unless -e $Null; - open(NULL,"/dev/null") or BAIL_OUT("Can't open /dev/null equivalent: $!"); - ok(! -t NULL, '/dev/null is not a TTY'); + open(NULL, $Null) or BAIL_OUT("Can't open $Null: $!"); + ok(! -t NULL, 'null device is not a TTY'); close(NULL); } @@ -276,7 +294,7 @@ ok(! -T $^X, '!-T'); open(FOO,'op/stat.t'); SKIP: { eval { -T FOO; }; - skip "-T/B on filehandle not implemented", 12 if $@ =~ /not implemented/; + skip "-T/B on filehandle not implemented", 15 if $@ =~ /not implemented/; is( $@, '', '-T on filehandle causes no errors' ); @@ -296,14 +314,24 @@ SKIP: { ok(! -B FOO, ' still !-B'); ok(seek(FOO,0,0), 'after seek'); - ok(-T FOO, ' still -T'); - ok(! -B FOO, ' still !-B'); + ok(-T FOO, ' still -T'); + ok(! -B FOO, ' still !-B'); + + # It's documented this way in perlfunc *shrug* + () = ; + ok(eof FOO, 'at EOF'); + ok(-T FOO, ' still -T'); + ok(-B FOO, ' now -B'); } close(FOO); -ok(-T '/dev/null', '/dev/null is -T'); -ok(-B '/dev/null', ' and -B'); +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: diff --git a/vms/test.com b/vms/test.com index 11f6a30..7c2174f 100644 --- a/vms/test.com +++ b/vms/test.com @@ -102,7 +102,7 @@ $ PerlShr_filespec = f$parse("Sys$Disk:[-]''dbg'PerlShr''exe'") $ Define 'dbg'Perlshr 'PerlShr_filespec' $ MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p3'" "''p4'" "''p5'" "''p6'" $ Deck/Dollar=$$END-OF-TEST$$ -# $RCSfile: test.com,v $$Revision: 1.1 $$Date: 2001/11/13 00:26:19 $ +# $RCSfile: test.com,v $$Revision: 1.1 $$Date: 2001/12/05 06:53:37 $ # Modified for VMS 30-Sep-1994 Charles Bailey bailey@newman.upenn.edu # # This is written in a peculiar style, since we're trying to avoid @@ -114,9 +114,6 @@ $ Deck/Dollar=$$END-OF-TEST$$ use Config; use File::Spec; -@exclist=('exec.t','stat.t'); -foreach $file (@exclist) { $skip{$file}++; } - $| = 1; # Let tests know they're running in the perl core. Useful for modules @@ -137,17 +134,10 @@ if ($ARGV[0] eq '') { $_ = File::Spec->abs2rel($_); s/\[([a-z]+)/[.$1/; # hmm, abs2rel doesn't do subdirs of the cwd ($fname = $_) =~ s/.*\]//; - if ($skip{"\L$fname"}) { push(@skipped,$_); } - else { push(@ARGV,$_); } + push(@ARGV,$_); } } -if (@skipped) { - print "The following tests were skipped because they rely extensively on\n"; - print " Unixisms not compatible with the current version of perl for VMS:\n"; - print "\t",join("\n\t",@skipped),"\n\n"; -} - $bad = 0; $good = 0; $extra_skip = 0; -- 2.7.4