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); |
f353a419 |
13 | @EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod |
a7d1454b |
14 | dos2unix); |
f353a419 |
15 | $VERSION = '1.11'; |
68dc0745 |
16 | |
a67d7a01 |
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 | |
f353a419 |
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... |
a7d1454b |
36 | ... |
68dc0745 |
37 | |
38 | =head1 DESCRIPTION |
39 | |
57b1a898 |
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. |
68dc0745 |
51 | |
52 | =over 4 |
53 | |
3fe9a6f1 |
54 | =cut |
55 | |
a67d7a01 |
56 | # VMS uses % instead of ? to mean "one character" |
57 | my $wild_regex = $Is_VMS ? '*%' : '*?'; |
3fe9a6f1 |
58 | sub expand_wildcards |
59 | { |
a67d7a01 |
60 | @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV); |
3fe9a6f1 |
61 | } |
62 | |
479d2113 |
63 | |
f353a419 |
64 | =item cat |
68dc0745 |
65 | |
3fe9a6f1 |
66 | Concatenates all files mentioned on command line to STDOUT. |
68dc0745 |
67 | |
68 | =cut |
69 | |
70 | sub cat () |
71 | { |
3fe9a6f1 |
72 | expand_wildcards(); |
68dc0745 |
73 | print while (<>); |
74 | } |
75 | |
f353a419 |
76 | =item eqtime src dst |
7292dc67 |
77 | |
f353a419 |
78 | Sets modified time of dst to that of src |
68dc0745 |
79 | |
80 | =cut |
81 | |
82 | sub eqtime |
83 | { |
84 | my ($src,$dst) = @ARGV; |
479d2113 |
85 | local @ARGV = ($dst); touch(); # in case $dst doesn't exist |
68dc0745 |
86 | utime((stat($src))[8,9],$dst); |
87 | } |
88 | |
f353a419 |
89 | =item rm_rf files.... |
7292dc67 |
90 | |
f353a419 |
91 | Removes directories - recursively (even if readonly) |
68dc0745 |
92 | |
93 | =cut |
94 | |
95 | sub rm_rf |
96 | { |
57b1a898 |
97 | expand_wildcards(); |
98 | rmtree([grep -e $_,@ARGV],0,0); |
68dc0745 |
99 | } |
100 | |
f353a419 |
101 | =item rm_f files.... |
68dc0745 |
102 | |
103 | Removes files (even if readonly) |
104 | |
105 | =cut |
106 | |
5dca256e |
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); |
f353a419 |
118 | |
5dca256e |
119 | carp "Cannot delete $file: $!"; |
120 | } |
68dc0745 |
121 | } |
122 | |
5dca256e |
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 | |
f353a419 |
134 | =item touch files ... |
68dc0745 |
135 | |
136 | Makes files exist, with current timestamp |
137 | |
138 | =cut |
139 | |
479d2113 |
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 | } |
68dc0745 |
148 | } |
149 | |
f353a419 |
150 | =item mv source... destination |
68dc0745 |
151 | |
a7d1454b |
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. |
68dc0745 |
156 | |
157 | =cut |
158 | |
479d2113 |
159 | sub mv { |
479d2113 |
160 | expand_wildcards(); |
a7d1454b |
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); |
479d2113 |
169 | } |
a7d1454b |
170 | return !$nok; |
68dc0745 |
171 | } |
172 | |
f353a419 |
173 | =item cp source... destination |
7292dc67 |
174 | |
f353a419 |
175 | Copies source to destination. Multiple sources are allowed if |
a7d1454b |
176 | destination is an existing directory. |
177 | |
178 | Returns true if all copies succeeded, false otherwise. |
68dc0745 |
179 | |
d5d4ec93 |
180 | =cut |
68dc0745 |
181 | |
479d2113 |
182 | sub cp { |
479d2113 |
183 | expand_wildcards(); |
a7d1454b |
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); |
479d2113 |
192 | } |
a7d1454b |
193 | return $nok; |
68dc0745 |
194 | } |
195 | |
f353a419 |
196 | =item chmod mode files... |
68dc0745 |
197 | |
479d2113 |
198 | Sets UNIX like permissions 'mode' on all the files. e.g. 0666 |
68dc0745 |
199 | |
200 | =cut |
201 | |
479d2113 |
202 | sub chmod { |
a7d1454b |
203 | local @ARGV = @ARGV; |
479d2113 |
204 | my $mode = shift(@ARGV); |
205 | expand_wildcards(); |
5dca256e |
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 | |
479d2113 |
222 | chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!"; |
68dc0745 |
223 | } |
224 | |
f353a419 |
225 | =item mkpath directory... |
7292dc67 |
226 | |
f353a419 |
227 | Creates directory, including any parent directories. |
68dc0745 |
228 | |
229 | =cut |
230 | |
231 | sub mkpath |
232 | { |
57b1a898 |
233 | expand_wildcards(); |
234 | File::Path::mkpath([@ARGV],0,0777); |
68dc0745 |
235 | } |
236 | |
f353a419 |
237 | =item test_f file |
68dc0745 |
238 | |
239 | Tests if a file exists |
240 | |
241 | =cut |
242 | |
243 | sub test_f |
244 | { |
a7d1454b |
245 | exit !-f $ARGV[0]; |
68dc0745 |
246 | } |
247 | |
f353a419 |
248 | =item test_d directory |
249 | |
250 | Tests if a directory exists |
251 | |
252 | =cut |
a7d1454b |
253 | |
f353a419 |
254 | sub test_d |
255 | { |
256 | exit !-d $ARGV[0]; |
257 | } |
258 | |
259 | =item dos2unix |
7292dc67 |
260 | |
a7d1454b |
261 | Converts DOS and OS/2 linefeeds to Unix style recursively. |
5b0d9cbe |
262 | |
a7d1454b |
263 | =cut |
264 | |
265 | sub dos2unix { |
266 | require File::Find; |
267 | File::Find::find(sub { |
dd0810f9 |
268 | return if -d; |
a7d1454b |
269 | return unless -w _; |
dd0810f9 |
270 | return unless -r _; |
a7d1454b |
271 | return if -B _; |
272 | |
a7d1454b |
273 | local $\; |
274 | |
dd0810f9 |
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; |
a7d1454b |
283 | } |
dd0810f9 |
284 | close ORIG; |
285 | close TEMP; |
286 | rename $temp, $orig; |
a7d1454b |
287 | |
288 | }, @ARGV); |
289 | } |
68dc0745 |
290 | |
291 | =back |
292 | |
f353a419 |
293 | =head1 BUGS |
68dc0745 |
294 | |
f353a419 |
295 | Should probably be Auto/Self loaded. |
296 | |
297 | =head1 SEE ALSO |
7292dc67 |
298 | |
f353a419 |
299 | ExtUtils::MakeMaker, ExtUtils::MM_Unix, ExtUtils::MM_Win32 |
68dc0745 |
300 | |
301 | =head1 AUTHOR |
302 | |
a7d1454b |
303 | Nick Ing-Simmons C<ni-s@cpan.org> |
304 | |
f353a419 |
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>. |
68dc0745 |
308 | |
309 | =cut |
310 | |