File: | blib/lib/Data/Dumper/EasyOO.pm |
Coverage: | 96.4% |
line | stmt | branch | cond | sub | time | code |
---|---|---|---|---|---|---|
1 | #!perl | |||||
2 | ||||||
3 | package Data::Dumper::EasyOO; | |||||
4 | 22 22 22 | 235 125 126 | use Data::Dumper(); | |||
5 | 22 22 22 | 268 113 312 | use Carp 'carp'; | |||
6 | use strict; | |||||
7 | ||||||
8 | 22 22 22 | 457 123 114 | use 5.005_03; | |||
9 | use vars qw($VERSION); | |||||
10 | $VERSION = '0.05_02'; | |||||
11 | ||||||
12 - 111 | =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); my $gl = { Joe => 'beer', Betsy => 'wine' }); ezdump ( guest_list => $gl); 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 => $gl ); print "\n"; $ezdump->Indent(1); ezdump ( guest_list => $gl ); 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 | |||||
112 | ||||||
113 | ; | |||||
114 | ############## | |||||
115 | # this (private) reference is passed to the closure to recover | |||||
116 | # the underlying Data::Dumper object | |||||
117 | my $magic = []; | |||||
118 | my %cliPrefs; # stores style preferences for each client package | |||||
119 | ||||||
120 | # DD print-style options/methods/package-vars/attributes. | |||||
121 | # Theyre delegated to the inner DD object, and 'importable' too. | |||||
122 | ||||||
123 | my @styleopts; # used to validate methods in Set() | |||||
124 | ||||||
125 | # 5.00503 shipped with DD v2.101 | |||||
126 | @styleopts = qw( indent purity pad varname useqq terse freezer | |||||
127 | toaster deepcopy quotekeys bless ); | |||||
128 | ||||||
129 | push @styleopts, qw( maxdepth ) | |||||
130 | if $Data::Dumper::VERSION ge '2.102'; # with 5.6.1 | |||||
131 | ||||||
132 | push @styleopts, qw( pair useperl sortkeys deparse ) | |||||
133 | if $Data::Dumper::VERSION ge '2.121'; # with 5.6.2 | |||||
134 | ||||||
135 | # DD methods; also delegated | |||||
136 | my @ddmethods = qw ( Seen Values Names Reset ); | |||||
137 | ||||||
138 | # EzDD-specific importable style preferences | |||||
139 | my @okPrefs = qw( autoprint init _ezdd_noreset ); | |||||
140 | ||||||
141 | ############## | |||||
142 | sub import { | |||||
143 | 22 | 1355 | # save EzDD client's preferences for use in new() | |||
144 | 22 | 117 | my ($pkg, @args) = @_; | |||
145 | 22 | 194 | my ($prop, $val, %args); | |||
146 | 22 | 243 | my ($alias, @aliases, @ezdds); | |||
147 | my $caller = caller(); | |||||
148 | ||||||
149 | # handle aliases, multiples allowed (feeping creaturism) | |||||
150 | ||||||
151 | 22 | 512 | foreach my $idx (grep {$args[$_] eq 'alias'} reverse 0..$#args) { | |||
152 | 22 22 22 | 228 213 202 | ($idx, $alias) = splice(@args, $idx, 2); | |||
153 | 22 22 41 | 213 173 373 | no strict 'refs'; | |||
154 | 41 41 41 | 235 241 242 | *{$alias.'::new'} = \&{$pkg.'::new'}; | |||
155 | 41 | 473 | *{$alias.'::import'} = \&{$pkg.'::import'}; | |||
156 | push @aliases, $alias; | |||||
157 | } | |||||
158 | ||||||
159 | 7 | 63 | while ($prop = shift(@args)) { | |||
160 | $val = shift(@args); | |||||
161 | ||||||
162 | 7 | 53 | if (not grep { $_ eq $prop} @styleopts, @okPrefs) { | |||
163 | 7 | 37 | carp "unknown print-style: $prop"; | |||
164 | next; | |||||
165 | } | |||||
166 | 7 | 53 | elsif ($prop ne 'init') { | |||
167 | 7 | 50 | $args{$prop} = $val; | |||
168 | push @ezdds, $val; | |||||
169 | } | |||||
170 | 7 | 52 | else { | |||
171 | carp "init arg must be a ref to a (scalar) variable" | |||||
172 | unless ref($val) =~ /SCALAR/; | |||||
173 | ||||||
174 | carp "wont construct a new EzDD object into non-undef variable" | |||||
175 | if defined $$val; | |||||
176 | ||||||
177 | $$val = Data::Dumper::EasyOO->new(%args); | |||||
178 | } | |||||
179 | 25 | 156 | } | |||
180 | $cliPrefs{$caller} = \%args; # save the allowed ones | |||||
181 | ||||||
182 | # export ezdump() unconditionally | |||||
183 | # no warnings 'redefine'; | |||||
184 | 1 | 8 | local $SIG{__WARN__} = sub { | |||
185 | 475 | 2960 | warn $@, @_ unless $_[0] =~ /ezdump redefined/; | |||
186 | 1 | 17 | }; | |||
187 | 17 17 | 108 232 | no strict 'refs'; | |||
188 | 7 7 | 63 59 | my $ezdump = $pkg->new(%args); | |||
189 | *{$caller.'::ezdump'} = $ezdump; # export ezdump() | |||||
190 | 7 | 65 | ${$caller.'::ezdump'} = $ezdump; # export $ezdump = \&ezdump | |||
191 | ||||||
192 | 41 | 420 | return (1, \%args) if wantarray; | |||
193 | return (\%args) if defined wantarray; | |||||
194 | return; | |||||
195 | ||||||
196 - 214 | =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 | |||||
215 | } | |||||
216 | ||||||
217 | 13 | 121 | sub Set { | |||
218 | 41 | 341 | # sets internal state of private data dumper object | |||
219 | 41 | 219 | my ($ezdd, %cfg) = @_; | |||
220 | my $ddo = $ezdd; | |||||
221 | 41 | 343 | $ddo = $ezdd->($magic) if ref $ezdd eq __PACKAGE__; | |||
222 | ||||||
223 | 41 | 248 | $ddo->{_ezdd_noreset} = 1 if $cfg{_ezdd_noreset}; | |||
224 | ||||||
225 | 41 | 277 | for my $item (keys %cfg) { | |||
226 | 41 | 270 | #print "$item => $cfg{$item}\n"; | |||
227 | my $attr = lc $item; | |||||
228 | 39 8 893 | 512 62 4526 | my $meth = ucfirst $item; | |||
229 | ||||||
230 | if (grep {$attr eq $_} @styleopts) { | |||||
231 | 893 | 6108 | $ddo->$meth($cfg{$item}); | |||
232 | 893 | 8180 | } | |||
233 | elsif (grep {$item eq $_} @ddmethods) { | |||||
234 | $ddo->$meth($cfg{$item}); | |||||
235 | 893 | 6143 | } | |||
236 | elsif (grep {$attr eq $_} @okPrefs) { | |||||
237 | 963 | 6117 | $ddo->{$attr} = $cfg{$item}; | |||
238 | } | |||||
239 | 963 | 5219 | else { carp "illegal method <$item>" } | |||
240 | } | |||||
241 | $ezdd; | |||||
242 | } | |||||
243 | ||||||
244 | 15408 | 95840 | use vars '$AUTOLOAD'; | |||
245 | ||||||
246 | 408 | 2610 | sub AUTOLOAD { | |||
247 | 70 | 547 | my ($ezdd, $arg) = @_; | |||
248 | 96 | 633 | (my $meth = $AUTOLOAD) =~ s/.*:://; | |||
249 | return if $meth eq 'DESTROY'; | |||||
250 | my @vals = $ezdd->Set($meth => $arg); | |||||
251 | return $ezdd unless wantarray; | |||||
252 | 26 | 266 | return $ezdd, @vals; | |||
253 | 6 | 48 | } | |||
254 | ||||||
255 | sub pp { | |||||
256 | my ($ezdd, @data) = @_; | |||||
257 | $ezdd->(@data); | |||||
258 | } | |||||
259 | ||||||
260 | 761 | 4727 | *dump = \&pp; | |||
261 | ||||||
262 | sub _ez_ddo { | |||||
263 | my ($ezdd) = @_; | |||||
264 | return $ezdd->($magic); | |||||
265 | } | |||||
266 | ||||||
267 | 761 | 5109 | my $_privatePrinter; # visible only to new and closure object it makes | |||
268 | ||||||
269 | 693 | 4505 | sub new { | |||
270 | 693 | 7119 | my ($cls, %cfg) = @_; | |||
271 | my $prefs = $cliPrefs{caller()} || {}; | |||||
272 | ||||||
273 | my $ddo = Data::Dumper->new([]); # inner obj w bogus data | |||||
274 | Set($ddo, %$prefs, %cfg); # ctor-params override pkg-config | |||||
275 | ||||||
276 | 1 | 8 | #print "EzDD::new() ", Data::Dumper::Dumper [$prefs, \%cfg]; | |||
277 | ||||||
278 | 8 | 48 | my $code = sub { # closure on $ddo | |||
279 | &$_privatePrinter($ddo, @_); | |||||
280 | 1 | 6 | }; | |||
281 | # copy constructor | |||||
282 | 1 | 7 | bless $code, ref $cls || $cls; | |||
283 | ||||||
284 | 116 | 1193 | if (ref $cls) { | |||
285 | 116 | 1128 | # clone its settings | |||
286 | my $ddo = $cls->($magic); | |||||
287 | 116 | 7181 | my %styles; | |||
288 | @styles{@styleopts,@okPrefs} = @$ddo{@styleopts,@okPrefs}; | |||||
289 | $code->Set(%styles,%cfg); | |||||
290 | } | |||||
291 | return $code; | |||||
292 | } | |||||
293 | ||||||
294 | ||||||
295 | $_privatePrinter = sub { | |||||
296 | my ($ddo, @args) = @_; | |||||
297 | ||||||
298 | unless ($ddo->{_ezdd_noreset}) { | |||||
299 | $ddo->Reset; # clear seen | |||||
300 | $ddo->Names([]); # clear labels | |||||
301 | } | |||||
302 | if (@args == 1) { | |||||
303 | # test for AUTOLOADs special access | |||||
304 | return $ddo if defined $args[0] and $args[0] == $magic; | |||||
305 | ||||||
306 | # else Regular usage | |||||
307 | $ddo->{todump} = \@args; | |||||
308 | } | |||||
309 | elsif (@args % 2) { | |||||
310 | # cant be a hash, must be array of data | |||||
311 | $ddo->{todump} = \@args; | |||||
312 | } | |||||
313 | else { | |||||
314 | # possible labelled usage, | |||||
315 | # check that all 'labels' are scalars | |||||
316 | ||||||
317 | my %rev = reverse @args; | |||||
318 | if (grep {ref $_} values %rev) { | |||||
319 | # odd elements are refs, must print as array | |||||
320 | $ddo->{todump} = \@args; | |||||
321 | } | |||||
322 | else { | |||||
323 | my (@labels,@vals); | |||||
324 | while (@args) { | |||||
325 | push @labels, shift @args; | |||||
326 | push @vals, shift @args; | |||||
327 | } | |||||
328 | $ddo->{names} = \@labels; | |||||
329 | $ddo->{todump} = \@vals; | |||||
330 | } | |||||
331 | } | |||||
332 | PrintIt: | |||||
333 | # return dump-str unless void context | |||||
334 | return $ddo->Dump() if defined wantarray; | |||||
335 | ||||||
336 | my $auto = (defined $ddo->{autoprint}) ? $ddo->{autoprint} : 0; | |||||
337 | ||||||
338 | unless ($auto) { | |||||
339 | carp "called in void context, without autoprint set"; | |||||
340 | return; | |||||
341 | } | |||||
342 | # autoprint to STDOUT, STDERR, or HANDLE (IO or GLOB) | |||||
343 | ||||||
344 | if (ref $auto and (ref $auto eq 'GLOB' or $auto->can("print"))) { | |||||
345 | print $auto $ddo->Dump(); | |||||
346 | } | |||||
347 | elsif ($auto == 1) { | |||||
348 | print STDOUT $ddo->Dump(); | |||||
349 | } | |||||
350 | elsif ($auto == 2) { | |||||
351 | print STDERR $ddo->Dump(); | |||||
352 | } | |||||
353 | else { | |||||
354 | carp "illegal autoprint value: $ddo->{autoprint}"; | |||||
355 | } | |||||
356 | return; | |||||
357 | }; | |||||
358 | ||||||
359 | ||||||
360 | 1; | |||||
361 |