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 23package Autom4te::FileUtils; 24 25=head1 NAME 26 27Autom4te::FileUtils - handling files 28 29=head1 SYNOPSIS 30 31 use Autom4te::FileUtils 32 33=head1 DESCRIPTION 34 35This perl module provides various general purpose file handling functions. 36 37=cut 38 39use strict; 40use Exporter; 41use File::stat; 42use IO::File; 43use Autom4te::Channels; 44use Autom4te::ChannelDefs; 45 46use 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 57Return the first path for a C<$file_name> in the C<include>s. 58 59We match exactly the behavior of GNU M4: first look in the current 60directory (which includes the case of absolute file names), and then, 61if the file name is not absolute, look in C<@include>. 62 63If the file is flagged as optional (ends with C<?>), then return undef 64if absent, otherwise exit with error. 65 66=cut 67 68# $FILE_NAME 69# find_file ($FILE_NAME, @INCLUDE) 70# ------------------------------- 71sub 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 100Return the mtime of C<$file>. Missing files, or C<-> standing for 101C<STDIN> or C<STDOUT> are ``obsolete'', i.e., as old as possible. 102 103=cut 104 105# $MTIME 106# MTIME ($FILE) 107# ------------- 108sub 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 124Rename C<$from> as C<$to>, preserving C<$to> timestamp if it has not 125changed, unless C<$force> is true (defaults to false). Recognize 126C<$to> = C<-> standing for C<STDIN>. C<$from> is always 127removed/renamed. 128 129=cut 130 131# &update_file ($FROM, $TO; $FORCE) 132# --------------------------------- 133sub 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 184Is C<$file> more recent than C<@dep>? 185 186=cut 187 188# $BOOLEAN 189# &up_to_date_p ($FILE, @DEP) 190# --------------------------- 191sub 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 212Display an error message for C<$command>, based on the content of 213C<$?> and C<$!>. Be quiet if the command exited normally 214with C<$expected_exit_code>. 215 216=cut 217 218sub 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 255Same as C<qx> (but in scalar context), but fails on errors. 256 257=cut 258 259# xqx ($COMMAND) 260# -------------- 261sub 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 278Same as C<system>, but fails on errors, and reports the C<@argv> 279in verbose mode. 280 281=cut 282 283sub 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 297Return the contents of C<$file_name>. 298 299=cut 300 301# contents ($FILE_NAME) 302# --------------------- 303sub 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 317Return true iff $DIR contains a file name that matches $FILE_NAME case 318insensitively. 319 320We need to be cautious on case-insensitive case-preserving file 321systems (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 323F<CHANGELOG> file, but has no F<ChangeLog> file, automake would still 324try to distribute F<ChangeLog> (because it thinks it exists) in 325addition to F<CHANGELOG>, although it is impossible for these two 326files to be in the same directory (the two file names designate the 327same file). 328 329=cut 330 331use vars '%_directory_cache'; 332sub 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 358Clear C<dir_has_case_matching_file>'s cache for C<$dirname>. 359 360=cut 361 362sub reset_dir_cache ($) 363{ 364 delete $_directory_cache{$_[0]}; 365} 366 3671; # 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: 385