lib/ExtUtils/Command.t

   1 #!./perl -w
   2
   3 BEGIN {
   4         chdir 't' if -d 't';
   5         @INC = '../lib';
   6 }
   7
   8 BEGIN {
   9         1 while unlink 'ecmdfile';
  10         # forcibly remove ecmddir/temp2, but don't import mkpath
  11         use File::Path ();
  12         File::Path::rmtree( 'ecmddir' );
  13 }
  14
  15 BEGIN {
  16         use Test::More tests => 21;
  17         use File::Spec;
  18 }
  19
  20 {
  21         use vars qw( *CORE::GLOBAL::exit );
  22
  23         # bad neighbor, but test_f() uses exit()
  24         *CORE::GLOBAL::exit = sub { return @_ };
  25
  26         use_ok( 'ExtUtils::Command' );
  27
  28         # get a file in the current directory, replace last char with wildcard
  29         my $file;
  30         {
  31                 local *DIR;
  32                 opendir(DIR, File::Spec->curdir());
  33                 while ($file = readdir(DIR)) {
  34                         $file =~ s/\.\z// if $^O eq 'VMS';
  35                         last if $file =~ /^\w/;
  36                 }
  37         }
  38
  39         # this should find the file
  40         ($ARGV[0] = $file) =~ s/.\z/\?/;
  41         ExtUtils::Command::expand_wildcards();
  42
  43         is( scalar @ARGV, 1, 'found one file' );
  44         like( $ARGV[0], qr/$file/, 'expanded wildcard ? successfully' );
  45
  46         # try it with the asterisk now
  47         ($ARGV[0] = $file) =~ s/.{3}\z/\*/;
  48         ExtUtils::Command::expand_wildcards();
  49
  50         ok( (grep { qr/$file/ } @ARGV), 'expanded wildcard * successfully' );
  51
  52         # concatenate this file with itself
  53         # be extra careful the regex doesn't match itself
  54         my $out = tie *STDOUT, 'TieOut';
  55         my $self = $0;
  56         unless (-f $self) {
  57             my ($vol, $dirs, $file) = File::Spec->splitpath($self);
  58             my @dirs = File::Spec->splitdir($dirs);
  59             unshift(@dirs, File::Spec->updir);
  60             $dirs = File::Spec->catdir(@dirs);
  61             $self = File::Spec->catpath($vol, $dirs, $file);
  62         }
  63         @ARGV = ($self, $self);
  64
  65         cat();
  66         is( scalar( $$out =~ s/use_ok\( 'ExtUtils::Command'//g), 2,
  67                 'concatenation worked' );
  68
  69         # the truth value here is reversed -- Perl true is C false
  70         @ARGV = ( 'ecmdfile' );
  71         ok( test_f(), 'testing non-existent file' );
  72
  73         @ARGV = ( 'ecmdfile' );
  74         is( ! test_f(), (-f 'ecmdfile'), 'testing non-existent file' );
  75
  76         # these are destructive, have to keep setting @ARGV
  77         @ARGV = ( 'ecmdfile' );
  78         touch();
  79
  80         @ARGV = ( 'ecmdfile' );
  81         ok( test_f(), 'now creating that file' );
  82
  83         @ARGV = ( 'ecmdfile' );
  84         ok( -e $ARGV[0], 'created!' );
  85
  86         my ($now) = time;
  87         utime ($now, $now, $ARGV[0]);
  88     sleep 2;
  89
  90         # Just checking modify time stamp, access time stamp is set
  91         # to the beginning of the day in Win95.
  92     # There's a small chance of a 1 second flutter here.
  93     my $stamp = (stat($ARGV[0]))[9];
  94         ok( abs($now - $stamp) <= 1, 'checking modify time stamp' ) ||
  95       print "# mtime == $stamp, should be $now\n";
  96
  97         # change a file to read-only
  98         @ARGV = ( 0600, 'ecmdfile' );
  99         ExtUtils::Command::chmod();
 100
 101         is( ((stat('ecmdfile'))[2] & 07777) & 0700, 0600, 'change a file to read-only' );
 102
 103         # mkpath
 104         @ARGV = ( File::Spec->join( 'ecmddir', 'temp2' ) );
 105         ok( ! -e $ARGV[0], 'temp directory not there yet' );
 106
 107         mkpath();
 108         ok( -e $ARGV[0], 'temp directory created' );
 109
 110         # copy a file to a nested subdirectory
 111         unshift @ARGV, 'ecmdfile';
 112         cp();
 113
 114         ok( -e File::Spec->join( 'ecmddir', 'temp2', 'ecmdfile' ), 'copied okay' );
 115
 116         # cp should croak if destination isn't directory (not a great warning)
 117         @ARGV = ( 'ecmdfile' ) x 3;
 118         eval { cp() };
 119
 120         like( $@, qr/Too many arguments/, 'cp croaks on error' );
 121
 122         # move a file to a subdirectory
 123         @ARGV = ( 'ecmdfile', 'ecmddir' );
 124         mv();
 125
 126         ok( ! -e 'ecmdfile', 'moved file away' );
 127         ok( -e File::Spec->join( 'ecmddir', 'ecmdfile' ), 'file in new location' );
 128
 129         # mv should also croak with the same wacky warning
 130         @ARGV = ( 'ecmdfile' ) x 3;
 131
 132         eval { mv() };
 133         like( $@, qr/Too many arguments/, 'mv croaks on error' );
 134
 135         # remove some files
 136         my @files = @ARGV = ( File::Spec->catfile( 'ecmddir', 'ecmdfile' ),
 137         File::Spec->catfile( 'ecmddir', 'temp2', 'ecmdfile' ) );
 138         rm_f();
 139
 140         ok( ! -e $_, "removed $_ successfully" ) for (@ARGV);
 141
 142         # rm_f dir
 143         @ARGV = my $dir = File::Spec->catfile( 'ecmddir' );
 144         rm_rf();
 145         ok( ! -e $dir, "removed $dir successfully" );
 146 }
 147
 148 END {
 149         1 while unlink 'ecmdfile';
 150         File::Path::rmtree( 'ecmddir' );
 151 }
 152
 153 package TieOut;
 154
 155 sub TIEHANDLE {
 156         bless( \(my $text), $_[0] );
 157 }
 158
 159 sub PRINT {
 160         ${ $_[0] } .= join($/, @_);
 161 }