lib/Autom4te/XFile.pm

   1 # Copyright (C) 2001-2017 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 <https://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
  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 versions of the
  66 methods C<close>, C<lock> (corresponding to C<flock>), C<new>,
  67 C<open>, C<seek>, and C<truncate>.  It also overrides the C<getline>
  68 and C<getlines> methods to translate C<\r\n> to C<\n>.
  69
  70 =cut
  71
  72 use 5.006;
  73 use strict;
  74 use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA);
  75 use Carp;
  76 use Errno;
  77 use IO::File;
  78 use File::Basename;
  79 use Autom4te::ChannelDefs;
  80 use Autom4te::Channels qw(msg);
  81 use Autom4te::FileUtils;
  82
  83 require Exporter;
  84 require DynaLoader;
  85
  86 @ISA = qw(IO::File Exporter DynaLoader);
  87
  88 $VERSION = "1.2";
  89
  90 @EXPORT = @IO::File::EXPORT;
  91
  92 eval {
  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
 106 Constructor a new XFile object.  Additional arguments
 107 are passed to C<open>, if any.
 108
 109 =cut
 110
 111 sub 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
 125 Open a file, passing C<$file> and further arguments to C<IO::File::open>.
 126 Die if opening fails.  Store the name of the file.  Use binmode for writing.
 127
 128 =cut
 129
 130 sub open
 131 {
 132   my $fh = shift;
 133   my ($file, $mode) = @_;
 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   # Correctly recognize usages like:
 151   #  - open ($file, "w")
 152   #  - open ($file, "+<")
 153   #  - open (" >$file")
 154   binmode $fh
 155     if (defined $mode && $mode =~ /^[+>wa]/ or $file =~ /^\s*>/);
 156 }
 157
 158 =item C<$fh-E<gt>close>
 159
 160 Close the file, handling errors.
 161
 162 =cut
 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 =item C<$line = $fh-E<gt>getline>
 177
 178 Read and return a line from the file.  Ensure C<\r\n> is translated to
 179 C<\n> on input files.
 180
 181 =cut
 182
 183 # Some native Windows/perl installations fail to translate \r\n to \n on
 184 # input so we do that here.
 185 sub getline
 186 {
 187   local $_ = $_[0]->SUPER::getline;
 188   # Perform a _global_ replacement: $_ may can contains many lines
 189   # in slurp mode ($/ = undef).
 190   s/\015\012/\n/gs if defined $_;
 191   return $_;
 192 }
 193
 194 =item C<@lines = $fh-E<gt>getlines>
 195
 196 Slurp lines from the files.
 197
 198 =cut
 199
 200 sub getlines
 201 {
 202   my @res = ();
 203   my $line;
 204   push @res, $line while $line = $_[0]->getline;
 205   return @res;
 206 }
 207
 208 =item C<$name = $fh-E<gt>name>
 209
 210 Return the name of the file.
 211
 212 =cut
 213
 214 sub name
 215 {
 216   my $fh = shift;
 217   return ${*$fh}{'autom4te_xfile_file'};
 218 }
 219
 220 =item C<$fh-E<gt>lock>
 221
 222 Lock the file using C<flock>.  If locking fails for reasons other than
 223 C<flock> being unsupported, then error out if C<$ENV{'MAKEFLAGS'}> indicates
 224 that we are spawned from a parallel C<make>.
 225
 226 =cut
 227
 228 sub lock
 229 {
 230   my ($fh, $mode) = @_;
 231   # Cannot use @_ here.
 232
 233   # Unless explicitly configured otherwise, Perl implements its 'flock' with the
 234   # first of flock(2), fcntl(2), or lockf(3) that works.  These can fail on
 235   # NFS-backed files, with ENOLCK (GNU/Linux) or EOPNOTSUPP (FreeBSD); we
 236   # usually ignore these errors.  If $ENV{MAKEFLAGS} suggests that a parallel
 237   # invocation of 'make' has invoked the tool we serve, report all locking
 238   # failures and abort.
 239   #
 240   # On Unicos, flock(2) and fcntl(2) over NFS hang indefinitely when 'lockd' is
 241   # not running.  NetBSD NFS clients silently grant all locks.  We do not
 242   # attempt to defend against these dangers.
 243   #
 244   # -j is for parallel BSD make, -P is for parallel HP-UX make.
 245   if (!flock ($fh, $mode))
 246     {
 247       my $make_j = (exists $ENV{'MAKEFLAGS'}
 248                     && " -$ENV{'MAKEFLAGS'}" =~ / (-[BdeikrRsSw]*[jP]|--[jP]|---?jobs)/);
 249       my $note = "\nforgo \"make -j\" or use a file system that supports locks";
 250       my $file = $fh->name;
 251
 252       msg ($make_j ? 'fatal' : 'unsupported',
 253            "cannot lock $file with mode $mode: $!" . ($make_j ? $note : ""))
 254         if $make_j || !($!{ENOLCK} || $!{EOPNOTSUPP});
 255     }
 256 }
 257
 258 =item C<$fh-E<gt>seek ($position, [$whence])>
 259
 260 Seek file to C<$position>.  Die if seeking fails.
 261
 262 =cut
 263
 264 sub seek
 265 {
 266   my $fh = shift;
 267   # Cannot use @_ here.
 268   if (!seek ($fh, $_[0], $_[1]))
 269     {
 270       my $file = $fh->name;
 271       fatal "cannot rewind $file with @_: $!";
 272     }
 273 }
 274
 275 =item C<$fh-E<gt>truncate ($len)>
 276
 277 Truncate the file to length C<$len>.  Die on failure.
 278
 279 =cut
 280
 281 sub truncate
 282 {
 283   my ($fh, $len) = @_;
 284   if (!truncate ($fh, $len))
 285     {
 286       my $file = $fh->name;
 287       fatal "cannot truncate $file at $len: $!";
 288     }
 289 }
 290
 291 =back
 292
 293 =head1 SEE ALSO
 294
 295 L<perlfunc>,
 296 L<perlop/"I/O Operators">,
 297 L<IO::File>
 298 L<IO::Handle>
 299 L<IO::Seekable>
 300
 301 =head1 HISTORY
 302
 303 Derived from IO::File.pm by Akim Demaille E<lt>F<akim@freefriends.org>E<gt>.
 304
 305 =cut
 306
 307 1;
 308
 309 ### Setup "GNU" style for perl-mode and cperl-mode.
 310 ## Local Variables:
 311 ## perl-indent-level: 2
 312 ## perl-continued-statement-offset: 2
 313 ## perl-continued-brace-offset: 0
 314 ## perl-brace-offset: 0
 315 ## perl-brace-imaginary-offset: 0
 316 ## perl-label-offset: -2
 317 ## cperl-indent-level: 2
 318 ## cperl-brace-offset: 0
 319 ## cperl-continued-brace-offset: 0
 320 ## cperl-label-offset: -2
 321 ## cperl-extra-newline-before-brace: t
 322 ## cperl-merge-trailing-else: nil
 323 ## cperl-continued-statement-offset: 2
 324 ## End: