1N/A#!/usr/bin/perl -w
1N/A
1N/ABEGIN {
1N/A if( $ENV{PERL_CORE} ) {
1N/A chdir 't';
1N/A @INC = ('../lib', 'lib/');
1N/A }
1N/A else {
1N/A unshift @INC, 't/lib/';
1N/A }
1N/A}
1N/Achdir 't';
1N/A
1N/ABEGIN {
1N/A $Testfile = 'testfile.foo';
1N/A}
1N/A
1N/ABEGIN {
1N/A 1 while unlink $Testfile, 'newfile';
1N/A # forcibly remove ecmddir/temp2, but don't import mkpath
1N/A use File::Path ();
1N/A File::Path::rmtree( 'ecmddir' );
1N/A}
1N/A
1N/ABEGIN {
1N/A use Test::More tests => 26;
1N/A use File::Spec;
1N/A}
1N/A
1N/ABEGIN {
1N/A # bad neighbor, but test_f() uses exit()
1N/A *CORE::GLOBAL::exit = ''; # quiet 'only once' warning.
1N/A *CORE::GLOBAL::exit = sub { return @_ };
1N/A use_ok( 'ExtUtils::Command' );
1N/A}
1N/A
1N/A{
1N/A # concatenate this file with itself
1N/A # be extra careful the regex doesn't match itself
1N/A use TieOut;
1N/A my $out = tie *STDOUT, 'TieOut';
1N/A my $self = $0;
1N/A unless (-f $self) {
1N/A my ($vol, $dirs, $file) = File::Spec->splitpath($self);
1N/A my @dirs = File::Spec->splitdir($dirs);
1N/A unshift(@dirs, File::Spec->updir);
1N/A $dirs = File::Spec->catdir(@dirs);
1N/A $self = File::Spec->catpath($vol, $dirs, $file);
1N/A }
1N/A @ARGV = ($self, $self);
1N/A
1N/A cat();
1N/A is( scalar( $$out =~ s/use_ok\( 'ExtUtils::Command'//g), 2,
1N/A 'concatenation worked' );
1N/A
1N/A # the truth value here is reversed -- Perl true is C false
1N/A @ARGV = ( $Testfile );
1N/A ok( test_f(), 'testing non-existent file' );
1N/A
1N/A @ARGV = ( $Testfile );
1N/A cmp_ok( ! test_f(), '==', (-f $Testfile), 'testing non-existent file' );
1N/A
1N/A # these are destructive, have to keep setting @ARGV
1N/A @ARGV = ( $Testfile );
1N/A touch();
1N/A
1N/A @ARGV = ( $Testfile );
1N/A ok( test_f(), 'now creating that file' );
1N/A
1N/A @ARGV = ( $Testfile );
1N/A ok( -e $ARGV[0], 'created!' );
1N/A
1N/A my ($now) = time;
1N/A utime ($now, $now, $ARGV[0]);
1N/A sleep 2;
1N/A
1N/A # Just checking modify time stamp, access time stamp is set
1N/A # to the beginning of the day in Win95.
1N/A # There's a small chance of a 1 second flutter here.
1N/A my $stamp = (stat($ARGV[0]))[9];
1N/A cmp_ok( abs($now - $stamp), '<=', 1, 'checking modify time stamp' ) ||
1N/A diag "mtime == $stamp, should be $now";
1N/A
1N/A @ARGV = qw(newfile);
1N/A touch();
1N/A
1N/A my $new_stamp = (stat('newfile'))[9];
1N/A cmp_ok( abs($new_stamp - $stamp), '>=', 2, 'newer file created' );
1N/A
1N/A @ARGV = ('newfile', $Testfile);
1N/A eqtime();
1N/A
1N/A $stamp = (stat($Testfile))[9];
1N/A cmp_ok( abs($new_stamp - $stamp), '<=', 1, 'eqtime' );
1N/A
1N/A # eqtime use to clear the contents of the file being equalized!
1N/A open(FILE, ">>$Testfile") || die $!;
1N/A print FILE "Foo";
1N/A close FILE;
1N/A
1N/A @ARGV = ('newfile', $Testfile);
1N/A eqtime();
1N/A ok( -s $Testfile, "eqtime doesn't clear the file being equalized" );
1N/A
1N/A SKIP: {
1N/A if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' ||
1N/A $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin' ||
1N/A $^O eq 'MacOS'
1N/A ) {
1N/A skip( "different file permission semantics on $^O", 3);
1N/A }
1N/A
1N/A # change a file to execute-only
1N/A @ARGV = ( '0100', $Testfile );
1N/A ExtUtils::Command::chmod();
1N/A
1N/A is( ((stat($Testfile))[2] & 07777) & 0700,
1N/A 0100, 'change a file to execute-only' );
1N/A
1N/A # change a file to read-only
1N/A @ARGV = ( '0400', $Testfile );
1N/A ExtUtils::Command::chmod();
1N/A
1N/A is( ((stat($Testfile))[2] & 07777) & 0700,
1N/A ($^O eq 'vos' ? 0500 : 0400), 'change a file to read-only' );
1N/A
1N/A # change a file to write-only
1N/A @ARGV = ( '0200', $Testfile );
1N/A ExtUtils::Command::chmod();
1N/A
1N/A is( ((stat($Testfile))[2] & 07777) & 0700,
1N/A ($^O eq 'vos' ? 0700 : 0200), 'change a file to write-only' );
1N/A }
1N/A
1N/A # change a file to read-write
1N/A @ARGV = ( '0600', $Testfile );
1N/A ExtUtils::Command::chmod();
1N/A
1N/A is( ((stat($Testfile))[2] & 07777) & 0700,
1N/A ($^O eq 'vos' ? 0700 : 0600), 'change a file to read-write' );
1N/A
1N/A # mkpath
1N/A @ARGV = ( File::Spec->join( 'ecmddir', 'temp2' ) );
1N/A ok( ! -e $ARGV[0], 'temp directory not there yet' );
1N/A
1N/A mkpath();
1N/A ok( -e $ARGV[0], 'temp directory created' );
1N/A
1N/A # copy a file to a nested subdirectory
1N/A unshift @ARGV, $Testfile;
1N/A cp();
1N/A
1N/A ok( -e File::Spec->join( 'ecmddir', 'temp2', $Testfile ), 'copied okay' );
1N/A
1N/A # cp should croak if destination isn't directory (not a great warning)
1N/A @ARGV = ( $Testfile ) x 3;
1N/A eval { cp() };
1N/A
1N/A like( $@, qr/Too many arguments/, 'cp croaks on error' );
1N/A
1N/A # move a file to a subdirectory
1N/A @ARGV = ( $Testfile, 'ecmddir' );
1N/A mv();
1N/A
1N/A ok( ! -e $Testfile, 'moved file away' );
1N/A ok( -e File::Spec->join( 'ecmddir', $Testfile ), 'file in new location' );
1N/A
1N/A # mv should also croak with the same wacky warning
1N/A @ARGV = ( $Testfile ) x 3;
1N/A
1N/A eval { mv() };
1N/A like( $@, qr/Too many arguments/, 'mv croaks on error' );
1N/A
1N/A # Test expand_wildcards()
1N/A {
1N/A my $file = $Testfile;
1N/A @ARGV = ();
1N/A chdir 'ecmddir';
1N/A
1N/A # % means 'match one character' on VMS. Everything else is ?
1N/A my $match_char = $^O eq 'VMS' ? '%' : '?';
1N/A ($ARGV[0] = $file) =~ s/.\z/$match_char/;
1N/A
1N/A # this should find the file
1N/A ExtUtils::Command::expand_wildcards();
1N/A
1N/A is_deeply( \@ARGV, [$file], 'expanded wildcard ? successfully' );
1N/A
1N/A # try it with the asterisk now
1N/A ($ARGV[0] = $file) =~ s/.{3}\z/\*/;
1N/A ExtUtils::Command::expand_wildcards();
1N/A
1N/A is_deeply( \@ARGV, [$file], 'expanded wildcard * successfully' );
1N/A
1N/A chdir File::Spec->updir;
1N/A }
1N/A
1N/A # remove some files
1N/A my @files = @ARGV = ( File::Spec->catfile( 'ecmddir', $Testfile ),
1N/A File::Spec->catfile( 'ecmddir', 'temp2', $Testfile ) );
1N/A rm_f();
1N/A
1N/A ok( ! -e $_, "removed $_ successfully" ) for (@ARGV);
1N/A
1N/A # rm_f dir
1N/A @ARGV = my $dir = File::Spec->catfile( 'ecmddir' );
1N/A rm_rf();
1N/A ok( ! -e $dir, "removed $dir successfully" );
1N/A}
1N/A
1N/AEND {
1N/A 1 while unlink $Testfile, 'newfile';
1N/A File::Path::rmtree( 'ecmddir' );
1N/A}