File: | blib/lib/Data/Dumper/EasyOO.pm |
Coverage: | 97.6% |
line | stmt | branch | cond | sub | time | code |
---|---|---|---|---|---|---|
1 | #!perl | |||||
2 | ||||||
3 | package Data::Dumper::EasyOO; | |||||
4 | 17 17 17 | 288 102 99 | use Data::Dumper(); | |||
5 | 17 17 17 | 199 83 192 | use Carp 'carp'; | |||
6 | ||||||
7 | 17 17 17 | 339 85 87 | use 5.005_03; | |||
8 | 17 17 17 | 188 85 250 | use vars qw($VERSION); | |||
9 | $VERSION = '0.05_01'; | |||||
10 | ||||||
11 - 109 | =head1 NAME Data::Dumper::EasyOO - wraps DD for easy use of various printing styles =head1 ABSTRACT EzDD is an object wrapper around Data::Dumper (henceforth just DD), and uses an inner DD object to produce all its output. Its purpose is to make DD's OO capabilities easier to use, ie to make it easy to: 1. label your data meaningfully, not just as $VARx 2. make and reuse EzDD objects 3. customize print styles on any/all of them independently 4. provide essentially all of DD's functionality 5. do so with fewest keystrokes possible =head1 SYNOPSIS 1st, an equivalent to DD's Dumper, which prints exactly like Dumper does use Data::Dumper::EasyOO; print ezdump([1,3]); which prints: $VAR1 = [ 1, 3 ]; Here, we provide our own (meaningful) label, and use autoprinting, and thereby drop the 'print' from all ezdump calls. use Data::Dumper::EasyOO (autoprint => 1); ezdump ( guest_list => { Joe => 'beer', Betsy => 'wine' }); which prints: $guest_list = { 'Joe' => 'beer', 'Betsy' => 'wine' }; And theres much more... =head1 DESCRIPTION EzDD wraps Data::Dumper, and uses an inner DD object to print/dump. By default the output is identical to DD. That said, EzDD gives you a nicer interface, thus encouraging you to tailor DD output the way you like it. A primary design feature of EzDD is that you can choose your preferred printing style in the 'use' statement. EzDD replaces the usual 'import' semantics with the same (property => value) pairs as are available in new(). You can think of the use statement as a way to set new()'s default behavior once, and reuse those styles (or override and supplement them) on EzDD objects you create thereafter. All of DD's style-setting methods are available in EzDD as both properties to new(), and as object methods; its your choice. =head2 An easy use of ezdump() For maximum laziness support, ezdump() is exported into your namespace, and supports the synopsis example. $ezdump is also exported; it is the EzDD object that ezdump() uses to do its dumping, and allows you to tailor ezdump()s print-style. It also lets you use OO style if you prefer. Continuing from 2nd synopsis example... $ezdump->Set(sortkeys=>1); ezdump ( guest_list => { Joe => 'beer', Betsy => 'wine' }); print "\n"; $ezdump->Indent(1); ezdump ( guest_list => { Joe => 'beer', Betsy => 'wine' }); which prints: $guest_list = { 'Betsy' => 'wine', 'Joe' => 'beer' }; $guest_list = { 'Betsy' => 'wine', 'Joe' => 'beer' }; The print-styles are set 2 times; 1st as a property setting, 2nd done like a DD method. The styles accumulate and persist on the object. =cut | |||||
110 | ||||||
111 | ; | |||||
112 | ############## | |||||
113 | # this (private) reference is passed to the closure to recover | |||||
114 | # the underlying Data::Dumper object | |||||
115 | my $magic = []; | |||||
116 | my %cliPrefs; # stores style preferences for each client package | |||||
117 | ||||||
118 | # DD print-style options/methods/package-vars/attributes. | |||||
119 | # Theyre delegated to the inner DD object, and 'importable' too. | |||||
120 | ||||||
121 | my @styleopts; # used to validate methods in Set() | |||||
122 | ||||||
123 | # 5.00503 shipped with DD v2.101 | |||||
124 | @styleopts = qw( indent purity pad varname useqq terse freezer | |||||
125 | toaster deepcopy quotekeys bless ); | |||||
126 | ||||||
127 | push @styleopts, qw( maxdepth ) | |||||
128 | if $Data::Dumper::VERSION ge '2.102'; # with 5.6.1 | |||||
129 | ||||||
130 | push @styleopts, qw( pair useperl sortkeys deparse ) | |||||
131 | if $Data::Dumper::VERSION ge '2.121'; # with 5.6.2 | |||||
132 | ||||||
133 | # DD methods; also delegated | |||||
134 | my @ddmethods = qw ( Seen Values Names Reset ); | |||||
135 | ||||||
136 | # EzDD-specific importable style preferences | |||||
137 | my @okPrefs = qw( autoprint init _ezdd_noreset ); | |||||
138 | ||||||
139 | ############## | |||||
140 | sub import { | |||||
141 | # save EzDD client's preferences for use in new() | |||||
142 | 29 | 299 | my ($pkg, @args) = @_; | |||
143 | 29 | 159 | my ($prop, $val, %args); | |||
144 | 29 | 166 | my (@aliases, @ezdds); | |||
145 | 29 | 167 | my $caller = caller(); | |||
146 | ||||||
147 | # handle aliases, multiples allowed (feeping creaturism) | |||||
148 | ||||||
149 | 29 46 | 327 413 | foreach my $idx (grep {$args[$_] eq 'alias'} reverse 0..$#args) { | |||
150 | 5 | 43 | ($idx, $alias) = splice(@args, $idx, 2); | |||
151 | 17 17 17 | 196 84 176 | no strict 'refs'; | |||
152 | 5 5 5 | 26 49 37 | *{$alias.'::new'} = \&{$pkg.'::new'}; | |||
153 | 5 | 37 | push @aliases, $alias; | |||
154 | } | |||||
155 | ||||||
156 | 29 | 294 | while ($prop = shift(@args)) { | |||
157 | 18 | 100 | $val = shift(@args); | |||
158 | ||||||
159 | 18 342 | 106 2004 | if (not grep { $_ eq $prop} @styleopts, @okPrefs) { | |||
160 | 1 | 10 | carp "unknown print-style: $prop"; | |||
161 | 1 | 18 | next; | |||
162 | } | |||||
163 | elsif ($prop ne 'init') { | |||||
164 | 10 | 61 | $args{$prop} = $val; | |||
165 | 10 | 135 | push @ezdds, $val; | |||
166 | } | |||||
167 | else { | |||||
168 | 7 | 68 | carp "init arg must be a ref to a (scalar) variable" | |||
169 | unless ref($val) =~ /SCALAR/; | |||||
170 | ||||||
171 | 7 | 62 | carp "wont construct a new EzDD object into non-undef variable" | |||
172 | if defined $$val; | |||||
173 | ||||||
174 | 7 | 61 | $$val = Data::Dumper::EasyOO->new(%args); | |||
175 | } | |||||
176 | } | |||||
177 | 29 | 215 | $cliPrefs{$caller} = \%args; # save the allowed ones | |||
178 | ||||||
179 | # export ezdump() unconditionally | |||||
180 | # no warnings 'redefine'; | |||||
181 | local $SIG{__WARN__} = sub { | |||||
182 | 7 | 63 | carp "@_" unless $_[0] =~ /ezdump redefined/; | |||
183 | 29 | 281 | }; | |||
184 | 29 | 227 | my $ezdump = $pkg->new(%args); | |||
185 | 29 29 | 150 245 | *{$caller.'::ezdump'} = $ezdump; # export ezdump() | |||
186 | 29 29 | 198 194 | ${$caller.'::ezdump'} = $ezdump; # export $ezdump = \&ezdump | |||
187 | ||||||
188 | 29 | 212 | return; | |||
189 | ||||||
190 - 208 | =for consideration # rest is EXPERIMENTAL, and incomplete, and broken # Im not sure I like it anyway, even if it did work if (@aliases) { # && not @ezdds) { # create default objects into the aliases foreach my $alias (@aliases) { my $x = $pkg->new(); # create the alias in caller pkg ${$caller.'::'.$alias} = $x; # this breaks aliasPkg->new() calls # *{$caller.'::'.$alias} = \&$x; } } =cut | |||||
209 | } | |||||
210 | ||||||
211 | sub Set { | |||||
212 | # sets internal state of private data dumper object | |||||
213 | 868 | 6240 | my ($ezdd, %cfg) = @_; | |||
214 | 868 | 4373 | my $ddo = $ezdd; | |||
215 | 868 | 7812 | $ddo = $ezdd->($magic) if ref $ezdd eq __PACKAGE__; | |||
216 | ||||||
217 | 868 | 6120 | $ddo->{_ezdd_noreset} = 1 if $cfg{_ezdd_noreset}; | |||
218 | ||||||
219 | 868 | 5938 | for my $item (keys %cfg) { | |||
220 | #print "$item => $cfg{$item}\n"; | |||||
221 | 950 | 5952 | my $attr = lc $item; | |||
222 | 950 | 5151 | my $meth = ucfirst $item; | |||
223 | ||||||
224 | 950 15200 400 | 5076 90013 2511 | if (grep {$attr eq $_} @styleopts) { | |||
225 | 850 | 6678 | $ddo->$meth($cfg{$item}); | |||
226 | } | |||||
227 | 90 | 574 | elsif (grep {$item eq $_} @ddmethods) { | |||
228 | 70 | 543 | $ddo->$meth($cfg{$item}); | |||
229 | } | |||||
230 | elsif (grep {$attr eq $_} @okPrefs) { | |||||
231 | 24 | 243 | $ddo->{$attr} = $cfg{$item}; | |||
232 | } | |||||
233 | 6 | 48 | else { carp "illegal method <$item>" } | |||
234 | } | |||||
235 | 868 | 6974 | $ezdd; | |||
236 | } | |||||
237 | ||||||
238 | sub AUTOLOAD { | |||||
239 | 748 | 4612 | my ($ezdd, $arg) = @_; | |||
240 | 748 | 5794 | (my $meth = $AUTOLOAD) =~ s/.*:://; | |||
241 | 748 | 4832 | return if $meth eq 'DESTROY'; | |||
242 | 693 | 4410 | my @vals = $ezdd->Set($meth => $arg); | |||
243 | 693 | 7022 | return $ezdd unless wantarray; | |||
244 | 1 | 8 | return $ezdd, @vals; | |||
245 | } | |||||
246 | ||||||
247 | sub pp { | |||||
248 | 8 | 51 | my ($ezdd, @data) = @_; | |||
249 | 8 | 50 | $ezdd->(@data); | |||
250 | } | |||||
251 | ||||||
252 | *dump = \&pp; | |||||
253 | ||||||
254 | my $_privatePrinter; # visible only to new and closure object it makes | |||||
255 | ||||||
256 | sub new { | |||||
257 | 92 | 1650 | my ($cls, %cfg) = @_; | |||
258 | 92 | 1004 | my $prefs = $cliPrefs{caller()} || {}; | |||
259 | ||||||
260 | 92 | 771 | my $ddo = Data::Dumper->new([]); # inner obj w bogus data | |||
261 | 92 | 4618 | Set($ddo, %$prefs, %cfg); # ctor-params override pkg-config | |||
262 | ||||||
263 | #print "EzDD::new() ", Data::Dumper::Dumper [$prefs, \%cfg]; | |||||
264 | ||||||
265 | my $code = sub { # closure on $ddo | |||||
266 | 1145 | 8677 | &$_privatePrinter($ddo, @_); | |||
267 | 92 | 1048 | }; | |||
268 | # copy constructor | |||||
269 | 92 | 1421 | bless $code, ref $cls || $cls; | |||
270 | ||||||
271 | 92 | 593 | if (ref $cls) { | |||
272 | # clone its settings | |||||
273 | 3 | 19 | my $ddo = $cls->($magic); | |||
274 | 3 | 15 | my %styles; | |||
275 | 3 | 84 | @styles{@styleopts,@okPrefs} = @$ddo{@styleopts,@okPrefs}; | |||
276 | 3 | 43 | $code->Set(%styles,%cfg); | |||
277 | } | |||||
278 | 92 | 670 | return $code; | |||
279 | } | |||||
280 | ||||||
281 | ||||||
282 | $_privatePrinter = sub { | |||||
283 | my ($ddo, @args) = @_; | |||||
284 | ||||||
285 | unless ($ddo->{_ezdd_noreset}) { | |||||
286 | $ddo->Reset; # clear seen | |||||
287 | $ddo->Names([]); # clear labels | |||||
288 | } | |||||
289 | if (@args == 1) { | |||||
290 | # test for AUTOLOADs special access | |||||
291 | return $ddo if defined $args[0] and $args[0] eq $magic; | |||||
292 | ||||||
293 | # else Regular usage | |||||
294 | $ddo->{todump} = \@args; | |||||
295 | #goto PrintIt; | |||||
296 | } | |||||
297 | # else | |||||
298 | elsif (@args % 2) { | |||||
299 | # cant be a hash, must be array of data | |||||
300 | $ddo->{todump} = \@args; | |||||
301 | #goto PrintIt; | |||||
302 | } | |||||
303 | else { | |||||
304 | # possible labelled usage, | |||||
305 | # check that all 'labels' are scalars | |||||
306 | ||||||
307 | my %rev = reverse @args; | |||||
308 | if (grep {ref $_} values %rev) { | |||||
309 | # odd elements are refs, must print as array | |||||
310 | $ddo->{todump} = \@args; | |||||
311 | goto PrintIt; | |||||
312 | } | |||||
313 | else { | |||||
314 | my (@labels,@vals); | |||||
315 | while (@args) { | |||||
316 | push @labels, shift @args; | |||||
317 | push @vals, shift @args; | |||||
318 | } | |||||
319 | $ddo->{names} = \@labels; | |||||
320 | $ddo->{todump} = \@vals; | |||||
321 | } | |||||
322 | #goto PrintIt; | |||||
323 | } | |||||
324 | PrintIt: | |||||
325 | # return dump-str unless void context | |||||
326 | return $ddo->Dump() if defined wantarray; | |||||
327 | ||||||
328 | my $auto = (defined $ddo->{autoprint}) ? $ddo->{autoprint} : 0; | |||||
329 | ||||||
330 | unless ($auto) { | |||||
331 | carp "called in void context, without autoprint set"; | |||||
332 | return; | |||||
333 | } | |||||
334 | # autoprint to STDOUT, STDERR, or HANDLE (IO or GLOB) | |||||
335 | ||||||
336 | if (ref $auto and (ref $auto eq 'GLOB' or $auto->can("print"))) { | |||||
337 | print $auto $ddo->Dump(); | |||||
338 | } | |||||
339 | elsif ($auto == 1) { | |||||
340 | print STDOUT $ddo->Dump(); | |||||
341 | } | |||||
342 | elsif ($auto == 2) { | |||||
343 | print STDERR $ddo->Dump(); | |||||
344 | } | |||||
345 | else { | |||||
346 | carp "illegal autoprint value: $ddo->{autoprint}"; | |||||
347 | } | |||||
348 | return; | |||||
349 | }; | |||||
350 | ||||||
351 | ||||||
352 | 1; | |||||
353 |