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