File: | /usr/local/share/automake-1.11/Automake/FileUtils.pm |
Coverage: | 25.1% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | # Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. | ||||||
2 | |||||||
3 | # This program is free software; you can redistribute it and/or modify | ||||||
4 | # it under the terms of the GNU General Public License as published by | ||||||
5 | # the Free Software Foundation; either version 2, or (at your option) | ||||||
6 | # any later version. | ||||||
7 | |||||||
8 | # This program is distributed in the hope that it will be useful, | ||||||
9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | ||||||
10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||||||
11 | # GNU General Public License for more details. | ||||||
12 | |||||||
13 | # You should have received a copy of the GNU General Public License | ||||||
14 | # along with this program. If not, see <http://www.gnu.org/licenses/>. | ||||||
15 | |||||||
16 | ############################################################### | ||||||
17 | # The main copy of this file is in Automake's CVS repository. # | ||||||
18 | # Updates should be sent to automake-patches@gnu.org. # | ||||||
19 | ############################################################### | ||||||
20 | |||||||
21 | package Automake::FileUtils; | ||||||
22 | |||||||
23 - 35 | =head1 NAME Automake::FileUtils - handling files =head1 SYNOPSIS use Automake::FileUtils =head1 DESCRIPTION This perl module provides various general purpose file handling functions. =cut | ||||||
36 | |||||||
37 | 1 1 1 | 4 78 4 | use strict; | ||||
38 | 1 1 1 | 3 1 2 | use Exporter; | ||||
39 | 1 1 1 | 6 1 4 | use File::stat; | ||||
40 | 1 1 1 | 4 1 3 | use IO::File; | ||||
41 | 1 1 1 | 4 1 2 | use Automake::Channels; | ||||
42 | 1 1 1 | 4 1 3 | use Automake::ChannelDefs; | ||||
43 | |||||||
44 | 1 1 1 | 4 1 3 | use vars qw (@ISA @EXPORT); | ||||
45 | |||||||
46 | @ISA = qw (Exporter); | ||||||
47 | @EXPORT = qw (&open_quote &contents | ||||||
48 | &find_file &mtime | ||||||
49 | &update_file &up_to_date_p | ||||||
50 | &xsystem &xsystem_hint &xqx | ||||||
51 | &dir_has_case_matching_file &reset_dir_cache | ||||||
52 | &set_dir_cache_file); | ||||||
53 | |||||||
54 | |||||||
55 - 59 | =item C<open_quote ($file_name)> Quote C<$file_name> for open. =cut | ||||||
60 | |||||||
61 | # $FILE_NAME | ||||||
62 | # open_quote ($FILE_NAME) | ||||||
63 | # ----------------------- | ||||||
64 | # If the string $S is a well-behaved file name, simply return it. | ||||||
65 | # If it starts with white space, prepend `./', if it ends with | ||||||
66 | # white space, add `\0'. Return the new string. | ||||||
67 | sub open_quote($) | ||||||
68 | { | ||||||
69 | 0 | 1 | my ($s) = @_; | ||||
70 | 0 | if ($s =~ m/^\s/) | |||||
71 | { | ||||||
72 | 0 | $s = "./$s"; | |||||
73 | } | ||||||
74 | 0 | if ($s =~ m/\s$/) | |||||
75 | { | ||||||
76 | 0 | $s = "$s\0"; | |||||
77 | } | ||||||
78 | 0 | return $s; | |||||
79 | } | ||||||
80 | |||||||
81 - 92 | =item C<find_file ($file_name, @include)> Return the first path for a C<$file_name> in the C<include>s. We match exactly the behavior of GNU M4: first look in the current directory (which includes the case of absolute file names), and then, if the file name is not absolute, look in C<@include>. If the file is flagged as optional (ends with C<?>), then return undef if absent, otherwise exit with error. =cut | ||||||
93 | |||||||
94 | # $FILE_NAME | ||||||
95 | # find_file ($FILE_NAME, @INCLUDE) | ||||||
96 | # ------------------------------- | ||||||
97 | sub find_file ($@) | ||||||
98 | { | ||||||
99 | 1 1 1 | 4 4 4 | use File::Spec; | ||||
100 | |||||||
101 | 0 | 1 | my ($file_name, @include) = @_; | ||||
102 | 0 | my $optional = 0; | |||||
103 | |||||||
104 | 0 | $optional = 1 | |||||
105 | if $file_name =~ s/\?$//; | ||||||
106 | |||||||
107 | 0 | return File::Spec->canonpath ($file_name) | |||||
108 | if -e $file_name; | ||||||
109 | |||||||
110 | 0 | if (!File::Spec->file_name_is_absolute ($file_name)) | |||||
111 | { | ||||||
112 | 0 | foreach my $path (@include) | |||||
113 | { | ||||||
114 | 0 | return File::Spec->canonpath (File::Spec->catfile ($path, $file_name)) | |||||
115 | if -e File::Spec->catfile ($path, $file_name) | ||||||
116 | } | ||||||
117 | } | ||||||
118 | |||||||
119 | 0 | fatal "$file_name: no such file or directory" | |||||
120 | unless $optional; | ||||||
121 | 0 | return undef; | |||||
122 | } | ||||||
123 | |||||||
124 - 129 | =item C<mtime ($file)> Return the mtime of C<$file>. Missing files, or C<-> standing for C<STDIN> or C<STDOUT> are ``obsolete'', i.e., as old as possible. =cut | ||||||
130 | |||||||
131 | # $MTIME | ||||||
132 | # MTIME ($FILE) | ||||||
133 | # ------------- | ||||||
134 | sub mtime ($) | ||||||
135 | { | ||||||
136 | 0 | 1 | my ($file) = @_; | ||||
137 | |||||||
138 | 0 | return 0 | |||||
139 | if $file eq '-' || ! -f $file; | ||||||
140 | |||||||
141 | 0 | my $stat = stat ($file) | |||||
142 | or fatal "cannot stat $file: $!"; | ||||||
143 | |||||||
144 | 0 | return $stat->mtime; | |||||
145 | } | ||||||
146 | |||||||
147 | |||||||
148 - 155 | =item C<update_file ($from, $to, [$force])> Rename C<$from> as C<$to>, preserving C<$to> timestamp if it has not changed, unless C<$force> is true (defaults to false). Recognize C<$to> = C<-> standing for C<STDIN>. C<$from> is always removed/renamed. =cut | ||||||
156 | |||||||
157 | # &update_file ($FROM, $TO; $FORCE) | ||||||
158 | # --------------------------------- | ||||||
159 | sub update_file ($$;$) | ||||||
160 | { | ||||||
161 | 0 | 1 | my ($from, $to, $force) = @_; | ||||
162 | 0 | $force = 0 | |||||
163 | unless defined $force; | ||||||
164 | 0 | my $SIMPLE_BACKUP_SUFFIX = $ENV{'SIMPLE_BACKUP_SUFFIX'} || '~'; | |||||
165 | 1 1 1 | 7 1 6 | use File::Compare; | ||||
166 | 1 1 1 | 13 2 7 | use File::Copy; | ||||
167 | |||||||
168 | 0 | if ($to eq '-') | |||||
169 | { | ||||||
170 | 0 | my $in = new IO::File ("< " . open_quote ($from)); | |||||
171 | 0 | my $out = new IO::File (">-"); | |||||
172 | 0 | while ($_ = $in->getline) | |||||
173 | { | ||||||
174 | 0 | print $out $_; | |||||
175 | } | ||||||
176 | 0 | $in->close; | |||||
177 | 0 | unlink ($from) || fatal "cannot remove $from: $!"; | |||||
178 | 0 | return; | |||||
179 | } | ||||||
180 | |||||||
181 | 0 | if (!$force && -f "$to" && compare ("$from", "$to") == 0) | |||||
182 | { | ||||||
183 | # File didn't change, so don't update its mod time. | ||||||
184 | 0 | msg 'note', "`$to' is unchanged"; | |||||
185 | 0 | unlink ($from) | |||||
186 | or fatal "cannot remove $from: $!"; | ||||||
187 | return | ||||||
188 | 0 | } | |||||
189 | |||||||
190 | 0 | if (-f "$to") | |||||
191 | { | ||||||
192 | # Back up and install the new one. | ||||||
193 | 0 | move ("$to", "$to$SIMPLE_BACKUP_SUFFIX") | |||||
194 | or fatal "cannot backup $to: $!"; | ||||||
195 | 0 | move ("$from", "$to") | |||||
196 | or fatal "cannot rename $from as $to: $!"; | ||||||
197 | 0 | msg 'note', "`$to' is updated"; | |||||
198 | } | ||||||
199 | else | ||||||
200 | { | ||||||
201 | 0 | move ("$from", "$to") | |||||
202 | or fatal "cannot rename $from as $to: $!"; | ||||||
203 | 0 | msg 'note', "`$to' is created"; | |||||
204 | } | ||||||
205 | } | ||||||
206 | |||||||
207 | |||||||
208 - 212 | =item C<up_to_date_p ($file, @dep)> Is C<$file> more recent than C<@dep>? =cut | ||||||
213 | |||||||
214 | # $BOOLEAN | ||||||
215 | # &up_to_date_p ($FILE, @DEP) | ||||||
216 | # --------------------------- | ||||||
217 | sub up_to_date_p ($@) | ||||||
218 | { | ||||||
219 | 0 | 1 | my ($file, @dep) = @_; | ||||
220 | 0 | my $mtime = mtime ($file); | |||||
221 | |||||||
222 | 0 | foreach my $dep (@dep) | |||||
223 | { | ||||||
224 | 0 | if ($mtime < mtime ($dep)) | |||||
225 | { | ||||||
226 | 0 | verb "up_to_date ($file): outdated: $dep"; | |||||
227 | 0 | return 0; | |||||
228 | } | ||||||
229 | } | ||||||
230 | |||||||
231 | 0 | verb "up_to_date ($file): up to date"; | |||||
232 | 0 | return 1; | |||||
233 | } | ||||||
234 | |||||||
235 | |||||||
236 - 243 | =item C<handle_exec_errors ($command, [$expected_exit_code = 0], [$hint])> Display an error message for C<$command>, based on the content of C<$?> and C<$!>. Be quiet if the command exited normally with C<$expected_exit_code>. If C<$hint> is given, display that as well if the command failed to run at all. =cut | ||||||
244 | |||||||
245 | sub handle_exec_errors ($;$$) | ||||||
246 | { | ||||||
247 | 0 | 1 | my ($command, $expected, $hint) = @_; | ||||
248 | 0 | $expected = 0 unless defined $expected; | |||||
249 | 0 | if (defined $hint) | |||||
250 | { | ||||||
251 | 0 | $hint = "\n" . $hint; | |||||
252 | } | ||||||
253 | else | ||||||
254 | { | ||||||
255 | 0 | $hint = ''; | |||||
256 | } | ||||||
257 | |||||||
258 | 0 | $command = (split (' ', $command))[0]; | |||||
259 | 0 | if ($!) | |||||
260 | { | ||||||
261 | 0 | fatal "failed to run $command: $!" . $hint; | |||||
262 | } | ||||||
263 | else | ||||||
264 | { | ||||||
265 | 1 1 1 | 10 1 7 | use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG); | ||||
266 | |||||||
267 | 0 | if (WIFEXITED ($?)) | |||||
268 | { | ||||||
269 | 0 | my $status = WEXITSTATUS ($?); | |||||
270 | # Propagate exit codes. | ||||||
271 | 0 | fatal ('', | |||||
272 | "$command failed with exit status: $status", | ||||||
273 | exit_code => $status) | ||||||
274 | unless $status == $expected; | ||||||
275 | } | ||||||
276 | elsif (WIFSIGNALED ($?)) | ||||||
277 | { | ||||||
278 | 0 | my $signal = WTERMSIG ($?); | |||||
279 | 0 | fatal "$command terminated by signal: $signal"; | |||||
280 | } | ||||||
281 | else | ||||||
282 | { | ||||||
283 | 0 | fatal "$command exited abnormally"; | |||||
284 | } | ||||||
285 | } | ||||||
286 | } | ||||||
287 | |||||||
288 - 292 | =item C<xqx ($command)> Same as C<qx> (but in scalar context), but fails on errors. =cut | ||||||
293 | |||||||
294 | # xqx ($COMMAND) | ||||||
295 | # -------------- | ||||||
296 | sub xqx ($) | ||||||
297 | { | ||||||
298 | 0 | 1 | my ($command) = @_; | ||||
299 | |||||||
300 | 0 | verb "running: $command"; | |||||
301 | |||||||
302 | 0 | $! = 0; | |||||
303 | 0 | my $res = `$command`; | |||||
304 | 0 | handle_exec_errors $command | |||||
305 | if $?; | ||||||
306 | |||||||
307 | 0 | return $res; | |||||
308 | } | ||||||
309 | |||||||
310 | |||||||
311 - 316 | =item C<xsystem (@argv)> Same as C<system>, but fails on errors, and reports the C<@argv> in verbose mode. =cut | ||||||
317 | |||||||
318 | sub xsystem (@) | ||||||
319 | { | ||||||
320 | 0 | 1 | my (@command) = @_; | ||||
321 | |||||||
322 | 0 | verb "running: @command"; | |||||
323 | |||||||
324 | 0 | $! = 0; | |||||
325 | 0 | handle_exec_errors "@command" | |||||
326 | if system @command; | ||||||
327 | } | ||||||
328 | |||||||
329 | |||||||
330 - 335 | =item C<xsystem_hint ($msg, @argv)> Same as C<xsystem>, but allows to pass a hint that will be displayed in case the command failed to run at all. =cut | ||||||
336 | |||||||
337 | sub xsystem_hint (@) | ||||||
338 | { | ||||||
339 | 0 | 1 | my ($hint, @command) = @_; | ||||
340 | |||||||
341 | 0 | verb "running: @command"; | |||||
342 | |||||||
343 | 0 | $! = 0; | |||||
344 | 0 | handle_exec_errors "@command", 0, $hint | |||||
345 | if system @command; | ||||||
346 | } | ||||||
347 | |||||||
348 | |||||||
349 - 353 | =item C<contents ($file_name)> Return the contents of C<$file_name>. =cut | ||||||
354 | |||||||
355 | # contents ($FILE_NAME) | ||||||
356 | # --------------------- | ||||||
357 | sub contents ($) | ||||||
358 | { | ||||||
359 | 0 | 1 | my ($file) = @_; | ||||
360 | 0 | verb "reading $file"; | |||||
361 | 0 | local $/; # Turn on slurp-mode. | |||||
362 | 0 | my $f = new Automake::XFile "< " . open_quote ($file); | |||||
363 | 0 | my $contents = $f->getline; | |||||
364 | 0 | $f->close; | |||||
365 | 0 | return $contents; | |||||
366 | } | ||||||
367 | |||||||
368 | |||||||
369 - 383 | =item C<dir_has_case_matching_file ($DIRNAME, $FILE_NAME)> Return true iff $DIR contains a file name that matches $FILE_NAME case insensitively. We need to be cautious on case-insensitive case-preserving file systems (e.g. Mac OS X's HFS+). On such systems C<-f 'Foo'> and C<-f 'foO'> answer the same thing. Hence if a package distributes its own F<CHANGELOG> file, but has no F<ChangeLog> file, automake would still try to distribute F<ChangeLog> (because it thinks it exists) in addition to F<CHANGELOG>, although it is impossible for these two files to be in the same directory (the two file names designate the same file). =cut | ||||||
384 | |||||||
385 | 1 1 1 | 5 1 4 | use vars '%_directory_cache'; | ||||
386 | sub dir_has_case_matching_file ($$) | ||||||
387 | { | ||||||
388 | # Note that print File::Spec->case_tolerant returns 0 even on MacOS | ||||||
389 | # X (with Perl v5.8.1-RC3 at least), so do not try to shortcut this | ||||||
390 | # function using that. | ||||||
391 | |||||||
392 | 0 | 1 | my ($dirname, $file_name) = @_; | ||||
393 | 0 | return 0 unless -f "$dirname/$file_name"; | |||||
394 | |||||||
395 | # The file appears to exist, however it might be a mirage if the | ||||||
396 | # system is case insensitive. Let's browse the directory and check | ||||||
397 | # whether the file is really in. We maintain a cache of directories | ||||||
398 | # so Automake doesn't spend all its time reading the same directory | ||||||
399 | # again and again. | ||||||
400 | 0 | if (!exists $_directory_cache{$dirname}) | |||||
401 | { | ||||||
402 | 0 | error "failed to open directory `$dirname'" | |||||
403 | unless opendir (DIR, $dirname); | ||||||
404 | 0 0 | $_directory_cache{$dirname} = { map { $_ => 1 } readdir (DIR) }; | |||||
405 | 0 | closedir (DIR); | |||||
406 | } | ||||||
407 | 0 | return exists $_directory_cache{$dirname}{$file_name}; | |||||
408 | } | ||||||
409 | |||||||
410 - 414 | =item C<reset_dir_cache ($dirname)> Clear C<dir_has_case_matching_file>'s cache for C<$dirname>. =cut | ||||||
415 | |||||||
416 | sub reset_dir_cache ($) | ||||||
417 | { | ||||||
418 | 0 | 1 | delete $_directory_cache{$_[0]}; | ||||
419 | } | ||||||
420 | |||||||
421 - 425 | =item C<set_dir_cache_file ($dirname, $file_name)> State that C<$dirname> contains C<$file_name> now. =cut | ||||||
426 | |||||||
427 | sub set_dir_cache_file ($$) | ||||||
428 | { | ||||||
429 | 0 | 1 | my ($dirname, $file_name) = @_; | ||||
430 | 0 | $_directory_cache{$dirname}{$file_name} = 1 | |||||
431 | if exists $_directory_cache{$dirname}; | ||||||
432 | } | ||||||
433 | |||||||
434 | 1; # for require | ||||||
435 | |||||||
436 | ### Setup "GNU" style for perl-mode and cperl-mode. | ||||||
437 | ## Local Variables: | ||||||
438 | ## perl-indent-level: 2 | ||||||
439 | ## perl-continued-statement-offset: 2 | ||||||
440 | ## perl-continued-brace-offset: 0 | ||||||
441 | ## perl-brace-offset: 0 | ||||||
442 | ## perl-brace-imaginary-offset: 0 | ||||||
443 | ## perl-label-offset: -2 | ||||||
444 | ## cperl-indent-level: 2 | ||||||
445 | ## cperl-brace-offset: 0 | ||||||
446 | ## cperl-continued-brace-offset: 0 | ||||||
447 | ## cperl-label-offset: -2 | ||||||
448 | ## cperl-extra-newline-before-brace: t | ||||||
449 | ## cperl-merge-trailing-else: nil | ||||||
450 | ## cperl-continued-statement-offset: 2 | ||||||
451 | ## End: |