X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExtUtils%2Ft%2FCommand.t;h=ff9eec1da42156ad7eadba7d0bceefb4c6673ade;hb=d5d4ec93a4679c6ba299b53290a0903a25094cec;hp=7115bea50305a776aa75f10fc6f0f2b1c182b5b7;hpb=dec42cceed3dfc21e5d89a12d2d11ae956e881a0;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/ExtUtils/t/Command.t b/lib/ExtUtils/t/Command.t
index 7115bea..ff9eec1 100644
--- a/lib/ExtUtils/t/Command.t
+++ b/lib/ExtUtils/t/Command.t
@@ -1,9 +1,15 @@
-#!./perl -w
+#!/usr/bin/perl -w
 
 BEGIN {
-	chdir 't' if -d 't';
-	@INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib/');
+    }
+    else {
+        unshift @INC, 't/lib/';
+    }
 }
+chdir 't';
 
 BEGIN {
 	1 while unlink 'ecmdfile';
@@ -13,14 +19,13 @@ BEGIN {
 }
 
 BEGIN {
-	use Test::More tests => 21;
+	use Test::More tests => 24;
 	use File::Spec;
 }
 
 {
-	use vars qw( *CORE::GLOBAL::exit );
-
 	# bad neighbor, but test_f() uses exit()
+    *CORE::GLOBAL::exit = '';   # quiet 'only once' warning.
 	*CORE::GLOBAL::exit = sub { return @_ };
 
 	use_ok( 'ExtUtils::Command' );
@@ -36,8 +41,12 @@ BEGIN {
 		}
 	}
 
+
+    # % means 'match one character' on VMS.  Everything else is ?
+    my $match_char = $^O eq 'VMS' ? '%' : '?';
+	($ARGV[0] = $file) =~ s/.\z/$match_char/;
+
 	# this should find the file
-	($ARGV[0] = $file) =~ s/.\z/\?/;
 	ExtUtils::Command::expand_wildcards();
 
 	is( scalar @ARGV, 1, 'found one file' );
@@ -51,6 +60,7 @@ BEGIN {
 
 	# concatenate this file with itself
 	# be extra careful the regex doesn't match itself
+    use TieOut;
 	my $out = tie *STDOUT, 'TieOut';
 	my $self = $0;
 	unless (-f $self) {
@@ -71,7 +81,7 @@ BEGIN {
 	ok( test_f(), 'testing non-existent file' );
 
 	@ARGV = ( 'ecmdfile' );
-	is( ! test_f(), (-f 'ecmdfile'), 'testing non-existent file' );
+	cmp_ok( ! test_f(), '==', (-f 'ecmdfile'), 'testing non-existent file' );
 
 	# these are destructive, have to keep setting @ARGV
 	@ARGV = ( 'ecmdfile' );
@@ -91,14 +101,45 @@ BEGIN {
 	# to the beginning of the day in Win95.
     # There's a small chance of a 1 second flutter here.
     my $stamp = (stat($ARGV[0]))[9];
-	ok( abs($now - $stamp) <= 1, 'checking modify time stamp' ) ||
-      print "# mtime == $stamp, should be $now\n";
+	cmp_ok( abs($now - $stamp), '<=', 1, 'checking modify time stamp' ) ||
+      diag "mtime == $stamp, should be $now";
+
+    SKIP: {
+        if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' ||
+            $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin'  ||
+            $^O eq 'MacOS'
+           ) {
+            skip( "different file permission semantics on $^O", 3);
+        }
+
+        # change a file to execute-only
+        @ARGV = ( 0100, 'ecmdfile' );
+        ExtUtils::Command::chmod();
+
+        is( ((stat('ecmdfile'))[2] & 07777) & 0700,
+            0100, 'change a file to execute-only' );
+
+        # change a file to read-only
+        @ARGV = ( 0400, 'ecmdfile' );
+        ExtUtils::Command::chmod();
+
+        is( ((stat('ecmdfile'))[2] & 07777) & 0700,
+            ($^O eq 'vos' ? 0500 : 0400), 'change a file to read-only' );
 
-	# change a file to read-only
+        # change a file to write-only
+        @ARGV = ( 0200, 'ecmdfile' );
+        ExtUtils::Command::chmod();
+
+        is( ((stat('ecmdfile'))[2] & 07777) & 0700,
+            ($^O eq 'vos' ? 0700 : 0200), 'change a file to write-only' );
+    }
+
+    # change a file to read-write
 	@ARGV = ( 0600, 'ecmdfile' );
 	ExtUtils::Command::chmod();
 
-	is( ((stat('ecmdfile'))[2] & 07777) & 0700, 0600, 'change a file to read-only' );
+    is( ((stat('ecmdfile'))[2] & 07777) & 0700,
+        ($^O eq 'vos' ? 0700 : 0600), 'change a file to read-write' );
 
 	# mkpath
 	@ARGV = ( File::Spec->join( 'ecmddir', 'temp2' ) );
@@ -149,13 +190,3 @@ END {
 	1 while unlink 'ecmdfile';
 	File::Path::rmtree( 'ecmddir' );
 }
-
-package TieOut;
-
-sub TIEHANDLE {
-	bless( \(my $text), $_[0] );
-}
-
-sub PRINT {
-	${ $_[0] } .= join($/, @_);
-}