File: | /usr/local/share/autoconf/Autom4te/FileUtils.pm |
Coverage: | 69.1% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | # Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2010 Free Software | ||||||
2 | # Foundation, Inc. | ||||||
3 | |||||||
4 | # This program is free software; you can redistribute it and/or modify | ||||||
5 | # it under the terms of the GNU General Public License as published by | ||||||
6 | # the Free Software Foundation; either version 2, or (at your option) | ||||||
7 | # any later version. | ||||||
8 | |||||||
9 | # This program is distributed in the hope that it will be useful, | ||||||
10 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | ||||||
11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||||||
12 | # GNU General Public License for more details. | ||||||
13 | |||||||
14 | # You should have received a copy of the GNU General Public License | ||||||
15 | # along with this program. If not, see <http://www.gnu.org/licenses/>. | ||||||
16 | |||||||
17 | ############################################################### | ||||||
18 | # The main copy of this file is in Automake's CVS repository. # | ||||||
19 | # Updates should be sent to automake-patches@gnu.org. # | ||||||
20 | ############################################################### | ||||||
21 | |||||||
22 | package Autom4te::FileUtils; | ||||||
23 | |||||||
24 - 36 | =head1 NAME Autom4te::FileUtils - handling files =head1 SYNOPSIS use Autom4te::FileUtils =head1 DESCRIPTION This perl module provides various general purpose file handling functions. =cut | ||||||
37 | |||||||
38 | 2774 2774 2774 | 7662 2482 9106 | use strict; | ||||
39 | 2774 2774 2774 | 10102 2569 6998 | use Exporter; | ||||
40 | 2774 2774 2774 | 17915 3674 11428 | use File::stat; | ||||
41 | 2774 2774 2774 | 11559 2754 24260 | use IO::File; | ||||
42 | 2774 2774 2774 | 10623 3239 13104 | use Autom4te::Channels; | ||||
43 | 2774 2774 2774 | 10512 2643 7032 | use Autom4te::ChannelDefs; | ||||
44 | |||||||
45 | 2774 2774 2774 | 10526 2980 9585 | use vars qw (@ISA @EXPORT); | ||||
46 | |||||||
47 | @ISA = qw (Exporter); | ||||||
48 | @EXPORT = qw (&open_quote &contents | ||||||
49 | &find_file &mtime | ||||||
50 | &update_file &up_to_date_p | ||||||
51 | &xsystem &xsystem_hint &xqx | ||||||
52 | &dir_has_case_matching_file &reset_dir_cache | ||||||
53 | &set_dir_cache_file); | ||||||
54 | |||||||
55 | |||||||
56 - 60 | =item C<open_quote ($file_name)> Quote C<$file_name> for open. =cut | ||||||
61 | |||||||
62 | # $FILE_NAME | ||||||
63 | # open_quote ($FILE_NAME) | ||||||
64 | # ----------------------- | ||||||
65 | # If the string $S is a well-behaved file name, simply return it. | ||||||
66 | # If it starts with white space, prepend `./', if it ends with | ||||||
67 | # white space, add `\0'. Return the new string. | ||||||
68 | sub open_quote($) | ||||||
69 | { | ||||||
70 | 26554 | 1 | 90634 | my ($s) = @_; | |||
71 | 26554 | 117639 | if ($s =~ m/^\s/) | ||||
72 | { | ||||||
73 | 0 | 0 | $s = "./$s"; | ||||
74 | } | ||||||
75 | 26554 | 90122 | if ($s =~ m/\s$/) | ||||
76 | { | ||||||
77 | 0 | 0 | $s = "$s\0"; | ||||
78 | } | ||||||
79 | 26554 | 278278 | return $s; | ||||
80 | } | ||||||
81 | |||||||
82 - 93 | =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 | ||||||
94 | |||||||
95 | # $FILE_NAME | ||||||
96 | # find_file ($FILE_NAME, @INCLUDE) | ||||||
97 | # -------------------------------- | ||||||
98 | sub find_file ($@) | ||||||
99 | { | ||||||
100 | 2774 2774 2774 | 12397 3058 11310 | use File::Spec; | ||||
101 | |||||||
102 | 34738 | 1 | 72187 | my ($file_name, @include) = @_; | |||
103 | 34738 | 38629 | my $optional = 0; | ||||
104 | |||||||
105 | 34738 | 97374 | $optional = 1 | ||||
106 | if $file_name =~ s/\?$//; | ||||||
107 | |||||||
108 | 34738 | 256236 | return File::Spec->canonpath ($file_name) | ||||
109 | if -e $file_name; | ||||||
110 | |||||||
111 | 11107 | 55434 | if (!File::Spec->file_name_is_absolute ($file_name)) | ||||
112 | { | ||||||
113 | 11107 | 117450 | foreach my $path (@include) | ||||
114 | { | ||||||
115 | 11066 | 65165 | return File::Spec->canonpath (File::Spec->catfile ($path, $file_name)) | ||||
116 | if -e File::Spec->catfile ($path, $file_name) | ||||||
117 | } | ||||||
118 | } | ||||||
119 | |||||||
120 | 2810 | 9438 | fatal "$file_name: no such file or directory" | ||||
121 | unless $optional; | ||||||
122 | 2810 | 8201 | return undef; | ||||
123 | } | ||||||
124 | |||||||
125 - 130 | =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 | ||||||
131 | |||||||
132 | # $MTIME | ||||||
133 | # MTIME ($FILE) | ||||||
134 | # ------------- | ||||||
135 | sub mtime ($) | ||||||
136 | { | ||||||
137 | 12991 | 1 | 32876 | my ($file) = @_; | |||
138 | |||||||
139 | 12991 | 143986 | return 0 | ||||
140 | if $file eq '-' || ! -f $file; | ||||||
141 | |||||||
142 | 12486 | 51678 | my $stat = stat ($file) | ||||
143 | or fatal "cannot stat $file: $!"; | ||||||
144 | |||||||
145 | 12486 | 278320 | return $stat->mtime; | ||||
146 | } | ||||||
147 | |||||||
148 | |||||||
149 - 156 | =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 | ||||||
157 | |||||||
158 | # &update_file ($FROM, $TO; $FORCE) | ||||||
159 | # --------------------------------- | ||||||
160 | sub update_file ($$;$) | ||||||
161 | { | ||||||
162 | 15 | 1 | 60 | my ($from, $to, $force) = @_; | |||
163 | 15 | 71 | $force = 0 | ||||
164 | unless defined $force; | ||||||
165 | 15 | 251 | my $SIMPLE_BACKUP_SUFFIX = $ENV{'SIMPLE_BACKUP_SUFFIX'} || '~'; | ||||
166 | 2774 2774 2774 | 25154 3028 16319 | use File::Compare; | ||||
167 | 2774 2774 2774 | 20595 3874 17550 | use File::Copy; | ||||
168 | |||||||
169 | 15 | 105 | if ($to eq '-') | ||||
170 | { | ||||||
171 | 0 | 0 | my $in = new IO::File ("< " . open_quote ($from)); | ||||
172 | 0 | 0 | my $out = new IO::File (">-"); | ||||
173 | 0 | 0 | while ($_ = $in->getline) | ||||
174 | { | ||||||
175 | 0 | 0 | print $out $_; | ||||
176 | } | ||||||
177 | 0 | 0 | $in->close; | ||||
178 | 0 | 0 | unlink ($from) || fatal "cannot remove $from: $!"; | ||||
179 | 0 | 0 | return; | ||||
180 | } | ||||||
181 | |||||||
182 | 15 | 422 | if (!$force && -f "$to" && compare ("$from", "$to") == 0) | ||||
183 | { | ||||||
184 | # File didn't change, so don't update its mod time. | ||||||
185 | 1 | 160 | msg 'note', "`$to' is unchanged"; | ||||
186 | 1 | 36 | unlink ($from) | ||||
187 | or fatal "cannot remove $from: $!"; | ||||||
188 | return | ||||||
189 | 1 | 9 | } | ||||
190 | |||||||
191 | 14 | 635 | if (-f "$to") | ||||
192 | { | ||||||
193 | # Back up and install the new one. | ||||||
194 | 5 | 55 | move ("$to", "$to$SIMPLE_BACKUP_SUFFIX") | ||||
195 | or fatal "cannot backup $to: $!"; | ||||||
196 | 5 | 432 | move ("$from", "$to") | ||||
197 | or fatal "cannot rename $from as $to: $!"; | ||||||
198 | 5 | 1427 | msg 'note', "`$to' is updated"; | ||||
199 | } | ||||||
200 | else | ||||||
201 | { | ||||||
202 | 9 | 93 | move ("$from", "$to") | ||||
203 | or fatal "cannot rename $from as $to: $!"; | ||||||
204 | 9 | 2653 | msg 'note', "`$to' is created"; | ||||
205 | } | ||||||
206 | } | ||||||
207 | |||||||
208 | |||||||
209 - 213 | =item C<up_to_date_p ($file, @dep)> Is C<$file> more recent than C<@dep>? =cut | ||||||
214 | |||||||
215 | # $BOOLEAN | ||||||
216 | # &up_to_date_p ($FILE, @DEP) | ||||||
217 | # --------------------------- | ||||||
218 | sub up_to_date_p ($@) | ||||||
219 | { | ||||||
220 | 850 | 1 | 5999 | my ($file, @dep) = @_; | |||
221 | 850 | 4669 | my $mtime = mtime ($file); | ||||
222 | |||||||
223 | 850 | 4305 | foreach my $dep (@dep) | ||||
224 | { | ||||||
225 | 3787 | 6985 | if ($mtime < mtime ($dep)) | ||||
226 | { | ||||||
227 | 117 | 1260 | verb "up_to_date ($file): outdated: $dep"; | ||||
228 | 117 | 3236 | return 0; | ||||
229 | } | ||||||
230 | } | ||||||
231 | |||||||
232 | 733 | 7247 | verb "up_to_date ($file): up to date"; | ||||
233 | 733 | 13607 | return 1; | ||||
234 | } | ||||||
235 | |||||||
236 | |||||||
237 - 244 | =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 | ||||||
245 | |||||||
246 | sub handle_exec_errors ($;$$) | ||||||
247 | { | ||||||
248 | 16 | 1 | 203 | my ($command, $expected, $hint) = @_; | |||
249 | 16 | 117 | $expected = 0 unless defined $expected; | ||||
250 | 16 | 119 | if (defined $hint) | ||||
251 | { | ||||||
252 | 0 | 0 | $hint = "\n" . $hint; | ||||
253 | } | ||||||
254 | else | ||||||
255 | { | ||||||
256 | 16 | 66 | $hint = ''; | ||||
257 | } | ||||||
258 | |||||||
259 | 16 | 465 | $command = (split (' ', $command))[0]; | ||||
260 | 16 | 229 | if ($!) | ||||
261 | { | ||||||
262 | 0 | 0 | fatal "failed to run $command: $!" . $hint; | ||||
263 | } | ||||||
264 | else | ||||||
265 | { | ||||||
266 | 2774 2774 2774 | 19940 3852 17100 | use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG); | ||||
267 | |||||||
268 | 16 | 310 | if (WIFEXITED ($?)) | ||||
269 | { | ||||||
270 | 16 | 84 | my $status = WEXITSTATUS ($?); | ||||
271 | # Propagate exit codes. | ||||||
272 | 16 | 398 | fatal ('', | ||||
273 | "$command failed with exit status: $status", | ||||||
274 | exit_code => $status) | ||||||
275 | unless $status == $expected; | ||||||
276 | } | ||||||
277 | elsif (WIFSIGNALED ($?)) | ||||||
278 | { | ||||||
279 | 0 | 0 | my $signal = WTERMSIG ($?); | ||||
280 | 0 | 0 | fatal "$command terminated by signal: $signal"; | ||||
281 | } | ||||||
282 | else | ||||||
283 | { | ||||||
284 | 0 | 0 | fatal "$command exited abnormally"; | ||||
285 | } | ||||||
286 | } | ||||||
287 | } | ||||||
288 | |||||||
289 - 293 | =item C<xqx ($command)> Same as C<qx> (but in scalar context), but fails on errors. =cut | ||||||
294 | |||||||
295 | # xqx ($COMMAND) | ||||||
296 | # -------------- | ||||||
297 | sub xqx ($) | ||||||
298 | { | ||||||
299 | 0 | 1 | 0 | my ($command) = @_; | |||
300 | |||||||
301 | 0 | 0 | verb "running: $command"; | ||||
302 | |||||||
303 | 0 | 0 | $! = 0; | ||||
304 | 0 | 0 | my $res = `$command`; | ||||
305 | 0 | 0 | handle_exec_errors $command | ||||
306 | if $?; | ||||||
307 | |||||||
308 | 0 | 0 | return $res; | ||||
309 | } | ||||||
310 | |||||||
311 | |||||||
312 - 317 | =item C<xsystem (@argv)> Same as C<system>, but fails on errors, and reports the C<@argv> in verbose mode. =cut | ||||||
318 | |||||||
319 | sub xsystem (@) | ||||||
320 | { | ||||||
321 | 2042 | 1 | 11015 | my (@command) = @_; | |||
322 | |||||||
323 | 2042 | 17415 | verb "running: @command"; | ||||
324 | |||||||
325 | 2042 | 7960 | $! = 0; | ||||
326 | 2042 | 190277991 | handle_exec_errors "@command" | ||||
327 | if system @command; | ||||||
328 | } | ||||||
329 | |||||||
330 | |||||||
331 - 336 | =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 | ||||||
337 | |||||||
338 | sub xsystem_hint (@) | ||||||
339 | { | ||||||
340 | 0 | 1 | 0 | my ($hint, @command) = @_; | |||
341 | |||||||
342 | 0 | 0 | verb "running: @command"; | ||||
343 | |||||||
344 | 0 | 0 | $! = 0; | ||||
345 | 0 | 0 | handle_exec_errors "@command", 0, $hint | ||||
346 | if system @command; | ||||||
347 | } | ||||||
348 | |||||||
349 | |||||||
350 - 354 | =item C<contents ($file_name)> Return the contents of C<$file_name>. =cut | ||||||
355 | |||||||
356 | # contents ($FILE_NAME) | ||||||
357 | # --------------------- | ||||||
358 | sub contents ($) | ||||||
359 | { | ||||||
360 | 2742 | 1 | 12787 | my ($file) = @_; | |||
361 | 2742 | 25739 | verb "reading $file"; | ||||
362 | 2742 | 15788 | local $/; # Turn on slurp-mode. | ||||
363 | 2742 | 9152 | my $f = new Autom4te::XFile "< " . open_quote ($file); | ||||
364 | 2742 | 10816 | my $contents = $f->getline; | ||||
365 | 2742 | 11943 | $f->close; | ||||
366 | 2742 | 63039 | return $contents; | ||||
367 | } | ||||||
368 | |||||||
369 | |||||||
370 - 384 | =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 | ||||||
385 | |||||||
386 | 2774 2774 2774 | 13007 3218 9852 | use vars '%_directory_cache'; | ||||
387 | sub dir_has_case_matching_file ($$) | ||||||
388 | { | ||||||
389 | # Note that print File::Spec->case_tolerant returns 0 even on MacOS | ||||||
390 | # X (with Perl v5.8.1-RC3 at least), so do not try to shortcut this | ||||||
391 | # function using that. | ||||||
392 | |||||||
393 | 0 | 1 | my ($dirname, $file_name) = @_; | ||||
394 | 0 | return 0 unless -f "$dirname/$file_name"; | |||||
395 | |||||||
396 | # The file appears to exist, however it might be a mirage if the | ||||||
397 | # system is case insensitive. Let's browse the directory and check | ||||||
398 | # whether the file is really in. We maintain a cache of directories | ||||||
399 | # so Automake doesn't spend all its time reading the same directory | ||||||
400 | # again and again. | ||||||
401 | 0 | if (!exists $_directory_cache{$dirname}) | |||||
402 | { | ||||||
403 | 0 | error "failed to open directory `$dirname'" | |||||
404 | unless opendir (DIR, $dirname); | ||||||
405 | 0 0 | $_directory_cache{$dirname} = { map { $_ => 1 } readdir (DIR) }; | |||||
406 | 0 | closedir (DIR); | |||||
407 | } | ||||||
408 | 0 | return exists $_directory_cache{$dirname}{$file_name}; | |||||
409 | } | ||||||
410 | |||||||
411 - 415 | =item C<reset_dir_cache ($dirname)> Clear C<dir_has_case_matching_file>'s cache for C<$dirname>. =cut | ||||||
416 | |||||||
417 | sub reset_dir_cache ($) | ||||||
418 | { | ||||||
419 | 0 | 1 | delete $_directory_cache{$_[0]}; | ||||
420 | } | ||||||
421 | |||||||
422 - 426 | =item C<set_dir_cache_file ($dirname, $file_name)> State that C<$dirname> contains C<$file_name> now. =cut | ||||||
427 | |||||||
428 | sub set_dir_cache_file ($$) | ||||||
429 | { | ||||||
430 | 0 | 1 | my ($dirname, $file_name) = @_; | ||||
431 | 0 | $_directory_cache{$dirname}{$file_name} = 1 | |||||
432 | if exists $_directory_cache{$dirname}; | ||||||
433 | } | ||||||
434 | |||||||
435 | 1; # for require | ||||||
436 | |||||||
437 | ### Setup "GNU" style for perl-mode and cperl-mode. | ||||||
438 | ## Local Variables: | ||||||
439 | ## perl-indent-level: 2 | ||||||
440 | ## perl-continued-statement-offset: 2 | ||||||
441 | ## perl-continued-brace-offset: 0 | ||||||
442 | ## perl-brace-offset: 0 | ||||||
443 | ## perl-brace-imaginary-offset: 0 | ||||||
444 | ## perl-label-offset: -2 | ||||||
445 | ## cperl-indent-level: 2 | ||||||
446 | ## cperl-brace-offset: 0 | ||||||
447 | ## cperl-continued-brace-offset: 0 | ||||||
448 | ## cperl-label-offset: -2 | ||||||
449 | ## cperl-extra-newline-before-brace: t | ||||||
450 | ## cperl-merge-trailing-else: nil | ||||||
451 | ## cperl-continued-statement-offset: 2 | ||||||
452 | ## End: |