lib/Automake/FileUtils.pm

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