File Coverage

blib/lib/IO/ReStoreFH.pm
Criterion Covered Total %
statement 60 61 98.3
branch 19 26 73.0
condition 7 12 58.3
subroutine 15 16 93.7
pod 3 3 100.0
total 104 118 88.1


line stmt bran cond sub pod time code
1             package IO::ReStoreFH;
2              
3             # ABSTRACT: store/restore file handles
4              
5 4     4   885258 use 5.10.0;
  4         38  
6              
7 4     4   20 use strict;
  4         7  
  4         70  
8 4     4   16 use warnings;
  4         6  
  4         235  
9              
10             our $VERSION = '0.09'; # TRIAL
11              
12             # In Perl 5.10.1 a use or require of FileHandle or something in the
13             # FileHandle hierarchy (like FileHandle::Fmode, below) will cause the
14             # compiler to creat a stash for FileHandle. Then, there's some
15             # code in Perl_newio which checks if FileHandle has been loaded (just
16             # by checking for the stash) and aliases it to IO::Handle.
17             #
18             # This it mucks up method calls on filehandles if FileHandle isn't
19             # actually loaded, resulting in errors such as
20             #
21             # Can't locate object method "getline" via package "FileHandle"
22             #
23             # see http://perlmonks.org/?node_id=1073753, and tobyink's reply
24              
25             # So, we explicitly load FileHandle on 5.10.x to avoid these action
26             # at a distance problems.
27 4   33 4   2533 use if $^V ge v5.10.0 && $^V lt v5.11.0, 'FileHandle';
  4         50  
  4         87  
28              
29 4     4   1877 use FileHandle::Fmode ();
  4         5548  
  4         103  
30 4     4   24 use POSIX ();
  4         7  
  4         57  
31 4     4   747 use IO::Handle;
  4         7662  
  4         151  
32 4     4   23 use Scalar::Util;
  4         7  
  4         121  
33 4     4   2024 use Try::Tiny ();
  4         7534  
  4         2385  
34              
35             sub _croak {
36 4     4   72 require Carp;
37 4         424 goto &Carp::croak;
38             }
39              
40             sub new {
41 10     10 1 27054 my $class = shift;
42              
43 10         34 my $obj = bless { dups => [] }, $class;
44 10         40 $obj->store( $_ ) for @_;
45 6         15 return $obj;
46             }
47              
48             sub store {
49 10     10 1 27 my ( $self, $fh ) = @_;
50              
51             # if $fh is a reference, or a GLOB, it's probably
52             # a filehandle object of somesort
53              
54 10 100 100     123 if ( ref( $fh ) || 'GLOB' eq ref( \$fh ) ) {
    100 66        
55              
56             # now that we are sure that everything is loaded,
57             # check if it is an open filehandle; this doesn't disambiguate
58             # between objects that aren't filehandles or closed filehandles.
59 8 100       50 _croak( "\$fh is not an open filehandle\n" )
60             unless FileHandle::Fmode::is_FH( $fh );
61              
62             # get access mode; open documentation says mode must
63             # match that of original filehandle; do the best we can
64 5 50 33     79 my $mode
    100          
    50          
65             = FileHandle::Fmode::is_RO( $fh ) ? '<'
66             : FileHandle::Fmode::is_WO( $fh ) ? '>'
67             : FileHandle::Fmode::is_W( $fh )
68             && FileHandle::Fmode::is_R( $fh ) ? '+<'
69             : undef;
70              
71             # give up
72 5 50       273 _croak( "inexplicable error: unable to determine mode for \$fh;\n" )
73             if !defined $mode;
74              
75 5 100       27 $mode .= '>' if FileHandle::Fmode::is_A( $fh );
76              
77             # dup the filehandle
78 5 50       206 open my $dup, $mode . '&', $fh
79             or _croak( "error fdopening \$fh: $!\n" );
80              
81 5         12 push @{ $self->{dups} }, { fh => $fh, mode => $mode, dup => $dup };
  5         40  
82             }
83              
84             elsif (Scalar::Util::looks_like_number( $fh )
85             && POSIX::ceil( $fh ) == POSIX::floor( $fh ) )
86             {
87              
88             # as the caller specifically used an fd, don't go through Perl's
89             # IO system
90 1 50       14 my $dup = POSIX::dup( $fh )
91             or _croak( "error dup'ing file descriptor $fh: $!\n" );
92              
93 1         3 push @{ $self->{dups} }, { fd => $fh, dup => $dup };
  1         16  
94             }
95              
96             else {
97 1         4 _croak(
98             "\$fh must be opened Perl filehandle or object or integer file descriptor\n"
99             );
100             }
101              
102 6         20 return;
103             }
104              
105             sub restore {
106 10     10 1 14 my $self = shift;
107              
108 10         19 my $dups = $self->{dups};
109             ## no critic (ProhibitAccessOfPrivateData)
110 10         15 while ( my $dup = pop @{$dups} ) {
  16         58  
111              
112 6 100       17 if ( exists $dup->{fd} ) {
113             POSIX::dup2( $dup->{dup}, $dup->{fd} )
114 1 50       13 or _croak( "error restoring file descriptor $dup->{fd}: $!\n" );
115 1         9 POSIX::close( $dup->{dup} );
116             }
117              
118             else {
119             open( $dup->{fh}, $dup->{mode} . '&', $dup->{dup} )
120 5 50       517 or _croak( "error restoring file handle $dup->{fh}: $!\n" );
121 5         59 close( $dup->{dup} );
122             }
123             }
124 10         27 return;
125             }
126              
127             sub DESTROY {
128 10     10   715 my $self = shift;
129 10     10   491 Try::Tiny::try { $self->restore }
130 10     0   79 Try::Tiny::catch { _croak $_ };
  0         0  
131 10         172 return;
132             }
133              
134             1;
135              
136             #
137             # This file is part of IO-ReStoreFH
138             #
139             # This software is Copyright (c) 2012 by Smithsonian Astrophysical Observatory.
140             #
141             # This is free software, licensed under:
142             #
143             # The GNU General Public License, Version 3, June 2007
144             #
145              
146             __END__