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