lib/Autom4te/XFile.pm

   1 # Copyright (C) 2001, 2003 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., 59 Temple Place - Suite 330, Boston, MA
  16 # 02111-1307, USA.
  17
  18 # Written by Akim Demaille <akim@freefriends.org>.
  19
  20 ###############################################################
  21 # The main copy of this file is in Autoconf's CVS repository. #
  22 # Updates should be sent to autoconf-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 IO::File;
  91 use File::Basename;
  92
  93 require Exporter;
  94 require DynaLoader;
  95
  96 @ISA = qw(IO::File Exporter DynaLoader);
  97
  98 $VERSION = "1.2";
  99
 100 @EXPORT = @IO::File::EXPORT;
 101
 102 eval {
 103   # Make all Fcntl O_XXX and LOCK_XXX constants available for importing
 104   require Fcntl;
 105   my @O = grep /^(LOCK|O)_/, @Fcntl::EXPORT, @Fcntl::EXPORT_OK;
 106   Fcntl->import (@O);  # first we import what we want to export
 107   push (@EXPORT, @O);
 108 };
 109
 110 # Used in croak error messages.
 111 my $me = basename ($0);
 112
 113 ################################################
 114 ## Constructor
 115 ##
 116
 117 sub new
 118 {
 119   my $type = shift;
 120   my $class = ref($type) || $type || "Autom4te::XFile";
 121   my $fh = $class->SUPER::new ();
 122   if (@_)
 123     {
 124       $fh->open (@_);
 125     }
 126   $fh;
 127 }
 128
 129 ################################################
 130 ## Open
 131 ##
 132
 133 sub open
 134 {
 135   my ($fh) = shift;
 136   my ($file) = @_;
 137
 138   # WARNING: Gross hack: $FH is a typeglob: use its hash slot to store
 139   # the `name' of the file we are opening.  See the example with
 140   # io_socket_timeout in IO::Socket for more, and read Graham's
 141   # comment in IO::Handle.
 142   ${*$fh}{'autom4te_xfile_file'} = "$file";
 143
 144   if (!$fh->SUPER::open (@_))
 145     {
 146       croak "$me: cannot open $file: $!\n";
 147     }
 148
 149   # In case we're running under MSWindows, don't write with CRLF.
 150   # (This circumvents a bug in at least Cygwin bash where the shell
 151   # parsing fails on lines ending with the continuation character '\'
 152   # and CRLF).
 153   binmode $fh if $file =~ /^\s*>/;
 154 }
 155
 156 ################################################
 157 ## Close
 158 ##
 159
 160 sub close
 161 {
 162   my ($fh) = shift;
 163   if (!$fh->SUPER::close (@_))
 164     {
 165       my $file = $fh->name;
 166       croak "$me: cannot close $file: $!\n";
 167     }
 168 }
 169
 170 ################################################
 171 ## Getline
 172 ##
 173
 174 # Some Win32/perl installations fail to translate \r\n to \n on input
 175 # so we do that here.
 176 sub getline
 177 {
 178   local $_ = $_[0]->SUPER::getline;
 179   # Perform a _global_ replacement: $_ may can contains many lines
 180   # in slurp mode ($/ = undef).
 181   s/\015\012/\n/gs if defined $_;
 182   return $_;
 183 }
 184
 185 ################################################
 186 ## Getlines
 187 ##
 188
 189 sub getlines
 190 {
 191   my @res = ();
 192   my $line;
 193   push @res, $line while $line = $_[0]->getline;
 194   return @res;
 195 }
 196
 197 ################################################
 198 ## Name
 199 ##
 200
 201 sub name
 202 {
 203   my ($fh) = shift;
 204   return ${*$fh}{'autom4te_xfile_file'};
 205 }
 206
 207 ################################################
 208 ## Lock
 209 ##
 210
 211 sub lock
 212 {
 213   my ($fh, $mode) = @_;
 214   # Cannot use @_ here.
 215   if (!flock ($fh, $mode))
 216     {
 217       my $file = $fh->name;
 218       croak "$me: cannot lock $file with mode $mode: $!\n";
 219     }
 220 }
 221
 222 ################################################
 223 ## Seek
 224 ##
 225
 226 sub seek
 227 {
 228   my ($fh) = shift;
 229   # Cannot use @_ here.
 230   if (!seek ($fh, $_[0], $_[1]))
 231     {
 232       my $file = $fh->name;
 233       croak "$me: cannot rewind $file with @_: $!\n";
 234     }
 235 }
 236
 237 ################################################
 238 ## Truncate
 239 ##
 240
 241 sub truncate
 242 {
 243   my ($fh, $len) = @_;
 244   if (!truncate ($fh, $len))
 245     {
 246       my $file = $fh->name;
 247       croak "$me: cannot truncate $file at $len: $!\n";
 248     }
 249 }
 250
 251 1;
 252
 253 ### Setup "GNU" style for perl-mode and cperl-mode.
 254 ## Local Variables:
 255 ## perl-indent-level: 2
 256 ## perl-continued-statement-offset: 2
 257 ## perl-continued-brace-offset: 0
 258 ## perl-brace-offset: 0
 259 ## perl-brace-imaginary-offset: 0
 260 ## perl-label-offset: -2
 261 ## cperl-indent-level: 2
 262 ## cperl-brace-offset: 0
 263 ## cperl-continued-brace-offset: 0
 264 ## cperl-label-offset: -2
 265 ## cperl-extra-newline-before-brace: t
 266 ## cperl-merge-trailing-else: nil
 267 ## cperl-continued-statement-offset: 2
 268 ## End: