lib/Automake/FileUtils.pm

   1 # Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2010 Free Software
   2 # Foundation, Inc.
   3
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2, or (at your option)
   7 # any later version.
   8
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17 ###############################################################
  18 # The main copy of this file is in Automake's git repository. #
  19 # Updates should be sent to automake-patches@gnu.org.         #
  20 ###############################################################
  21
  22 package Automake::FileUtils;
  23
  24 =head1 NAME
  25
  26 Automake::FileUtils - handling files
  27
  28 =head1 SYNOPSIS
  29
  30   use Automake::FileUtils
  31
  32 =head1 DESCRIPTION
  33
  34 This perl module provides various general purpose file handling functions.
  35
  36 =cut
  37
  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 (&open_quote &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
  56 =item C<open_quote ($file_name)>
  57
  58 Quote C<$file_name> for open.
  59
  60 =cut
  61
  62 # $FILE_NAME
  63 # open_quote ($FILE_NAME)
  64 # -----------------------
  65 # If the string $S is a well-behaved file name, simply return it.
  66 # If it starts with white space, prepend `./', if it ends with
  67 # white space, add `\0'.  Return the new string.
  68 sub open_quote($)
  69 {
  70   my ($s) = @_;
  71   if ($s =~ m/^\s/)
  72     {
  73       $s = "./$s";
  74     }
  75   if ($s =~ m/\s$/)
  76     {
  77       $s = "$s\0";
  78     }
  79   return $s;
  80 }
  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 $stat = stat ($file)
 143     or fatal "cannot stat $file: $!";
 144
 145   return $stat->mtime;
 146 }
 147
 148
 149 =item C<update_file ($from, $to, [$force])>
 150
 151 Rename C<$from> as C<$to>, preserving C<$to> timestamp if it has not
 152 changed, unless C<$force> is true (defaults to false).  Recognize
 153 C<$to> = C<-> standing for C<STDIN>.  C<$from> is always
 154 removed/renamed.
 155
 156 =cut
 157
 158 # &update_file ($FROM, $TO; $FORCE)
 159 # ---------------------------------
 160 sub update_file ($$;$)
 161 {
 162   my ($from, $to, $force) = @_;
 163   $force = 0
 164     unless defined $force;
 165   my $SIMPLE_BACKUP_SUFFIX = $ENV{'SIMPLE_BACKUP_SUFFIX'} || '~';
 166   use File::Compare;
 167   use File::Copy;
 168
 169   if ($to eq '-')
 170     {
 171       my $in = new IO::File ("< " . open_quote ($from));
 172       my $out = new IO::File (">-");
 173       while ($_ = $in->getline)
 174         {
 175           print $out $_;
 176         }
 177       $in->close;
 178       unlink ($from) || fatal "cannot remove $from: $!";
 179       return;
 180     }
 181
 182   if (!$force && -f "$to" && compare ("$from", "$to") == 0)
 183     {
 184       # File didn't change, so don't update its mod time.
 185       msg 'note', "`$to' is unchanged";
 186       unlink ($from)
 187         or fatal "cannot remove $from: $!";
 188       return
 189     }
 190
 191   if (-f "$to")
 192     {
 193       # Back up and install the new one.
 194       move ("$to",  "$to$SIMPLE_BACKUP_SUFFIX")
 195         or fatal "cannot backup $to: $!";
 196       move ("$from", "$to")
 197         or fatal "cannot rename $from as $to: $!";
 198       msg 'note', "`$to' is updated";
 199     }
 200   else
 201     {
 202       move ("$from", "$to")
 203         or fatal "cannot rename $from as $to: $!";
 204       msg 'note', "`$to' is created";
 205     }
 206 }
 207
 208
 209 =item C<up_to_date_p ($file, @dep)>
 210
 211 Is C<$file> more recent than C<@dep>?
 212
 213 =cut
 214
 215 # $BOOLEAN
 216 # &up_to_date_p ($FILE, @DEP)
 217 # ---------------------------
 218 sub up_to_date_p ($@)
 219 {
 220   my ($file, @dep) = @_;
 221   my $mtime = mtime ($file);
 222
 223   foreach my $dep (@dep)
 224     {
 225       if ($mtime < mtime ($dep))
 226         {
 227           verb "up_to_date ($file): outdated: $dep";
 228           return 0;
 229         }
 230     }
 231
 232   verb "up_to_date ($file): up to date";
 233   return 1;
 234 }
 235
 236
 237 =item C<handle_exec_errors ($command, [$expected_exit_code = 0], [$hint])>
 238
 239 Display an error message for C<$command>, based on the content of
 240 C<$?> and C<$!>.  Be quiet if the command exited normally
 241 with C<$expected_exit_code>.  If C<$hint> is given, display that as well
 242 if the command failed to run at all.
 243
 244 =cut
 245
 246 sub handle_exec_errors ($;$$)
 247 {
 248   my ($command, $expected, $hint) = @_;
 249   $expected = 0 unless defined $expected;
 250   if (defined $hint)
 251     {
 252       $hint = "\n" . $hint;
 253     }
 254   else
 255     {
 256       $hint = '';
 257     }
 258
 259   $command = (split (' ', $command))[0];
 260   if ($!)
 261     {
 262       fatal "failed to run $command: $!" . $hint;
 263     }
 264   else
 265     {
 266       use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
 267
 268       if (WIFEXITED ($?))
 269         {
 270           my $status = WEXITSTATUS ($?);
 271           # Propagate exit codes.
 272           fatal ('',
 273                  "$command failed with exit status: $status",
 274                  exit_code => $status)
 275             unless $status == $expected;
 276         }
 277       elsif (WIFSIGNALED ($?))
 278         {
 279           my $signal = WTERMSIG ($?);
 280           fatal "$command terminated by signal: $signal";
 281         }
 282       else
 283         {
 284           fatal "$command exited abnormally";
 285         }
 286     }
 287 }
 288
 289 =item C<xqx ($command)>
 290
 291 Same as C<qx> (but in scalar context), but fails on errors.
 292
 293 =cut
 294
 295 # xqx ($COMMAND)
 296 # --------------
 297 sub xqx ($)
 298 {
 299   my ($command) = @_;
 300
 301   verb "running: $command";
 302
 303   $! = 0;
 304   my $res = `$command`;
 305   handle_exec_errors $command
 306     if $?;
 307
 308   return $res;
 309 }
 310
 311
 312 =item C<xsystem (@argv)>
 313
 314 Same as C<system>, but fails on errors, and reports the C<@argv>
 315 in verbose mode.
 316
 317 =cut
 318
 319 sub xsystem (@)
 320 {
 321   my (@command) = @_;
 322
 323   verb "running: @command";
 324
 325   $! = 0;
 326   handle_exec_errors "@command"
 327     if system @command;
 328 }
 329
 330
 331 =item C<xsystem_hint ($msg, @argv)>
 332
 333 Same as C<xsystem>, but allows to pass a hint that will be displayed
 334 in case the command failed to run at all.
 335
 336 =cut
 337
 338 sub xsystem_hint (@)
 339 {
 340   my ($hint, @command) = @_;
 341
 342   verb "running: @command";
 343
 344   $! = 0;
 345   handle_exec_errors "@command", 0, $hint
 346     if system @command;
 347 }
 348
 349
 350 =item C<contents ($file_name)>
 351
 352 Return the contents of C<$file_name>.
 353
 354 =cut
 355
 356 # contents ($FILE_NAME)
 357 # ---------------------
 358 sub contents ($)
 359 {
 360   my ($file) = @_;
 361   verb "reading $file";
 362   local $/;                     # Turn on slurp-mode.
 363   my $f = new Automake::XFile "< " . open_quote ($file);
 364   my $contents = $f->getline;
 365   $f->close;
 366   return $contents;
 367 }
 368
 369
 370 =item C<dir_has_case_matching_file ($DIRNAME, $FILE_NAME)>
 371
 372 Return true iff $DIR contains a file name that matches $FILE_NAME case
 373 insensitively.
 374
 375 We need to be cautious on case-insensitive case-preserving file
 376 systems (e.g. Mac OS X's HFS+).  On such systems C<-f 'Foo'> and C<-f
 377 'foO'> answer the same thing.  Hence if a package distributes its own
 378 F<CHANGELOG> file, but has no F<ChangeLog> file, automake would still
 379 try to distribute F<ChangeLog> (because it thinks it exists) in
 380 addition to F<CHANGELOG>, although it is impossible for these two
 381 files to be in the same directory (the two file names designate the
 382 same file).
 383
 384 =cut
 385
 386 use vars '%_directory_cache';
 387 sub dir_has_case_matching_file ($$)
 388 {
 389   # Note that print File::Spec->case_tolerant returns 0 even on MacOS
 390   # X (with Perl v5.8.1-RC3 at least), so do not try to shortcut this
 391   # function using that.
 392
 393   my ($dirname, $file_name) = @_;
 394   return 0 unless -f "$dirname/$file_name";
 395
 396   # The file appears to exist, however it might be a mirage if the
 397   # system is case insensitive.  Let's browse the directory and check
 398   # whether the file is really in.  We maintain a cache of directories
 399   # so Automake doesn't spend all its time reading the same directory
 400   # again and again.
 401   if (!exists $_directory_cache{$dirname})
 402     {
 403       error "failed to open directory `$dirname'"
 404         unless opendir (DIR, $dirname);
 405       $_directory_cache{$dirname} = { map { $_ => 1 } readdir (DIR) };
 406       closedir (DIR);
 407     }
 408   return exists $_directory_cache{$dirname}{$file_name};
 409 }
 410
 411 =item C<reset_dir_cache ($dirname)>
 412
 413 Clear C<dir_has_case_matching_file>'s cache for C<$dirname>.
 414
 415 =cut
 416
 417 sub reset_dir_cache ($)
 418 {
 419   delete $_directory_cache{$_[0]};
 420 }
 421
 422 =item C<set_dir_cache_file ($dirname, $file_name)>
 423
 424 State that C<$dirname> contains C<$file_name> now.
 425
 426 =cut
 427
 428 sub set_dir_cache_file ($$)
 429 {
 430   my ($dirname, $file_name) = @_;
 431   $_directory_cache{$dirname}{$file_name} = 1
 432     if exists $_directory_cache{$dirname};
 433 }
 434
 435 1; # for require
 436
 437 ### Setup "GNU" style for perl-mode and cperl-mode.
 438 ## Local Variables:
 439 ## perl-indent-level: 2
 440 ## perl-continued-statement-offset: 2
 441 ## perl-continued-brace-offset: 0
 442 ## perl-brace-offset: 0
 443 ## perl-brace-imaginary-offset: 0
 444 ## perl-label-offset: -2
 445 ## cperl-indent-level: 2
 446 ## cperl-brace-offset: 0
 447 ## cperl-continued-brace-offset: 0
 448 ## cperl-label-offset: -2
 449 ## cperl-extra-newline-before-brace: t
 450 ## cperl-merge-trailing-else: nil
 451 ## cperl-continued-statement-offset: 2
 452 ## End: