Current File : //usr/share/automake-1.16/Automake/FileUtils.pm
# Copyright (C) 2003-2018 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 <https://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 Automake::FileUtils;
=head1 NAME
Automake::FileUtils - handling files
=head1 SYNOPSIS
use Automake::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 Automake::Channels;
use Automake::ChannelDefs;
use vars qw (@ISA @EXPORT);
@ISA = qw (Exporter);
@EXPORT = qw (&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<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 $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 Automake::XFile $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
Mini Shell