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