File Coverage

File:/usr/local/share/automake-1.11/Automake/XFile.pm
Coverage:30.6%

linestmtbrancondsubpodtimecode
1# Copyright (C) 2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation,
2# Inc.
3
4# This program is free software; you can redistribute it and/or modify
5# it under the terms of the GNU General Public License as published by
6# the Free Software Foundation; either version 2, or (at your option)
7# any later version.
8
9# This program is distributed in the hope that it will be useful,
10# but WITHOUT ANY WARRANTY; without even the implied warranty of
11# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12# GNU General Public License for more details.
13
14# You should have received a copy of the GNU General Public License
15# along with this program. If not, see <http://www.gnu.org/licenses/>.
16
17# Written by Akim Demaille <akim@freefriends.org>.
18
19###############################################################
20# The main copy of this file is in Automake's CVS repository. #
21# Updates should be sent to automake-patches@gnu.org. #
22###############################################################
23
24package Automake::XFile;
25
26 - 83
=head1 NAME

Automake::XFile - supply object methods for filehandles with error handling

=head1 SYNOPSIS

    use Automake::XFile;

    $fh = new Automake::XFile;
    $fh->open ("< file");
    # No need to check $FH: we died if open failed.
    print <$fh>;
    $fh->close;
    # No need to check the return value of close: we died if it failed.

    $fh = new Automake::XFile "> file";
    # No need to check $FH: we died if new failed.
    print $fh "bar\n";
    $fh->close;

    $fh = new Automake::XFile "file", "r";
    # No need to check $FH: we died if new failed.
    defined $fh
    print <$fh>;
    undef $fh;   # automatically closes the file and checks for errors.

    $fh = new Automake::XFile "file", O_WRONLY | O_APPEND;
    # No need to check $FH: we died if new failed.
    print $fh "corge\n";

    $pos = $fh->getpos;
    $fh->setpos ($pos);

    undef $fh;   # automatically closes the file and checks for errors.

    autoflush STDOUT 1;

=head1 DESCRIPTION

C<Automake::XFile> inherits from C<IO::File>.  It provides the method
C<name> returning the file name.  It provides dying versions of the
methods C<close>, C<lock> (corresponding to C<flock>), C<new>,
C<open>, C<seek>, and C<truncate>.  It also overrides the C<getline>
and C<getlines> methods to translate C<\r\n> to C<\n>.

=head1 SEE ALSO

L<perlfunc>,
L<perlop/"I/O Operators">,
L<IO::File>
L<IO::Handle>
L<IO::Seekable>

=head1 HISTORY

Derived from IO::File.pm by Akim Demaille E<lt>F<akim@freefriends.org>E<gt>.

