This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Documentation typo fix
[perl5.git] / dist / ExtUtils-Command / 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.18';
16
17 my $Is_VMS   = $^O eq 'VMS';
18 my $Is_VMS_mode = $Is_VMS;
19 my $Is_VMS_noefs = $Is_VMS;
20 my $Is_Win32 = $^O eq 'MSWin32';
21
22 if( $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'} || '';
35         $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
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
43
44 =head1 NAME
45
46 ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc.
47
48 =head1 SYNOPSIS
49
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...
61   ...
62
63 =head1 DESCRIPTION
64
65 The module is used to replace common UNIX commands.  In all cases the
66 functions work from @ARGV rather than taking arguments.  This makes
67 them easier to deal with in Makefiles.  Call them like this:
68
69   perl -MExtUtils::Command -e some_command some files to work on
70
71 and I<NOT> like this:
72
73   perl -MExtUtils::Command -e 'some_command qw(some files to work on)'
74
75 For that use L<Shell::Command>.
76
77 Filenames with * and ? will be glob expanded.
78
79
80 =head2 FUNCTIONS
81
82 =over 4
83
84 =cut
85
86 # VMS uses % instead of ? to mean "one character"
87 my $wild_regex = $Is_VMS ? '*%' : '*?';
88 sub expand_wildcards
89 {
90  @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV);
91 }
92
93
94 =item cat
95
96     cat file ...
97
98 Concatenates all files mentioned on command line to STDOUT.
99
100 =cut
101
102 sub cat ()
103 {
104  expand_wildcards();
105  print while (<>);
106 }
107
108 =item eqtime
109
110     eqtime source destination
111
112 Sets modified time of destination to that of source.
113
114 =cut
115
116 sub eqtime
117 {
118  my ($src,$dst) = @ARGV;
119  local @ARGV = ($dst);  touch();  # in case $dst doesn't exist
120  utime((stat($src))[8,9],$dst);
121 }
122
123 =item rm_rf
124
125     rm_rf files or directories ...
126
127 Removes files and directories - recursively (even if readonly)
128
129 =cut
130
131 sub rm_rf
132 {
133  expand_wildcards();
134  rmtree([grep -e $_,@ARGV],0,0);
135 }
136
137 =item rm_f
138
139     rm_f file ...
140
141 Removes files (even if readonly)
142
143 =cut
144
145 sub 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);
156
157         carp "Cannot delete $file: $!";
158     }
159 }
160
161 sub _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
172 =item touch
173
174     touch file ...
175
176 Makes files exist, with current timestamp
177
178 =cut
179
180 sub 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     }
188 }
189
190 =item mv
191
192     mv source_file destination_file
193     mv source_file source_file destination_dir
194
195 Moves source to destination.  Multiple sources are allowed if
196 destination is an existing directory.
197
198 Returns true if all moves succeeded, false otherwise.
199
200 =cut
201
202 sub mv {
203     expand_wildcards();
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);
212     }
213     return !$nok;
214 }
215
216 =item cp
217
218     cp source_file destination_file
219     cp source_file source_file destination_dir
220
221 Copies sources to the destination.  Multiple sources are allowed if
222 destination is an existing directory.
223
224 Returns true if all copies succeeded, false otherwise.
225
226 =cut
227
228 sub cp {
229     expand_wildcards();
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);
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;
242     }
243     return $nok;
244 }
245
246 =item chmod
247
248     chmod mode files ...
249
250 Sets UNIX like permissions 'mode' on all the files.  e.g. 0666
251
252 =cut
253
254 sub chmod {
255     local @ARGV = @ARGV;
256     my $mode = shift(@ARGV);
257     expand_wildcards();
258
259     if( $Is_VMS_mode && $Is_VMS_noefs) {
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
274     chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!";
275 }
276
277 =item mkpath
278
279     mkpath directory ...
280
281 Creates directories, including any parent directories.
282
283 =cut
284
285 sub mkpath
286 {
287  expand_wildcards();
288  File::Path::mkpath([@ARGV],0,0777);
289 }
290
291 =item test_f
292
293     test_f file
294
295 Tests if a file exists.  I<Exits> with 0 if it does, 1 if it does not (ie.
296 shell's idea of true and false).
297
298 =cut
299
300 sub test_f
301 {
302  exit(-f $ARGV[0] ? 0 : 1);
303 }
304
305 =item test_d
306
307     test_d directory
308
309 Tests if a directory exists.  I<Exits> with 0 if it does, 1 if it does
310 not (ie. shell's idea of true and false).
311
312 =cut
313
314 sub test_d
315 {
316  exit(-d $ARGV[0] ? 0 : 1);
317 }
318
319 =item dos2unix
320
321     dos2unix files or dirs ...
322
323 Converts DOS and OS/2 linefeeds to Unix style recursively.
324
325 =cut
326
327 sub dos2unix {
328     require File::Find;
329     File::Find::find(sub {
330         return if -d;
331         return unless -w _;
332         return unless -r _;
333         return if -B _;
334
335         local $\;
336
337         my $orig = $_;
338         my $temp = '.dos2unix_tmp';
339         open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return };
340         open TEMP, ">$temp" or
341             do { warn "dos2unix can't create .dos2unix_tmp: $!"; return };
342         while (my $line = <ORIG>) {
343             $line =~ s/\015\012/\012/g;
344             print TEMP $line;
345         }
346         close ORIG;
347         close TEMP;
348         rename $temp, $orig;
349
350     }, @ARGV);
351 }
352
353 =back
354
355 =head1 SEE ALSO
356
357 Shell::Command which is these same functions but take arguments normally.
358
359
360 =head1 AUTHOR
361
362 Nick Ing-Simmons C<ni-s@cpan.org>
363
364 Maintained by Michael G Schwern C<schwern@pobox.com> within the
365 ExtUtils-MakeMaker package and, as a separate CPAN package, by
366 Randy Kobes C<r.kobes@uwinnipeg.ca>.
367
368 =cut