File Coverage

blib/lib/Data/Printer.pm
Criterion Covered Total %
statement 119 131 90.8
branch 45 66 68.1
condition 34 48 70.8
subroutine 15 15 100.0
pod 2 2 100.0
total 215 262 82.0


line stmt bran cond sub pod time code
1             package Data::Printer;
2 7     7   4048 use strict;
  7         13  
  7         230  
3 7     7   36 use warnings;
  7         13  
  7         182  
4 7     7   3466 use Data::Printer::Object;
  7         20  
  7         279  
5 7     7   50 use Data::Printer::Common;
  7         14  
  7         131  
6 7     7   31 use Data::Printer::Config;
  7         11  
  7         1385  
7              
8             our $VERSION = '1.000004';
9             $VERSION = eval $VERSION;
10              
11             my $rc_arguments;
12             my %arguments_for;
13              
14             sub import {
15 9     9   103 my $class = shift;
16              
17 9         26 _initialize();
18              
19 9         29 my $args;
20 9 100       30 if (@_ > 0) {
21 7 50       38 $args = @_ == 1 ? shift : {@_};
22 7 50       25 Data::Printer::Common::_warn(
23             undef,
24             'Data::Printer can receive either a hash or a hash reference'
25             ) unless ref $args eq 'HASH';
26             $args = Data::Printer::Config::_expand_profile($args)
27 7 50       22 if exists $args->{profile};
28             }
29              
30             # every time you load it, we override the version from *your* caller
31 9         21 my $caller = caller;
32 9         27 $arguments_for{$caller} = $args;
33              
34 9         23 my $use_prototypes = _find_option('use_prototypes', $args, $caller, 1);
35 9 100       25 my $exported = ($use_prototypes ? \&p : \&_p_without_prototypes);
36              
37 9         19 my $imported = _find_option('alias', $args, $caller, 'p');
38              
39 7     7   58 { no strict 'refs';
  7         18  
  7         620  
  9         17  
40 9         14 *{"$caller\::$imported"} = $exported;
  9         45  
41 9         18 *{"$caller\::np"} = \&np;
  9         9486  
42             }
43             }
44              
45             sub _initialize {
46             # potential race but worst case is we read it twice :)
47 7     7   42 { no warnings 'redefine'; *_initialize = sub {} }
  7     61   22  
  7         7174  
48             $rc_arguments = Data::Printer::Config::load_rc_file();
49             }
50              
51             sub np (\[@$%&];%) {
52 13     13 1 11905 my (undef, %properties) = @_;
53              
54 13         50 _initialize();
55              
56 13         37 my $caller = caller;
57 13         46 my $args_to_use = _fetch_args_with($caller, \%properties);
58 13         61 my $printer = Data::Printer::Object->new($args_to_use);
59              
60             # force color level 0 on 'auto' colors:
61 13 50       53 if ($printer->colored eq 'auto') {
62 0         0 $printer->{_output_color_level} = 0;
63             }
64              
65 13         50 my $ref = ref $_[0];
66 13 100 100     124 if ($ref eq 'ARRAY' || $ref eq 'HASH' || ($ref eq 'REF' && ref ${$_[0]} eq 'REF')) {
  10   100     52  
      100        
67 3         8 $printer->{_refcount_base}++;
68             }
69 13         64 my $output = $printer->parse($_[0]);
70 13 50       56 if ($printer->caller_message_position eq 'after') {
71 0         0 $output .= $printer->_write_label;
72             }
73             else {
74 13         43 $output = $printer->_write_label . $output;
75             }
76 13         419 return $output;
77             }
78              
79              
80             sub p (\[@$%&];%) {
81 42     42 1 116554 my (undef, %properties) = @_;
82              
83 42         167 _initialize();
84              
85 42         105 my $caller = caller;
86 42         135 my $args_to_use = _fetch_args_with($caller, \%properties);
87 42         251 my $printer = Data::Printer::Object->new($args_to_use);
88 42         90 my $want_value = defined wantarray;
89 42 0 33     125 if ($printer->colored eq 'auto' && $printer->return_value eq 'dump' && $want_value) {
      33        
90 0         0 $printer->{_output_color_level} = 0;
91             }
92              
93 42         126 my $ref = ref $_[0];
94 42 100 100     268 if ($ref eq 'ARRAY' || $ref eq 'HASH' || ($ref eq 'REF' && ref ${$_[0]} eq 'REF')) {
  17   100     77  
      100        
95 7         19 $printer->{_refcount_base}++;
96             }
97 42         171 my $output = $printer->parse($_[0]);
98 42 50       114 if ($printer->caller_message_position eq 'after') {
99 0         0 $output .= $printer->_write_label;
100             }
101             else {
102 42         119 $output = $printer->_write_label . $output;
103             }
104              
105 42         155 return _handle_output($printer, $output, $want_value, $_[0]);
106             }
107              
108             # This is a p() clone without prototypes. Just like regular Data::Dumper,
109             # this version expects a reference as its first argument. We make a single
110             # exception for when we only get one argument, in which case we ref it
111             # for the user and keep going.
112             sub _p_without_prototypes {
113 4     4   77 my (undef, %properties) = @_;
114              
115 4         6 my $item;
116 4 100 66     17 if (!ref $_[0] && @_ == 1) {
117 1         2 my $item_value = $_[0];
118 1         2 $item = \$item_value;
119             }
120              
121 4         10 _initialize();
122              
123 4         8 my $caller = caller;
124 4         11 my $args_to_use = _fetch_args_with($caller, \%properties);
125 4         19 my $printer = Data::Printer::Object->new($args_to_use);
126              
127 4         7 my $want_value = defined wantarray;
128 4 0 33     11 if ($printer->colored eq 'auto' && $printer->return_value eq 'dump' && $want_value) {
      33        
129 0         0 $printer->{_output_color_level} = 0;
130             }
131              
132 4 100       14 my $ref = ref( defined $item ? $item : $_[0] );
133 4 0 100     30 if ($ref eq 'ARRAY' || $ref eq 'HASH' || ($ref eq 'REF'
    100 33        
      66        
134 0         0 && ref(defined $item ? $item : ${$_[0]}) eq 'REF')) {
135 2         4 $printer->{_refcount_base}++;
136             }
137 4 100       17 my $output = $printer->parse((defined $item ? $item : $_[0]));
138 4 50       9 if ($printer->caller_message_position eq 'after') {
139 0         0 $output .= $printer->_write_label;
140             }
141             else {
142 4         8 $output = $printer->_write_label . $output;
143             }
144              
145 4         13 return _handle_output($printer, $output, $want_value, $_[0]);
146             }
147              
148              
149             sub _handle_output {
150 46     46   126 my ($printer, $output, $wantarray, $data) = @_;
151              
152 46 100 100     118 if ($printer->return_value eq 'pass') {
    100          
153 9         13 print { $printer->{output_handle} } $output . "\n";
  9         480  
154 9         80 require Scalar::Util;
155 9         30 my $ref = Scalar::Util::blessed($data);
156 9 100       47 return $data if defined $ref;
157 8         21 $ref = Scalar::Util::reftype($data);
158 8 50       39 if (!$ref) {
    100          
    100          
    50          
159 0         0 return $data;
160             }
161             elsif ($ref eq 'ARRAY') {
162 2         53 return @$data;
163             }
164             elsif ($ref eq 'HASH') {
165 2         61 return %$data;
166             }
167 12         28 elsif ( grep { $ref eq $_ } qw(REF SCALAR VSTRING) ) {
168 4         92 return $$data;
169             }
170             else {
171 0         0 return $data;
172             }
173             }
174             elsif ($printer->return_value eq 'void' || !$wantarray) {
175 7         10 print { $printer->{output_handle} } $output . "\n";
  7         269  
176 7         297 return;
177             }
178             else {
179 30         959 return $output;
180             }
181             }
182              
183             sub _fetch_args_with {
184 59     59   154 my ($caller, $run_properties) = @_;
185              
186 59         109 my $args_to_use = {};
187 59 50       211 if (keys %$rc_arguments) {
188             $args_to_use = Data::Printer::Config::_merge_options(
189 59         278 $args_to_use, $rc_arguments->{'_'}
190             );
191 59 50       195 if (exists $rc_arguments->{$caller}) {
192             $args_to_use = Data::Printer::Config::_merge_options(
193 0         0 $args_to_use, $rc_arguments->{$caller}
194             );
195             }
196             }
197 59 50       179 if ($arguments_for{$caller}) {
198             $args_to_use = Data::Printer::Config::_merge_options(
199 59         204 $args_to_use, $arguments_for{$caller}
200             );
201             }
202 59 100       188 if (keys %$run_properties) {
203             $run_properties = Data::Printer::Config::_expand_profile($run_properties)
204 14 50       41 if exists $run_properties->{profile};
205 14         32 $args_to_use = Data::Printer::Config::_merge_options(
206             $args_to_use, $run_properties
207             );
208             }
209 59         122 return $args_to_use;
210             }
211              
212              
213             sub _find_option {
214 18     18   39 my ($key, $args, $caller, $default) = @_;
215              
216 18         23 my $value;
217 18 100 33     127 if (exists $args->{$key}) {
    50          
    50          
218 2         4 $value = $args->{$key};
219             }
220             elsif (
221             exists $rc_arguments->{$caller}
222             && exists $rc_arguments->{$caller}{$key}
223             ) {
224 0         0 $value = $rc_arguments->{$caller}{$key};
225             }
226             elsif (exists $rc_arguments->{'_'}{$key}) {
227 0         0 $value = $rc_arguments->{'_'}{$key};
228             }
229             else {
230 16         26 $value = $default;
231             }
232 18         34 return $value;
233             }
234              
235              
236             'Marielle, presente.';
237             __END__