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