This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
053f28e50c29dfe6f0429701fdd7591ee7341014
[perl5.git] / 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.11';
16
17 my $Is_VMS = $^O eq 'VMS';
18
19 =head1 NAME
20
21 ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc.
22
23 =head1 SYNOPSIS
24
25   perl -MExtUtils::Command       -e cat files... > destination
26   perl -MExtUtils::Command       -e mv source... destination
27   perl -MExtUtils::Command       -e cp source... destination
28   perl -MExtUtils::Command       -e touch files...
29   perl -MExtUtils::Command       -e rm_f files...
30   perl -MExtUtils::Command       -e rm_rf directories...
31   perl -MExtUtils::Command       -e mkpath directories...
32   perl -MExtUtils::Command       -e eqtime source destination
33   perl -MExtUtils::Command       -e test_f file
34   perl -MExtUtils::Command       -e test_d directory
35   perl -MExtUtils::Command       -e chmod mode files...
36   ...
37
38 =head1 DESCRIPTION
39
40 The module is used to replace common UNIX commands.  In all cases the
41 functions work from @ARGV rather than taking arguments.  This makes
42 them easier to deal with in Makefiles.
43
44   perl -MExtUtils::Command -e some_command some files to work on
45
46 I<NOT>
47
48   perl -MExtUtils::Command -e 'some_command qw(some files to work on)'
49
50 Filenames with * and ? will be glob expanded.
51
52 =over 4
53
54 =cut
55
56 # VMS uses % instead of ? to mean "one character"
57 my $wild_regex = $Is_VMS ? '*%' : '*?';
58 sub expand_wildcards
59 {
60  @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV);
61 }
62
63
64 =item cat 
65
66 Concatenates all files mentioned on command line to STDOUT.
67
68 =cut 
69
70 sub cat ()
71 {
72  expand_wildcards();
73  print while (<>);
74 }
75
76 =item eqtime src dst
77
78 Sets modified time of dst to that of src
79
80 =cut 
81
82 sub eqtime
83 {
84  my ($src,$dst) = @ARGV;
85  local @ARGV = ($dst);  touch();  # in case $dst doesn't exist
86  utime((stat($src))[8,9],$dst);
87 }
88
89 =item rm_rf files....
90
91 Removes directories - recursively (even if readonly)
92
93 =cut 
94
95 sub rm_rf
96 {
97  expand_wildcards();
98  rmtree([grep -e $_,@ARGV],0,0);
99 }
100
101 =item rm_f files....
102
103 Removes files (even if readonly)
104
105 =cut 
106
107 sub rm_f {
108     expand_wildcards();
109
110     foreach my $file (@ARGV) {
111         next unless -f $file;
112
113         next if _unlink($file);
114
115         chmod(0777, $file);
116
117         next if _unlink($file);
118             
119         carp "Cannot delete $file: $!";
120     }
121 }
122
123 sub _unlink {
124     my $files_unlinked = 0;
125     foreach my $file (@_) {
126         my $delete_count = 0;
127         $delete_count++ while unlink $file;
128         $files_unlinked++ if $delete_count;
129     }
130     return $files_unlinked;
131 }
132
133
134 =item touch files ...
135
136 Makes files exist, with current timestamp 
137
138 =cut 
139
140 sub touch {
141     my $t    = time;
142     expand_wildcards();
143     foreach my $file (@ARGV) {
144         open(FILE,">>$file") || die "Cannot write $file:$!";
145         close(FILE);
146         utime($t,$t,$file);
147     }
148 }
149
150 =item mv source... destination
151
152 Moves source to destination.  Multiple sources are allowed if
153 destination is an existing directory.
154
155 Returns true if all moves succeeded, false otherwise.
156
157 =cut 
158
159 sub mv {
160     expand_wildcards();
161     my @src = @ARGV;
162     my $dst = pop @src;
163
164     croak("Too many arguments") if (@src > 1 && ! -d $dst);
165
166     my $nok = 0;
167     foreach my $src (@src) {
168         $nok ||= !move($src,$dst);
169     }
170     return !$nok;
171 }
172
173 =item cp source... destination
174
175 Copies source to destination.  Multiple sources are allowed if
176 destination is an existing directory.
177
178 Returns true if all copies succeeded, false otherwise.
179
180 =cut
181
182 sub cp {
183     expand_wildcards();
184     my @src = @ARGV;
185     my $dst = pop @src;
186
187     croak("Too many arguments") if (@src > 1 && ! -d $dst);
188
189     my $nok = 0;
190     foreach my $src (@src) {
191         $nok ||= !copy($src,$dst);
192     }
193     return $nok;
194 }
195
196 =item chmod mode files...
197
198 Sets UNIX like permissions 'mode' on all the files.  e.g. 0666
199
200 =cut 
201
202 sub chmod {
203     local @ARGV = @ARGV;
204     my $mode = shift(@ARGV);
205     expand_wildcards();
206
207     if( $Is_VMS ) {
208         foreach my $idx (0..$#ARGV) {
209             my $path = $ARGV[$idx];
210             next unless -d $path;
211
212             # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do
213             # chmod 0777, [.foo]bar.dir
214             my @dirs = File::Spec->splitdir( $path );
215             $dirs[-1] .= '.dir';
216             $path = File::Spec->catfile(@dirs);
217
218             $ARGV[$idx] = $path;
219         }
220     }
221
222     chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!";
223 }
224
225 =item mkpath directory...
226
227 Creates directory, including any parent directories.
228
229 =cut 
230
231 sub mkpath
232 {
233  expand_wildcards();
234  File::Path::mkpath([@ARGV],0,0777);
235 }
236
237 =item test_f file
238
239 Tests if a file exists
240
241 =cut 
242
243 sub test_f
244 {
245  exit !-f $ARGV[0];
246 }
247
248 =item test_d directory
249
250 Tests if a directory exists
251
252 =cut 
253
254 sub test_d
255 {
256  exit !-d $ARGV[0];
257 }
258
259 =item dos2unix
260
261 Converts DOS and OS/2 linefeeds to Unix style recursively.
262
263 =cut
264
265 sub dos2unix {
266     require File::Find;
267     File::Find::find(sub {
268         return if -d;
269         return unless -w _;
270         return unless -r _;
271         return if -B _;
272
273         local $\;
274
275         my $orig = $_;
276         my $temp = '.dos2unix_tmp';
277         open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return };
278         open TEMP, ">$temp" or 
279             do { warn "dos2unix can't create .dos2unix_tmp: $!"; return };
280         while (my $line = <ORIG>) { 
281             $line =~ s/\015\012/\012/g;
282             print TEMP $line;
283         }
284         close ORIG;
285         close TEMP;
286         rename $temp, $orig;
287
288     }, @ARGV);
289 }
290
291 =back
292
293 =head1 BUGS
294
295 Should probably be Auto/Self loaded.
296
297 =head1 SEE ALSO 
298
299 ExtUtils::MakeMaker, ExtUtils::MM_Unix, ExtUtils::MM_Win32
300
301 =head1 AUTHOR
302
303 Nick Ing-Simmons C<ni-s@cpan.org>
304
305 Maintained by Michael G Schwern C<schwern@pobox.com> within the
306 ExtUtils-MakeMaker package and, as a separate CPAN package, by
307 Randy Kobes C<r.kobes@uwinnipeg.ca>.
308
309 =cut
310