diff options
Diffstat (limited to 'lib/Autom4te/FileUtils.pm')
| -rw-r--r-- | lib/Autom4te/FileUtils.pm | 452 |
1 files changed, 452 insertions, 0 deletions
diff --git a/lib/Autom4te/FileUtils.pm b/lib/Autom4te/FileUtils.pm new file mode 100644 index 0000000..30bbdb9 --- /dev/null +++ b/lib/Autom4te/FileUtils.pm @@ -0,0 +1,452 @@ +# Copyright (C) 2003-2012 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <http://www.gnu.org/licenses/>. + +############################################################### +# The main copy of this file is in Automake's git repository. # +# Updates should be sent to automake-patches@gnu.org. # +############################################################### + +package Autom4te::FileUtils; + +=head1 NAME + +Autom4te::FileUtils - handling files + +=head1 SYNOPSIS + + use Autom4te::FileUtils + +=head1 DESCRIPTION + +This perl module provides various general purpose file handling functions. + +=cut + +use 5.006; +use strict; +use Exporter; +use File::stat; +use IO::File; +use Autom4te::Channels; +use Autom4te::ChannelDefs; + +use vars qw (@ISA @EXPORT); + +@ISA = qw (Exporter); +@EXPORT = qw (&open_quote &contents + &find_file &mtime + &update_file &up_to_date_p + &xsystem &xsystem_hint &xqx + &dir_has_case_matching_file &reset_dir_cache + &set_dir_cache_file); + + +=item C<open_quote ($file_name)> + +Quote C<$file_name> for open. + +=cut + +# $FILE_NAME +# open_quote ($FILE_NAME) +# ----------------------- +# If the string $S is a well-behaved file name, simply return it. +# If it starts with white space, prepend './', if it ends with +# white space, add '\0'. Return the new string. +sub open_quote($) +{ + my ($s) = @_; + if ($s =~ m/^\s/) + { + $s = "./$s"; + } + if ($s =~ m/\s$/) + { + $s = "$s\0"; + } + return $s; +} + +=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 + +# $FILE_NAME +# find_file ($FILE_NAME, @INCLUDE) +# -------------------------------- +sub find_file ($@) +{ + use File::Spec; + + my ($file_name, @include) = @_; + my $optional = 0; + + $optional = 1 + if $file_name =~ s/\?$//; + + return File::Spec->canonpath ($file_name) + if -e $file_name; + + if (!File::Spec->file_name_is_absolute ($file_name)) + { + foreach my $path (@include) + { + return File::Spec->canonpath (File::Spec->catfile ($path, $file_name)) + if -e File::Spec->catfile ($path, $file_name) + } + } + + fatal "$file_name: no such file or directory" + unless $optional; + return undef; +} + +=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 + +# $MTIME +# MTIME ($FILE) +# ------------- +sub mtime ($) +{ + my ($file) = @_; + + return 0 + if $file eq '-' || ! -f $file; + + my $stat = stat ($file) + or fatal "cannot stat $file: $!"; + + return $stat->mtime; +} + + +=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 + +# &update_file ($FROM, $TO; $FORCE) +# --------------------------------- +sub update_file ($$;$) +{ + my ($from, $to, $force) = @_; + $force = 0 + unless defined $force; + my $SIMPLE_BACKUP_SUFFIX = $ENV{'SIMPLE_BACKUP_SUFFIX'} || '~'; + use File::Compare; + use File::Copy; + + if ($to eq '-') + { + my $in = new IO::File ("< " . open_quote ($from)); + my $out = new IO::File (">-"); + while ($_ = $in->getline) + { + print $out $_; + } + $in->close; + unlink ($from) || fatal "cannot remove $from: $!"; + return; + } + + if (!$force && -f "$to" && compare ("$from", "$to") == 0) + { + # File didn't change, so don't update its mod time. + msg 'note', "'$to' is unchanged"; + unlink ($from) + or fatal "cannot remove $from: $!"; + return + } + + if (-f "$to") + { + # Back up and install the new one. + move ("$to", "$to$SIMPLE_BACKUP_SUFFIX") + or fatal "cannot backup $to: $!"; + move ("$from", "$to") + or fatal "cannot rename $from as $to: $!"; + msg 'note', "'$to' is updated"; + } + else + { + move ("$from", "$to") + or fatal "cannot rename $from as $to: $!"; + msg 'note', "'$to' is created"; + } +} + + +=item C<up_to_date_p ($file, @dep)> + +Is C<$file> more recent than C<@dep>? + +=cut + +# $BOOLEAN +# &up_to_date_p ($FILE, @DEP) +# --------------------------- +sub up_to_date_p ($@) +{ + my ($file, @dep) = @_; + my $mtime = mtime ($file); + + foreach my $dep (@dep) + { + if ($mtime < mtime ($dep)) + { + verb "up_to_date ($file): outdated: $dep"; + return 0; + } + } + + verb "up_to_date ($file): up to date"; + return 1; +} + + +=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 + +sub handle_exec_errors ($;$$) +{ + my ($command, $expected, $hint) = @_; + $expected = 0 unless defined $expected; + if (defined $hint) + { + $hint = "\n" . $hint; + } + else + { + $hint = ''; + } + + $command = (split (' ', $command))[0]; + if ($!) + { + fatal "failed to run $command: $!" . $hint; + } + else + { + use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG); + + if (WIFEXITED ($?)) + { + my $status = WEXITSTATUS ($?); + # Propagate exit codes. + fatal ('', + "$command failed with exit status: $status", + exit_code => $status) + unless $status == $expected; + } + elsif (WIFSIGNALED ($?)) + { + my $signal = WTERMSIG ($?); + fatal "$command terminated by signal: $signal"; + } + else + { + fatal "$command exited abnormally"; + } + } +} + +=item C<xqx ($command)> + +Same as C<qx> (but in scalar context), but fails on errors. + +=cut + +# xqx ($COMMAND) +# -------------- +sub xqx ($) +{ + my ($command) = @_; + + verb "running: $command"; + + $! = 0; + my $res = `$command`; + handle_exec_errors $command + if $?; + + return $res; +} + + +=item C<xsystem (@argv)> + +Same as C<system>, but fails on errors, and reports the C<@argv> +in verbose mode. + +=cut + +sub xsystem (@) +{ + my (@command) = @_; + + verb "running: @command"; + + $! = 0; + handle_exec_errors "@command" + if system @command; +} + + +=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 + +sub xsystem_hint (@) +{ + my ($hint, @command) = @_; + + verb "running: @command"; + + $! = 0; + handle_exec_errors "@command", 0, $hint + if system @command; +} + + +=item C<contents ($file_name)> + +Return the contents of C<$file_name>. + +=cut + +# contents ($FILE_NAME) +# --------------------- +sub contents ($) +{ + my ($file) = @_; + verb "reading $file"; + local $/; # Turn on slurp-mode. + my $f = new Autom4te::XFile "< " . open_quote ($file); + my $contents = $f->getline; + $f->close; + return $contents; +} + + +=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 + +use vars '%_directory_cache'; +sub dir_has_case_matching_file ($$) +{ + # Note that print File::Spec->case_tolerant returns 0 even on MacOS + # X (with Perl v5.8.1-RC3 at least), so do not try to shortcut this + # function using that. + + my ($dirname, $file_name) = @_; + return 0 unless -f "$dirname/$file_name"; + + # The file appears to exist, however it might be a mirage if the + # system is case insensitive. Let's browse the directory and check + # whether the file is really in. We maintain a cache of directories + # so Automake doesn't spend all its time reading the same directory + # again and again. + if (!exists $_directory_cache{$dirname}) + { + error "failed to open directory '$dirname'" + unless opendir (DIR, $dirname); + $_directory_cache{$dirname} = { map { $_ => 1 } readdir (DIR) }; + closedir (DIR); + } + return exists $_directory_cache{$dirname}{$file_name}; +} + +=item C<reset_dir_cache ($dirname)> + +Clear C<dir_has_case_matching_file>'s cache for C<$dirname>. + +=cut + +sub reset_dir_cache ($) +{ + delete $_directory_cache{$_[0]}; +} + +=item C<set_dir_cache_file ($dirname, $file_name)> + +State that C<$dirname> contains C<$file_name> now. + +=cut + +sub set_dir_cache_file ($$) +{ + my ($dirname, $file_name) = @_; + $_directory_cache{$dirname}{$file_name} = 1 + if exists $_directory_cache{$dirname}; +} + +1; # for require + +### Setup "GNU" style for perl-mode and cperl-mode. +## Local Variables: +## perl-indent-level: 2 +## perl-continued-statement-offset: 2 +## perl-continued-brace-offset: 0 +## perl-brace-offset: 0 +## perl-brace-imaginary-offset: 0 +## perl-label-offset: -2 +## cperl-indent-level: 2 +## cperl-brace-offset: 0 +## cperl-continued-brace-offset: 0 +## cperl-label-offset: -2 +## cperl-extra-newline-before-brace: t +## cperl-merge-trailing-else: nil +## cperl-continued-statement-offset: 2 +## End: |