File Coverage

recurse2txt
Criterion Covered Total %
statement 37 72 51.3
branch 19 40 47.5
condition 6 9 66.6
subroutine 6 9 66.6
pod n/a
total 68 130 52.3


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             #
3             # recurse2txt routines
4             #
5             # version 1.08, 12-20-12, michael@bizsystems.com
6             #
7             # 10-3-11 updated to bless into calling package
8             # 10-10-11 add SCALAR ref support
9             # 1.06 12-16-12 add hexDumper
10             # 1.07 12-19-12 added wantarray return of data and elements
11             # 1.08 12-20-12 add wantarray to hexDumper
12             #
13             #use strict;
14             #use diagnostics;
15              
16 7     7   3410 use overload;
  7         15  
  7         46  
17              
18             # generate a unique signature for a particular hash
19             #
20             # Data::Dumper actually does much more than this, however, it
21             # does not stringify hash's in a consistent manner. i.e. no SORT
22             #
23             # The routine below, while not covering recursion loops, non ascii
24             # characters, etc.... does produce text that can be eval'd and is
25             # consistent with each rendering.
26             #
27             sub hexDumper {
28 264 50   264   1672 if (wantarray) {
29 0         0 ($data,$count) = Dumper($_[0]);
30 0         0 $data =~ s/(\b\d+)/sprintf("0x%x",$1)/ge;
  0         0  
31 0         0 return ($data,$count);
32             }
33 264         533 (my $x = Dumper($_[0])) =~ s/(\b\d+)/sprintf("0x%x",$1)/ge;
  1403         5366  
34 264         836 $x;
35             }
36              
37             sub Dumper {
38 277 50   277   665 unless (defined $_[0]) {
39 0 0       0 return ("undef\n",'undef') if wantarray;
40 0         0 return "undef\n";
41             }
42 277         462 my $ref = ref $_[0];
43 277 50       560 return "not a reference\n" unless $ref;
44 277 100 66     1359 unless ($ref eq 'HASH' or $ref eq 'ARRAY' or $ref eq 'SCALAR') {
      66        
45 11         36 ($ref) = (overload::StrVal($_[0]) =~ /^(?:.*\=)?([^=]*)\(/);
46             }
47 277         787 my $p = {
48             depth => 0,
49             elements => 0,
50             };
51 277         1906 (my $pkg = (caller(0))[3]) =~ s/(.+)::Dumper/$1/;
52 277         599 bless $p,$pkg;
53 277         339 my $data;
54 277 50       733 if ($ref eq 'HASH') {
    50          
55 0         0 $data = $p->hash_recurse($_[0],"\n");
56             }
57             elsif ($ref eq 'ARRAY') {
58 277         647 $data = $p->array_recurse($_[0]);
59             } else {
60             # return $ref ." unsupported\n";
61 0         0 $data = $p->scalar_recurse($_[0]);
62             }
63 277         962 $data =~ s/,\n$/;\n/;
64 277 50       631 return ($data,$p->{elements}) if wantarray;
65 277         1824 return $p->{elements} ."\t= ". $data;
66             }
67            
68             # input: pointer to scalar, terminator
69             # returns data
70             #
71             sub scalar_recurse {
72 0     0   0 my($p,$ptr,$n) = @_;
73 0 0       0 $n = '' unless $n;
74 0         0 my $data = "\\";
75 0         0 $data .= _dump($p,$$ptr);
76 0         0 $data .= "\n";
77             }
78              
79             # input: pointer to hash, terminator
80             # returns: data
81             #
82             sub hash_recurse {
83 0     0   0 my($p,$ptr,$n) = @_;
84 0 0       0 $n = '' unless $n;
85 0         0 my $data = "{\n";
86 0         0 foreach my $key (sort keys %$ptr) {
87 0         0 $data .= "\t'". $key ."'\t=> ";
88 0         0 $data .= _dump($p,$ptr->{$key},"\n");
89             }
90 0         0 $data .= '},'.$n;
91             }
92              
93             # generate a unique signature for a particular array
94             #
95             # input: pointer to array, terminator
96             # returns: data
97             sub array_recurse {
98 277     277   417 my($p,$ptr,$n) = @_;
99 277 50       613 $n = '' unless $n;
100 277         373 my $data = '[';
101 277         467 foreach my $item (@$ptr) {
102 1308         2434 $data .= _dump($p,$item);
103             }
104 277         680 $data .= "],\n";
105             }
106              
107             # input: self, item, append
108             # return: data
109             #
110             sub _dump {
111 1308     1308   1786 my($p,$item,$n) = @_;
112 1308         2180 $p->{elements}++;
113 1308 50       2692 $n = '' unless $n;
114 1308         1736 my $ref = ref $item;
115 1308 50       4331 if ($ref eq 'HASH') {
    50          
    50          
    50          
    50          
    50          
    50          
116 0         0 return tabout($p->hash_recurse($item,"\n"));
117             }
118             elsif($ref eq 'ARRAY') {
119 0         0 return $p->array_recurse($item,$n);
120             }
121             elsif($ref eq 'SCALAR') {
122             # return q|\$SCALAR,|.$n;
123 0         0 return($p->scalar_recurse($item,$n));
124             }
125             elsif ($ref eq 'GLOB') {
126 0         0 my $g = *{$item};
  0         0  
127 0         0 return "\\$g" .','.$n;
128             }
129 1308         1674 elsif(do {my $g = \$item; ref $g eq 'GLOB'}) {
  1308         4629  
130 0         0 return "$item" .','.$n;
131             }
132             elsif($ref eq 'CODE') {
133 0         0 return q|sub {'DUMMY'},|.$n;
134             }
135             elsif (defined $item) {
136 1308         2282 return wrap_data($item) .','.$n;
137             }
138             else {
139 0         0 return 'undef,'.$n;
140             }
141             }
142              
143             sub tabout {
144 0     0   0 my @data = split(/\n/,shift);
145 0         0 my $data = shift @data;
146 0         0 $data .= "\n";
147 0         0 foreach(@data) {
148 0         0 $data .= "\t$_\n";
149             }
150 0         0 $data;
151             }
152              
153             sub wrap_data {
154 1308     1308   1699 my $data = shift;
155 1308 100 66     9605 return ($data =~ /\D/ || $data =~ /^$/)
156             ? q|'|. $data .q|'|
157             : $data;
158             }
159              
160             1;