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