lib/Autom4te/FileUtils.pm

   1 # Copyright (C) 2003-2017 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 Autom4te::FileUtils;
  22
  23 =head1 NAME
  24
  25 Autom4te::FileUtils - handling files
  26
  27 =head1 SYNOPSIS
  28
  29   use Autom4te::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 Exporter;
  40 use File::stat;
  41 use IO::File;
  42 use Autom4te::Channels;
  43 use Autom4te::ChannelDefs;
  44
  45 use vars qw (@ISA @EXPORT);
  46
  47 @ISA = qw (Exporter);
  48 @EXPORT = qw (&contents
  49               &find_file &mtime
  50               &update_file &up_to_date_p
  51               &xsystem &xsystem_hint &xqx
  52               &dir_has_case_matching_file &reset_dir_cache
  53               &set_dir_cache_file);
  54
  55 =item C<find_file ($file_name, @include)>
  56
  57 Return the first path for a C<$file_name> in the C<include>s.
  58
  59 We match exactly the behavior of GNU M4: first look in the current
  60 directory (which includes the case of absolute file names), and then,
  61 if the file name is not absolute, look in C<@include>.
  62
  63 If the file is flagged as optional (ends with C<?>), then return undef
  64 if absent, otherwise exit with error.
  65
  66 =cut
  67
  68 # $FILE_NAME
  69 # find_file ($FILE_NAME, @INCLUDE)
  70 # --------------------------------
  71 sub 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
 100 Return the mtime of C<$file>.  Missing files, or C<-> standing for
 101 C<STDIN> or C<STDOUT> are "obsolete", i.e., as old as possible.
 102
 103 =cut
 104
 105 # $MTIME
 106 # MTIME ($FILE)
 107 # -------------
 108 sub 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
 124 Rename C<$from> as C<$to>, preserving C<$to> timestamp if it has not
 125 changed, unless C<$force> is true (defaults to false).  Recognize
 126 C<$to> = C<-> standing for C<STDIN>.  C<$from> is always
 127 removed/renamed.
 128
 129 =cut
 130
 131 # &update_file ($FROM, $TO; $FORCE)
 132 # ---------------------------------
 133 sub 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   my $exists = (-f "$to");
 165   if ($exists)
 166     {
 167       # Back up any existing destination.
 168       move ("$to",  "$to$SIMPLE_BACKUP_SUFFIX")
 169         or fatal "cannot backup $to: $!";
 170     }
 171
 172   # Do not use move ("$from", "$to"), as it truncates file timestamps.
 173   rename ("$from", "$to")
 174     or system ("mv", "$from", "$to") == 0
 175     or fatal "cannot rename $from as $to: $!";
 176
 177   msg 'note', ($exists ? "'$to' is updated" : "'$to is created")
 178 }
 179
 180
 181 =item C<up_to_date_p ($file, @dep)>
 182
 183 Is C<$file> more recent than C<@dep>?
 184
 185 =cut
 186
 187 # $BOOLEAN
 188 # &up_to_date_p ($FILE, @DEP)
 189 # ---------------------------
 190 sub up_to_date_p ($@)
 191 {
 192   my ($file, @dep) = @_;
 193   my $mtime = mtime ($file);
 194
 195   foreach my $dep (@dep)
 196     {
 197       if ($mtime < mtime ($dep))
 198         {
 199           verb "up_to_date ($file): outdated: $dep";
 200           return 0;
 201         }
 202     }
 203
 204   verb "up_to_date ($file): up to date";
 205   return 1;
 206 }
 207
 208
 209 =item C<handle_exec_errors ($command, [$expected_exit_code = 0], [$hint])>
 210
 211 Display an error message for C<$command>, based on the content of
 212 C<$?> and C<$!>.  Be quiet if the command exited normally
 213 with C<$expected_exit_code>.  If C<$hint> is given, display that as well
 214 if the command failed to run at all.
 215
 216 =cut
 217
 218 sub handle_exec_errors ($;$$)
 219 {
 220   my ($command, $expected, $hint) = @_;
 221   $expected = 0 unless defined $expected;
 222   if (defined $hint)
 223     {
 224       $hint = "\n" . $hint;
 225     }
 226   else
 227     {
 228       $hint = '';
 229     }
 230
 231   $command = (split (' ', $command))[0];
 232   if ($!)
 233     {
 234       fatal "failed to run $command: $!" . $hint;
 235     }
 236   else
 237     {
 238       use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
 239
 240       if (WIFEXITED ($?))
 241         {
 242           my $status = WEXITSTATUS ($?);
 243           # Propagate exit codes.
 244           fatal ('',
 245                  "$command failed with exit status: $status",
 246                  exit_code => $status)
 247             unless $status == $expected;
 248         }
 249       elsif (WIFSIGNALED ($?))
 250         {
 251           my $signal = WTERMSIG ($?);
 252           fatal "$command terminated by signal: $signal";
 253         }
 254       else
 255         {
 256           fatal "$command exited abnormally";
 257         }
 258     }
 259 }
 260
 261 =item C<xqx ($command)>
 262
 263 Same as C<qx> (but in scalar context), but fails on errors.
 264
 265 =cut
 266
 267 # xqx ($COMMAND)
 268 # --------------
 269 sub xqx ($)
 270 {
 271   my ($command) = @_;
 272
 273   verb "running: $command";
 274
 275   $! = 0;
 276   my $res = `$command`;
 277   handle_exec_errors $command
 278     if $?;
 279
 280   return $res;
 281 }
 282
 283
 284 =item C<xsystem (@argv)>
 285
 286 Same as C<system>, but fails on errors, and reports the C<@argv>
 287 in verbose mode.
 288
 289 =cut
 290
 291 sub xsystem (@)
 292 {
 293   my (@command) = @_;
 294
 295   verb "running: @command";
 296
 297   $! = 0;
 298   handle_exec_errors "@command"
 299     if system @command;
 300 }
 301
 302
 303 =item C<xsystem_hint ($msg, @argv)>
 304
 305 Same as C<xsystem>, but allows to pass a hint that will be displayed
 306 in case the command failed to run at all.
 307
 308 =cut
 309
 310 sub xsystem_hint (@)
 311 {
 312   my ($hint, @command) = @_;
 313
 314   verb "running: @command";
 315
 316   $! = 0;
 317   handle_exec_errors "@command", 0, $hint
 318     if system @command;
 319 }
 320
 321
 322 =item C<contents ($file_name)>
 323
 324 Return the contents of C<$file_name>.
 325
 326 =cut
 327
 328 # contents ($FILE_NAME)
 329 # ---------------------
 330 sub contents ($)
 331 {
 332   my ($file) = @_;
 333   verb "reading $file";
 334   local $/;                     # Turn on slurp-mode.
 335   my $f = new Autom4te::XFile $file, "<";
 336   my $contents = $f->getline;
 337   $f->close;
 338   return $contents;
 339 }
 340
 341
 342 =item C<dir_has_case_matching_file ($DIRNAME, $FILE_NAME)>
 343
 344 Return true iff $DIR contains a file name that matches $FILE_NAME case
 345 insensitively.
 346
 347 We need to be cautious on case-insensitive case-preserving file
 348 systems (e.g. Mac OS X's HFS+).  On such systems C<-f 'Foo'> and C<-f
 349 'foO'> answer the same thing.  Hence if a package distributes its own
 350 F<CHANGELOG> file, but has no F<ChangeLog> file, automake would still
 351 try to distribute F<ChangeLog> (because it thinks it exists) in
 352 addition to F<CHANGELOG>, although it is impossible for these two
 353 files to be in the same directory (the two file names designate the
 354 same file).
 355
 356 =cut
 357
 358 use vars '%_directory_cache';
 359 sub dir_has_case_matching_file ($$)
 360 {
 361   # Note that print File::Spec->case_tolerant returns 0 even on MacOS
 362   # X (with Perl v5.8.1-RC3 at least), so do not try to shortcut this
 363   # function using that.
 364
 365   my ($dirname, $file_name) = @_;
 366   return 0 unless -f "$dirname/$file_name";
 367
 368   # The file appears to exist, however it might be a mirage if the
 369   # system is case insensitive.  Let's browse the directory and check
 370   # whether the file is really in.  We maintain a cache of directories
 371   # so Automake doesn't spend all its time reading the same directory
 372   # again and again.
 373   if (!exists $_directory_cache{$dirname})
 374     {
 375       error "failed to open directory '$dirname'"
 376         unless opendir (DIR, $dirname);
 377       $_directory_cache{$dirname} = { map { $_ => 1 } readdir (DIR) };
 378       closedir (DIR);
 379     }
 380   return exists $_directory_cache{$dirname}{$file_name};
 381 }
 382
 383 =item C<reset_dir_cache ($dirname)>
 384
 385 Clear C<dir_has_case_matching_file>'s cache for C<$dirname>.
 386
 387 =cut
 388
 389 sub reset_dir_cache ($)
 390 {
 391   delete $_directory_cache{$_[0]};
 392 }
 393
 394 =item C<set_dir_cache_file ($dirname, $file_name)>
 395
 396 State that C<$dirname> contains C<$file_name> now.
 397
 398 =cut
 399
 400 sub set_dir_cache_file ($$)
 401 {
 402   my ($dirname, $file_name) = @_;
 403   $_directory_cache{$dirname}{$file_name} = 1
 404     if exists $_directory_cache{$dirname};
 405 }
 406
 407 1; # for require