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 21package Autom4te::FileUtils; 22 23=head1 NAME 24 25Autom4te::FileUtils - handling files 26 27=head1 SYNOPSIS 28 29 use Autom4te::FileUtils 30 31=head1 DESCRIPTION 32 33This perl module provides various general purpose file handling functions. 34 35=cut 36 37use strict; 38use Exporter; 39use File::stat; 40use IO::File; 41use Autom4te::Channels; 42use Autom4te::ChannelDefs; 43 44use 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 57Quote 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. 67sub 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 83Return the first path for a C<$file_name> in the C<include>s. 84 85We match exactly the behavior of GNU M4: first look in the current 86directory (which includes the case of absolute file names), and then, 87if the file name is not absolute, look in C<@include>. 88 89If the file is flagged as optional (ends with C<?>), then return undef 90if absent, otherwise exit with error. 91 92=cut 93 94# $FILE_NAME 95# find_file ($FILE_NAME, @INCLUDE) 96# ------------------------------- 97sub 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 126Return the mtime of C<$file>. Missing files, or C<-> standing for 127C<STDIN> or C<STDOUT> are ``obsolete'', i.e., as old as possible. 128 129=cut 130 131# $MTIME 132# MTIME ($FILE) 133# ------------- 134sub 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 150Rename C<$from> as C<$to>, preserving C<$to> timestamp if it has not 151changed, unless C<$force> is true (defaults to false). Recognize 152C<$to> = C<-> standing for C<STDIN>. C<$from> is always 153removed/renamed. 154 155=cut 156 157# &update_file ($FROM, $TO; $FORCE) 158# --------------------------------- 159sub 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 210Is C<$file> more recent than C<@dep>? 211 212=cut 213 214# $BOOLEAN 215# &up_to_date_p ($FILE, @DEP) 216# --------------------------- 217sub 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 238Display an error message for C<$command>, based on the content of 239C<$?> and C<$!>. Be quiet if the command exited normally 240with C<$expected_exit_code>. If C<$hint> is given, display that as well 241if the command failed to run at all. 242 243=cut 244 245sub 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 290Same as C<qx> (but in scalar context), but fails on errors. 291 292=cut 293 294# xqx ($COMMAND) 295# -------------- 296sub 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 313Same as C<system>, but fails on errors, and reports the C<@argv> 314in verbose mode. 315 316=cut 317 318sub 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 332Same as C<xsystem>, but allows to pass a hint that will be displayed 333in case the command failed to run at all. 334 335=cut 336 337sub 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 351Return the contents of C<$file_name>. 352 353=cut 354 355# contents ($FILE_NAME) 356# --------------------- 357sub 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 371Return true iff $DIR contains a file name that matches $FILE_NAME case 372insensitively. 373 374We need to be cautious on case-insensitive case-preserving file 375systems (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 377F<CHANGELOG> file, but has no F<ChangeLog> file, automake would still 378try to distribute F<ChangeLog> (because it thinks it exists) in 379addition to F<CHANGELOG>, although it is impossible for these two 380files to be in the same directory (the two file names designate the 381same file). 382 383=cut 384 385use vars '%_directory_cache'; 386sub 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 412Clear C<dir_has_case_matching_file>'s cache for C<$dirname>. 413 414=cut 415 416sub reset_dir_cache ($) 417{ 418 delete $_directory_cache{$_[0]}; 419} 420 421=item C<set_dir_cache_file ($dirname, $file_name)> 422 423State that C<$dirname> contains C<$file_name> now. 424 425=cut 426 427sub 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 4341; # 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: 452