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

package IO::ReStoreFH;

# ABSTRACT: store/restore file handles

use 5.10.0;

use strict;
use warnings;

our $VERSION = '0.10';

# In Perl 5.10.1 a use or require of FileHandle or something in the
# FileHandle hierarchy (like FileHandle::Fmode, below) will cause the
# compiler to creat a stash for FileHandle.  Then, there's some
# code in Perl_newio which checks if FileHandle has been loaded (just
# by checking for the stash) and aliases it to IO::Handle.
#
#  This it mucks up method calls on filehandles if FileHandle isn't
#  actually loaded, resulting in errors such as
#
#   Can't locate object method "getline" via package "FileHandle"
#
# see http://perlmonks.org/?node_id=1073753, and tobyink's reply

# So, we explicitly load FileHandle on 5.10.x to avoid these action
# at a distance problems.
use if $^V ge v5.10.0 && $^V lt v5.11.0, 'FileHandle';

use FileHandle::Fmode ();
use POSIX             ();
use IO::Handle;
use Scalar::Util;
use Try::Tiny ();

sub _croak {
    require Carp;
    goto &Carp::croak;
}

sub new {
    my $class = shift;

    my $obj = bless { dups => [] }, $class;
    $obj->store( $_ ) for @_;
    return $obj;
}

sub store {
    my ( $self, $fh ) = @_;

    # if $fh is a reference, or a GLOB, it's probably
    # a filehandle object of somesort

    if ( ref( $fh ) || 'GLOB' eq ref( \$fh ) ) {

        # now that we are sure that everything is loaded,
        # check if it is an open filehandle; this doesn't disambiguate
        # between objects that aren't filehandles or closed filehandles.
        _croak( "\$fh is not an open filehandle\n" )
          unless FileHandle::Fmode::is_FH( $fh );

        # get access mode; open documentation says mode must
        # match that of original filehandle; do the best we can
        my $mode
          = FileHandle::Fmode::is_RO( $fh ) ? '<'
          : FileHandle::Fmode::is_WO( $fh ) ? '>'
          : FileHandle::Fmode::is_W( $fh )
          && FileHandle::Fmode::is_R( $fh ) ? '+<'
          : undef;

        # give up
        _croak( "inexplicable error: unable to determine mode for \$fh;\n" )
          if !defined $mode;

        $mode .= '>' if FileHandle::Fmode::is_A( $fh );

        # dup the filehandle
        open my $dup, $mode . '&', $fh
          or _croak( "error fdopening \$fh: $!\n" );

        push @{ $self->{dups} }, { fh => $fh, mode => $mode, dup => $dup };
    }

    elsif (Scalar::Util::looks_like_number( $fh )
        && POSIX::ceil( $fh ) == POSIX::floor( $fh ) )
    {

        # as the caller specifically used an fd, don't go through Perl's
        # IO system
        my $dup = POSIX::dup( $fh )
          or _croak( "error dup'ing file descriptor $fh: $!\n" );

        push @{ $self->{dups} }, { fd => $fh, dup => $dup };
    }

    else {
        _croak(
            "\$fh must be opened Perl filehandle or object or integer file descriptor\n"
        );
    }

    return;
}

sub restore {
    my $self = shift;

    my $dups = $self->{dups};
    ## no critic (ProhibitAccessOfPrivateData)
    while ( my $dup = pop @{$dups} ) {

        if ( exists $dup->{fd} ) {
            POSIX::dup2( $dup->{dup}, $dup->{fd} )
              or _croak( "error restoring file descriptor $dup->{fd}: $!\n" );
            POSIX::close( $dup->{dup} );
        }

        else {
            open( $dup->{fh}, $dup->{mode} . '&', $dup->{dup} )
              or _croak( "error restoring file handle $dup->{fh}: $!\n" );
            close( $dup->{dup} );
        }
    }
    return;
}

sub DESTROY {
    my $self = shift;
    Try::Tiny::try { $self->restore }
    Try::Tiny::catch { _croak $_ };
    return;
}

1;

#
# This file is part of IO-ReStoreFH
#
# This software is Copyright (c) 2012 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__