lib/Autom4te/FileUtils.pm

   1 # Copyright (C) 2003, 2004, 2005, 2006, 2007  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 of the License, or
   6 # (at your option) 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 (&contents
  48               &find_file &mtime
  49               &update_file &up_to_date_p
  50               &xsystem &xqx &dir_has_case_matching_file &reset_dir_cache
  51               $SIMPLE_BACKUP_SUFFIX);
  52
  53
  54 =item C<find_file ($file_name, @include)>
  55
  56 Return the first path for a C<$file_name> in the C<include>s.
  57
  58 We match exactly the behavior of GNU M4: first look in the current
  59 directory (which includes the case of absolute file names), and then,
  60 if the file name is not absolute, look in C<@include>.
  61
  62 If the file is flagged as optional (ends with C<?>), then return undef
  63 if absent, otherwise exit with error.
  64
  65 =cut
  66
  67 # $FILE_NAME
  68 # find_file ($FILE_NAME, @INCLUDE)
  69 # -------------------------------
  70 sub find_file ($@)
  71 {
  72   use File::Spec;
  73
  74   my ($file_name, @include) = @_;
  75   my $optional = 0;
  76
  77   $optional = 1
  78     if $file_name =~ s/\?$//;
  79
  80   return File::Spec->canonpath ($file_name)
  81     if -e $file_name;
  82
  83   if (!File::Spec->file_name_is_absolute ($file_name))
  84     {
  85       foreach my $path (@include)
  86         {
  87           return File::Spec->canonpath (File::Spec->catfile ($path, $file_name))
  88             if -e File::Spec->catfile ($path, $file_name)
  89         }
  90     }
  91
  92   fatal "$file_name: no such file or directory"
  93     unless $optional;
  94   return undef;
  95 }
  96
  97 =item C<mtime ($file)>
  98
  99 Return the mtime of C<$file>.  Missing files, or C<-> standing for
 100 C<STDIN> or C<STDOUT> are ``obsolete'', i.e., as old as possible.
 101
 102 =cut
 103
 104 # $MTIME
 105 # MTIME ($FILE)
 106 # -------------
 107 sub mtime ($)
 108 {
 109   my ($file) = @_;
 110
 111   return 0
 112     if $file eq '-' || ! -f $file;
 113
 114   my $stat = stat ($file)
 115     or fatal "cannot stat $file: $!";
 116
 117   return $stat->mtime;
 118 }
 119
 120
 121 =item C<$SIMPLE_BACKUP_SUFFIX>
 122
 123 Suffix to use for files backed up.  Defaults to `~'.  Can be overridden
 124 with the environment variable SIMPLE_BACKUP_SUFFIX.
 125
 126 =cut
 127
 128 use vars qw ($SIMPLE_BACKUP_SUFFIX);
 129 $SIMPLE_BACKUP_SUFFIX = $ENV{'SIMPLE_BACKUP_SUFFIX'} || '~';
 130
 131
 132 =item C<update_file ($from, $to, [$force])>
 133
 134 Rename C<$from> as C<$to>, preserving C<$to> timestamp if it has not
 135 changed, unless C<$force> is true (defaults to false).  Recognize
 136 C<$to> = C<-> standing for C<STDIN>.  C<$from> is always
 137 removed/renamed.
 138
 139 =cut
 140
 141 # &update_file ($FROM, $TO; $FORCE)
 142 # ---------------------------------
 143 sub update_file ($$;$)
 144 {
 145   my ($from, $to, $force) = @_;
 146   $force = 0
 147     unless defined $force;
 148   use File::Compare;
 149   use File::Copy;
 150
 151   if ($to eq '-')
 152     {
 153       my $in = new IO::File ("$from");
 154       my $out = new IO::File (">-");
 155       while ($_ = $in->getline)
 156         {
 157           print $out $_;
 158         }
 159       $in->close;
 160       unlink ($from) || fatal "cannot remove $from: $!";
 161       return;
 162     }
 163
 164   if (!$force && -f "$to" && compare ("$from", "$to") == 0)
 165     {
 166       # File didn't change, so don't update its mod time.
 167       msg 'note', "`$to' is unchanged";
 168       unlink ($from)
 169         or fatal "cannot remove $from: $!";
 170       return
 171     }
 172
 173   if (-f "$to")
 174     {
 175       # Back up and install the new one.
 176       move ("$to",  "$to$SIMPLE_BACKUP_SUFFIX")
 177         or fatal "cannot backup $to: $!";
 178       move ("$from", "$to")
 179         or fatal "cannot rename $from as $to: $!";
 180       msg 'note', "`$to' is updated";
 181     }
 182   else
 183     {
 184       move ("$from", "$to")
 185         or fatal "cannot rename $from as $to: $!";
 186       msg 'note', "`$to' is created";
 187     }
 188 }
 189
 190
 191 =item C<up_to_date_p ($file, @dep)>
 192
 193 Is C<$file> more recent than C<@dep>?
 194
 195 =cut
 196
 197 # $BOOLEAN
 198 # &up_to_date_p ($FILE, @DEP)
 199 # ---------------------------
 200 sub up_to_date_p ($@)
 201 {
 202   my ($file, @dep) = @_;
 203   my $mtime = mtime ($file);
 204
 205   foreach my $dep (@dep)
 206     {
 207       if ($mtime < mtime ($dep))
 208         {
 209           verb "up_to_date ($file): outdated: $dep";
 210           return 0;
 211         }
 212     }
 213
 214   verb "up_to_date ($file): up to date";
 215   return 1;
 216 }
 217
 218
 219 =item C<handle_exec_errors ($command, [$expected_exit_code = 0])>
 220
 221 Display an error message for C<$command>, based on the content of
 222 C<$?> and C<$!>.  Be quiet if the command exited normally
 223 with C<$expected_exit_code>.
 224
 225 =cut
 226
 227 sub handle_exec_errors ($;$)
 228 {
 229   my ($command, $expected) = @_;
 230   $expected = 0 unless defined $expected;
 231
 232   $command = (split (' ', $command))[0];
 233   if ($!)
 234     {
 235       fatal "failed to run $command: $!";
 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<contents ($file_name)>
 305
 306 Return the contents of C<$file_name>.
 307
 308 =cut
 309
 310 # contents ($FILE_NAME)
 311 # ---------------------
 312 sub contents ($)
 313 {
 314   my ($file) = @_;
 315   verb "reading $file";
 316   local $/;                     # Turn on slurp-mode.
 317   my $f = new Autom4te::XFile "< $file";
 318   my $contents = $f->getline;
 319   $f->close;
 320   return $contents;
 321 }
 322
 323
 324 =item C<dir_has_case_matching_file ($DIRNAME, $FILE_NAME)>
 325
 326 Return true iff $DIR contains a file name that matches $FILE_NAME case
 327 insensitively.
 328
 329 We need to be cautious on case-insensitive case-preserving file
 330 systems (e.g. Mac OS X's HFS+).  On such systems C<-f 'Foo'> and C<-f
 331 'foO'> answer the same thing.  Hence if a package distributes its own
 332 F<CHANGELOG> file, but has no F<ChangeLog> file, automake would still
 333 try to distribute F<ChangeLog> (because it thinks it exists) in
 334 addition to F<CHANGELOG>, although it is impossible for these two
 335 files to be in the same directory (the two file names designate the
 336 same file).
 337
 338 =cut
 339
 340 use vars '%_directory_cache';
 341 sub dir_has_case_matching_file ($$)
 342 {
 343   # Note that print File::Spec->case_tolerant returns 0 even on MacOS
 344   # X (with Perl v5.8.1-RC3 at least), so do not try to shortcut this
 345   # function using that.
 346
 347   my ($dirname, $file_name) = @_;
 348   return 0 unless -f "$dirname/$file_name";
 349
 350   # The file appears to exist, however it might be a mirage if the
 351   # system is case insensitive.  Let's browse the directory and check
 352   # whether the file is really in.  We maintain a cache of directories
 353   # so Automake doesn't spend all its time reading the same directory
 354   # again and again.
 355   if (!exists $_directory_cache{$dirname})
 356     {
 357       error "failed to open directory `$dirname'"
 358         unless opendir (DIR, $dirname);
 359       $_directory_cache{$dirname} = { map { $_ => 1 } readdir (DIR) };
 360       closedir (DIR);
 361     }
 362   return exists $_directory_cache{$dirname}{$file_name};
 363 }
 364
 365 =item C<reset_dir_cache ($dirname)>
 366
 367 Clear C<dir_has_case_matching_file>'s cache for C<$dirname>.
 368
 369 =cut
 370
 371 sub reset_dir_cache ($)
 372 {
 373   delete $_directory_cache{$_[0]};
 374 }
 375
 376 1; # for require
 377
 378 ### Setup "GNU" style for perl-mode and cperl-mode.
 379 ## Local Variables:
 380 ## perl-indent-level: 2
 381 ## perl-continued-statement-offset: 2
 382 ## perl-continued-brace-offset: 0
 383 ## perl-brace-offset: 0
 384 ## perl-brace-imaginary-offset: 0
 385 ## perl-label-offset: -2
 386 ## cperl-indent-level: 2
 387 ## cperl-brace-offset: 0
 388 ## cperl-continued-brace-offset: 0
 389 ## cperl-label-offset: -2
 390 ## cperl-extra-newline-before-brace: t
 391 ## cperl-merge-trailing-else: nil
 392 ## cperl-continued-statement-offset: 2
 393 ## End: