File Coverage

blib/lib/CGI/Carp/DebugScreen/Dumper.pm
Criterion Covered Total %
statement 56 58 96.5
branch 31 38 81.5
condition 5 9 55.5
subroutine 6 6 100.0
pod 2 2 100.0
total 100 113 88.5


line stmt bran cond sub pod time code
1             package CGI::Carp::DebugScreen::Dumper;
2            
3 3     3   28759 use strict;
  3         8  
  3         125  
4 3     3   18 use warnings;
  3         6  
  3         2644  
5            
6             our $VERSION = '0.15';
7            
8             my $IgnoreOverload;
9            
10 6     6 1 11 sub ignore_overload { shift; $IgnoreOverload = shift; }
  6         18  
11            
12             sub dump {
13 22     22 1 5031 my ($pkg, $thingy) = @_;
14            
15 22         54 return _dump($thingy);
16             }
17            
18             sub _dump {
19 31     31   46 my $thingy = shift;
20            
21 31         40 my $res = '';
22            
23 31 50       73 require overload if $IgnoreOverload;
24            
25 31 100       204 if (!defined $thingy) {
    100          
    100          
    100          
    100          
    100          
    100          
26 1         2 $res .= 'undef';
27             }
28             elsif (ref $thingy eq 'HASH') {
29 3 100       4 if (%{ $thingy }) {
  3         8  
30 2         4 $res = qq{\n}; \n};
31 2         2 foreach my $key (sort {$a cmp $b} keys %{ $thingy }) {
  0         0  
  2         10  
32 2         14 $res .= q{
}._escape($key).q{}._dump($thingy->{$key}).qq{
33             }
34 2         6 $res .= qq{
\n};
35             }
36             else {
37 1         3 $res .= '*EMPTY_HASH*';
38             }
39             }
40             elsif (ref $thingy eq 'ARRAY') {
41 3 100       4 if (@{ $thingy }) {
  3         10  
42 2         4 $res .= join ', ', map { _dump($_) } @{ $thingy };
  4         17  
  2         4  
43             }
44             else {
45 1         3 $res .= '*EMPTY_ARRAY*';
46             }
47             }
48             elsif (ref $thingy eq 'SCALAR') {
49 1         2 $res .= _escape(${ $thingy });
  1         3  
50             }
51             elsif (ref $thingy eq 'CODE') {
52 2         5 $res .= '*CODE*';
53             }
54             elsif (ref $thingy eq 'GLOB') {
55 1         2 $res .= '*GLOB*';
56             }
57             elsif (my $name = ref $thingy) {
58 3         3 my $blessed;
59 3 50       8 my $strval = $IgnoreOverload ? overload::StrVal($thingy) : '';
60 3 100 66     54 if ($thingy =~ /=HASH/ or $strval =~ /=HASH/) {
    100 66        
    50 33        
    0          
61 1         2 my %hash = %{ $thingy };
  1         4  
62 1         2 $blessed = \%hash;
63             }
64             elsif ($thingy =~ /=ARRAY/ or $strval =~ /=ARRAY/) {
65 1         2 my @array = @{ $thingy };
  1         3  
66 1         4 $blessed = \@array;
67             }
68             elsif ($thingy =~ /=SCALAR/ or $strval =~ /=SCALAR/) {
69 1         2 $blessed = $$thingy;
70             }
71             elsif ($name eq 'REF') {
72 0         0 $blessed = $$thingy;
73             }
74            
75 3         8 $res .= qq{\n}; \n};
76 3 50       7 $res .= q{
}._escape($name).q{ (blessed)}.($blessed ? _dump($blessed) : _escape($thingy)).qq{
77 3         8 $res .= qq{
\n};
78             }
79             else {
80 17         41 $res .= _escape($thingy);
81             }
82 31         134 return $res;
83             }
84            
85             sub _escape {
86 23     23   32 my $str = shift;
87            
88 23 50       51 return 'undef' unless defined $str;
89 23 100       74 return '*BINARY*' if $str =~ /[\x00-\x08\x0b\x0c\x0e-\x1f]/;
90            
91 22         39 $str =~ s/&/&/g;
92 22         27 $str =~ s/"/"/g;
93 22         32 $str =~ s/>/>/g;
94 22         28 $str =~ s/
95            
96 22 100       84 $str eq '' ? '*BLANK*' : $str;
97             }
98            
99             1;
100            
101             __END__