Commit | Line | Data |
68dc0745 |
1 | package ExtUtils::Command; |
17f410f9 |
2 | |
57b1a898 |
3 | use 5.00503; |
68dc0745 |
4 | use strict; |
3fe9a6f1 |
5 | use Carp; |
68dc0745 |
6 | use File::Copy; |
7 | use File::Compare; |
8 | use File::Basename; |
9 | use File::Path qw(rmtree); |
10 | require Exporter; |
a7d1454b |
11 | use 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); |
2319519c |
15 | $VERSION = '1.16'; |
8bdaab24 |
16 | |
17 | my $Is_VMS = $^O eq 'VMS'; |
2319519c |
18 | my $Is_VMS_mode = $Is_VMS; |
19 | my $Is_VMS_noefs = $Is_VMS; |
8bdaab24 |
20 | my $Is_Win32 = $^O eq 'MSWin32'; |
68dc0745 |
21 | |
2319519c |
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 | |
a67d7a01 |
43 | |
68dc0745 |
44 | =head1 NAME |
45 | |
46 | ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. |
47 | |
dc848c6f |
48 | =head1 SYNOPSIS |
68dc0745 |
49 | |
a85f5f83 |
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 |
62 | |
63 | =head1 DESCRIPTION |
64 | |
57b1a898 |
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 |
a85f5f83 |
67 | them easier to deal with in Makefiles. Call them like this: |
57b1a898 |
68 | |
69 | perl -MExtUtils::Command -e some_command some files to work on |
70 | |
a85f5f83 |
71 | and I<NOT> like this: |
57b1a898 |
72 | |
73 | perl -MExtUtils::Command -e 'some_command qw(some files to work on)' |
74 | |
a85f5f83 |
75 | For that use L<Shell::Command>. |
76 | |
57b1a898 |
77 | Filenames with * and ? will be glob expanded. |
68dc0745 |
78 | |
a85f5f83 |
79 | |
80 | =head2 FUNCTIONS |
81 | |
68dc0745 |
82 | =over 4 |
83 | |
3fe9a6f1 |
84 | =cut |
85 | |
a67d7a01 |
86 | # VMS uses % instead of ? to mean "one character" |
87 | my $wild_regex = $Is_VMS ? '*%' : '*?'; |
3fe9a6f1 |
88 | sub expand_wildcards |
89 | { |
a67d7a01 |
90 | @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV); |
3fe9a6f1 |
91 | } |
92 | |
479d2113 |
93 | |
a85f5f83 |
94 | =item cat |
95 | |
96 | cat file ... |
68dc0745 |
97 | |
3fe9a6f1 |
98 | Concatenates all files mentioned on command line to STDOUT. |
68dc0745 |
99 | |
100 | =cut |
101 | |
102 | sub cat () |
103 | { |
3fe9a6f1 |
104 | expand_wildcards(); |
68dc0745 |
105 | print while (<>); |
106 | } |
107 | |
a85f5f83 |
108 | =item eqtime |
109 | |
110 | eqtime source destination |
7292dc67 |
111 | |
a85f5f83 |
112 | Sets modified time of destination to that of source. |
68dc0745 |
113 | |
114 | =cut |
115 | |
116 | sub eqtime |
117 | { |
118 | my ($src,$dst) = @ARGV; |
479d2113 |
119 | local @ARGV = ($dst); touch(); # in case $dst doesn't exist |
68dc0745 |
120 | utime((stat($src))[8,9],$dst); |
121 | } |
122 | |
a85f5f83 |
123 | =item rm_rf |
7292dc67 |
124 | |
a85f5f83 |
125 | rm_rf files or directories ... |
126 | |
127 | Removes files and directories - recursively (even if readonly) |
68dc0745 |
128 | |
129 | =cut |
130 | |
131 | sub rm_rf |
132 | { |
57b1a898 |
133 | expand_wildcards(); |
134 | rmtree([grep -e $_,@ARGV],0,0); |
68dc0745 |
135 | } |
136 | |
a85f5f83 |
137 | =item rm_f |
138 | |
139 | rm_f file ... |
68dc0745 |
140 | |
141 | Removes files (even if readonly) |
142 | |
143 | =cut |
144 | |
5dca256e |
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); |
a85f5f83 |
156 | |
5dca256e |
157 | carp "Cannot delete $file: $!"; |
158 | } |
68dc0745 |
159 | } |
160 | |
5dca256e |
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 | |
a85f5f83 |
172 | =item touch |
173 | |
174 | touch file ... |
68dc0745 |
175 | |
176 | Makes files exist, with current timestamp |
177 | |
178 | =cut |
179 | |
479d2113 |
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 | } |
68dc0745 |
188 | } |
189 | |
a85f5f83 |
190 | =item mv |
191 | |
192 | mv source_file destination_file |
193 | mv source_file source_file destination_dir |
68dc0745 |
194 | |
a7d1454b |
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. |
68dc0745 |
199 | |
200 | =cut |
201 | |
479d2113 |
202 | sub mv { |
479d2113 |
203 | expand_wildcards(); |
a7d1454b |
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 |
214 | } |
215 | |
a85f5f83 |
216 | =item cp |
7292dc67 |
217 | |
a85f5f83 |
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 |
a7d1454b |
222 | destination is an existing directory. |
223 | |
224 | Returns true if all copies succeeded, false otherwise. |
68dc0745 |
225 | |
d5d4ec93 |
226 | =cut |
68dc0745 |
227 | |
479d2113 |
228 | sub cp { |
479d2113 |
229 | expand_wildcards(); |
a7d1454b |
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 |
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 |
244 | } |
245 | |
a85f5f83 |
246 | =item chmod |
247 | |
248 | chmod mode files ... |
68dc0745 |
249 | |
479d2113 |
250 | Sets UNIX like permissions 'mode' on all the files. e.g. 0666 |
68dc0745 |
251 | |
252 | =cut |
253 | |
479d2113 |
254 | sub chmod { |
a7d1454b |
255 | local @ARGV = @ARGV; |
479d2113 |
256 | my $mode = shift(@ARGV); |
257 | expand_wildcards(); |
5dca256e |
258 | |
2319519c |
259 | if( $Is_VMS_mode && $Is_VMS_noefs) { |
5dca256e |
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 |
275 | } |
276 | |
a85f5f83 |
277 | =item mkpath |
278 | |
279 | mkpath directory ... |
7292dc67 |
280 | |
a85f5f83 |
281 | Creates directories, including any parent directories. |
68dc0745 |
282 | |
283 | =cut |
284 | |
285 | sub mkpath |
286 | { |
57b1a898 |
287 | expand_wildcards(); |
288 | File::Path::mkpath([@ARGV],0,0777); |
68dc0745 |
289 | } |
290 | |
a85f5f83 |
291 | =item test_f |
68dc0745 |
292 | |
a85f5f83 |
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). |
68dc0745 |
297 | |
298 | =cut |
299 | |
300 | sub test_f |
301 | { |
a85f5f83 |
302 | exit(-f $ARGV[0] ? 0 : 1); |
68dc0745 |
303 | } |
304 | |
a85f5f83 |
305 | =item test_d |
f353a419 |
306 | |
a85f5f83 |
307 | test_d directory |
f353a419 |
308 | |
a85f5f83 |
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 |
a7d1454b |
313 | |
f353a419 |
314 | sub test_d |
315 | { |
a85f5f83 |
316 | exit(-d $ARGV[0] ? 0 : 1); |
f353a419 |
317 | } |
318 | |
319 | =item dos2unix |
7292dc67 |
320 | |
a85f5f83 |
321 | dos2unix files or dirs ... |
322 | |
a7d1454b |
323 | Converts DOS and OS/2 linefeeds to Unix style recursively. |
5b0d9cbe |
324 | |
a7d1454b |
325 | =cut |
326 | |
327 | sub 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 |
333 | return if -B _; |
334 | |
a7d1454b |
335 | local $\; |
336 | |
dd0810f9 |
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; |
a7d1454b |
345 | } |
dd0810f9 |
346 | close ORIG; |
347 | close TEMP; |
348 | rename $temp, $orig; |
a7d1454b |
349 | |
350 | }, @ARGV); |
351 | } |
68dc0745 |
352 | |
353 | =back |
354 | |
a85f5f83 |
355 | =head1 SEE ALSO |
f353a419 |
356 | |
a85f5f83 |
357 | Shell::Command which is these same functions but take arguments normally. |
7292dc67 |
358 | |
68dc0745 |
359 | |
360 | =head1 AUTHOR |
361 | |
a7d1454b |
362 | Nick Ing-Simmons C<ni-s@cpan.org> |
363 | |
f353a419 |
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>. |
68dc0745 |
367 | |
368 | =cut |
369 | |