File Coverage

blib/lib/File/Tee.pm

Criterion	Covered	Total	%
statement	99	171	57.8
branch	40	114	35.0
condition	1	12	8.3
subroutine	9	9	100.0
pod	1	1	100.0
total	150	307	48.8

package File::Tee;

our $VERSION = '0.07';

use strict;
use warnings;
no warnings 'uninitialized';

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(tee);

use Carp;

use Symbol qw(qualify_to_ref);
use POSIX qw(_exit);
use Fcntl qw(:flock);

sub tee (*;@) {
    @_ >= 2 or croak 'Usage: tee($fh, $target, ...)';

    my $fh = qualify_to_ref(shift, caller);

    my $last_mode;

    my @target;
    while (@_) {
        my $arg = shift @_;
        my %target;
        my %opts = ( ref $arg eq 'HASH' ? %$arg :
                     ref $arg eq 'CODE' ? ( process => $arg ) :
                                          ( open => $arg ) );

        $target{ignore_errors} = delete $opts{ignore_errors};
        $target{prefix} = delete $opts{prefix};
        $target{end} = delete $opts{end};
        $target{begin} = delete $opts{begin};
        $target{preprocess} = delete $opts{preprocess};
        $target{process} = delete $opts{process};
        unless (defined $target{process}) {
            $target{mode} = delete $opts{mode};
            $target{open} = delete $opts{open};
            $target{reopen} = delete $opts{reopen};
            $target{autoflush} = delete $opts{autoflush};
            $target{lock} = delete $opts{lock};
        }

        %opts and croak "bad options '".join("', '", keys %opts)."'";

        unless (defined $target{process}) {
            if (defined $target{reopen}) {
                croak "both 'open' and 'reopen' options used for the same target"
                    if defined $target{open};
                $target{open} = $target{reopen};
                $target{reopen} = 1;
            }
            elsif (!defined $target{open}) {
                croak "missing mandatory argument 'open'";
            }

            $target{autoflush} = 1 unless defined $target{autoflush};

            $target{open} = [$target{open}]
                unless ref $target{open} eq 'ARRAY';
            unless (defined $target{mode}) {
                if (ref $target{open}[0]) {
                    if (ref $target{open}[0] eq 'CODE') {
                        $target{mode} = 'CODE';
                    }
                    else {
                        $target{mode} = (defined $last_mode ? $last_mode : '>>&');
                    }
                }
                else {
                    my ($mode, $fn) = shift(@{$target{open}}) =~ /^(\+?[<>]{1,2}(?:&=?)?|\|-?|)\s*(.*)$/;

                    $mode = (defined $last_mode ? $last_mode : '>>') unless length $mode;
                    $mode = '|-' if $mode eq '|';

                    unshift @{$target{open}}, $fn
                        if length $fn;

                    $target{mode} = $mode;
                }
            }

            $target{mode} =~ /^(?:>{1,2}&?|\|-|CODE)$/ or croak "invalid mode '$target{mode}'";

            # file name is next argument or slurp everything when mode is '|-'
            unless (@{$target{open}} > 0) {
                if (ref $arg ne 'HASH' and @_) {
                    if ($target{mode} eq '|-') {
                        @{$target{open}} = splice @_;
                    }
                    else {
                        my $last_mode = $target{mode};
                        @{$target{open}} = shift;
                    }
                }
                else {
                    croak "missing target file name";
                }
            }

            $target{open}[0] = qualify_to_ref($target{open}[0], caller)
                if $target{mode} =~ tr/&//;

            unless ($target{mode} eq '|-')  {
                open my $teefh, $target{mode}, @{$target{open}}
                    or return undef;

                if ($target{reopen}) {
                    $target{mode} =~ s/>+/>>/;
                    close $teefh
                        or return undef;
                }
                else {
                    $target{teefh} = $teefh;
                    if ($target{autoflush}) {
                        my $oldsel = select $teefh;
                        $| = 1;
                        select $oldsel;
                    }
                }
            }
        }

        push @target, \%target;
    }

    my $fileno = eval { fileno($fh) };

    defined $fileno
        or croak "only real file handles can be tee'ed";

    unless (defined $fileno) {
        return undef;
    }

    # flush any data buffered in $fh
    my $oldsel = select($fh);
    my @oldstate = ($|, $%, $=, $-, $~, $^, $.);
    $| = 1;
    select $oldsel;

    open my $out, ">&$fileno" or return undef;

    $oldsel = select $out;
    $| = $oldstate[0];
    select $oldsel;

    my $pid = open $fh, '|-';
    unless ($pid) {
        defined $pid
            or return undef;

	$SIG{INT} = 'IGNORE';
        undef @ARGV;
        eval { $0 = "perl [File::Tee]" };

        my $error = 0;

        my $oldsel = select STDERR;
        $| = 1;

        for my $target (@target) {
            my $begin = $target->{begin};
            &$begin if $begin;
        }
        my $buffer = '';
        my $eof;
        while(!$error and !$eof) {
            my $read = sysread STDIN, $buffer, 16*1024, length $buffer;
            if ($read) {
                print $out substr $buffer, -$read;
            }
            else {
                $eof = 1;
            }
            while (!$error and length $buffer) {
                my $line;
                my $eol = index $buffer, $/;
                if ($eol >= 0) {
                    $line = substr $buffer, 0, $eol + length $/, '';
                }
                elsif ($eof) {
                    $line = $buffer;
                    $buffer = '';
                }
                else {
                    last;
                }

                for my $target (@target) {
                    my $cp = $line;
                    $cp = join('', $target->{preprocess}($cp)) if $target->{preprocess};
                    $cp = $target->{prefix} . $cp if length $target->{prefix};
                    my $process = $target->{process};
                    if ($process) {
                        my $ok;
                        $ok = &$process for ($cp);
                        $error = 1 unless ($ok or $target->{ignore_errors});
                    }
                    else {
                        my $teefh = $target->{teefh};
                        unless ($teefh) {
                            undef $teefh;
                            if (open $teefh, $target->{mode}, @{$target->{open}}) {
                                unless ($target->{reopen}) {
                                    $target->{teefh} = $teefh;
                                    if ($target->{autoflush}) {
                                        my $oldsel = select $teefh;
                                        $| = 1;
                                        select $oldsel;
                                    }
                                }
                            }
                            else {
                                $error = 1 unless $target->{ignore_errors};
                                next;
                            }
                        }
                        flock($teefh, LOCK_EX) if $target->{lock};
                        print $teefh $cp;
                        flock($teefh, LOCK_UN) if $target->{lock};

                        if ($target->{reopen}) {
                            unless (close $teefh) {
                                $error = 1 unless $target->{ignore_errors};
                            }
                            delete $target->{teefh};
                        }
                    }
                }
            }
        }

        for my $target (@target) {

            my $end = $target->{end};
            &$end if $end;

            my $teefh = $target->{teefh};
            if ($teefh) {
                unless (close $teefh) {
                    $error = 1 unless $target->{ignore_errors};
                }
            }
        }

        close $out or $error = 1;

        _exit($error);
    }
    # close $teefh;

    $oldsel = select($fh);
    no warnings 'once';
    ($|, $%, $=, $-, $~, $^, $.) = @oldstate;
    select($oldsel);

    return $pid;
}

1;
__END__