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