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
  89         # Just checking modify time stamp, access time stamp is set
  90         # to the beginning of the day in Win95
  91         is( (stat($ARGV[0]))[9], $now, 'checking modify time stamp' );
  92
  93         # change a file to read-only
  94         @ARGV = ( 0600, 'ecmdfile' );
  95         ExtUtils::Command::chmod();
  96
  97         is( ((stat('ecmdfile'))[2] & 07777) & 0700, 0600, 'change a file to read-only' );
  98
  99         # mkpath
 100         @ARGV = ( File::Spec->join( 'ecmddir', 'temp2' ) );
 101         ok( ! -e $ARGV[0], 'temp directory not there yet' );
 102
 103         mkpath();
 104         ok( -e $ARGV[0], 'temp directory created' );
 105
 106         # copy a file to a nested subdirectory
 107         unshift @ARGV, 'ecmdfile';
 108         cp();
 109
 110         ok( -e File::Spec->join( 'ecmddir', 'temp2', 'ecmdfile' ), 'copied okay' );
 111
 112         # cp should croak if destination isn't directory (not a great warning)
 113         @ARGV = ( 'ecmdfile' ) x 3;
 114         eval { cp() };
 115
 116         like( $@, qr/Too many arguments/, 'cp croaks on error' );
 117
 118         # move a file to a subdirectory
 119         @ARGV = ( 'ecmdfile', 'ecmddir' );
 120         mv();
 121
 122         ok( ! -e 'ecmdfile', 'moved file away' );
 123         ok( -e File::Spec->join( 'ecmddir', 'ecmdfile' ), 'file in new location' );
 124
 125         # mv should also croak with the same wacky warning
 126         @ARGV = ( 'ecmdfile' ) x 3;
 127
 128         eval { mv() };
 129         like( $@, qr/Too many arguments/, 'mv croaks on error' );
 130
 131         # remove some files
 132         my @files = @ARGV = ( File::Spec->catfile( 'ecmddir', 'ecmdfile' ),
 133         File::Spec->catfile( 'ecmddir', 'temp2', 'ecmdfile' ) );
 134         rm_f();
 135
 136         ok( ! -e $_, "removed $_ successfully" ) for (@ARGV);
 137
 138         # rm_f dir
 139         @ARGV = my $dir = File::Spec->catfile( 'ecmddir' );
 140         rm_rf();
 141         ok( ! -e $dir, "removed $dir successfully" );
 142 }
 143
 144 END {
 145         1 while unlink 'ecmdfile';
 146         File::Path::rmtree( 'ecmddir' );
 147 }
 148
 149 package TieOut;
 150
 151 sub TIEHANDLE {
 152         bless( \(my $text), $_[0] );
 153 }
 154
 155 sub PRINT {
 156         ${ $_[0] } .= join($/, @_);
 157 }