# Copyright (C) 2001-2018 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, see <https://www.gnu.org/licenses/>.
# Written by Akim Demaille <akim@freefriends.org>.
###############################################################
# The main copy of this file is in Automake's git repository. #
# Updates should be sent to automake-patches@gnu.org. #
###############################################################
package Automake::XFile;
=head1 NAME
Automake::XFile - supply object methods for filehandles with error handling
=head1 SYNOPSIS
use Automake::XFile;
$fh = new Automake::XFile;
$fh->open ("file", "<");
# No need to check $FH: we died if open failed.
print <$fh>;
$fh->close;
# No need to check the return value of close: we died if it failed.
$fh = new Automake::XFile "file", ">";
# No need to check $FH: we died if new failed.
print $fh "bar\n";
$fh->close;
$fh = new Automake::XFile "file", "r";
# No need to check $FH: we died if new failed.
defined $fh
print <$fh>;
undef $fh; # automatically closes the file and checks for errors.
$fh = new Automake::XFile "file", O_WRONLY | O_APPEND;
# No need to check $FH: we died if new failed.
print $fh "corge\n";
$pos = $fh->getpos;
$fh->setpos ($pos);
undef $fh; # automatically closes the file and checks for errors.
autoflush STDOUT 1;
=head1 DESCRIPTION
C<Automake::XFile> inherits from C<IO::File>. It provides the method
C<name> returning the file name. It provides dying versions of the
methods C<close>, C<lock> (corresponding to C<flock>), C<new>,
C<open>, C<seek>, and C<truncate>. It also overrides the C<getline>
and C<getlines> methods to translate C<\r\n> to C<\n>.
=cut
use 5.006;
use strict;
use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA);
use Carp;
use Errno;
use IO::File;
use File::Basename;
use Automake::ChannelDefs;
use Automake::Channels qw(msg);
use Automake::FileUtils;
require Exporter;
require DynaLoader;
@ISA = qw(IO::File Exporter DynaLoader);
$VERSION = "1.2";
@EXPORT = @IO::File::EXPORT;
eval {
# Make all Fcntl O_XXX and LOCK_XXX constants available for importing
require Fcntl;
my @O = grep /^(LOCK|O)_/, @Fcntl::EXPORT, @Fcntl::EXPORT_OK;
Fcntl->import (@O); # first we import what we want to export
push (@EXPORT, @O);
};
=head2 Methods
=over
=item C<$fh = new Automake::XFile ([$expr, ...]>
Constructor a new XFile object. Additional arguments
are passed to C<open>, if any.
=cut
sub new
{
my $type = shift;
my $class = ref $type || $type || "Automake::XFile";
my $fh = $class->SUPER::new ();
if (@_)
{
$fh->open (@_);
}
$fh;
}
=item C<$fh-E<gt>open ([$file, ...])>
Open a file, passing C<$file> and further arguments to C<IO::File::open>.
Die if opening fails. Store the name of the file. Use binmode for writing.
=cut
sub open
{
my $fh = shift;
my ($file, $mode) = @_;
# WARNING: Gross hack: $FH is a typeglob: use its hash slot to store
# the 'name' of the file we are opening. See the example with
# io_socket_timeout in IO::Socket for more, and read Graham's
# comment in IO::Handle.
${*$fh}{'autom4te_xfile_file'} = "$file";
if (!$fh->SUPER::open (@_))
{
fatal "cannot open $file: $!";
}
# In case we're running under MSWindows, don't write with CRLF.
# (This circumvents a bug in at least Cygwin bash where the shell
# parsing fails on lines ending with the continuation character '\'
# and CRLF).
# Correctly recognize usages like:
# - open ($file, "w")
# - open ($file, "+<")
# - open (" >$file")
binmode $fh
if (defined $mode && $mode =~ /^[+>wa]/ or $file =~ /^\s*>/);
}
=item C<$fh-E<gt>close>
Close the file, handling errors.
=cut
sub close
{
my $fh = shift;
if (!$fh->SUPER::close (@_))
{
my $file = $fh->name;
Automake::FileUtils::handle_exec_errors $file
unless $!;
fatal "cannot close $file: $!";
}
}
=item C<$line = $fh-E<gt>getline>
Read and return a line from the file. Ensure C<\r\n> is translated to
C<\n> on input files.
=cut
# Some native Windows/perl installations fail to translate \r\n to \n on
# input so we do that here.
sub getline
{
local $_ = $_[0]->SUPER::getline;
# Perform a _global_ replacement: $_ may can contains many lines
# in slurp mode ($/ = undef).
s/\015\012/\n/gs if defined $_;
return $_;
}
=item C<@lines = $fh-E<gt>getlines>
Slurp lines from the files.
=cut
sub getlines
{
my @res = ();
my $line;
push @res, $line while $line = $_[0]->getline;
return @res;
}
=item C<$name = $fh-E<gt>name>
Return the name of the file.
=cut
sub name
{
my $fh = shift;
return ${*$fh}{'autom4te_xfile_file'};
}
=item C<$fh-E<gt>lock>
Lock the file using C<flock>. If locking fails for reasons other than
C<flock> being unsupported, then error out if C<$ENV{'MAKEFLAGS'}> indicates
that we are spawned from a parallel C<make>.
=cut
sub lock
{
my ($fh, $mode) = @_;
# Cannot use @_ here.
# Unless explicitly configured otherwise, Perl implements its 'flock' with the
# first of flock(2), fcntl(2), or lockf(3) that works. These can fail on
# NFS-backed files, with ENOLCK (GNU/Linux) or EOPNOTSUPP (FreeBSD); we
# usually ignore these errors. If $ENV{MAKEFLAGS} suggests that a parallel
# invocation of 'make' has invoked the tool we serve, report all locking
# failures and abort.
#
# On Unicos, flock(2) and fcntl(2) over NFS hang indefinitely when 'lockd' is
# not running. NetBSD NFS clients silently grant all locks. We do not
# attempt to defend against these dangers.
#
# -j is for parallel BSD make, -P is for parallel HP-UX make.
if (!flock ($fh, $mode))
{
my $make_j = (exists $ENV{'MAKEFLAGS'}
&& " -$ENV{'MAKEFLAGS'}" =~ / (-[BdeikrRsSw]*[jP]|--[jP]|---?jobs)/);
my $note = "\nforgo \"make -j\" or use a file system that supports locks";
my $file = $fh->name;
msg ($make_j ? 'fatal' : 'unsupported',
"cannot lock $file with mode $mode: $!" . ($make_j ? $note : ""))
if $make_j || !($!{ENOLCK} || $!{EOPNOTSUPP});
}
}
=item C<$fh-E<gt>seek ($position, [$whence])>
Seek file to C<$position>. Die if seeking fails.
=cut
sub seek
{
my $fh = shift;
# Cannot use @_ here.
if (!seek ($fh, $_[0], $_[1]))
{
my $file = $fh->name;
fatal "cannot rewind $file with @_: $!";
}
}
=item C<$fh-E<gt>truncate ($len)>
Truncate the file to length C<$len>. Die on failure.
=cut
sub truncate
{
my ($fh, $len) = @_;
if (!truncate ($fh, $len))
{
my $file = $fh->name;
fatal "cannot truncate $file at $len: $!";
}
}
=back
=head1 SEE ALSO
L<perlfunc>,
L<perlop/"I/O Operators">,
L<IO::File>
L<IO::Handle>
L<IO::Seekable>
=head1 HISTORY
Derived from IO::File.pm by Akim Demaille E<lt>F<akim@freefriends.org>E<gt>.
=cut
1;
