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


line stmt bran cond sub pod time code
1             package Hook::Output::Tiny;
2 9     9   69689 use strict;
  9         64  
  9         255  
3 9     9   43 use warnings;
  9         17  
  9         392  
4              
5             our $VERSION = '1.01';
6              
7 9     9   52 use Carp qw(croak);
  9         12  
  9         731  
8              
9             BEGIN {
10             # Auto generate the stdout() and stderr() methods, and their private
11             # helper counterparts
12              
13 9     9   59 no strict 'refs';
  9         17  
  9         2748  
14              
15 9     9   62 for ('stdout', 'stderr') {
16 18         56 my $sub_name = $_; # We need to make a copy
17              
18             # Public
19              
20             *$_ = sub {
21 30     30   2559 my ($self) = @_;
22              
23 30 100       73 if (! wantarray) {
24 2         12 warn "Calling $sub_name() in non-list context is deprecated!\n";
25             }
26             return defined $self->{$sub_name}{data}
27             ? split /\n/, $self->{$sub_name}{data}
28 30 100       169 : @{[ () ]}; # Empty list
  8         27  
29 18         139 };
30              
31             # Private
32              
33 18         60 my $private_sub_name = "_$sub_name";
34              
35             *$private_sub_name = sub {
36 24     24   3201 my ($self) = @_;
37              
38 24         58 my $HANDLE = uc $sub_name;
39 24 50       709 open $self->{$sub_name}{handle}, '>&', $HANDLE
40             or croak("can't hook " . uc $sub_name . ": $!");
41 24         204 close $HANDLE;
42 24 50   7   412 open $HANDLE, '>>', \$self->{$sub_name}{data} or croak($!);
  7         111  
  7         15  
  7         56  
43 18         1640 };
44             }
45             }
46             sub new {
47 12     12 1 3418 my %struct = map { $_ => {_struct()} } qw(stderr stdout);
  24         65  
48 12         52 return bless \%struct, $_[0];
49             }
50             sub hook {
51 18     18 1 12165 my ($self, $handle) = @_;
52 18 100       51 $_ eq 'stderr' ? $self->_stderr : $self->_stdout for _handles($handle);
53             }
54             sub unhook {
55 19     19 1 2240 my ($self, $handle) = @_;
56              
57 19         44 for (_handles($handle)) {
58 9     9   68 no strict 'refs'; # To allow a string as STDOUT/STDERR bareword handles
  9         19  
  9         3959  
59 26         107 close uc $_;
60 26 50       558 open uc $_, '>&', $self->{$_}{handle} or croak($!);
61             }
62             }
63              
64             # Commenting out include() and exclude(). They're to be used to filter the
65             # output. They have no docs nor tests yet.
66              
67             #sub include {
68             # my ($self, $include) = @_;
69             #
70             # if (defined $include) {
71             # if (ref $include ne 'ARRAY') {
72             # croak("include() requires an array of regex objects sent in");
73             # }
74             # if (! defined $include->[0]) {
75             # croak("include() requires at least one regex object within the array reference");
76             # }
77             # for (@$include) {
78             # if (ref $_ ne 'REGEX') {
79             # croak("include()'s array reference must only contain regex objects");
80             # }
81             # }
82             # $self->{include} = $include;
83             # }
84             #
85             # return $self->{include} // [];
86             #}
87             #sub exclude {
88             # my ($self, $exclude) = @_;
89             #
90             # if (defined $exclude) {
91             # if (ref $exclude ne 'ARRAY') {
92             # croak("exclude() requires an array of regex objects sent in");
93             # }
94             # if (! defined $exclude->[0]) {
95             # croak("exclude() requires at least one regex object within the array reference");
96             # }
97             # for (@$exclude) {
98             # if (ref $_ ne 'REGEX') {
99             # croak("exclude()'s array reference must only contain regex objects");
100             # }
101             # }
102             # $self->{exclude} = $exclude;
103             # }
104             #
105             # return $self->{exclude} // [];
106             #}
107             sub flush {
108 8     8 1 1454 my ($self, $handle) = @_;
109 8         22 delete $self->{$_}{data} for _handles($handle);
110             }
111             sub write {
112 6     6 1 590 my ($self, $fn, $handle) = @_;
113 6 100 66     38 if ($fn eq 'stderr' || $fn eq 'stdout'){
114 1         69 croak("write() requires a file name sent in before the handle\n");
115             }
116              
117 5         15 for (_handles($handle)){
118 4 50       323 open my $wfh, '>>', $fn or croak($!);
119 4         67 print $wfh $self->{$_}{data};
120 4         185 close $wfh;
121 4         24 $self->flush($_);
122             }
123             }
124             sub _struct {
125 24     24   161 return (handle => *fh, data => '');
126             }
127             sub _handles {
128 50     50   89 my ($handle) = @_;
129 50         353 my $sub = (caller(1))[3];
130 50 100       206 _check_param($sub, $handle) if $handle;
131 46 100       254 return $handle ? ($handle) : qw(stderr stdout);
132             }
133             sub _check_param {
134             # validates the $handle param
135 34     34   70 my ($sub, $handle) = @_;
136 34 100       67 if (! grep {$handle eq $_} qw(stderr stdout)){
  68         205  
137 4         466 croak(
138             "$sub() either takes 'stderr', 'stdout' or no params\n" .
139             "You supplied '$handle'\n"
140             );
141             }
142             }
143              
144             1;
145             __END__