File Coverage

blib/lib/Devel/Dumpvar.pm
Criterion Covered Total %
statement 112 137 81.7
branch 44 70 62.8
condition 3 12 25.0
subroutine 18 20 90.0
pod 3 3 100.0
total 180 242 74.3


line stmt bran cond sub pod time code
1             package Devel::Dumpvar;
2              
3             # Devel::Dumpvar is a pure-OO re-implementation of the dumpvar.pl
4             # script used with the perl debugger.
5             # This module accepts that this will be slower than the original,
6             # but is designed to be easier to use, more accessible, and more
7             # upgradable without upgrading perl itself.
8              
9 2     2   27036 use 5.006;
  2         8  
  2         88  
10 2     2   10 use strict;
  2         4  
  2         81  
11 2     2   23 use Scalar::Util 1.18 ();
  2         48  
  2         43  
12              
13 2     2   9 use vars qw{$VERSION};
  2         4  
  2         147  
14             BEGIN {
15 2     2   4539 $VERSION = '1.06';
16             }
17              
18              
19              
20              
21              
22             #####################################################################
23             # Constructor and Accessors
24              
25             sub new {
26 2     2 1 22 my $class = shift;
27 2         5 my %options = @_;
28              
29             # Create the basic object
30 2         6 my $self = bless {}, $class;
31              
32             # Handle the various options
33 2 50       7 if ( defined $options{to} ) {
34 2         6 $self->to( $options{to} );
35             }
36              
37 2         6 $self;
38             }
39              
40             sub to {
41 2     2 1 3 my $self = shift;
42              
43             # Just return if no argument
44 2 50       5 return $self->{to} unless @_;
45              
46             # If passed undef, print to STDOUT
47 2         2 my $to = shift;
48 2 50       9 unless ( defined $to ) {
49 0         0 delete $self->{to};
50 0         0 delete $self->{return};
51 0         0 return 1;
52             }
53              
54             # Is it something we can print to
55 2 50 33     11 if ( Scalar::Util::blessed($to) and $to->can('print') ) {
56 0         0 $self->{to} = $to;
57 0         0 return 1;
58             }
59              
60             # Handle the magic 'return' option
61 2 50 33     11 if ( ! ref $to and $to eq 'return' ) {
62 2         9 $self->{to} = 'return';
63 2         4 return 1;
64             }
65              
66             # Unknown option
67 0         0 die "Unknown value '$to' for 'to' options";
68             }
69              
70              
71              
72              
73              
74             #####################################################################
75             # Dumping Methods
76              
77             # Single method dumping
78             sub dump {
79 9 50   9 1 1440 my $self = ref $_[0] ? shift : shift->new;
80              
81             # Set up for dumping
82 9         16 $self->{indent} = '';
83 9         14 $self->{seen} = {};
84 9 50       19 $self->{return} = '' if $self->_return;
85              
86 9 100       18 if ( @_ ) {
87             # Hand off to the array dumper
88 8         22 $self->_dump_array( [ @_ ] );
89             } else {
90             # Shortcut the "no arguments" case
91 1         4 $self->_print( " empty array");
92             }
93              
94             # Clean up and return the data if needed
95 9         18 delete $self->{indent};
96 9         20 delete $self->{seen};
97 9 50       16 $self->_return ? delete $self->{return} : 1;
98             }
99              
100             sub _dump_scalar {
101 9     9   8 my $self = shift;
102 9         9 my $value = shift;
103              
104             # Print the printable form of the scalar
105 9         18 $self->_print( "$self->{indent}-> " . $self->_scalar($$value) );
106             }
107              
108             sub _dump_ref {
109 3     3   4 my $self = shift;
110 3         4 my $value = ${shift()};
  3         4  
111              
112             # Print the current line
113 3         8 $self->_print( "$self->{indent}-> " . $self->_refstring($value) );
114              
115             # Decend to the child reference
116 3         7 $self->_dump_child( $value );
117             }
118              
119             sub _dump_array {
120 15     15   16 my $self = shift;
121 15         13 my $array_ref = shift;
122              
123             # Handle the null array
124 15 100       42 unless ( @$array_ref ) {
125 1         4 return $self->_print( $self->{indent} . " empty array" );
126             }
127              
128 14         33 for ( my $i = 0; $i <= $#$array_ref; $i++ ) {
129 38         46 my $value = $array_ref->[$i];
130              
131             # Handle scalar values
132 38 100       63 unless ( ref $value ) {
133             # Get the printable form of the scalar
134 28         72 $self->_print( "$self->{indent}$i " . $self->_scalar($value) );
135 28         85 next;
136             }
137              
138             # Print the array line
139 10         30 $self->_print( "$self->{indent}$i " . $self->_refstring($value) );
140              
141             # Descend to the child
142 10         27 $self->_dump_child( $value );
143             }
144             }
145              
146             sub _dump_hash {
147 4     4   4 my $self = shift;
148 4         3 my $hash_ref = shift;
149              
150 4         21 foreach my $key ( sort keys %$hash_ref ) {
151 18         23 my $value = $hash_ref->{$key};
152              
153             # Handle scalar values
154 18 100       30 unless ( ref $value ) {
155             # Get the printable form of the scalar
156 6         14 $self->_print( "$self->{indent}$key => " . $self->_scalar($value) );
157 6         14 next;
158             }
159              
160             # Print the array line
161 12         28 $self->_print( "$self->{indent}$key => " . $self->_refstring($value) );
162              
163             # Decent to the child
164 12         20 $self->_dump_child( $value );
165             }
166             }
167              
168             sub _dump_code {
169 0     0   0 my $self = shift;
170 0         0 $self->_print( "$self->{indent}-> Sub detail listing unsupported" );
171             }
172              
173             sub _dump_child {
174 25     25   22 my $self = shift;
175 25 50       45 my $value = ref $_[0] ? shift
176             : die "Bad argument to _dump_child";
177              
178             # Regexp are a special case, they are immune
179             # from the normal re-used address rules
180 25 50       46 if ( ref $value eq 'Regexp' ) {
181             # Print the pointer to the regexp
182 0         0 return $self->_print( "$self->{indent} -> qr/$value/" );
183             }
184              
185             # Handle re-used addresses
186 25         38 my $addr = Scalar::Util::refaddr $value;
187 25 100       74 if ( $self->{seen}->{$addr}++ ) {
188             # We've already seen this before
189 2         5 return $self->_print( "$self->{indent} -> REUSED_ADDRESS" );
190             }
191              
192             # Indent to descend
193 23         27 $self->{indent} .= ' ';
194              
195             # Split by type for the remaining items
196 23         40 my $type = Scalar::Util::reftype $value;
197 23 100       57 if ( $type eq 'REF' ) {
    100          
    100          
    50          
    0          
198 3         6 $self->_dump_ref( $value );
199             } elsif ( $type eq 'SCALAR' ) {
200 9         15 $self->_dump_scalar( $value );
201             } elsif ( $type eq 'ARRAY' ) {
202 7         18 $self->_dump_array( $value );
203             } elsif ( $type eq 'HASH' ) {
204 4         10 $self->_dump_hash( $value );
205             } elsif ( $type eq 'CODE' ) {
206 0         0 $self->_dump_code( $value );
207             } else {
208 0         0 warn "ARRAY -> $type not supported";
209             }
210              
211             # Remove indent
212 23         105 $self->{indent} =~ s/ $//;
213             }
214              
215              
216              
217              
218              
219             #####################################################################
220             # Support Methods
221              
222             # Get the display string for a scalar value
223             sub _scalar {
224 43     43   40 my $self = shift;
225 43         41 my $v = shift;
226              
227             # Shortcuts
228 43 100       75 return 'undef' unless defined $v;
229 41 50       63 return "''" unless length $v;
230              
231             # Is it a number?
232 41 100       90 if ( Scalar::Util::looks_like_number($v) ) {
233             # Show as-is
234 28         106 return $v;
235             }
236              
237             # Auto-detect the tick to use
238 13         15 my $tick = "'";
239 13         12 if ( ord('A') == 193 ) {
240             if ( $v =~ /[\000-\011]/ or $v =~ /[\013-\024\31-\037\177]/ ) {
241             $tick = '"';
242             } else {
243             $tick = "'";
244             }
245             } else {
246 13 50       24 if ( $v =~ /[\000-\011\013-\037\177]/ ) {
247 0         0 $tick = '"';
248             } else {
249 13         16 $tick = "'";
250             }
251             }
252              
253             # Tick-specific escaping
254 13 50       18 if ( $tick eq "'" ) {
255 13         17 $v =~ s/([\'\\])/\\$1/g;
256             } else {
257 0         0 $v =~ s/([\"\\\$\@])/\\$1/g;
258 0         0 $v =~ s/\033/\\e/g;
259 0         0 if ( ord('A') == 193 ) { # EBCDIC.
260             $v =~ s/([\000-\037\177])/'\\c'.chr(193)/eg; # Unfinished.
261             } else {
262 0         0 $v =~ s/([\000-\037\177])/'\\c'._scalar_ord($1)/eg;
  0         0  
263             }
264             }
265              
266             # Unicode and high-bit escaping
267 13         22 $v = _scalar_unicode($v);
268 13         23 $v =~ s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg;
  0         0  
269              
270 13         41 return "${tick}${v}${tick}";
271             }
272              
273             sub _scalar_ord {
274 0     0   0 my $chr = shift;
275 0         0 $chr = chr(ord($chr)^64);
276 0         0 $chr =~ s{\\}{\\\\}g;
277 0         0 return $chr;
278             }
279              
280             sub _scalar_unicode {
281 61 50       127 join( "",
282 13     13   41 map { $_ > 255 ? sprintf("\\x{%04X}", $_) : chr($_) }
283             unpack("U*", $_[0]));
284             }
285              
286             sub _refstring {
287 25     25   546 my $self = shift;
288 25 50       42 my $value = ref $_[0] ? shift
289             : die "Bad argument to _refstring";
290              
291             # Handle regexp
292 25 50       49 if ( ref $value eq 'Regexp' ) {
293 0         0 return "$value";
294             }
295              
296 25         68 my $addr = sprintf '0x%x', Scalar::Util::refaddr($value);
297 25         48 my $type = Scalar::Util::reftype($value);
298 25 50       85 unless ( $type =~ /^(?:SCALAR|ARRAY|HASH|REF|CODE)$/ ) {
299 0         0 return "UNSUPPORTED($addr)";
300             }
301 25         43 my $class = Scalar::Util::blessed($value);
302 25 100       150 defined $class
303             ? "$class=$type($addr)"
304             : "$type($addr)";
305             }
306              
307             sub _print {
308 72     72   74 my $self = shift;
309 72 50       125 my $line = defined $_[0] ? "$_[0]\n" : "\n";
310              
311             # Handle the default case
312 72 50       124 return print $line unless $self->{to};
313              
314 72 50 0     105 if ( $self->{to} eq 'return' ) {
    0          
315             # Handle the "return data" case
316 72         113 $self->{return} .= $line;
317              
318             } elsif ( Scalar::Util::blessed($self->{to}) and $self->{to}->can('print') ) {
319             # If we have a we something we can print to, do so
320 0         0 $self->{to}->print( $line );
321              
322             } else {
323             # If the dump target is unknown, do nothing
324             }
325              
326 72         84 1;
327             }
328              
329             # Are we returning the dump data
330             sub _return {
331 18     18   20 my $self = shift;
332 18 50 33     166 defined $self->{to} and ! ref $self->{to} and $self->{to} eq 'return';
333             }
334              
335             1;
336              
337             __END__