File Coverage

blib/lib/Print/Indented/Handle.pm
Criterion Covered Total %
statement 38 55 69.0
branch 2 8 25.0
condition 1 2 50.0
subroutine 11 15 73.3
pod 0 4 0.0
total 52 84 61.9


line stmt bran cond sub pod time code
1             package Print::Indented::Handle;
2 1     1   6 use strict;
  1         2  
  1         30  
3 1     1   5 use warnings;
  1         2  
  1         21  
4 1     1   718 use Tie::Handle;
  1         1866  
  1         20  
5 1     1   735 use parent -norequire => 'Tie::StdHandle';
  1         263  
  1         6  
6 1     1   39 use Scalar::Util qw(refaddr);
  1         1  
  1         107  
7 1     1   1230 use Path::Tiny;
  1         13078  
  1         63  
8 1     1   771 use Symbol;
  1         915  
  1         65  
9 1     1   794 use List::MoreUtils qw(any);
  1         1036  
  1         531  
10              
11             our (%Fh, %Packages);
12              
13             sub new {
14 2     2 0 3 my ($class, $target) = @_;
15              
16 2         5 my $symbol = Symbol::gensym();
17 2         28 my $self = tie *$symbol, $class;
18              
19 2 50       50 open my $original_fh, '>&', $target or die $!;
20 2         5 $self->original_fh($original_fh);
21              
22 2         4 *$target = $symbol;
23              
24 2         14 return $self;
25             }
26              
27             sub original_fh {
28 2     2 0 3 my ($self, $fh) = @_;
29 2 50       5 if (defined $fh) {
30 2         7 $Fh{ refaddr $self } = $fh;
31             }
32 2         5 return $Fh{ refaddr $self };
33             }
34              
35             sub packages_re {
36 0     0 0 0 my $self = shift;
37 0 0       0 return @{ $Packages{ refaddr $self } || [] };
  0         0  
38             }
39              
40             sub add_package_re {
41 2     2 0 4 my $self = shift;
42 2   50     1 push @{ $Packages{ refaddr $self } ||= [] }, @_;
  2         23  
43             }
44              
45             sub PRINT {
46 0     0     my ($self, @args) = @_;
47 0           my ($pkg, $filename, $nr) = caller;
48              
49 0 0   0     if (any { $pkg =~ $_ } $self->packages_re) {
  0            
50 0           my $line = (path($filename)->lines)[$nr-1];
51 0           my ($indent) = $line =~ /^(\s*)/;
52 0           foreach (grep length, split m<(.*$/?)>, join('', @args)) {
53 0           print { $self->original_fh } "$indent$_";
  0            
54             }
55             } else {
56             # do not indent
57 0           print { $self->original_fh } @args;
  0            
58             }
59             }
60              
61             sub PRINTF {
62 0     0     my ($self, $format, @args) = @_;
63 0           @_ = ( $self, sprintf $format, @args );
64 0           goto \&PRINT;
65             }
66              
67             1;