1#!/usr/bin/perl -w
2
3use strict;
4use warnings;
5
6my $Testfile;
7
8BEGIN {
9    unshift @INC, 't/lib/';
10}
11chdir 't';
12
13BEGIN {
14    $Testfile = 'testfile.foo';
15}
16
17BEGIN {
18    1 while unlink $Testfile, 'newfile';
19    # forcibly remove ecmddir/temp2, but don't import mkpath
20    use File::Path ();
21    File::Path::rmtree( 'ecmddir' ) if -e 'ecmddir';
22}
23
24use Test::More tests => 40;
25use File::Spec;
26
27BEGIN {
28    # bad neighbor, but test_f() uses exit()
29    *CORE::GLOBAL::exit = '';   # quiet 'only once' warning.
30    *CORE::GLOBAL::exit = sub (;$) { return $_[0] };
31    use_ok( 'ExtUtils::Command' );
32}
33
34{
35    # concatenate this file with itself
36    # be extra careful the regex doesn't match itself
37    use TieOut;
38    my $out = tie *STDOUT, 'TieOut';
39    my $self = $0;
40    unless (-f $self) {
41        my ($vol, $dirs, $file) = File::Spec->splitpath($self);
42        my @dirs = File::Spec->splitdir($dirs);
43        unshift(@dirs, File::Spec->updir);
44        $dirs = File::Spec->catdir(@dirs);
45        $self = File::Spec->catpath($vol, $dirs, $file);
46    }
47    @ARGV = ($self, $self);
48
49    cat();
50    is( scalar( $$out =~ s/use_ok\( 'ExtUtils::Command'//g), 2,
51        'concatenation worked' );
52
53    # the truth value here is reversed -- Perl true is shell false
54    @ARGV = ( $Testfile );
55    is( test_f(), 1, 'testing non-existent file' );
56
57    # these are destructive, have to keep setting @ARGV
58    @ARGV = ( $Testfile );
59    touch();
60
61    @ARGV = ( $Testfile );
62    is( test_f(), 0, 'testing touch() and test_f()' );
63    is_deeply( \@ARGV, [$Testfile], 'test_f preserves @ARGV' );
64
65    @ARGV = ( $Testfile );
66    ok( -e $ARGV[0], 'created!' );
67
68    my ($now) = time;
69    utime ($now, $now, $ARGV[0]);
70    sleep 2;
71
72    # Just checking modify time stamp, access time stamp is set
73    # to the beginning of the day in Win95.
74    # There's a small chance of a 1 second flutter here.
75    my $stamp = (stat($ARGV[0]))[9];
76    cmp_ok( abs($now - $stamp), '<=', 1, 'checking modify time stamp' ) ||
77      diag "mtime == $stamp, should be $now";
78
79    @ARGV = qw(newfile);
80    touch();
81
82    my $new_stamp = (stat('newfile'))[9];
83    cmp_ok( abs($new_stamp - $stamp), '>=', 2,  'newer file created' );
84
85    @ARGV = ('newfile', $Testfile);
86    eqtime();
87
88    $stamp = (stat($Testfile))[9];
89    cmp_ok( abs($new_stamp - $stamp), '<=', 1, 'eqtime' );
90
91    # eqtime use to clear the contents of the file being equalized!
92    open(FILE, ">>$Testfile") || die $!;
93    print FILE "Foo";
94    close FILE;
95
96    @ARGV = ('newfile', $Testfile);
97    eqtime();
98    ok( -s $Testfile, "eqtime doesn't clear the file being equalized" );
99
100    SKIP: {
101        if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' ||
102            $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin'  ||
103            $^O eq 'MacOS'
104           ) {
105            skip( "different file permission semantics on $^O", 3);
106        }
107
108        # change a file to execute-only
109        @ARGV = ( '0100', $Testfile );
110        ExtUtils::Command::chmod();
111
112        is( ((stat($Testfile))[2] & 07777) & 0700,
113            0100, 'change a file to execute-only' );
114
115        # change a file to read-only
116        @ARGV = ( '0400', $Testfile );
117        ExtUtils::Command::chmod();
118
119        is( ((stat($Testfile))[2] & 07777) & 0700,
120            0400, 'change a file to read-only' );
121
122        # change a file to write-only
123        @ARGV = ( '0200', $Testfile );
124        ExtUtils::Command::chmod();
125
126        is( ((stat($Testfile))[2] & 07777) & 0700,
127            0200, 'change a file to write-only' );
128    }
129
130    # change a file to read-write
131    @ARGV = ( '0600', $Testfile );
132    my @orig_argv = @ARGV;
133    ExtUtils::Command::chmod();
134    is_deeply( \@ARGV, \@orig_argv, 'chmod preserves @ARGV' );
135
136    is( ((stat($Testfile))[2] & 07777) & 0700,
137        0600, 'change a file to read-write' );
138
139
140    SKIP: {
141        if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' ||
142            $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin'  ||
143            $^O eq 'MacOS'   || $^O eq 'haiku'
144           ) {
145            skip( "different file permission semantics on $^O", 5);
146        }
147
148        @ARGV = ('testdir');
149        mkpath;
150        ok( -e 'testdir' );
151
152        # change a dir to execute-only
153        @ARGV = ( '0100', 'testdir' );
154        ExtUtils::Command::chmod();
155
156        is( ((stat('testdir'))[2] & 07777) & 0700,
157            0100, 'change a dir to execute-only' );
158
159        # change a dir to write-only
160        @ARGV = ( '0200', 'testdir' );
161        ExtUtils::Command::chmod();
162
163        is( ((stat('testdir'))[2] & 07777) & 0700,
164            0200, 'change a dir to write-only' );
165
166        # change a dir to read-only
167        @ARGV = ( '0400', 'testdir' );
168        ExtUtils::Command::chmod();
169
170        is( ((stat('testdir'))[2] & 07777) & 0700,
171            0400, 'change a dir to read-only' );
172
173        # remove the dir we've been playing with
174        @ARGV = ('testdir');
175        rm_rf;
176        ok( ! -e 'testdir', 'rm_rf can delete a read-only dir' );
177    }
178
179
180    # mkpath
181    my $test_dir = File::Spec->join( 'ecmddir', 'temp2' );
182    @ARGV = ( $test_dir );
183    ok( ! -e $ARGV[0], 'temp directory not there yet' );
184    is( test_d(), 1, 'testing non-existent directory' );
185
186    @ARGV = ( $test_dir );
187    mkpath();
188    ok( -e $ARGV[0], 'temp directory created' );
189    is( test_d(), 0, 'testing existing dir' );
190
191    @ARGV = ( $test_dir );
192    # copy a file to a nested subdirectory
193    unshift @ARGV, $Testfile;
194    @orig_argv = @ARGV;
195    cp();
196    is_deeply( \@ARGV, \@orig_argv, 'cp preserves @ARGV' );
197
198    ok( -e File::Spec->join( 'ecmddir', 'temp2', $Testfile ), 'copied okay' );
199
200    # cp should croak if destination isn't directory (not a great warning)
201    @ARGV = ( $Testfile ) x 3;
202    eval { cp() };
203
204    like( $@, qr/Too many arguments/, 'cp croaks on error' );
205
206    # move a file to a subdirectory
207    @ARGV = ( $Testfile, 'ecmddir' );
208    @orig_argv = @ARGV;
209    ok( mv() );
210    is_deeply( \@ARGV, \@orig_argv, 'mv preserves @ARGV' );
211
212    ok( ! -e $Testfile, 'moved file away' );
213    ok( -e File::Spec->join( 'ecmddir', $Testfile ), 'file in new location' );
214
215    # mv should also croak with the same wacky warning
216    @ARGV = ( $Testfile ) x 3;
217
218    eval { mv() };
219    like( $@, qr/Too many arguments/, 'mv croaks on error' );
220
221    # Test expand_wildcards()
222    {
223        my $file = $Testfile;
224        @ARGV = ();
225        chdir 'ecmddir';
226
227        # % means 'match one character' on VMS.  Everything else is ?
228        my $match_char = $^O eq 'VMS' ? '%' : '?';
229        ($ARGV[0] = $file) =~ s/.\z/$match_char/;
230
231        # this should find the file
232        ExtUtils::Command::expand_wildcards();
233
234        is_deeply( \@ARGV, [$file], 'expanded wildcard ? successfully' );
235
236        # try it with the asterisk now
237        ($ARGV[0] = $file) =~ s/.{3}\z/\*/;
238        ExtUtils::Command::expand_wildcards();
239
240        is_deeply( \@ARGV, [$file], 'expanded wildcard * successfully' );
241
242        chdir File::Spec->updir;
243    }
244
245    # remove some files
246    my @files = @ARGV = ( File::Spec->catfile( 'ecmddir', $Testfile ),
247    File::Spec->catfile( 'ecmddir', 'temp2', $Testfile ) );
248    rm_f();
249
250    ok( ! -e $_, "removed $_ successfully" ) for (@ARGV);
251
252    # rm_f dir
253    @ARGV = my $dir = File::Spec->catfile( 'ecmddir' );
254    rm_rf();
255    ok( ! -e $dir, "removed $dir successfully" );
256}
257
258{
259    { local @ARGV = 'd2utest'; mkpath; }
260    open(FILE, '>d2utest/foo');
261    binmode(FILE);
262    print FILE "stuff\015\012and thing\015\012";
263    close FILE;
264
265    open(FILE, '>d2utest/bar');
266    binmode(FILE);
267    my $bin = "\c@\c@\c@\c@\c@\c@\cA\c@\c@\c@\015\012".
268              "\@\c@\cA\c@\c@\c@8__LIN\015\012";
269    print FILE $bin;
270    close FILE;
271
272    local @ARGV = 'd2utest';
273    ExtUtils::Command::dos2unix();
274
275    open(FILE, 'd2utest/foo');
276    is( join('', <FILE>), "stuff\012and thing\012", 'dos2unix' );
277    close FILE;
278
279    open(FILE, 'd2utest/bar');
280    binmode(FILE);
281    ok( -B 'd2utest/bar' );
282    is( join('', <FILE>), $bin, 'dos2unix preserves binaries');
283    close FILE;
284}
285
286END {
287    1 while unlink $Testfile, 'newfile';
288    File::Path::rmtree( 'ecmddir' ) if -e 'ecmddir';
289    File::Path::rmtree( 'd2utest' ) if -e 'd2utest';
290}
291