1# Copyright (C) 2001-2021 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
23package Automake::XFile;
24
25=head1 NAME
26
27Automake::XFile - supply object methods for filehandles with error handling
28
29=head1 SYNOPSIS
30
31    use Automake::XFile;
32
33    $fh = new Automake::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 Automake::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 Automake::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 Automake::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<Automake::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 warnings FATAL => 'all';
75
76use Errno;
77use Exporter;
78use IO::File;
79
80use Automake::ChannelDefs;
81use Automake::Channels qw (msg);
82use Automake::FileUtils;
83
84our @ISA = qw(Exporter IO::File);
85our @EXPORT = @IO::File::EXPORT;
86our $VERSION = "1.2";
87
88eval {
89  # Make all Fcntl O_XXX and LOCK_XXX constants available for importing
90  require Fcntl;
91  my @O = grep /^(LOCK|O)_/, @Fcntl::EXPORT, @Fcntl::EXPORT_OK;
92  Fcntl->import (@O);  # first we import what we want to export
93  push (@EXPORT, @O);
94};
95
96=head2 Methods
97
98=over
99
100=item C<$fh = new Automake::XFile ([$expr, ...]>
101
102Constructor a new XFile object.  Additional arguments
103are passed to C<open>, if any.
104
105=cut
106
107sub new
108{
109  my $type = shift;
110  my $class = ref $type || $type || "Automake::XFile";
111  my $fh = $class->SUPER::new ();
112  if (@_)
113    {
114      $fh->open (@_);
115    }
116  $fh;
117}
118
119=item C<$fh-E<gt>open ([$file, ...])>
120
121Open a file, passing C<$file> and further arguments to C<IO::File::open>.
122Die if opening fails.  Store the name of the file.  Use binmode for writing.
123
124=cut
125
126sub open
127{
128  my $fh = shift;
129  my ($file, $mode) = @_;
130
131  # WARNING: Gross hack: $FH is a typeglob: use its hash slot to store
132  # the 'name' of the file we are opening.  See the example with
133  # io_socket_timeout in IO::Socket for more, and read Graham's
134  # comment in IO::Handle.
135  ${*$fh}{'autom4te_xfile_file'} = "$file";
136
137  if (!$fh->SUPER::open (@_))
138    {
139      fatal "cannot open $file: $!";
140    }
141
142  # In case we're running under MSWindows, don't write with CRLF.
143  # (This circumvents a bug in at least Cygwin bash where the shell
144  # parsing fails on lines ending with the continuation character '\'
145  # and CRLF).
146  # Correctly recognize usages like:
147  #  - open ($file, "w")
148  #  - open ($file, "+<")
149  #  - open (" >$file")
150  binmode $fh
151    if (defined $mode && $mode =~ /^[+>wa]/ or $file =~ /^\s*>/);
152}
153
154=item C<$fh-E<gt>close>
155
156Close the file, handling errors.
157
158=cut
159
160sub close
161{
162  my $fh = shift;
163  if (!$fh->SUPER::close (@_))
164    {
165      my $file = $fh->name;
166      Automake::FileUtils::handle_exec_errors $file
167	unless $!;
168      fatal "cannot close $file: $!";
169    }
170}
171
172=item C<$line = $fh-E<gt>getline>
173
174Read and return a line from the file.  Ensure C<\r\n> is translated to
175C<\n> on input files.
176
177=cut
178
179# Some native Windows/perl installations fail to translate \r\n to \n on
180# input so we do that here.
181sub getline
182{
183  local $_ = $_[0]->SUPER::getline;
184  # Perform a _global_ replacement: $_ may can contains many lines
185  # in slurp mode ($/ = undef).
186  s/\015\012/\n/gs if defined $_;
187  return $_;
188}
189
190=item C<@lines = $fh-E<gt>getlines>
191
192Slurp lines from the files.
193
194=cut
195
196sub getlines
197{
198  my @res = ();
199  my $line;
200  push @res, $line while $line = $_[0]->getline;
201  return @res;
202}
203
204=item C<$name = $fh-E<gt>name>
205
206Return the name of the file.
207
208=cut
209
210sub name
211{
212  my $fh = shift;
213  return ${*$fh}{'autom4te_xfile_file'};
214}
215
216=item C<$fh-E<gt>lock>
217
218Lock the file using C<flock>.  If locking fails for reasons other than
219C<flock> being unsupported, then error out if C<$ENV{'MAKEFLAGS'}> indicates
220that we are spawned from a parallel C<make>.
221
222=cut
223
224sub lock
225{
226  my ($fh, $mode) = @_;
227  # Cannot use @_ here.
228
229  # Unless explicitly configured otherwise, Perl implements its 'flock' with the
230  # first of flock(2), fcntl(2), or lockf(3) that works.  These can fail on
231  # NFS-backed files, with ENOLCK (GNU/Linux) or EOPNOTSUPP (FreeBSD) or
232  # EINVAL (OpenIndiana, as per POSIX 1003.1-2017 fcntl spec); we
233  # usually ignore these errors.  If $ENV{MAKEFLAGS} suggests that a parallel
234  # invocation of 'make' has invoked the tool we serve, report all locking
235  # failures and abort.
236  #
237  # On Unicos, flock(2) and fcntl(2) over NFS hang indefinitely when 'lockd' is
238  # not running.  NetBSD NFS clients silently grant all locks.  We do not
239  # attempt to defend against these dangers.
240  #
241  # -j is for parallel BSD make, -P is for parallel HP-UX make.
242  if (!flock ($fh, $mode))
243    {
244      my $make_j = (exists $ENV{'MAKEFLAGS'}
245		    && " -$ENV{'MAKEFLAGS'}" =~ / (-[BdeikrRsSw]*[jP]|--[jP]|---?jobs)/);
246      my $note = "\nforgo \"make -j\" or use a file system that supports locks";
247      my $file = $fh->name;
248
249      msg ($make_j ? 'fatal' : 'unsupported',
250	   "cannot lock $file with mode $mode: $!" . ($make_j ? $note : ""))
251	if $make_j || !($!{EINVAL} || $!{ENOLCK} || $!{EOPNOTSUPP});
252    }
253}
254
255=item C<$fh-E<gt>seek ($position, [$whence])>
256
257Seek file to C<$position>.  Die if seeking fails.
258
259=cut
260
261sub seek
262{
263  my $fh = shift;
264  # Cannot use @_ here.
265  if (!seek ($fh, $_[0], $_[1]))
266    {
267      my $file = $fh->name;
268      fatal "cannot rewind $file with @_: $!";
269    }
270}
271
272=item C<$fh-E<gt>truncate ($len)>
273
274Truncate the file to length C<$len>.  Die on failure.
275
276=cut
277
278sub truncate
279{
280  my ($fh, $len) = @_;
281  if (!truncate ($fh, $len))
282    {
283      my $file = $fh->name;
284      fatal "cannot truncate $file at $len: $!";
285    }
286}
287
288=back
289
290=head1 SEE ALSO
291
292L<perlfunc>,
293L<perlop/"I/O Operators">,
294L<IO::File>
295L<IO::Handle>
296L<IO::Seekable>
297
298=head1 HISTORY
299
300Derived from IO::File.pm by Akim Demaille E<lt>F<akim@freefriends.org>E<gt>.
301
302=cut
303
3041;
305