File: | blib/lib/Data/Dumper/EasyOO.pm |
Coverage: | 99.1% |
line | stmt | branch | cond | sub | time | code |
---|---|---|---|---|---|---|
1 | #!perl | |||||
2 | ||||||
3 | package Data::Dumper::EasyOO; | |||||
4 | 16 16 16 | 260 100 109 | use Data::Dumper(); | |||
5 | 16 16 16 | 197 95 1121 | use Carp 'carp'; | |||
6 | ||||||
7 | 16 16 16 | 312 83 81 | use 5.005_03; | |||
8 | 16 16 16 | 174 82 254 | use vars qw($VERSION); | |||
9 | $VERSION = '0.04'; | |||||
10 | ||||||
11 - 62 | =head1 NAME Data::Dumper::EasyOO - wraps DD for easy use of various printing styles =head1 ABSTRACT EzDD is an object wrapper upon Data::Dumper (henceforth just DD), and uses an inner DD object to produce all its output. Its purpose is to provide shiny new interface that makes it B<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 my $ezdd; # declare a default object (optional) use Data::Dumper::EasyOO ( alias => EzDD, # a temporary top-level-name alias # set some print-style defaults indent => 1, # change DD's default from 2 sortkeys => 1, # a personal favorite # autoconstruct a printer obj (calls EzDD->new) with the defaults init => \$ezdd, # var must be undef b4 use # set some more default print-styles terse => 1, # change DD's default of 0 autoprint => $fh, # prints to $fh when you $ezdd->(\%something); # autoconstruct a 2nd printer object, using current print-styles init => \our $ez2, # var must be undef b4 use ); $ezdd->(p1 => $person); # print as '$p1 => ...' my $foo = EzDD->new(%style) # create a printer, via alias, w new style ->(there => $place); # and print with it too. $ez2-> (p2 => $person); # dump w $ez2, use its style $foo->(here => $where); # dump w $foo style (use 2 w/o interference) $foo->Set(%morestyle); # change style at runtime $foo->($_) foreach @things; # print many things =cut | |||||
63 | ||||||
64 | ; | |||||
65 | ############## | |||||
66 | # this (private) reference is passed to the closure to recover | |||||
67 | # the underlying Data::Dumper object | |||||
68 | my $magic = []; | |||||
69 | my %cliPrefs; # stores style preferences for each client package | |||||
70 | ||||||
71 | # DD print-style options/methods/package-vars/attributes. | |||||
72 | # Theyre delegated to the inner DD object, and 'importable' too. | |||||
73 | ||||||
74 | my @styleopts; # used to validate methods in Set() | |||||
75 | ||||||
76 | # 5.00503 shipped with DD v2.101 | |||||
77 | @styleopts = qw( indent purity pad varname useqq terse freezer | |||||
78 | toaster deepcopy quotekeys bless ); | |||||
79 | ||||||
80 | push @styleopts, qw( maxdepth ) | |||||
81 | if $Data::Dumper::VERSION ge '2.102'; # with 5.6.1 | |||||
82 | ||||||
83 | push @styleopts, qw( pair useperl sortkeys deparse ) | |||||
84 | if $Data::Dumper::VERSION ge '2.121'; # with 5.6.2 | |||||
85 | ||||||
86 | # DD methods; also delegated | |||||
87 | my @ddmethods = qw ( Seen Values Names Reset ); | |||||
88 | ||||||
89 | # EzDD-specific importable style preferences | |||||
90 | my @okPrefs = qw( autoprint init _ezdd_noreset ); | |||||
91 | ||||||
92 | ############## | |||||
93 | sub import { | |||||
94 | # save EzDD client's preferences for use in new() | |||||
95 | 27 | 286 | my ($pkg, @args) = @_; | |||
96 | 27 | 157 | my ($prop, $val, %args); | |||
97 | ||||||
98 | # handle aliases, multiples allowed (feeping creaturism) | |||||
99 | ||||||
100 | 27 44 | 306 338 | foreach my $idx (grep {$args[$_] eq 'alias'} reverse 0..$#args) { | |||
101 | 5 | 42 | ($idx, $alias) = splice(@args, $idx, 2); | |||
102 | 16 16 16 | 185 85 175 | no strict 'refs'; | |||
103 | #*{$alias.'::'} = *{$pkg.'::'}; | |||||
104 | 5 5 5 | 28 58 38 | *{$alias.'::new'} = *{$pkg.'::new'}; | |||
105 | } | |||||
106 | ||||||
107 | 27 | 261 | while ($prop = shift(@args)) { | |||
108 | 17 | 94 | $val = shift(@args); | |||
109 | ||||||
110 | 17 323 | 156 1996 | if (not grep { $_ eq $prop} @styleopts, @okPrefs) { | |||
111 | 1 | 9 | carp "unknown print-style: $prop"; | |||
112 | 1 | 18 | next; | |||
113 | } | |||||
114 | elsif ($prop ne 'init') { | |||||
115 | 9 | 119 | $args{$prop} = $val; | |||
116 | } | |||||
117 | else { | |||||
118 | 7 | 62 | carp "init arg must be a ref to a (scalar) variable" | |||
119 | unless ref($val) =~ /SCALAR/; | |||||
120 | ||||||
121 | 7 | 63 | carp "wont construct a new EzDD object into non-undef variable" | |||
122 | if defined $$val; | |||||
123 | ||||||
124 | 7 | 62 | $$val = Data::Dumper::EasyOO->new(%args); | |||
125 | } | |||||
126 | } | |||||
127 | 27 | 308 | $cliPrefs{caller()} = {%args}; # save the allowed ones | |||
128 | #print "EzDD client cache: ", Data::Dumper::Dumper \%cliPrefs; | |||||
129 | } | |||||
130 | ||||||
131 | sub Set { | |||||
132 | # sets internal state of private data dumper object | |||||
133 | 833 | 6060 | my ($ezdd, %cfg) = @_; | |||
134 | 833 | 5076 | my $ddo = $ezdd; | |||
135 | 833 | 7764 | $ddo = $ezdd->($magic) if ref $ezdd eq __PACKAGE__; | |||
136 | ||||||
137 | 833 | 6311 | for my $item (keys %cfg) { | |||
138 | #print "$item => $cfg{$item}\n"; | |||||
139 | 927 | 6044 | my $attr = lc $item; | |||
140 | 927 | 5300 | my $meth = ucfirst $item; | |||
141 | ||||||
142 | 927 14832 392 | 5152 91837 2553 | if (grep {$attr eq $_} @styleopts) { | |||
143 | 829 | 6723 | $ddo->$meth($cfg{$item}); | |||
144 | } | |||||
145 | 84 | 549 | elsif (grep {$item eq $_} @ddmethods) { | |||
146 | 70 | 560 | $ddo->$meth($cfg{$item}); | |||
147 | } | |||||
148 | elsif (grep {$attr eq $_} @okPrefs) { | |||||
149 | 22 | 236 | $ddo->{$attr} = $cfg{$item}; | |||
150 | } | |||||
151 | 6 | 52 | else { carp "illegal method <$item>" } | |||
152 | } | |||||
153 | 833 | 6463 | $ezdd; | |||
154 | } | |||||
155 | ||||||
156 | sub AUTOLOAD { | |||||
157 | 737 | 4864 | my ($ezdd, $arg) = @_; | |||
158 | 737 | 5342 | (my $meth = $AUTOLOAD) =~ s/.*:://; | |||
159 | 737 | 4897 | return if $meth eq 'DESTROY'; | |||
160 | 692 | 4500 | my @vals = $ezdd->Set($meth => $arg); | |||
161 | 692 | 7574 | return $ezdd unless wantarray; | |||
162 | 1 | 9 | return $ezdd, @vals; | |||
163 | } | |||||
164 | ||||||
165 | sub pp { | |||||
166 | 8 | 55 | my ($ezdd, @data) = @_; | |||
167 | 8 | 55 | $ezdd->(@data); | |||
168 | } | |||||
169 | ||||||
170 | *dump = \&pp; | |||||
171 | ||||||
172 | my $_privatePrinter; # visible only to new and closure object it makes | |||||
173 | ||||||
174 | sub new { | |||||
175 | 60 | 1310 | my ($cls, %cfg) = @_; | |||
176 | 60 | 534 | my $prefs = $cliPrefs{caller()} || {}; | |||
177 | ||||||
178 | 60 | 624 | my $ddo = Data::Dumper->new([]); # inner obj w bogus data | |||
179 | 60 | 2917 | Set($ddo, %$prefs, %cfg); # ctor-params override pkg-config | |||
180 | ||||||
181 | #print "EzDD::new() ", Data::Dumper::Dumper [$prefs, \%cfg]; | |||||
182 | ||||||
183 | my $code = sub { # closure on $ddo | |||||
184 | 1136 | 7980 | &$_privatePrinter($ddo, @_); | |||
185 | 60 | 728 | }; | |||
186 | # copy constructor | |||||
187 | 60 | 789 | bless $code, ref $cls || $cls; | |||
188 | ||||||
189 | 60 | 413 | if (ref $cls) { | |||
190 | # clone its settings | |||||
191 | 3 | 19 | my $ddo = $cls->($magic); | |||
192 | 3 | 16 | my %styles; | |||
193 | 3 | 73 | @styles{@styleopts,@okPrefs} = @$ddo{@styleopts,@okPrefs}; | |||
194 | 3 | 42 | $code->Set(%styles,%cfg); | |||
195 | } | |||||
196 | 60 | 485 | return $code; | |||
197 | } | |||||
198 | ||||||
199 | ||||||
200 | $_privatePrinter = sub { | |||||
201 | my ($ddo, @args) = @_; | |||||
202 | ||||||
203 | unless ($ddo->{_ezdd_noreset}) { | |||||
204 | $ddo->Reset; # clear seen | |||||
205 | $ddo->Names([]); # clear labels | |||||
206 | } | |||||
207 | if (@args == 1) { | |||||
208 | # test for AUTOLOADs special access | |||||
209 | return $ddo if defined $args[0] and $args[0] eq $magic; | |||||
210 | ||||||
211 | # else Regular usage | |||||
212 | $ddo->{todump} = \@args; | |||||
213 | #goto PrintIt; | |||||
214 | } | |||||
215 | # else | |||||
216 | elsif (@args % 2) { | |||||
217 | # cant be a hash, must be array of data | |||||
218 | $ddo->{todump} = \@args; | |||||
219 | #goto PrintIt; | |||||
220 | } | |||||
221 | else { | |||||
222 | # possible labelled usage, | |||||
223 | # check that all 'labels' are scalars | |||||
224 | ||||||
225 | my %rev = reverse @args; | |||||
226 | if (grep {ref $_} values %rev) { | |||||
227 | # odd elements are refs, must print as array | |||||
228 | $ddo->{todump} = \@args; | |||||
229 | goto PrintIt; | |||||
230 | } | |||||
231 | else { | |||||
232 | my (@labels,@vals); | |||||
233 | while (@args) { | |||||
234 | push @labels, shift @args; | |||||
235 | push @vals, shift @args; | |||||
236 | } | |||||
237 | $ddo->{names} = \@labels; | |||||
238 | $ddo->{todump} = \@vals; | |||||
239 | } | |||||
240 | #goto PrintIt; | |||||
241 | } | |||||
242 | PrintIt: | |||||
243 | # return dump-str unless void context | |||||
244 | return $ddo->Dump() if defined wantarray; | |||||
245 | ||||||
246 | my $auto = (defined $ddo->{autoprint}) ? $ddo->{autoprint} : 0; | |||||
247 | ||||||
248 | unless ($auto) { | |||||
249 | carp "called in void context, without autoprint set"; | |||||
250 | return; | |||||
251 | } | |||||
252 | # autoprint to STDOUT, STDERR, or HANDLE (IO or GLOB) | |||||
253 | ||||||
254 | if (ref $auto and (ref $auto eq 'GLOB' or $auto->can("print"))) { | |||||
255 | print $auto $ddo->Dump(); | |||||
256 | } | |||||
257 | elsif ($auto == 1) { | |||||
258 | print STDOUT $ddo->Dump(); | |||||
259 | } | |||||
260 | elsif ($auto == 2) { | |||||
261 | print STDERR $ddo->Dump(); | |||||
262 | } | |||||
263 | else { | |||||
264 | carp "illegal autoprint value: $ddo->{autoprint}"; | |||||
265 | } | |||||
266 | return; | |||||
267 | }; | |||||
268 | ||||||
269 | ||||||
270 | 1; | |||||
271 |