"Fossies" - the Fresh Open Source Software Archive

Member "automake-1.16.3/lib/Automake/FileUtils.pm" (19 Nov 2020, 8671 Bytes) of package /linux/misc/automake-1.16.3.tar.xz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "FileUtils.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 1.16.2_vs_1.16.3.

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