File Coverage

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

linestmtbranchcondsubtimecode
1#!perl
2
3package Data::Dumper::EasyOO;
4
22
22
22
235
125
126
use Data::Dumper();
5
22
22
22
268
113
312
use Carp 'carp';
6use strict;
7
8
22
22
22
457
123
114
use 5.005_03;
9use 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
117my $magic = [];
118my %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
123my @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
129push @styleopts, qw( maxdepth )
130    if $Data::Dumper::VERSION ge '2.102'; # with 5.6.1
131
132push @styleopts, qw( pair useperl sortkeys deparse )
133    if $Data::Dumper::VERSION ge '2.121'; # with 5.6.2
134
135# DD methods; also delegated
136my @ddmethods = qw ( Seen Values Names Reset );
137
138# EzDD-specific importable style preferences
139my @okPrefs = qw( autoprint init _ezdd_noreset );
140
141##############
142sub 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
255sub pp {
256    my ($ezdd, @data) = @_;
257    $ezdd->(@data);
258}
259
260
761
4727
*dump = \&pp;
261
262sub _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
3601;
361