1# Copyright (C) 2001-2021 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 <https://www.gnu.org/licenses/>. 15 16# Written by Akim Demaille <akim@freefriends.org>. 17 18############################################################### 19# The main copy of this file is in Automake's git repository. # 20# Updates should be sent to automake-patches@gnu.org. # 21############################################################### 22 23package Automake::XFile; 24 25=head1 NAME 26 27Automake::XFile - supply object methods for filehandles with error handling 28 29=head1 SYNOPSIS 30 31 use Automake::XFile; 32 33 $fh = new Automake::XFile; 34 $fh->open ("file", "<"); 35 # No need to check $FH: we died if open failed. 36 print <$fh>; 37 $fh->close; 38 # No need to check the return value of close: we died if it failed. 39 40 $fh = new Automake::XFile "file", ">"; 41 # No need to check $FH: we died if new failed. 42 print $fh "bar\n"; 43 $fh->close; 44 45 $fh = new Automake::XFile "file", "r"; 46 # No need to check $FH: we died if new failed. 47 defined $fh 48 print <$fh>; 49 undef $fh; # automatically closes the file and checks for errors. 50 51 $fh = new Automake::XFile "file", O_WRONLY | O_APPEND; 52 # No need to check $FH: we died if new failed. 53 print $fh "corge\n"; 54 55 $pos = $fh->getpos; 56 $fh->setpos ($pos); 57 58 undef $fh; # automatically closes the file and checks for errors. 59 60 autoflush STDOUT 1; 61 62=head1 DESCRIPTION 63 64C<Automake::XFile> inherits from C<IO::File>. It provides the method 65C<name> returning the file name. It provides dying versions of the 66methods C<close>, C<lock> (corresponding to C<flock>), C<new>, 67C<open>, C<seek>, and C<truncate>. It also overrides the C<getline> 68and C<getlines> methods to translate C<\r\n> to C<\n>. 69 70=cut 71 72use 5.006; 73use strict; 74use warnings FATAL => 'all'; 75 76use Errno; 77use Exporter; 78use IO::File; 79 80use Automake::ChannelDefs; 81use Automake::Channels qw (msg); 82use Automake::FileUtils; 83 84our @ISA = qw(Exporter IO::File); 85our @EXPORT = @IO::File::EXPORT; 86our $VERSION = "1.2"; 87 88eval { 89 # Make all Fcntl O_XXX and LOCK_XXX constants available for importing 90 require Fcntl; 91 my @O = grep /^(LOCK|O)_/, @Fcntl::EXPORT, @Fcntl::EXPORT_OK; 92 Fcntl->import (@O); # first we import what we want to export 93 push (@EXPORT, @O); 94}; 95 96=head2 Methods 97 98=over 99 100=item C<$fh = new Automake::XFile ([$expr, ...]> 101 102Constructor a new XFile object. Additional arguments 103are passed to C<open>, if any. 104 105=cut 106 107sub new 108{ 109 my $type = shift; 110 my $class = ref $type || $type || "Automake::XFile"; 111 my $fh = $class->SUPER::new (); 112 if (@_) 113 { 114 $fh->open (@_); 115 } 116 $fh; 117} 118 119=item C<$fh-E<gt>open ([$file, ...])> 120 121Open a file, passing C<$file> and further arguments to C<IO::File::open>. 122Die if opening fails. Store the name of the file. Use binmode for writing. 123 124=cut 125 126sub open 127{ 128 my $fh = shift; 129 my ($file, $mode) = @_; 130 131 # WARNING: Gross hack: $FH is a typeglob: use its hash slot to store 132 # the 'name' of the file we are opening. See the example with 133 # io_socket_timeout in IO::Socket for more, and read Graham's 134 # comment in IO::Handle. 135 ${*$fh}{'autom4te_xfile_file'} = "$file"; 136 137 if (!$fh->SUPER::open (@_)) 138 { 139 fatal "cannot open $file: $!"; 140 } 141 142 # In case we're running under MSWindows, don't write with CRLF. 143 # (This circumvents a bug in at least Cygwin bash where the shell 144 # parsing fails on lines ending with the continuation character '\' 145 # and CRLF). 146 # Correctly recognize usages like: 147 # - open ($file, "w") 148 # - open ($file, "+<") 149 # - open (" >$file") 150 binmode $fh 151 if (defined $mode && $mode =~ /^[+>wa]/ or $file =~ /^\s*>/); 152} 153 154=item C<$fh-E<gt>close> 155 156Close the file, handling errors. 157 158=cut 159 160sub close 161{ 162 my $fh = shift; 163 if (!$fh->SUPER::close (@_)) 164 { 165 my $file = $fh->name; 166 Automake::FileUtils::handle_exec_errors $file 167 unless $!; 168 fatal "cannot close $file: $!"; 169 } 170} 171 172=item C<$line = $fh-E<gt>getline> 173 174Read and return a line from the file. Ensure C<\r\n> is translated to 175C<\n> on input files. 176 177=cut 178 179# Some native Windows/perl installations fail to translate \r\n to \n on 180# input so we do that here. 181sub getline 182{ 183 local $_ = $_[0]->SUPER::getline; 184 # Perform a _global_ replacement: $_ may can contains many lines 185 # in slurp mode ($/ = undef). 186 s/\015\012/\n/gs if defined $_; 187 return $_; 188} 189 190=item C<@lines = $fh-E<gt>getlines> 191 192Slurp lines from the files. 193 194=cut 195 196sub getlines 197{ 198 my @res = (); 199 my $line; 200 push @res, $line while $line = $_[0]->getline; 201 return @res; 202} 203 204=item C<$name = $fh-E<gt>name> 205 206Return the name of the file. 207 208=cut 209 210sub name 211{ 212 my $fh = shift; 213 return ${*$fh}{'autom4te_xfile_file'}; 214} 215 216=item C<$fh-E<gt>lock> 217 218Lock the file using C<flock>. If locking fails for reasons other than 219C<flock> being unsupported, then error out if C<$ENV{'MAKEFLAGS'}> indicates 220that we are spawned from a parallel C<make>. 221 222=cut 223 224sub lock 225{ 226 my ($fh, $mode) = @_; 227 # Cannot use @_ here. 228 229 # Unless explicitly configured otherwise, Perl implements its 'flock' with the 230 # first of flock(2), fcntl(2), or lockf(3) that works. These can fail on 231 # NFS-backed files, with ENOLCK (GNU/Linux) or EOPNOTSUPP (FreeBSD) or 232 # EINVAL (OpenIndiana, as per POSIX 1003.1-2017 fcntl spec); we 233 # usually ignore these errors. If $ENV{MAKEFLAGS} suggests that a parallel 234 # invocation of 'make' has invoked the tool we serve, report all locking 235 # failures and abort. 236 # 237 # On Unicos, flock(2) and fcntl(2) over NFS hang indefinitely when 'lockd' is 238 # not running. NetBSD NFS clients silently grant all locks. We do not 239 # attempt to defend against these dangers. 240 # 241 # -j is for parallel BSD make, -P is for parallel HP-UX make. 242 if (!flock ($fh, $mode)) 243 { 244 my $make_j = (exists $ENV{'MAKEFLAGS'} 245 && " -$ENV{'MAKEFLAGS'}" =~ / (-[BdeikrRsSw]*[jP]|--[jP]|---?jobs)/); 246 my $note = "\nforgo \"make -j\" or use a file system that supports locks"; 247 my $file = $fh->name; 248 249 msg ($make_j ? 'fatal' : 'unsupported', 250 "cannot lock $file with mode $mode: $!" . ($make_j ? $note : "")) 251 if $make_j || !($!{EINVAL} || $!{ENOLCK} || $!{EOPNOTSUPP}); 252 } 253} 254 255=item C<$fh-E<gt>seek ($position, [$whence])> 256 257Seek file to C<$position>. Die if seeking fails. 258 259=cut 260 261sub seek 262{ 263 my $fh = shift; 264 # Cannot use @_ here. 265 if (!seek ($fh, $_[0], $_[1])) 266 { 267 my $file = $fh->name; 268 fatal "cannot rewind $file with @_: $!"; 269 } 270} 271 272=item C<$fh-E<gt>truncate ($len)> 273 274Truncate the file to length C<$len>. Die on failure. 275 276=cut 277 278sub truncate 279{ 280 my ($fh, $len) = @_; 281 if (!truncate ($fh, $len)) 282 { 283 my $file = $fh->name; 284 fatal "cannot truncate $file at $len: $!"; 285 } 286} 287 288=back 289 290=head1 SEE ALSO 291 292L<perlfunc>, 293L<perlop/"I/O Operators">, 294L<IO::File> 295L<IO::Handle> 296L<IO::Seekable> 297 298=head1 HISTORY 299 300Derived from IO::File.pm by Akim Demaille E<lt>F<akim@freefriends.org>E<gt>. 301 302=cut 303 3041; 305