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