1package ExtUtils::Command;
2
3use 5.00503;
4use strict;
5use Carp;
6use File::Copy;
7use File::Compare;
8use File::Basename;
9use File::Path qw(rmtree);
10require Exporter;
11use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
12@ISA       = qw(Exporter);
13@EXPORT    = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f chmod
14                dos2unix);
15$VERSION = '1.09';
16
17my $Is_VMS = $^O eq 'VMS';
18
19=head1 NAME
20
21ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc.
22
23=head1 SYNOPSIS
24
25  perl -MExtUtils::Command  -e cat files... > destination
26  perl -MExtUtils::Command  -e mv source... destination
27  perl -MExtUtils::Command  -e cp source... destination
28  perl -MExtUtils::Command  -e touch files...
29  perl -MExtUtils::Command  -e rm_f files...
30  perl -MExtUtils::Command  -e rm_rf directories...
31  perl -MExtUtils::Command  -e mkpath directories...
32  perl -MExtUtils::Command  -e eqtime source destination
33  perl -MExtUtils::Command  -e test_f file
34  perl -MExtUtils::Command  -e chmod mode files...
35  ...
36
37=head1 DESCRIPTION
38
39The module is used to replace common UNIX commands.  In all cases the
40functions work from @ARGV rather than taking arguments.  This makes
41them easier to deal with in Makefiles.
42
43  perl -MExtUtils::Command -e some_command some files to work on
44
45I<NOT>
46
47  perl -MExtUtils::Command -e 'some_command qw(some files to work on)'
48
49For that use L<Shell::Command>.
50
51Filenames with * and ? will be glob expanded.
52
53=over 4
54
55=cut
56
57# VMS uses % instead of ? to mean "one character"
58my $wild_regex = $Is_VMS ? '*%' : '*?';
59sub expand_wildcards
60{
61 @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV);
62}
63
64
65=item cat
66
67    cat file ...
68
69Concatenates all files mentioned on command line to STDOUT.
70
71=cut 
72
73sub cat ()
74{
75 expand_wildcards();
76 print while (<>);
77}
78
79=item eqtime
80
81    eqtime source destination
82
83Sets modified time of destination to that of source.
84
85=cut 
86
87sub eqtime
88{
89 my ($src,$dst) = @ARGV;
90 local @ARGV = ($dst);  touch();  # in case $dst doesn't exist
91 utime((stat($src))[8,9],$dst);
92}
93
94=item rm_rf
95
96    rm_rf files or directories ...
97
98Removes files and directories - recursively (even if readonly)
99
100=cut 
101
102sub rm_rf
103{
104 expand_wildcards();
105 rmtree([grep -e $_,@ARGV],0,0);
106}
107
108=item rm_f
109
110    rm_f file ...
111
112Removes files (even if readonly)
113
114=cut 
115
116sub rm_f {
117    expand_wildcards();
118
119    foreach my $file (@ARGV) {
120        next unless -f $file;
121
122        next if _unlink($file);
123
124        chmod(0777, $file);
125
126        next if _unlink($file);
127
128        carp "Cannot delete $file: $!";
129    }
130}
131
132sub _unlink {
133    my $files_unlinked = 0;
134    foreach my $file (@_) {
135        my $delete_count = 0;
136        $delete_count++ while unlink $file;
137        $files_unlinked++ if $delete_count;
138    }
139    return $files_unlinked;
140}
141
142
143=item touch
144
145    touch file ...
146
147Makes files exist, with current timestamp
148
149=cut 
150
151sub touch {
152    my $t    = time;
153    expand_wildcards();
154    foreach my $file (@ARGV) {
155        open(FILE,">>$file") || die "Cannot write $file:$!";
156        close(FILE);
157        utime($t,$t,$file);
158    }
159}
160
161=item mv
162
163    mv source_file destination_file
164    mv source_file source_file destination_dir
165
166Moves source to destination.  Multiple sources are allowed if
167destination is an existing directory.
168
169Returns true if all moves succeeded, false otherwise.
170
171=cut 
172
173sub mv {
174    expand_wildcards();
175    my @src = @ARGV;
176    my $dst = pop @src;
177
178    croak("Too many arguments") if (@src > 1 && ! -d $dst);
179
180    my $nok = 0;
181    foreach my $src (@src) {
182        $nok ||= !move($src,$dst);
183    }
184    return !$nok;
185}
186
187=item cp
188
189    cp source_file destination_file
190    cp source_file source_file destination_dir
191
192Copies sources to the destination.  Multiple sources are allowed if
193destination is an existing directory.
194
195Returns true if all copies succeeded, false otherwise.
196
197=cut
198
199sub cp {
200    expand_wildcards();
201    my @src = @ARGV;
202    my $dst = pop @src;
203
204    croak("Too many arguments") if (@src > 1 && ! -d $dst);
205
206    my $nok = 0;
207    foreach my $src (@src) {
208        $nok ||= !copy($src,$dst);
209    }
210    return $nok;
211}
212
213=item chmod
214
215    chmod mode files ...
216
217Sets UNIX like permissions 'mode' on all the files.  e.g. 0666
218
219=cut 
220
221sub chmod {
222    local @ARGV = @ARGV;
223    my $mode = shift(@ARGV);
224    expand_wildcards();
225
226    if( $Is_VMS ) {
227        foreach my $idx (0..$#ARGV) {
228            my $path = $ARGV[$idx];
229            next unless -d $path;
230
231            # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do
232            # chmod 0777, [.foo]bar.dir
233            my @dirs = File::Spec->splitdir( $path );
234            $dirs[-1] .= '.dir';
235            $path = File::Spec->catfile(@dirs);
236
237            $ARGV[$idx] = $path;
238        }
239    }
240
241    chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!";
242}
243
244=item mkpath
245
246    mkpath directory ...
247
248Creates directories, including any parent directories.
249
250=cut 
251
252sub mkpath
253{
254 expand_wildcards();
255 File::Path::mkpath([@ARGV],0,0777);
256}
257
258=item test_f
259
260    test_f file
261
262Tests if a file exists
263
264=cut 
265
266sub test_f
267{
268 exit !-f $ARGV[0];
269}
270
271=item dos2unix
272
273    dos2unix files or dirs ...
274
275Converts DOS and OS/2 linefeeds to Unix style recursively.
276
277=cut
278
279sub dos2unix {
280    require File::Find;
281    File::Find::find(sub {
282        return if -d;
283        return unless -w _;
284        return unless -r _;
285        return if -B _;
286
287        local $\;
288
289	my $orig = $_;
290	my $temp = '.dos2unix_tmp';
291	open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return };
292	open TEMP, ">$temp" or
293	    do { warn "dos2unix can't create .dos2unix_tmp: $!"; return };
294        while (my $line = <ORIG>) {
295            $line =~ s/\015\012/\012/g;
296            print TEMP $line;
297        }
298	close ORIG;
299	close TEMP;
300	rename $temp, $orig;
301
302    }, @ARGV);
303}
304
305=back
306
307=head1 SEE ALSO
308
309Shell::Command which is these same functions but take arguments normally.
310
311
312=head1 AUTHOR
313
314Nick Ing-Simmons C<ni-s@cpan.org>
315
316Currently maintained by Michael G Schwern C<schwern@pobox.com>.
317
318=cut
319
320