lib/Autom4te/XFile.pm

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