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