File Coverage

blib/lib/IO/Default.pm

Criterion	Covered	Total	%
statement	30	67	44.7
branch	0	30	0.0
condition	0	6	0.0
subroutine	11	18	61.1
pod			n/a
total	41	121	33.8

# $Id: Default.pm,v 1.3 2000/09/13 21:57:07 nwiger Exp $
####################################################################
#
# Copyright (c) 2000, Nathan Wiger
#
# IO::Default - Replace select() and default filehandle with $DEFOUT
#               Also add $DEFIN and $DEFERR variables
#
####################################################################

require 5.005;
package IO::Default;

use strict;
no strict 'refs';
use vars qw(@EXPORT @ISA $VERSION $DEFOUT $DEFERR $DEFIN);
$VERSION = do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };

use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw($DEFOUT $DEFERR $DEFIN);

use Carp;

# This works via tie(), "plain and simple", but with a couple special
# subclasses since each variable is tied differently. On assignment,
# basically we just do some select or open calls to twiddle what
# we're working with. The $DEFIN handle is more complicated because
# it tries to override what is done with <> and .

tie $DEFOUT, 'IO::Default::DEFOUT';
tie $DEFERR, 'IO::Default::DEFERR';
tie $DEFIN, 'IO::Default::DEFIN';

# Stolen from CGI.pm - thanks Lincoln!
# Man, will I be glad when these become scalars in Perl 6...

sub _to_filehandle {
    my $thingy = shift;
    return undef unless $thingy;
    return $thingy if UNIVERSAL::isa($thingy,'GLOB');
    return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
    if (!ref($thingy)) {
        my $caller = 1;
        while (my $package = caller($caller++)) {
            my($tmp) = $thingy =~ /[\':]/ ? $thingy : "$package\:\:$thingy";
            return $tmp if defined(fileno($tmp));
        }
    }
    return undef;
}


# For $DEFOUT, we just call select() on STORE/FETCH

package IO::Default::DEFOUT;
use Carp;

sub TIESCALAR {
    my $c = shift;
    bless { DEFOUT => (select) }, $c;
}

sub STORE {
    my $c = shift;
    my $h = IO::Default::_to_filehandle(shift);
    return $h if ($c->{DEFOUT} and $h eq $c->{DEFOUT});     # duplicate, skip
    select $h or carp "Assignment to \$DEFOUT failed: $!";
    return $c->{DEFOUT} = $h;
}

sub FETCH {
    my $c = shift;
    return $c->{DEFOUT} = select;
}


# For $DEFERR, we just reopen STDERR

package IO::Default::DEFERR;
use Carp;

sub TIESCALAR {
    my $c = shift;
    bless { DEFERR => "STDERR" }, $c;
}

sub STORE {
    my $c = shift;
    my $h = IO::Default::_to_filehandle(shift);
    return $h if $h eq $c->{DEFERR};     # duplicate, skip
    if ( ref $h ) {
       *STDERR = *$h;       # use typeglob aliases
    } else {
       open(STDERR, ">&$h") or carp "Assignment to \$DEFERR failed: $!";
    }
    $c->{DEFERR} = $h;
}

sub FETCH {
    shift->{DEFERR};
}


# For $DEFIN, we just copy whatever's been passed in

package IO::Default::DEFIN;
use Carp;

sub TIESCALAR {
    my $c = shift;
    bless { DEFIN => undef }, $c;
}

sub STORE {
    my $c = shift;
    my $h = IO::Default::_to_filehandle(shift);
    return $h if ($c->{DEFERR} and $h eq $c->{DEFERR});     # duplicate, skip

    # This may seem mean, but the whole purpose of this module
    # is to change the meaning of <> to not iterate over
    # command-line files. As such, we need to blow away any
    # @ARGV that's hanging around still because of ARGV's
    # inherent special-ness.
    undef @ARGV;

    if ( ref $h ) {
       *ARGV = *$h;          # use typeglob aliases
    } else {
       open(ARGV, "<&$h") or carp "Assignment to \$DEFIN failed: $!";
    }
    $c->{DEFIN} = $h;
}

sub FETCH {
    my $c = shift;
    my $h = IO::Default::_to_filehandle(shift);
    return $h if $h eq $c->{DEFIN};     # duplicate, skip

    # If we haven't set $DEFIN yet, but we're trying to
    # read from it explicitly, then basically do what STORE
    # does and reopen ARGV "correctly".
    $c->STORE($h);
}


1;

__END__