File Coverage

File:/usr/local/share/automake-1.11/Automake/FileUtils.pm
Coverage:25.1%

linestmtbrancondsubpodtimecode
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
21package 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.
67sub 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# -------------------------------
97sub 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# -------------
134sub 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# ---------------------------------
159sub 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# ---------------------------
217sub 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
245sub 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# --------------
296sub 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
318sub 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
337sub 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# ---------------------
357sub 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';
386sub 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
416sub 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
427sub 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
4341; # 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: