File Coverage

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

linestmtbranchcondsubtimecode
1#!perl
2
3package 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
115my $magic = [];
116my %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
121my @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
127push @styleopts, qw( maxdepth )
128    if $Data::Dumper::VERSION ge '2.102'; # with 5.6.1
129
130push @styleopts, qw( pair useperl sortkeys deparse )
131    if $Data::Dumper::VERSION ge '2.121'; # with 5.6.2
132
133# DD methods; also delegated
134my @ddmethods = qw ( Seen Values Names Reset );
135
136# EzDD-specific importable style preferences
137my @okPrefs = qw( autoprint init _ezdd_noreset );
138
139##############
140sub 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
211sub 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
238sub 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
247sub pp {
248
8
51
    my ($ezdd, @data) = @_;
249
8
50
    $ezdd->(@data);
250}
251
252*dump = \&pp;
253
254my $_privatePrinter; # visible only to new and closure object it makes
255
256sub 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
3521;
353