lib/Automake/FileUtils.pm

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