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