File Coverage

File:/usr/local/share/autoconf/Autom4te/FileUtils.pm
Coverage:69.1%

linestmtbrancondsubpodtimecode
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
22package 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.
68sub 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# --------------------------------
98sub 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# -------------
135sub 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# ---------------------------------
160sub 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# ---------------------------
218sub 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
246sub 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# --------------
297sub 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
319sub 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
338sub 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# ---------------------
358sub 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';
387sub 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
417sub 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
428sub 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
4351; # 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: