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