lib/Automake/FileUtils.pm

   1 # Copyright (C) 2003-2012 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 <http://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 Exporter;
  40 use File::stat;
  41 use IO::File;
  42 use Automake::Channels;
  43 use Automake::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   if (-f "$to")
 165     {
 166       # Back up and install the new one.
 167       move ("$to",  "$to$SIMPLE_BACKUP_SUFFIX")
 168         or fatal "cannot backup $to: $!";
 169       move ("$from", "$to")
 170         or fatal "cannot rename $from as $to: $!";
 171       msg 'note', "'$to' is updated";
 172     }
 173   else
 174     {
 175       move ("$from", "$to")
 176         or fatal "cannot rename $from as $to: $!";
 177       msg 'note', "'$to' is created";
 178     }
 179 }
 180
 181
 182 =item C<up_to_date_p ($file, @dep)>
 183
 184 Is C<$file> more recent than C<@dep>?
 185
 186 =cut
 187
 188 # $BOOLEAN
 189 # &up_to_date_p ($FILE, @DEP)
 190 # ---------------------------
 191 sub up_to_date_p ($@)
 192 {
 193   my ($file, @dep) = @_;
 194   my $mtime = mtime ($file);
 195
 196   foreach my $dep (@dep)
 197     {
 198       if ($mtime < mtime ($dep))
 199         {
 200           verb "up_to_date ($file): outdated: $dep";
 201           return 0;
 202         }
 203     }
 204
 205   verb "up_to_date ($file): up to date";
 206   return 1;
 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 use vars '%_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 1; # for require
 409
 410 ### Setup "GNU" style for perl-mode and cperl-mode.
 411 ## Local Variables:
 412 ## perl-indent-level: 2
 413 ## perl-continued-statement-offset: 2
 414 ## perl-continued-brace-offset: 0
 415 ## perl-brace-offset: 0
 416 ## perl-brace-imaginary-offset: 0
 417 ## perl-label-offset: -2
 418 ## cperl-indent-level: 2
 419 ## cperl-brace-offset: 0
 420 ## cperl-continued-brace-offset: 0
 421 ## cperl-label-offset: -2
 422 ## cperl-extra-newline-before-brace: t
 423 ## cperl-merge-trailing-else: nil
 424 ## cperl-continued-statement-offset: 2
 425 ## End: