# Copyright (C) 2003 Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA # 02111-1307, USA. package Autom4te::FileUtils; use strict; use Exporter; use File::stat; use IO::File; use Autom4te::Channels; use Autom4te::ChannelDefs; use vars qw (@ISA @EXPORT); @ISA = qw (Exporter); @EXPORT = qw (&find_file &mtime &update_file &xsystem &contents); # $FILENAME # find_file ($FILENAME, @INCLUDE) # ------------------------------- # We match exactly the behavior of GNU m4: first look in the current # directory (which includes the case of absolute file names), and, if # the file is not absolute, just fail. Otherwise, look in the path. # # If the file is flagged as optional (ends with `?'), then return undef # if absent. sub find_file ($@) { use File::Spec; my ($filename, @include) = @_; my $optional = 0; $optional = 1 if $filename =~ s/\?$//; return File::Spec->canonpath ($filename) if -e $filename; if (File::Spec->file_name_is_absolute ($filename)) { fatal "$filename: no such file or directory" unless $optional; return undef; } foreach my $path (reverse @include) { return File::Spec->canonpath (File::Spec->catfile ($path, $filename)) if -e File::Spec->catfile ($path, $filename) } fatal "$filename: no such file or directory" unless $optional; return undef; } # $MTIME # MTIME ($FILE) # ------------- # Return the mtime of $FILE. Missing files, or `-' standing for STDIN # or STDOUT are ``obsolete'', i.e., as old as possible. sub mtime ($) { my ($file) = @_; return 0 if $file eq '-' || ! -f $file; my $stat = stat ($file) or fatal "cannot stat $file: $!"; return $stat->mtime; } # &update_file ($FROM, $TO) # ------------------------- # Rename $FROM as $TO, preserving $TO timestamp if it has not changed. # Recognize `$TO = -' standing for stdin. sub update_file ($$) { my ($from, $to) = @_; my $SIMPLE_BACKUP_SUFFIX = $ENV{'SIMPLE_BACKUP_SUFFIX'} || '~'; use File::Compare; use File::Copy; if ($to eq '-') { my $in = new IO::File ("$from"); my $out = new IO::File (">-"); while ($_ = $in->getline) { print $out $_; } $in->close; unlink ($from) || fatal "cannot not remove $from: $!"; return; } if (-f "$to" && compare ("$from", "$to") == 0) { # File didn't change, so don't update its mod time. msg 'note', "`$to' is unchanged"; return } if (-f "$to") { # Back up and install the new one. move ("$to", "$to$SIMPLE_BACKUP_SUFFIX") or fatal "cannot not backup $to: $!"; move ("$from", "$to") or fatal "cannot not rename $from as $to: $!"; msg 'note', "`$to' is updated"; } else { move ("$from", "$to") or fatal "cannot not rename $from as $to: $!"; msg 'note', "`$to' is created"; } } # handle_exec_errors ($COMMAND) # ----------------------------- # Display an error message for $COMMAND, based on the content of $? and $!. sub handle_exec_errors ($) { my ($command) = @_; $command = (split (' ', $command))[0]; if ($!) { fatal "failed to run $command: $!"; } else { use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG); if (WIFEXITED ($?)) { my $status = WEXITSTATUS ($?); # Propagate exit codes. fatal ("$command failed with exit status: $status", exit_code => $status); } elsif (WIFSIGNALED ($?)) { my $signal = WTERMSIG ($?); fatal "$command terminated by signal: $signal"; } else { fatal "$command exited abnormally"; } } } # xqx ($COMMAND) # -------------- # Same as `qx' (but in scalar context), but fails on errors. sub xqx ($) { my ($command) = @_; verb "running: $command"; $! = 0; my $res = `$command`; handle_exec_errors $command if $?; return $res; } # xsystem ($COMMAND) # ------------------ sub xsystem ($) { my ($command) = @_; verb "running: $command"; $! = 0; handle_exec_errors $command if system $command; } # contents ($FILENAME) # -------------------- # Swallow the contents of file $FILENAME. sub contents ($) { my ($file) = @_; verb "reading $file"; local $/; # Turn on slurp-mode. my $f = new Autom4te::XFile "< $file"; my $contents = $f->getline; $f->close; return $contents; } 1; # for require ### Setup "GNU" style for perl-mode and cperl-mode. ## Local Variables: ## perl-indent-level: 2 ## perl-continued-statement-offset: 2 ## perl-continued-brace-offset: 0 ## perl-brace-offset: 0 ## perl-brace-imaginary-offset: 0 ## perl-label-offset: -2 ## cperl-indent-level: 2 ## cperl-brace-offset: 0 ## cperl-continued-brace-offset: 0 ## cperl-label-offset: -2 ## cperl-extra-newline-before-brace: t ## cperl-merge-trailing-else: nil ## cperl-continued-statement-offset: 2 ## End: