1# Copyright (C) 2003-2012 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 git repository. #
18# Updates should be sent to automake-patches@gnu.org.         #
19###############################################################
20
21package Autom4te::FileUtils;
22
23=head1 NAME
24
25Autom4te::FileUtils - handling files
26
27=head1 SYNOPSIS
28
29  use Autom4te::FileUtils
30
31=head1 DESCRIPTION
32
33This perl module provides various general purpose file handling functions.
34
35=cut
36
37use 5.006;
38use strict;
39use Exporter;
40use File::stat;
41use IO::File;
42use Autom4te::Channels;
43use Autom4te::ChannelDefs;
44
45use 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=item C<open_quote ($file_name)>
57
58Quote C<$file_name> for open.
59
60=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  my ($s) = @_;
71  if ($s =~ m/^\s/)
72    {
73      $s = "./$s";
74    }
75  if ($s =~ m/\s$/)
76    {
77      $s = "$s\0";
78    }
79  return $s;
80}
81
82=item C<find_file ($file_name, @include)>
83
84Return the first path for a C<$file_name> in the C<include>s.
85
86We match exactly the behavior of GNU M4: first look in the current
87directory (which includes the case of absolute file names), and then,
88if the file name is not absolute, look in C<@include>.
89
90If the file is flagged as optional (ends with C<?>), then return undef
91if absent, otherwise exit with error.
92
93=cut
94
95# $FILE_NAME
96# find_file ($FILE_NAME, @INCLUDE)
97# --------------------------------
98sub find_file ($@)
99{
100  use File::Spec;
101
102  my ($file_name, @include) = @_;
103  my $optional = 0;
104
105  $optional = 1
106    if $file_name =~ s/\?$//;
107
108  return File::Spec->canonpath ($file_name)
109    if -e $file_name;
110
111  if (!File::Spec->file_name_is_absolute ($file_name))
112    {
113      foreach my $path (@include)
114	{
115	  return File::Spec->canonpath (File::Spec->catfile ($path, $file_name))
116	    if -e File::Spec->catfile ($path, $file_name)
117	}
118    }
119
120  fatal "$file_name: no such file or directory"
121    unless $optional;
122  return undef;
123}
124
125=item C<mtime ($file)>
126
127Return the mtime of C<$file>.  Missing files, or C<-> standing for
128C<STDIN> or C<STDOUT> are "obsolete", i.e., as old as possible.
129
130=cut
131
132# $MTIME
133# MTIME ($FILE)
134# -------------
135sub mtime ($)
136{
137  my ($file) = @_;
138
139  return 0
140    if $file eq '-' || ! -f $file;
141
142  my $stat = stat ($file)
143    or fatal "cannot stat $file: $!";
144
145  return $stat->mtime;
146}
147
148
149=item C<update_file ($from, $to, [$force])>
150
151Rename C<$from> as C<$to>, preserving C<$to> timestamp if it has not
152changed, unless C<$force> is true (defaults to false).  Recognize
153C<$to> = C<-> standing for C<STDIN>.  C<$from> is always
154removed/renamed.
155
156=cut
157
158# &update_file ($FROM, $TO; $FORCE)
159# ---------------------------------
160sub update_file ($$;$)
161{
162  my ($from, $to, $force) = @_;
163  $force = 0
164    unless defined $force;
165  my $SIMPLE_BACKUP_SUFFIX = $ENV{'SIMPLE_BACKUP_SUFFIX'} || '~';
166  use File::Compare;
167  use File::Copy;
168
169  if ($to eq '-')
170    {
171      my $in = new IO::File ("< " . open_quote ($from));
172      my $out = new IO::File (">-");
173      while ($_ = $in->getline)
174	{
175	  print $out $_;
176	}
177      $in->close;
178      unlink ($from) || fatal "cannot remove $from: $!";
179      return;
180    }
181
182  if (!$force && -f "$to" && compare ("$from", "$to") == 0)
183    {
184      # File didn't change, so don't update its mod time.
185      msg 'note', "'$to' is unchanged";
186      unlink ($from)
187        or fatal "cannot remove $from: $!";
188      return
189    }
190
191  if (-f "$to")
192    {
193      # Back up and install the new one.
194      move ("$to",  "$to$SIMPLE_BACKUP_SUFFIX")
195	or fatal "cannot backup $to: $!";
196      move ("$from", "$to")
197	or fatal "cannot rename $from as $to: $!";
198      msg 'note', "'$to' is updated";
199    }
200  else
201    {
202      move ("$from", "$to")
203	or fatal "cannot rename $from as $to: $!";
204      msg 'note', "'$to' is created";
205    }
206}
207
208
209=item C<up_to_date_p ($file, @dep)>
210
211Is C<$file> more recent than C<@dep>?
212
213=cut
214
215# $BOOLEAN
216# &up_to_date_p ($FILE, @DEP)
217# ---------------------------
218sub up_to_date_p ($@)
219{
220  my ($file, @dep) = @_;
221  my $mtime = mtime ($file);
222
223  foreach my $dep (@dep)
224    {
225      if ($mtime < mtime ($dep))
226	{
227	  verb "up_to_date ($file): outdated: $dep";
228	  return 0;
229	}
230    }
231
232  verb "up_to_date ($file): up to date";
233  return 1;
234}
235
236
237=item C<handle_exec_errors ($command, [$expected_exit_code = 0], [$hint])>
238
239Display an error message for C<$command>, based on the content of
240C<$?> and C<$!>.  Be quiet if the command exited normally
241with C<$expected_exit_code>.  If C<$hint> is given, display that as well
242if the command failed to run at all.
243
244=cut
245
246sub handle_exec_errors ($;$$)
247{
248  my ($command, $expected, $hint) = @_;
249  $expected = 0 unless defined $expected;
250  if (defined $hint)
251    {
252      $hint = "\n" . $hint;
253    }
254  else
255    {
256      $hint = '';
257    }
258
259  $command = (split (' ', $command))[0];
260  if ($!)
261    {
262      fatal "failed to run $command: $!" . $hint;
263    }
264  else
265    {
266      use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
267
268      if (WIFEXITED ($?))
269	{
270	  my $status = WEXITSTATUS ($?);
271	  # Propagate exit codes.
272	  fatal ('',
273		 "$command failed with exit status: $status",
274		 exit_code => $status)
275	    unless $status == $expected;
276	}
277      elsif (WIFSIGNALED ($?))
278	{
279	  my $signal = WTERMSIG ($?);
280	  fatal "$command terminated by signal: $signal";
281	}
282      else
283	{
284	  fatal "$command exited abnormally";
285	}
286    }
287}
288
289=item C<xqx ($command)>
290
291Same as C<qx> (but in scalar context), but fails on errors.
292
293=cut
294
295# xqx ($COMMAND)
296# --------------
297sub xqx ($)
298{
299  my ($command) = @_;
300
301  verb "running: $command";
302
303  $! = 0;
304  my $res = `$command`;
305  handle_exec_errors $command
306    if $?;
307
308  return $res;
309}
310
311
312=item C<xsystem (@argv)>
313
314Same as C<system>, but fails on errors, and reports the C<@argv>
315in verbose mode.
316
317=cut
318
319sub xsystem (@)
320{
321  my (@command) = @_;
322
323  verb "running: @command";
324
325  $! = 0;
326  handle_exec_errors "@command"
327    if system @command;
328}
329
330
331=item C<xsystem_hint ($msg, @argv)>
332
333Same as C<xsystem>, but allows to pass a hint that will be displayed
334in case the command failed to run at all.
335
336=cut
337
338sub xsystem_hint (@)
339{
340  my ($hint, @command) = @_;
341
342  verb "running: @command";
343
344  $! = 0;
345  handle_exec_errors "@command", 0, $hint
346    if system @command;
347}
348
349
350=item C<contents ($file_name)>
351
352Return the contents of C<$file_name>.
353
354=cut
355
356# contents ($FILE_NAME)
357# ---------------------
358sub contents ($)
359{
360  my ($file) = @_;
361  verb "reading $file";
362  local $/;			# Turn on slurp-mode.
363  my $f = new Autom4te::XFile "< " . open_quote ($file);
364  my $contents = $f->getline;
365  $f->close;
366  return $contents;
367}
368
369
370=item C<dir_has_case_matching_file ($DIRNAME, $FILE_NAME)>
371
372Return true iff $DIR contains a file name that matches $FILE_NAME case
373insensitively.
374
375We need to be cautious on case-insensitive case-preserving file
376systems (e.g. Mac OS X's HFS+).  On such systems C<-f 'Foo'> and C<-f
377'foO'> answer the same thing.  Hence if a package distributes its own
378F<CHANGELOG> file, but has no F<ChangeLog> file, automake would still
379try to distribute F<ChangeLog> (because it thinks it exists) in
380addition to F<CHANGELOG>, although it is impossible for these two
381files to be in the same directory (the two file names designate the
382same file).
383
384=cut
385
386use 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  my ($dirname, $file_name) = @_;
394  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  if (!exists $_directory_cache{$dirname})
402    {
403      error "failed to open directory '$dirname'"
404	unless opendir (DIR, $dirname);
405      $_directory_cache{$dirname} = { map { $_ => 1 } readdir (DIR) };
406      closedir (DIR);
407    }
408  return exists $_directory_cache{$dirname}{$file_name};
409}
410
411=item C<reset_dir_cache ($dirname)>
412
413Clear C<dir_has_case_matching_file>'s cache for C<$dirname>.
414
415=cut
416
417sub reset_dir_cache ($)
418{
419  delete $_directory_cache{$_[0]};
420}
421
422=item C<set_dir_cache_file ($dirname, $file_name)>
423
424State that C<$dirname> contains C<$file_name> now.
425
426=cut
427
428sub set_dir_cache_file ($$)
429{
430  my ($dirname, $file_name) = @_;
431  $_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:
453