1#!/usr/bin/perl 2# 3# recurse2txt routines 4# 5# version 1.10, 5-24-13, 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# 1.09 5-18-13 add my (data,count) 13# 1.10 5-24-13 add pod and support for blessed objects 14# 15#use strict; 16#use diagnostics; 17 18use overload; 19 20=head1 $ref to text - similar to Data::Dumper 21 22recurse2txt generates a unique signature for a particular hash 23 24Data::Dumper actually does much more than this, however, it 25does not stringify hash's in a consistent manner. i.e. no SORT 26 27The routines below, while not covering recursion loops, non ascii 28characters, etc.... does produce text that can be eval'd and is 29consistent with each rendering. 30 31=item * hexDumper($ref); 32 33 same as: 34 scalar hexDumperA(ref); 35 36=item * hexDumperA($ref); 37 38Returns the text of the data items converted to hex. 39 40 input: reference 41 return: array context 42 text_for_reference_contents, 43 count_of_data_items 44 45 scalar context 46 count text_for_reference_contents 47 48=cut 49 50# 51sub hexDumper { 52 return scalar &hexDumperA; 53} 54 55sub hexDumperA { 56 if (wantarray) { 57 my ($data,$count) = Dumper($_[0]); 58 $data =~ s/(\b\d+)/sprintf("0x%x",$1)/ge; 59 return ($data,$count); 60 } 61 (my $x = Dumper($_[0])) =~ s/(\b\d+)/sprintf("0x%x",$1)/ge; 62 $x; 63} 64 65=item * Dumper($ref); 66 67 same as: 68 scalar DumperA($ref); 69 70=item * DumperA($ref); 71 72 input: reference 73 return: array context 74 text_for_reference_contents, 75 count_of_data_items 76 77 scalar context 78 count text_for_reference_contents 79 80=cut 81 82# input: potential reference 83# return: ref type or '', 84# blessing if blessed 85 86sub __getref { 87 return ('') unless (my $class = ref($_[0])); 88 if ($class =~ /(HASH|ARRAY|SCALAR|CODE|GLOB)/) { 89 return ($1,''); 90 } 91 my($ref) = (overload::StrVal($_[0]) =~ /^(?:.*\=)?([^=]*)\(/); 92 return ($ref,$class); 93} 94 95sub Dumper { 96 return scalar &DumperA; 97} 98 99sub DumperA { 100 unless (defined $_[0]) { 101 return ("undef\n",'undef') if wantarray; 102 return "undef\n"; 103 } 104# my $ref = ref $_[0]; 105# return "not a reference\n" unless $ref; 106# unless ($ref eq 'HASH' or $ref eq 'ARRAY' or $ref eq 'SCALAR') { 107# ($ref) = (overload::StrVal($_[0]) =~ /^(?:.*\=)?([^=]*)\(/); 108# } 109 my($ref,$class) = &__getref; 110 return "not a reference\n" unless $ref; 111 my $p = { 112 depth => 0, 113 elements => 0, 114 }; 115 (my $pkg = (caller(0))[3]) =~ s/(.+)::DumperA/$1/; 116 bless $p,$pkg; 117 my $data; 118 if ($ref eq 'HASH') { 119 $data = $p->hash_recurse($_[0],"\n",$class); 120 } 121 elsif ($ref eq 'ARRAY') { 122 $data = $p->array_recurse($_[0],'',$class); 123 } else { 124# return $ref ." unsupported\n"; 125 $data = $p->scalar_recurse($_[0],'',$class); 126 } 127 $data =~ s/,\n$/;\n/; 128 return ($data,$p->{elements}) if wantarray; 129 return $p->{elements} ."\t= ". $data; 130} 131 132# input: pointer to scalar, terminator 133# returns data 134# 135sub scalar_recurse { 136 my($p,$ptr,$n,$bls) = @_; 137 $n = '' unless $n; 138 my $data = $bls ? 'bless ' : ''; 139 $data .= "\\"; 140 $data .= _dump($p,$$ptr); 141 $data .= " '". $bls ."'," if $bls; 142 $data .= "\n"; 143} 144 145# input: pointer to hash, terminator 146# returns: data 147# 148sub hash_recurse { 149 my($p,$ptr,$n,$bls) = @_; 150 $n = '' unless $n; 151 my $data = $bls ? 'bless ' : ''; 152 $data .= "{\n"; 153 foreach my $key (sort keys %$ptr) { 154 $data .= "\t'". $key ."'\t=> "; 155 $data .= _dump($p,$ptr->{$key},"\n"); 156 } 157 $data .= '},'; 158 $data .= " '". $bls ."'," if $bls; 159 $data .= $n; 160} 161 162# generate a unique signature for a particular array 163# 164# input: pointer to array, terminator 165# returns: data 166sub array_recurse { 167 my($p,$ptr,$n,$bls) = @_; 168 $n = '' unless $n; 169 my $data = $bls ? 'bless ' : ''; 170 $data .= '['; 171 foreach my $item (@$ptr) { 172 $data .= _dump($p,$item); 173 } 174 $data .= "],"; 175 $data .= " '". $bls ."'," if $bls; 176 $data .= "\n"; 177} 178 179# input: self, item, append 180# return: data 181# 182sub _dump { 183 my($p,$item,$n) = @_; 184 $p->{elements}++; 185 $n = '' unless $n; 186 my($ref,$class) = __getref($item); 187 if ($ref eq 'HASH') { 188 return tabout($p->hash_recurse($item,"\n",$class)); 189 } 190 elsif($ref eq 'ARRAY') { 191 return $p->array_recurse($item,$n,$class); 192 } 193 elsif($ref eq 'SCALAR') { 194 # return q|\$SCALAR,|.$n; 195 return($p->scalar_recurse($item,$n,$class)); 196 } 197 elsif ($ref eq 'GLOB') { 198 my $g = *{$item}; 199 return "\\$g" .','.$n; 200 } 201 elsif(do {my $g = \$item; ref $g eq 'GLOB'}) { 202 return "$item" .','.$n; 203 } 204 elsif($ref eq 'CODE') { 205 return q|sub {'DUMMY'},|.$n; 206 } 207 elsif (defined $item) { 208 return wrap_data($item) .','.$n; 209 } 210 else { 211 return 'undef,'.$n; 212 } 213} 214 215sub tabout { 216 my @data = split(/\n/,shift); 217 my $data = shift @data; 218 $data .= "\n"; 219 foreach(@data) { 220 $data .= "\t$_\n"; 221 } 222 $data; 223} 224 225sub wrap_data { 226 my $data = shift; 227 if ($data =~ /^$/) { 228 return ''; 229 } elsif ($data =~ /\D/) { 230 $data =~ s/'/\\'/g; 231 return q|'|. $data .q|'|; 232 } 233 $data; 234} 235 236sub xx { 237 return ($data =~ /\D/ || $data =~ /^$/) 238 ? q|'|. $data .q|'| 239 : $data; 240} 241 2421; 243