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                         last if $file =~ /^\w/;
  35                 }
  36         }
  37
  38         # this should find the file
  39         ($ARGV[0] = $file) =~ s/.\z/\?/;
  40         ExtUtils::Command::expand_wildcards();
  41
  42         is( scalar @ARGV, 1, 'found one file' );
  43         like( $ARGV[0], qr/$file/, 'expanded wildcard ? successfully' );
  44
  45         # try it with the asterisk now
  46         ($ARGV[0] = $file) =~ s/.{3}\z/\*/;
  47         ExtUtils::Command::expand_wildcards();
  48
  49         ok( (grep { qr/$file/ } @ARGV), 'expanded wildcard * successfully' );
  50
  51         # concatenate this file with itself
  52         # be extra careful the regex doesn't match itself
  53         my $out = tie *STDOUT, 'TieOut';
  54         my $self = $0;
  55         unless (-f $self) {
  56             my ($vol, $dirs, $file) = File::Spec->splitpath($self);
  57             my @dirs = File::Spec->splitdir($dirs);
  58             unshift(@dirs, File::Spec->updir);
  59             $dirs = File::Spec->catdir(@dirs);
  60             $self = File::Spec->catpath($vol, $dirs, $file);
  61         }
  62         @ARGV = ($self, $self);
  63
  64         cat();
  65         is( scalar( $$out =~ s/use_ok\( 'ExtUtils::Command'//g), 2,
  66                 'concatenation worked' );
  67
  68         # the truth value here is reversed -- Perl true is C false
  69         @ARGV = ( 'ecmdfile' );
  70         ok( test_f(), 'testing non-existent file' );
  71
  72         @ARGV = ( 'ecmdfile' );
  73         is( ! test_f(), (-f 'ecmdfile'), 'testing non-existent file' );
  74
  75         # these are destructive, have to keep setting @ARGV
  76         @ARGV = ( 'ecmdfile' );
  77         touch();
  78
  79         @ARGV = ( 'ecmdfile' );
  80         ok( test_f(), 'now creating that file' );
  81
  82         @ARGV = ( 'ecmdfile' );
  83         ok( -e $ARGV[0], 'created!' );
  84
  85         my ($now) = time;
  86         utime ($now, $now, $ARGV[0]);
  87
  88         # Just checking modify time stamp, access time stamp is set
  89         # to the beginning of the day in Win95
  90         is( (stat($ARGV[0]))[9], $now, 'checking modify time stamp' );
  91
  92         # change a file to read-only
  93         @ARGV = ( 0600, 'ecmdfile' );
  94         ExtUtils::Command::chmod();
  95
  96         is( ((stat('ecmdfile'))[2] & 07777) & 0700, 0600, 'change a file to read-only' );
  97
  98         # mkpath
  99         @ARGV = ( File::Spec->join( 'ecmddir', 'temp2' ) );
 100         ok( ! -e $ARGV[0], 'temp directory not there yet' );
 101
 102         mkpath();
 103         ok( -e $ARGV[0], 'temp directory created' );
 104
 105         # copy a file to a nested subdirectory
 106         unshift @ARGV, 'ecmdfile';
 107         cp();
 108
 109         ok( -e File::Spec->join( 'ecmddir', 'temp2', 'ecmdfile' ), 'copied okay' );
 110
 111         # cp should croak if destination isn't directory (not a great warning)
 112         @ARGV = ( 'ecmdfile' ) x 3;
 113         eval { cp() };
 114
 115         like( $@, qr/Too many arguments/, 'cp croaks on error' );
 116
 117         # move a file to a subdirectory
 118         @ARGV = ( 'ecmdfile', 'ecmddir' );
 119         mv();
 120
 121         ok( ! -e 'ecmdfile', 'moved file away' );
 122         ok( -e File::Spec->join( 'ecmddir', 'ecmdfile' ), 'file in new location' );
 123
 124         # mv should also croak with the same wacky warning
 125         @ARGV = ( 'ecmdfile' ) x 3;
 126
 127         eval { mv() };
 128         like( $@, qr/Too many arguments/, 'mv croaks on error' );
 129
 130         # remove some files
 131         my @files = @ARGV = ( File::Spec->catfile( 'ecmddir', 'ecmdfile' ),
 132         File::Spec->catfile( 'ecmddir', 'temp2', 'ecmdfile' ) );
 133         rm_f();
 134
 135         ok( ! -e $_, "removed $_ successfully" ) for (@ARGV);
 136
 137         # rm_f dir
 138         @ARGV = my $dir = File::Spec->catfile( 'ecmddir' );
 139         rm_rf();
 140         ok( ! -e $dir, "removed $dir successfully" );
 141 }
 142
 143 END {
 144         1 while unlink 'ecmdfile';
 145         File::Path::rmtree( 'ecmddir' );
 146 }
 147
 148 package TieOut;
 149
 150 sub TIEHANDLE {
 151         bless( \(my $text), $_[0] );
 152 }
 153
 154 sub PRINT {
 155         ${ $_[0] } .= join($/, @_);
 156 }