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