File Coverage: blib/lib/Data/Dumper/EasyOO.pm

# File Coverage

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 |  |  | 17 | 288 102 99 | use Data::Dumper();
5 | 17 17 17 |  |  | 17 | 199 83 192 | use Carp 'carp';
6 |
7 | 17 17 17 |  |  | 17 | 339 85 87 | use 5.005_03;
8 | 17 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 |  |  | 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 |  |  | 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 | 100 100 |  |  | 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 | 100 |  |  | 68 | carp "init arg must be a ref to a (scalar) variable"
169 |  |  |  |  |  | unless ref($val) =~ /SCALAR/;
170 |
171 | 7 | 100 |  |  | 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 | 50 |  | 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 |  |  | 868 | 6240 | my ($ezdd, %cfg) = @_;
214 | 868 |  |  |  | 4373 | my $ddo = $ezdd;
215 | 868 | 100 |  |  | 7812 | $ddo = $ezdd->($magic) if ref $ezdd eq __PACKAGE__;
216 |
217 | 868 | 50 |  |  | 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 | 100 100 100 |  |  | 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 |  |  | 748 | 4612 | my ($ezdd, $arg) = @_;
240 | 748 |  |  |  | 5794 | (my $meth = $AUTOLOAD) =~ s/.*:://;
241 | 748 | 100 |  |  | 4832 | return if $meth eq 'DESTROY';
242 | 693 |  |  |  | 4410 | my @vals = $ezdd->Set($meth => $arg);
243 | 693 | 100 |  |  | 7022 | return $ezdd unless wantarray;
244 | 1 |  |  |  | 8 | return $ezdd, @vals;
245 |  |  |  |  |  | }
246 |
247 |  |  |  |  |  | sub pp {
248 | 8 |  |  | 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 |  |  | 92 | 1650 | my ($cls, %cfg) = @_;
258 | 92 |  | 100 |  | 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 |  |  | 1145 | 8677 | &$_privatePrinter($ddo, @_);
267 | 92 |  |  |  | 1048 | };
268 |  |  |  |  |  | # copy constructor
269 | 92 |  | 67 |  | 1421 | bless $code, ref $cls || $cls;
270 |
271 | 92 | 100 |  |  | 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 |