=cut
84
85require 5.000;
86
1
1
1
4
2
3
use strict;
87
1
1
1
3
1
2
use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA);
88
1
1
1
4
1
3
use Carp;
89
1
1
1
7
1
6
use Errno;
90
1
1
1
4
1
12
use IO::File;
91
1
1
1
4
1
3
use File::Basename;
92
1
1
1
11
2
8
use Automake::ChannelDefs;
93
1
1
1
4
1
3
use Automake::Channels qw(msg);
94
1
1
1
12
1
8
use Automake::FileUtils;
95
96require Exporter;
97require DynaLoader;
98
99@ISA = qw(IO::File Exporter DynaLoader);
100
101$VERSION = "1.2";
102
103@EXPORT = @IO::File::EXPORT;
104
105eval {
106  # Make all Fcntl O_XXX and LOCK_XXX constants available for importing
107  require Fcntl;
108  my @O = grep /^(LOCK|O)_/, @Fcntl::EXPORT, @Fcntl::EXPORT_OK;
109  Fcntl->import (@O); # first we import what we want to export
110  push (@EXPORT, @O);
111};
112
113# Used in croak error messages.
114my $me = basename ($0);
115
116################################################
117## Constructor
118##
119
120sub new
121{
122
0
1
  my $type = shift;
123
0
  my $class = ref $type || $type || "Automake::XFile";
124
0
  my $fh = $class->SUPER::new ();
125
0
  if (@_)
126    {
127
0
      $fh->open (@_);
128    }
129
0
  $fh;
130}
131
132################################################
133## Open
134##
135
136sub open
137{
138
0
1
  my $fh = shift;
139
0
  my ($file) = @_;
140
141  # WARNING: Gross hack: $FH is a typeglob: use its hash slot to store
142  # the `name' of the file we are opening. See the example with
143  # io_socket_timeout in IO::Socket for more, and read Graham's
144  # comment in IO::Handle.
145
0
0
  ${*$fh}{'autom4te_xfile_file'} = "$file";
146
147
0
  if (!$fh->SUPER::open (@_))
148    {
149
0
      fatal "cannot open $file: $!";
150    }
151
152  # In case we're running under MSWindows, don't write with CRLF.
153  # (This circumvents a bug in at least Cygwin bash where the shell
154  # parsing fails on lines ending with the continuation character '\'
155  # and CRLF).
156
0
  binmode $fh if $file =~ /^\s*>/;
157}
158
159################################################
160## Close
161##
162
163sub close
164{
165
0
0
  my $fh = shift;
166
0
  if (!$fh->SUPER::close (@_))
167    {
168
0
      my $file = $fh->name;
169
0
      Automake::FileUtils::handle_exec_errors $file
170        unless $!;
171
0
      fatal "cannot close $file: $!";
172    }
173}
174
175################################################
176## Getline
177##
178
179# Some Win32/perl installations fail to translate \r\n to \n on input
180# so we do that here.
181sub getline
182{
183
0
1
  local $_ = $_[0]->SUPER::getline;
184  # Perform a _global_ replacement: $_ may can contains many lines
185  # in slurp mode ($/ = undef).
186
0
  s/\015\012/\n/gs if defined $_;
187
0
  return $_;
188}
189
190################################################
191## Getlines
192##
193
194sub getlines
195{
196
0
1
  my @res = ();
197
0
  my $line;
198
0
  push @res, $line while $line = $_[0]->getline;
199
0
  return @res;
200}
201
202################################################
203## Name
204##
205
206sub name
207{
208
0
0
  my $fh = shift;
209
0
0
  return ${*$fh}{'autom4te_xfile_file'};
210}
211
212################################################
213## Lock
214##
215
216sub lock
217{
218
0
0
  my ($fh, $mode) = @_;
219  # Cannot use @_ here.
220
221  # Unless explicitly configured otherwise, Perl implements its `flock' with the
222  # first of flock(2), fcntl(2), or lockf(3) that works. These can fail on
223  # NFS-backed files, with ENOLCK (GNU/Linux) or EOPNOTSUPP (FreeBSD); we
224  # usually ignore these errors. If $ENV{MAKEFLAGS} suggests that a parallel
225  # invocation of `make' has invoked the tool we serve, report all locking
226  # failures and abort.
227  #
228  # On Unicos, flock(2) and fcntl(2) over NFS hang indefinitely when `lockd' is
229  # not running. NetBSD NFS clients silently grant all locks. We do not
230  # attempt to defend against these dangers.
231  #
232  # -j is for parallel BSD make, -P is for parallel HP-UX make.
233
0
  if (!flock ($fh, $mode))
234    {
235
0
      my $make_j = (exists $ENV{'MAKEFLAGS'}
236                    && " -$ENV{'MAKEFLAGS'}" =~ / (-[BdeikrRsSw]*[jP]|--[jP]|---?jobs)/);
237
0
      my $note = "\nforgo `make -j' or use a file system that supports locks";
238
0
      my $file = $fh->name;
239
240
0
      msg ($make_j ? 'fatal' : 'unsupported',
241           "cannot lock $file with mode $mode: $!" . ($make_j ? $note : ""))
242        if $make_j || !($!{ENOLCK} || $!{EOPNOTSUPP});
243    }
244}
245
246################################################
247## Seek
248##
249
250sub seek
251{
252
0
1
  my $fh = shift;
253  # Cannot use @_ here.
254
0
  if (!seek ($fh, $_[0], $_[1]))
255    {
256
0
      my $file = $fh->name;
257
0
      fatal "$me: cannot rewind $file with @_: $!";
258    }
259}
260
261################################################
262## Truncate
263##
264
265sub truncate
266{
267
0
0
  my ($fh, $len) = @_;
268
0
  if (!truncate ($fh, $len))
269    {
270
0
      my $file = $fh->name;
271
0
      fatal "cannot truncate $file at $len: $!";
272    }
273}
274
2751;
276
277### Setup "GNU" style for perl-mode and cperl-mode.
278## Local Variables:
279## perl-indent-level: 2
280## perl-continued-statement-offset: 2
281## perl-continued-brace-offset: 0
282## perl-brace-offset: 0
283## perl-brace-imaginary-offset: 0
284## perl-label-offset: -2
285## cperl-indent-level: 2
286## cperl-brace-offset: 0
287## cperl-continued-brace-offset: 0
288## cperl-label-offset: -2
289## cperl-extra-newline-before-brace: t
290## cperl-merge-trailing-else: nil
291## cperl-continued-statement-offset: 2
292## End: