Commit | Line | Data |
---|---|---|
920dae64 AT |
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 chmod | |
14 | dos2unix); | |
15 | $VERSION = '1.09'; | |
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 chmod mode files... | |
35 | ... | |
36 | ||
37 | =head1 DESCRIPTION | |
38 | ||
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 | ||
49 | For that use L<Shell::Command>. | |
50 | ||
51 | Filenames with * and ? will be glob expanded. | |
52 | ||
53 | =over 4 | |
54 | ||
55 | =cut | |
56 | ||
57 | # VMS uses % instead of ? to mean "one character" | |
58 | my $wild_regex = $Is_VMS ? '*%' : '*?'; | |
59 | sub expand_wildcards | |
60 | { | |
61 | @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV); | |
62 | } | |
63 | ||
64 | ||
65 | =item cat | |
66 | ||
67 | cat file ... | |
68 | ||
69 | Concatenates all files mentioned on command line to STDOUT. | |
70 | ||
71 | =cut | |
72 | ||
73 | sub cat () | |
74 | { | |
75 | expand_wildcards(); | |
76 | print while (<>); | |
77 | } | |
78 | ||
79 | =item eqtime | |
80 | ||
81 | eqtime source destination | |
82 | ||
83 | Sets modified time of destination to that of source. | |
84 | ||
85 | =cut | |
86 | ||
87 | sub eqtime | |
88 | { | |
89 | my ($src,$dst) = @ARGV; | |
90 | local @ARGV = ($dst); touch(); # in case $dst doesn't exist | |
91 | utime((stat($src))[8,9],$dst); | |
92 | } | |
93 | ||
94 | =item rm_rf | |
95 | ||
96 | rm_rf files or directories ... | |
97 | ||
98 | Removes files and directories - recursively (even if readonly) | |
99 | ||
100 | =cut | |
101 | ||
102 | sub rm_rf | |
103 | { | |
104 | expand_wildcards(); | |
105 | rmtree([grep -e $_,@ARGV],0,0); | |
106 | } | |
107 | ||
108 | =item rm_f | |
109 | ||
110 | rm_f file ... | |
111 | ||
112 | Removes files (even if readonly) | |
113 | ||
114 | =cut | |
115 | ||
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); | |
127 | ||
128 | carp "Cannot delete $file: $!"; | |
129 | } | |
130 | } | |
131 | ||
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 | ||
143 | =item touch | |
144 | ||
145 | touch file ... | |
146 | ||
147 | Makes files exist, with current timestamp | |
148 | ||
149 | =cut | |
150 | ||
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 | } | |
159 | } | |
160 | ||
161 | =item mv | |
162 | ||
163 | mv source_file destination_file | |
164 | mv source_file source_file destination_dir | |
165 | ||
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. | |
170 | ||
171 | =cut | |
172 | ||
173 | sub mv { | |
174 | expand_wildcards(); | |
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); | |
183 | } | |
184 | return !$nok; | |
185 | } | |
186 | ||
187 | =item cp | |
188 | ||
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 | |
193 | destination is an existing directory. | |
194 | ||
195 | Returns true if all copies succeeded, false otherwise. | |
196 | ||
197 | =cut | |
198 | ||
199 | sub cp { | |
200 | expand_wildcards(); | |
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); | |
209 | } | |
210 | return $nok; | |
211 | } | |
212 | ||
213 | =item chmod | |
214 | ||
215 | chmod mode files ... | |
216 | ||
217 | Sets UNIX like permissions 'mode' on all the files. e.g. 0666 | |
218 | ||
219 | =cut | |
220 | ||
221 | sub chmod { | |
222 | local @ARGV = @ARGV; | |
223 | my $mode = shift(@ARGV); | |
224 | expand_wildcards(); | |
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 | ||
241 | chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!"; | |
242 | } | |
243 | ||
244 | =item mkpath | |
245 | ||
246 | mkpath directory ... | |
247 | ||
248 | Creates directories, including any parent directories. | |
249 | ||
250 | =cut | |
251 | ||
252 | sub mkpath | |
253 | { | |
254 | expand_wildcards(); | |
255 | File::Path::mkpath([@ARGV],0,0777); | |
256 | } | |
257 | ||
258 | =item test_f | |
259 | ||
260 | test_f file | |
261 | ||
262 | Tests if a file exists | |
263 | ||
264 | =cut | |
265 | ||
266 | sub test_f | |
267 | { | |
268 | exit !-f $ARGV[0]; | |
269 | } | |
270 | ||
271 | =item dos2unix | |
272 | ||
273 | dos2unix files or dirs ... | |
274 | ||
275 | Converts DOS and OS/2 linefeeds to Unix style recursively. | |
276 | ||
277 | =cut | |
278 | ||
279 | sub dos2unix { | |
280 | require File::Find; | |
281 | File::Find::find(sub { | |
282 | return if -d; | |
283 | return unless -w _; | |
284 | return unless -r _; | |
285 | return if -B _; | |
286 | ||
287 | local $\; | |
288 | ||
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; | |
297 | } | |
298 | close ORIG; | |
299 | close TEMP; | |
300 | rename $temp, $orig; | |
301 | ||
302 | }, @ARGV); | |
303 | } | |
304 | ||
305 | =back | |
306 | ||
307 | =head1 SEE ALSO | |
308 | ||
309 | Shell::Command which is these same functions but take arguments normally. | |
310 | ||
311 | ||
312 | =head1 AUTHOR | |
313 | ||
314 | Nick Ing-Simmons C<ni-s@cpan.org> | |
315 | ||
316 | Currently maintained by Michael G Schwern C<schwern@pobox.com>. | |
317 | ||
318 | =cut | |
319 |