share/autoconf/Autom4te/FileUtils.pm

   1 # Copyright (C) 2003, 2004, 2005, 2006  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, write to the Free Software
  15 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16 # 02110-1301, USA.
  17
  18 ###############################################################
  19 # The main copy of this file is in Automake's CVS repository. #
  20 # Updates should be sent to automake-patches@gnu.org.         #
  21 ###############################################################
  22
  23 package Autom4te::FileUtils;
  24
  25 =head1 NAME
  26
  27 Autom4te::FileUtils - handling files
  28
  29 =head1 SYNOPSIS
  30
  31   use Autom4te::FileUtils
  32
  33 =head1 DESCRIPTION
  34
  35 This perl module provides various general purpose file handling functions.
  36
  37 =cut
  38
  39 use strict;
  40 use Exporter;
  41 use File::stat;
  42 use IO::File;
  43 use Autom4te::Channels;
  44 use Autom4te::ChannelDefs;
  45
  46 use vars qw (@ISA @EXPORT);
  47
  48 @ISA = qw (Exporter);
  49 @EXPORT = qw (&contents
  50               &find_file &mtime
  51               &update_file &up_to_date_p
  52               &xsystem &xqx &dir_has_case_matching_file &reset_dir_cache);
  53
  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])>
 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>.
 215
 216 =cut
 217
 218 sub handle_exec_errors ($;$)
 219 {
 220   my ($command, $expected) = @_;
 221   $expected = 0 unless defined $expected;
 222
 223   $command = (split (' ', $command))[0];
 224   if ($!)
 225     {
 226       fatal "failed to run $command: $!";
 227     }
 228   else
 229     {
 230       use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
 231
 232       if (WIFEXITED ($?))
 233         {
 234           my $status = WEXITSTATUS ($?);
 235           # Propagate exit codes.
 236           fatal ('',
 237                  "$command failed with exit status: $status",
 238                  exit_code => $status)
 239             unless $status == $expected;
 240         }
 241       elsif (WIFSIGNALED ($?))
 242         {
 243           my $signal = WTERMSIG ($?);
 244           fatal "$command terminated by signal: $signal";
 245         }
 246       else
 247         {
 248           fatal "$command exited abnormally";
 249         }
 250     }
 251 }
 252
 253 =item C<xqx ($command)>
 254
 255 Same as C<qx> (but in scalar context), but fails on errors.
 256
 257 =cut
 258
 259 # xqx ($COMMAND)
 260 # --------------
 261 sub xqx ($)
 262 {
 263   my ($command) = @_;
 264
 265   verb "running: $command";
 266
 267   $! = 0;
 268   my $res = `$command`;
 269   handle_exec_errors $command
 270     if $?;
 271
 272   return $res;
 273 }
 274
 275
 276 =item C<xsystem (@argv)>
 277
 278 Same as C<system>, but fails on errors, and reports the C<@argv>
 279 in verbose mode.
 280
 281 =cut
 282
 283 sub xsystem (@)
 284 {
 285   my (@command) = @_;
 286
 287   verb "running: @command";
 288
 289   $! = 0;
 290   handle_exec_errors "@command"
 291     if system @command;
 292 }
 293
 294
 295 =item C<contents ($file_name)>
 296
 297 Return the contents of C<$file_name>.
 298
 299 =cut
 300
 301 # contents ($FILE_NAME)
 302 # ---------------------
 303 sub contents ($)
 304 {
 305   my ($file) = @_;
 306   verb "reading $file";
 307   local $/;                     # Turn on slurp-mode.
 308   my $f = new Autom4te::XFile "< $file";
 309   my $contents = $f->getline;
 310   $f->close;
 311   return $contents;
 312 }
 313
 314
 315 =item C<dir_has_case_matching_file ($DIRNAME, $FILE_NAME)>
 316
 317 Return true iff $DIR contains a file name that matches $FILE_NAME case
 318 insensitively.
 319
 320 We need to be cautious on case-insensitive case-preserving file
 321 systems (e.g. Mac OS X's HFS+).  On such systems C<-f 'Foo'> and C<-f
 322 'foO'> answer the same thing.  Hence if a package distributes its own
 323 F<CHANGELOG> file, but has no F<ChangeLog> file, automake would still
 324 try to distribute F<ChangeLog> (because it thinks it exists) in
 325 addition to F<CHANGELOG>, although it is impossible for these two
 326 files to be in the same directory (the two file names designate the
 327 same file).
 328
 329 =cut
 330
 331 use vars '%_directory_cache';
 332 sub dir_has_case_matching_file ($$)
 333 {
 334   # Note that print File::Spec->case_tolerant returns 0 even on MacOS
 335   # X (with Perl v5.8.1-RC3 at least), so do not try to shortcut this
 336   # function using that.
 337
 338   my ($dirname, $file_name) = @_;
 339   return 0 unless -f "$dirname/$file_name";
 340
 341   # The file appears to exist, however it might be a mirage if the
 342   # system is case insensitive.  Let's browse the directory and check
 343   # whether the file is really in.  We maintain a cache of directories
 344   # so Automake doesn't spend all its time reading the same directory
 345   # again and again.
 346   if (!exists $_directory_cache{$dirname})
 347     {
 348       error "failed to open directory `$dirname'"
 349         unless opendir (DIR, $dirname);
 350       $_directory_cache{$dirname} = { map { $_ => 1 } readdir (DIR) };
 351       closedir (DIR);
 352     }
 353   return exists $_directory_cache{$dirname}{$file_name};
 354 }
 355
 356 =item C<reset_dir_cache ($dirname)>
 357
 358 Clear C<dir_has_case_matching_file>'s cache for C<$dirname>.
 359
 360 =cut
 361
 362 sub reset_dir_cache ($)
 363 {
 364   delete $_directory_cache{$_[0]};
 365 }
 366
 367 1; # for require
 368
 369 ### Setup "GNU" style for perl-mode and cperl-mode.
 370 ## Local Variables:
 371 ## perl-indent-level: 2
 372 ## perl-continued-statement-offset: 2
 373 ## perl-continued-brace-offset: 0
 374 ## perl-brace-offset: 0
 375 ## perl-brace-imaginary-offset: 0
 376 ## perl-label-offset: -2
 377 ## cperl-indent-level: 2
 378 ## cperl-brace-offset: 0
 379 ## cperl-continued-brace-offset: 0
 380 ## cperl-label-offset: -2
 381 ## cperl-extra-newline-before-brace: t
 382 ## cperl-merge-trailing-else: nil
 383 ## cperl-continued-statement-offset: 2
 384 ## End: