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