File Coverage

blib/lib/IO/Tee.pm

Criterion	Covered	Total	%
statement	93	134	69.4
branch	19	36	52.7
condition	1	5	20.0
subroutine	23	43	53.4
pod	0	26	0.0
total	136	244	55.7

package IO::Tee;

require 5.006;
use strict;
use warnings;

use parent 'IO::Handle';

use Carp;
use Symbol;
use IO::Handle;
use IO::File;

our $VERSION = '0.65';

# Constructor -- bless array reference into our class

sub new
{
    my $class = shift;
    my $self = gensym;
    @{*$self} = map {
        ! ref($_) ? IO::File->new($_)
        : ref($_) eq 'ARRAY' ? IO::File->new(@$_)
        : ref($_) eq 'GLOB' ? bless $_, 'IO::Handle'
        : $_ or return undef } @_;
    bless $self, $class;
    tie *$self, $class, $self;
    return $self;
}

# Return a list of all associated handles

sub handles
{
    @{*{$_[0]}};
}

# Proxy routines for various IO::Handle and IO::File operations

sub _method_return_success
{
    my $method = (caller(1))[3];
    $method =~ s/.*:://;

    my $self = shift;
    my $ret = 1;
    foreach my $fh (@{*$self}) { undef $ret unless $fh->$method(@_) }
    return $ret;
}

sub close        { _method_return_success(@_) }
sub truncate     { _method_return_success(@_) }
sub write        { _method_return_success(@_) }
sub syswrite     { _method_return_success(@_) }
sub format_write { _method_return_success(@_) }
sub fcntl        { _method_return_success(@_) }
sub ioctl        { _method_return_success(@_) }
sub flush        { _method_return_success(@_) }
sub clearerr     { _method_return_success(@_) }
sub seek         { _method_return_success(@_) }

sub formline
{
    my $self = shift;
    my $picture = shift;
    local($^A) = $^A;
    local($\) = "";
    formline($picture, @_);

    my $ret = 1;
    foreach my $fh (@{*$self}) { undef $ret unless print $fh $^A }
    return $ret;
}

sub _state_modify
{
    my $method = (caller(1))[3];
    $method =~ s/.*:://;
    croak "$method values cannot be retrieved collectively" if @_ <= 1;

    my $self = shift;
    if (ref $self)
    {
        foreach my $fh (@{*$self}) { $fh->$method(@_) }
    }
    else
    {
        IO::Handle->$method(@_);
    }
    # Note that we do not return any "previous value" here
}

sub autoflush                    { _state_modify(@_) }
sub output_field_separator       { _state_modify(@_) }
sub output_record_separator      { _state_modify(@_) }
sub format_page_number           { _state_modify(@_) }
sub format_lines_per_page        { _state_modify(@_) }
sub format_lines_left            { _state_modify(@_) }
sub format_name                  { _state_modify(@_) }
sub format_top_name              { _state_modify(@_) }
sub format_line_break_characters { _state_modify(@_) }
sub format_formfeed              { _state_modify(@_) }

sub input_record_separator
{
    my $self = shift;
    my $ret = (ref $self ? ${*$self}[0] : 'IO::Handle')
        ->input_record_separator(@_);
    $ret; # This works around an apparent bug in Perl 5.004_04
}

sub input_line_number
{
    my $self = shift;
    my $ret = ${*$self}[0]->input_line_number(@_);
    $ret; # This works around an apparent bug in Perl 5.004_04
}

# File handle tying interface

sub TIEHANDLE
{
    my ($class, $self) = @_;
    return bless *$self{ARRAY}, $class;
}

sub PRINT
{
    my $self = shift;
    my $ret = 1;
    foreach my $fh (@$self) { undef $ret unless print $fh @_ }
    return $ret;
}

sub PRINTF
{
    my $self = shift;
    my $fmt = shift;
    my $ret = 1;
    foreach my $fh (@$self) { undef $ret unless printf $fh $fmt, @_ }
    return $ret;
}

sub _multiplex_input
{
    my ($self, $input) = @_;
    my $ret = 1;
    if (length $input)
    {
        for (my $i = 1; $i < @$self; ++$i)
        {
            undef $ret unless print {$self->[$i]} $input;
        }
    }
    $ret;
}

sub READ
{
    my $self = shift;
    my $bytes = $self->[0]->read(@_);
    $bytes and $self->_multiplex_input(substr($_[0], $_[2], $bytes));
    $bytes;
}

sub READLINE
{
    my $self = shift;
    my $infh = $self->[0];
    if (wantarray)
    {
        my @data;
        my $data;
        while (defined($data = <$infh>) and length($data))
        {
            push @data, $data;
            $self->_multiplex_input($data);
        }
        @data;
    }
    else
    {
        my $data = <$infh>;
        defined $data and $self->_multiplex_input($data);
        $data;
    }
}

sub GETC
{
    my $self = shift;
    my $data = getc($self->[0]);
    defined $data and $self->_multiplex_input($data);
    $data;
}

sub sysread
{
    my $self = shift;
    my $bytes = ${*$self}[0]->sysread(@_);
    $bytes and (\@{*$self})->
        _multiplex_input(substr($_[0], $_[2] || 0, $bytes));
    $bytes;
}

sub EOF
{
    my $self = shift;
    return $self->[0]->eof;
}

1;
__END__