File Coverage

blib/lib/Hook/Output/Tiny.pm

Criterion	Covered	Total	%
statement	61	61	100.0
branch	18	22	81.8
condition	2	3	66.6
subroutine	17	17	100.0
pod	5	5	100.0
total	103	108	95.3

package Hook::Output::Tiny;
use strict;
use warnings;

our $VERSION = '1.00';

use Carp qw(croak);

BEGIN {
    # Auto generate the stdout() and stderr() methods, and their private
    # helper counterparts

    no strict 'refs';

    for ('stdout', 'stderr') {
        my $sub_name = $_; # We need to make a copy

        # Public

        *$_ = sub {
            my ($self) = @_;

            if (!wantarray) {
                warn "Calling $sub_name() in non-list context is deprecated!\n";
            }
            return defined $self->{$sub_name}{data}
                ? split /\n/, $self->{$sub_name}{data}
                : @{[ () ]}; # Empty list
        };

        # Private

        my $private_sub_name = "_$sub_name";

        *$private_sub_name = sub {
            my ($self) = @_;

            my $HANDLE = uc $sub_name;
            open $self->{$sub_name}{handle}, ">&$HANDLE"
              or croak("can't hook " . uc $sub_name . ": $!");
            close $HANDLE;
            open $HANDLE, '>>', \$self->{$sub_name}{data} or croak($!);
        };
    }
}

sub new {
    my %struct = map { $_ => {_struct()} } qw(stderr stdout);
    return bless \%struct, $_[0];
}
sub hook {
    my ($self, $handle) = @_;
    $_ eq 'stderr' ? $self->_stderr : $self->_stdout for _handles($handle);
}
sub unhook {
    my ($self, $handle) = @_;

    for (_handles($handle)) {
        no strict 'refs'; # To allow a string as STDOUT/STDERR bareword handles
        close uc $_;
        open uc $_, ">&$self->{$_}{handle}" or croak($!);
    }
}
sub flush {
    my ($self, $handle) = @_;
    delete $self->{$_}{data} for _handles($handle);
}
sub write {
    my ($self, $fn, $handle) = @_;
    if ($fn eq 'stderr' || $fn eq 'stdout'){
        croak("write() requires a file name sent in before the handle\n");
    }

    for (_handles($handle)){
        open my $wfh, '>>', $fn or croak($!);
        print $wfh $self->{$_}{data};
        close $wfh;
        $self->flush($_);
    }
}
sub _struct {
     return (handle => *fh, data => '');
}
sub _handles {
    my ($handle) = @_;
    my $sub = (caller(1))[3];
    _check_param($sub, $handle) if $handle;
    return $handle ? ($handle) : qw(stderr stdout);
}
sub _check_param {
    # validates the $handle param
    my ($sub, $handle) = @_;
    if (! grep {$handle eq $_} qw(stderr stdout)){
        croak(
            "$sub() either takes 'stderr', 'stdout' or no params\n" .
            "You supplied '$handle'\n"
        );
    }
}

1;
__END__