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.02';

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($!);
    }
}

# Commenting out include() and exclude(). They're to be used to filter the
# output. They have no docs nor tests yet.

#sub include {
#    my ($self, $include) = @_;
#
#    if (defined $include) {
#        if (ref $include ne 'ARRAY') {
#            croak("include() requires an array of regex objects sent in");
#        }
#        if (! defined $include->[0]) {
#            croak("include() requires at least one regex object within the array reference");
#        }
#        for (@$include) {
#            if (ref $_ ne 'REGEX') {
#                croak("include()'s array reference must only contain regex objects");
#            }
#        }
#        $self->{include} = $include;
#    }
#
#    return $self->{include} // [];
#}
#sub exclude {
#    my ($self, $exclude) = @_;
#
#    if (defined $exclude) {
#        if (ref $exclude ne 'ARRAY') {
#            croak("exclude() requires an array of regex objects sent in");
#        }
#        if (! defined $exclude->[0]) {
#            croak("exclude() requires at least one regex object within the array reference");
#        }
#        for (@$exclude) {
#            if (ref $_ ne 'REGEX') {
#                croak("exclude()'s array reference must only contain regex objects");
#            }
#        }
#        $self->{exclude} = $exclude;
#    }
#
#    return $self->{exclude} // [];
#}
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__