File Coverage

blib/lib/auto/share/dist/Alien-autoconf/share/autoconf/Autom4te/FileUtils.pm

Criterion	Covered	Total	%
statement	37	117	31.6
branch	0	58	0.0
condition	0	11	0.0
subroutine	12	23	52.1
pod	11	11	100.0
total	60	220	27.2

# Copyright (C) 2003-2023 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 .

###############################################################
# The main copy of this file is in Automake's git repository. #
# Updates should be sent to [e-mail].         #
###############################################################

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 warnings FATAL => 'all';

BEGIN
{
  require Exporter;
  our @ISA = qw (Exporter);
  our @EXPORT = qw (&contents
		    &find_file &mtime
		    &update_file
		    &xsystem &xsystem_hint &xqx
		    &dir_has_case_matching_file &reset_dir_cache
		    &set_dir_cache_file);
}

# Use sub-second resolution file timestamps if available, carry on
# with one-second resolution timestamps if Time::HiRes is not available.
#
# Unfortunately, even if Time::HiRes is available, we don't get
# timestamps to the full precision recorded by the operating system,
# because Time::HiRes converts timestamps to floating-point, and the
# rounding error is hundreds of nanoseconds for circa-2023 timestamps
# in IEEE double precision.  But this is the best we can do without
# dropping down to C.
#
# $subsecond_mtime is not exported, but is intended for external
# consumption, as $Autom4te::FileUtils::subsecond_mtime.
BEGIN
{
  our $subsecond_mtime = 0;
  eval
    {
      require Time::HiRes;
      import Time::HiRes qw(stat);
      $subsecond_mtime = 1;
    }
}

use IO::File;
use Autom4te::Channels;
use Autom4te::ChannelDefs;

=over 4

=item C

Return the first path for a C<$file_name> in the Cs.

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

Return the mtime of C<$file>.  Missing files, or C<-> standing for
C or C are "obsolete", i.e., as old as possible.

=cut

# $MTIME
# MTIME ($FILE)
# -------------
sub mtime ($)
{
  my ($file) = @_;

  return 0
    if $file eq '-' || ! -f $file;

  my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
    $atime,$mtime,$ctime,$blksize,$blocks) = stat ($file)
    or fatal "cannot stat $file: $!";

  return $mtime;
}


=item C

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.  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

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

Same as C (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

Same as C, 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

Same as C, 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

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 $file, "<";
  my $contents = $f->getline;
  $f->close;
  return $contents;
}


=item C

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 file, but has no F file, automake would still
try to distribute F (because it thinks it exists) in
addition to F, although it is impossible for these two
files to be in the same directory (the two file names designate the
same file).

=cut

our %_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

Clear C's cache for C<$dirname>.

=cut

sub reset_dir_cache ($)
{
  delete $_directory_cache{$_[0]};
}

=item C

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};
}

=back

=cut

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: