File Coverage

blib/lib/Capture/Attribute.pm
Criterion Covered Total %
statement 76 113 67.2
branch 13 40 32.5
condition 2 5 40.0
subroutine 21 21 100.0
pod 1 1 100.0
total 113 180 62.7


line stmt bran cond sub pod time code
1             package Capture::Attribute;
2              
3 2     2   67198 use 5.010;
  2         6  
  2         84  
4 2     2   12 use strict;
  2         4  
  2         128  
5              
6             BEGIN {
7 2     2   4 $Capture::Attribute::AUTHORITY = 'cpan:TOBYINK';
8 2         48 $Capture::Attribute::VERSION = '0.003';
9             }
10              
11 2     2   14254 use Attribute::Handlers;
  2         24531  
  2         14  
12 2     2   2533 use Capture::Attribute::Return;
  2         11  
  2         85  
13 2     2   6657 use Capture::Tiny qw//;
  2         120269  
  2         90  
14 2     2   19 use Carp qw//;
  2         4  
  2         37  
15 2     2   2052 use Sub::Name qw//;
  2         2352  
  2         287  
16              
17             my @importers;
18             sub import
19             {
20 2     2   41 my ($class, %args) = @_;
21 2   33     33 my $caller =
22             $args{-into}
23             || $args{-package}
24             || caller;
25            
26 2     2   14 no strict 'refs';
  2         4  
  2         2593  
27 2         5 push @{"$caller\::ISA"}, __PACKAGE__;
  2         34  
28 2 50       52 push @importers, $caller unless $args{-keep};
29             }
30              
31             my ($make_replacement_coderef, $save_coderef, $saved);
32             BEGIN
33             {
34             $make_replacement_coderef = sub
35             {
36 1         2 my ($orig, $data) = @_;
37              
38 1 50       14 if ($data eq 'STDOUT')
    50          
    50          
    50          
    50          
39             {
40             return sub
41             {
42 0         0 my (@args) = @_;
43 0         0 my $wa = wantarray;
44             my $stdout = Capture::Tiny::capture {
45             $wa ? $save_coderef->(1, my @r = $orig->(@args)) :
46             defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
47 0 0       0 do { $orig->(@args); $save_coderef->() } ;
  0 0       0  
  0         0  
48 0         0 };
49 0         0 return $stdout;
50             }
51 0         0 }
52             elsif ($data eq 'STDERR')
53             {
54             return sub
55             {
56 0         0 my (@args) = @_;
57 0         0 my $wa = wantarray;
58             my (undef, $stderr) = Capture::Tiny::capture {
59             $wa ? $save_coderef->(1, my @r = $orig->(@args)) :
60             defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
61 0 0       0 do { $orig->(@args); $save_coderef->() } ;
  0 0       0  
  0         0  
62 0         0 };
63 0         0 return $stderr;
64             }
65 0         0 }
66             elsif ($data eq 'MERGED')
67             {
68             return sub
69             {
70 0         0 my (@args) = @_;
71 0         0 my $wa = wantarray;
72             my $merged = Capture::Tiny::capture_merged {
73             $wa ? $save_coderef->(1, my @r = $orig->(@args)) :
74             defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
75 0 0       0 do { $orig->(@args); $save_coderef->() } ;
  0 0       0  
  0         0  
76 0         0 };
77 0         0 return $merged;
78             }
79 0         0 }
80             elsif ($data eq 'STDERR,STDOUT')
81             {
82             return sub
83             {
84 0         0 my (@args) = @_;
85 0         0 my $wa = wantarray;
86             my @r = Capture::Tiny::capture {
87             $wa ? $save_coderef->(1, my @r = $orig->(@args)) :
88             defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
89 0 0       0 do { $orig->(@args); $save_coderef->() } ;
  0 0       0  
  0         0  
90 0         0 };
91 0 0       0 return wantarray ? reverse(@r[0..1]) : $r[0];
92             }
93 0         0 }
94             elsif ($data eq 'STDOUT,STDERR')
95             {
96             return sub
97             {
98 2     2   10 my (@args) = @_;
99 2         6 my $wa = wantarray;
100             return Capture::Tiny::capture {
101             $wa ? $save_coderef->(1, my @r = $orig->(@args)) :
102             defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
103 2 50   2   4341 do { $orig->(@args); $save_coderef->() } ;
  0 100       0  
  0         0  
104 2         121 };
105             }
106 1         10 }
107              
108 0         0 return;
109 2     2   15 };
110            
111             $save_coderef = sub
112             {
113 2 50       233 if (not scalar @_)
114             {
115 0         0 $saved = Capture::Attribute::Return->new(wasarray => undef);
116 0         0 return;
117             }
118            
119 2         11 my $context = shift;
120 2 100       112 $saved = Capture::Attribute::Return->new(
121             wasarray => $context,
122             value => ($context ? \@_ : $_[0]),
123             );
124             }
125 2         78 }
126              
127             INIT # runs AFTER attributes have been handled.
128             {
129 2     2   23 no strict 'refs';
  2         5  
  2         214  
130 2     2   33 foreach my $caller (@importers)
131             {
132 2         6 @{"$caller\::ISA"} = grep { $_ ne __PACKAGE__ } @{"$caller\::ISA"};
  2         74  
  2         7  
  2         46  
133             }
134 2     2   13 no warnings 'once';
  2         3  
  2         406  
135 2     4   130 *return = sub { $saved };
  4         15325  
136             }
137              
138             sub Capture :ATTR(CODE,RAWDATA)
139             {
140             my (
141 1     1 1 33006 $package,
142             $symbol,
143             $referent,
144             $attr,
145             $data,
146             $phase,
147             $filename,
148             $linenum,
149             ) = @_;
150              
151 1   50     7 $data = uc($data) || (my $default_data = 'STDOUT');
152              
153 1         3 my $orig = *{$symbol}{CODE};
  1         3  
154 1 50       5 my $replacement = $make_replacement_coderef->($orig, $data)
155             or Carp::croak "Unrecognised option string: $data";
156              
157             {
158 2     2   12 no strict 'refs';
  2         3  
  2         92  
  1         3  
159 2     2   12 no warnings 'redefine';
  2         4  
  2         300  
160 1         3 my $subname = sprintf '%s::%s', *{$symbol}{PACKAGE}, *{$symbol}{NAME};
  1         4  
  1         6  
161 1         10 *{$subname} = Sub::Name::subname($subname, $replacement);
  1         6  
162             }
163 2     2   15 }
  2         2  
  2         19  
164              
165             __PACKAGE__
166             __END__