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