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