1# Copyright (C) 2001-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# 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 Autom4te::XFile; 24 25=head1 NAME 26 27Autom4te::XFile - supply object methods for filehandles with error handling 28 29=head1 SYNOPSIS 30 31 use Autom4te::XFile; 32 33 $fh = new Autom4te::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 Autom4te::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 Autom4te::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 Autom4te::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<Autom4te::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 vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA); 75use Carp; 76use Errno; 77use IO::File; 78use File::Basename; 79use Autom4te::ChannelDefs; 80use Autom4te::Channels qw(msg); 81use Autom4te::FileUtils; 82 83require Exporter; 84require DynaLoader; 85 86@ISA = qw(IO::File Exporter DynaLoader); 87 88$VERSION = "1.2"; 89 90@EXPORT = @IO::File::EXPORT; 91 92eval { 93 # Make all Fcntl O_XXX and LOCK_XXX constants available for importing 94 require Fcntl; 95 my @O = grep /^(LOCK|O)_/, @Fcntl::EXPORT, @Fcntl::EXPORT_OK; 96 Fcntl->import (@O); # first we import what we want to export 97 push (@EXPORT, @O); 98}; 99 100=head2 Methods 101 102=over 103 104=item C<$fh = new Autom4te::XFile ([$expr, ...]> 105 106Constructor a new XFile object. Additional arguments 107are passed to C<open>, if any. 108 109=cut 110 111sub new 112{ 113 my $type = shift; 114 my $class = ref $type || $type || "Autom4te::XFile"; 115 my $fh = $class->SUPER::new (); 116 if (@_) 117 { 118 $fh->open (@_); 119 } 120 $fh; 121} 122 123=item C<$fh-E<gt>open ([$file, ...])> 124 125Open a file, passing C<$file> and further arguments to C<IO::File::open>. 126Die if opening fails. Store the name of the file. Use binmode for writing. 127 128=cut 129 130sub open 131{ 132 my $fh = shift; 133 my ($file) = @_; 134 135 # WARNING: Gross hack: $FH is a typeglob: use its hash slot to store 136 # the 'name' of the file we are opening. See the example with 137 # io_socket_timeout in IO::Socket for more, and read Graham's 138 # comment in IO::Handle. 139 ${*$fh}{'autom4te_xfile_file'} = "$file"; 140 141 if (!$fh->SUPER::open (@_)) 142 { 143 fatal "cannot open $file: $!"; 144 } 145 146 # In case we're running under MSWindows, don't write with CRLF. 147 # (This circumvents a bug in at least Cygwin bash where the shell 148 # parsing fails on lines ending with the continuation character '\' 149 # and CRLF). 150 binmode $fh if $file =~ /^\s*>/; 151} 152 153=item C<$fh-E<gt>close> 154 155Close the file, handling errors. 156 157=cut 158 159sub close 160{ 161 my $fh = shift; 162 if (!$fh->SUPER::close (@_)) 163 { 164 my $file = $fh->name; 165 Autom4te::FileUtils::handle_exec_errors $file 166 unless $!; 167 fatal "cannot close $file: $!"; 168 } 169} 170 171=item C<$line = $fh-E<gt>getline> 172 173Read and return a line from the file. Ensure C<\r\n> is translated to 174C<\n> on input files. 175 176=cut 177 178# Some native Windows/perl installations fail to translate \r\n to \n on 179# input so we do that here. 180sub getline 181{ 182 local $_ = $_[0]->SUPER::getline; 183 # Perform a _global_ replacement: $_ may can contains many lines 184 # in slurp mode ($/ = undef). 185 s/\015\012/\n/gs if defined $_; 186 return $_; 187} 188 189=item C<@lines = $fh-E<gt>getlines> 190 191Slurp lines from the files. 192 193=cut 194 195sub getlines 196{ 197 my @res = (); 198 my $line; 199 push @res, $line while $line = $_[0]->getline; 200 return @res; 201} 202 203=item C<$name = $fh-E<gt>name> 204 205Return the name of the file. 206 207=cut 208 209sub name 210{ 211 my $fh = shift; 212 return ${*$fh}{'autom4te_xfile_file'}; 213} 214 215=item C<$fh-E<gt>lock> 216 217Lock the file using C<flock>. If locking fails for reasons other than 218C<flock> being unsupported, then error out if C<$ENV{'MAKEFLAGS'}> indicates 219that we are spawned from a parallel C<make>. 220 221=cut 222 223sub lock 224{ 225 my ($fh, $mode) = @_; 226 # Cannot use @_ here. 227 228 # Unless explicitly configured otherwise, Perl implements its 'flock' with the 229 # first of flock(2), fcntl(2), or lockf(3) that works. These can fail on 230 # NFS-backed files, with ENOLCK (GNU/Linux) or EOPNOTSUPP (FreeBSD); we 231 # usually ignore these errors. If $ENV{MAKEFLAGS} suggests that a parallel 232 # invocation of 'make' has invoked the tool we serve, report all locking 233 # failures and abort. 234 # 235 # On Unicos, flock(2) and fcntl(2) over NFS hang indefinitely when 'lockd' is 236 # not running. NetBSD NFS clients silently grant all locks. We do not 237 # attempt to defend against these dangers. 238 # 239 # -j is for parallel BSD make, -P is for parallel HP-UX make. 240 if (!flock ($fh, $mode)) 241 { 242 my $make_j = (exists $ENV{'MAKEFLAGS'} 243 && " -$ENV{'MAKEFLAGS'}" =~ / (-[BdeikrRsSw]*[jP]|--[jP]|---?jobs)/); 244 my $note = "\nforgo \"make -j\" or use a file system that supports locks"; 245 my $file = $fh->name; 246 247 msg ($make_j ? 'fatal' : 'unsupported', 248 "cannot lock $file with mode $mode: $!" . ($make_j ? $note : "")) 249 if $make_j || !($!{ENOLCK} || $!{EOPNOTSUPP}); 250 } 251} 252 253=item C<$fh-E<gt>seek ($position, [$whence])> 254 255Seek file to C<$position>. Die if seeking fails. 256 257=cut 258 259sub seek 260{ 261 my $fh = shift; 262 # Cannot use @_ here. 263 if (!seek ($fh, $_[0], $_[1])) 264 { 265 my $file = $fh->name; 266 fatal "cannot rewind $file with @_: $!"; 267 } 268} 269 270=item C<$fh-E<gt>truncate ($len)> 271 272Truncate the file to length C<$len>. Die on failure. 273 274=cut 275 276sub truncate 277{ 278 my ($fh, $len) = @_; 279 if (!truncate ($fh, $len)) 280 { 281 my $file = $fh->name; 282 fatal "cannot truncate $file at $len: $!"; 283 } 284} 285 286=back 287 288=head1 SEE ALSO 289 290L<perlfunc>, 291L<perlop/"I/O Operators">, 292L<IO::File> 293L<IO::Handle> 294L<IO::Seekable> 295 296=head1 HISTORY 297 298Derived from IO::File.pm by Akim Demaille E<lt>F<akim@freefriends.org>E<gt>. 299 300=cut 301 3021; 303 304### Setup "GNU" style for perl-mode and cperl-mode. 305## Local Variables: 306## perl-indent-level: 2 307## perl-continued-statement-offset: 2 308## perl-continued-brace-offset: 0 309## perl-brace-offset: 0 310## perl-brace-imaginary-offset: 0 311## perl-label-offset: -2 312## cperl-indent-level: 2 313## cperl-brace-offset: 0 314## cperl-continued-brace-offset: 0 315## cperl-label-offset: -2 316## cperl-extra-newline-before-brace: t 317## cperl-merge-trailing-else: nil 318## cperl-continued-statement-offset: 2 319## End: 320