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 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
  25 package Autom4te::XFile;
  26
  27 =head1 NAME
  28
  29 Autom4te::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
  66 C<Autom4te::XFile> inherits from C<IO::File>.  It provides the method
  67 C<name> returning the file name.  It provides dying version of the
  68 methods C<close>, C<lock> (corresponding to C<flock>), C<new>,
  69 C<open>, C<seek>, and C<trunctate>.  It also overrides the C<getline>
  70 and C<getlines> methods to translate C<\r\n> to C<\n>.
  71
  72 =head1 SEE ALSO
  73
  74 L<perlfunc>,
  75 L<perlop/"I/O Operators">,
  76 L<IO::File>
  77 L<IO::Handle>
  78 L<IO::Seekable>
  79
  80 =head1 HISTORY
  81
  82 Derived from IO::File.pm by Akim Demaille E<lt>F<akim@freefriends.org>E<gt>.
  83
  84 =cut
  85
  86 require 5.000;
  87 use strict;
  88 use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA);
  89 use Carp;
  90 use Errno;
  91 use IO::File;
  92 use File::Basename;
  93 use Autom4te::ChannelDefs;
  94 use Autom4te::Channels qw(msg);
  95 use Autom4te::FileUtils;
  96
  97 require Exporter;
  98 require DynaLoader;
  99
 100 @ISA = qw(IO::File Exporter DynaLoader);
 101
 102 $VERSION = "1.2";
 103
 104 @EXPORT = @IO::File::EXPORT;
 105
 106 eval {
 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.
 115 my $me = basename ($0);
 116
 117 ################################################
 118 ## Constructor
 119 ##
 120
 121 sub 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
 137 sub 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
 164 sub 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.
 182 sub 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
 195 sub 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
 207 sub name
 208 {
 209   my $fh = shift;
 210   return ${*$fh}{'autom4te_xfile_file'};
 211 }
 212
 213 ################################################
 214 ## Lock
 215 ##
 216
 217 sub 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
 249 sub 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
 264 sub 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
 274 1;
 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: