File Coverage

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

linestmtbranchcondsubtimecode
1#!perl
2
3package Data::Dumper::EasyOO;
4
32
32
32
32
314
233
178
use Data::Dumper();
5
32
32
32
32
381
162
391
use Carp 'carp';
6
7
32
32
32
32
633
168
165
use 5.005_03;
8
32
32
32
32
339
170
321
use vars qw($VERSION);
9$VERSION = '0.04_03';
10
11 - 66
=head1 NAME

Data::Dumper::EasyOO - wraps DD for easy use of various printing styles

=head1 ABSTRACT

EzDD's main goals are to make it easy to label data that you
print/dump, and to make it easy to one or more dumper objects, and one
or more print styles with each one.

Its designed to give you maximum control with a minimum of keystrokes.
At use-time, you can specify default print style(s), and can also
create 1 or more EzDD printer objects to use those styles.  Each
printer object's style can be adjusted thereafter.

EzDD has similar goals as its step-sibling, Data::Dumper::Simple, but
differs in that it does not use source filtering, and it exposes
essentially all of DD's functionality, but with an easier interface.


=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
67
68    ;
69##############
70# this (private) reference is passed to the closure to recover
71# the underlying Data::Dumper object
72my $magic = [];
73my %cliPrefs; # stores style preferences for each client package
74
75# DD print-style options/methods/package-vars/attributes.
76# Theyre delegated to the inner DD object, and 'importable' too.
77
78my @styleopts; # used to validate methods in Set()
79
80# 5.00503 shipped with DD v2.101
81@styleopts = qw( indent purity pad varname useqq terse freezer
82                    toaster deepcopy quotekeys bless );
83
84push @styleopts, qw( maxdepth )
85    if $Data::Dumper::VERSION ge '2.102'; # with 5.6.1
86
87push @styleopts, qw( pair useperl sortkeys deparse )
88    if $Data::Dumper::VERSION ge '2.121'; # with 5.6.2
89
90# DD methods; also delegated
91my @ddmethods = qw ( Seen Values Names Reset );
92
93# EzDD-specific importable style preferences
94my @okPrefs = qw( autoprint init );
95
96##############
97sub import {
98    # save EzDD client's preferences for use in new()
99
54
54
564
    my ($pkg, @args) = @_;
100
54
523
    my ($prop, $val, %args);
101
102    # handle aliases, multiples allowed (feeping creaturism)
103
104
54
88
641
643
    foreach my $idx (grep {$args[$_] eq 'alias'} reverse 0..$#args) {
105
10
84
        ($idx, $alias) = splice(@args, $idx, 2);
106
32
32
32
32
355
169
438
        no strict 'refs';
107        #*{$alias.'::'} = *{$pkg.'::'};
108
10
10
10
54
115
72
        *{$alias.'::new'} = *{$pkg.'::new'};
109    }
110
111
54
520
    while ($prop = shift(@args)) {
112
34
191
        $val = shift(@args);
113
114
34
612
100
100
201
3796
        if (not grep { $_ eq $prop} @styleopts, @okPrefs) {
115
2
17
            carp "unknown print-style: $prop";
116
2
36
            next;
117        }
118        elsif ($prop ne 'init') {
119
18
231
            $args{$prop} = $val;
120        }
121        else {
122
14
100
134
            carp "init arg must be a ref to a (scalar) variable"
123                unless ref($val) =~ /SCALAR/;
124
125
14
100
120
            carp "wont construct a new EzDD object into non-undef variable"
126                if defined $$val;
127
128
14
125
            $$val = Data::Dumper::EasyOO->new(%args);
129        }
130    }
131
54
583
    $cliPrefs{caller()} = {%args}; # save the allowed ones
132    #print "EzDD client cache: ", Data::Dumper::Dumper \%cliPrefs;
133}
134
135sub Set {
136    # sets internal state of private data dumper object
137
1642
1642
11584
    my ($ezdd, %cfg) = @_;
138
1642
8580
    my $ddo = $ezdd;
139
1642
100
16309
    $ddo = $ezdd->($magic) if ref $ezdd eq __PACKAGE__;
140
141
1642
11875
    for my $item (keys %cfg) {
142        #print "$item => $cfg{$item}\n";
143
1824
11520
        my $attr = lc $item;
144
1824
10126
        my $meth = ucfirst $item;
145
146
1824
29184
712
100
100
100
9879
179200
4540
        if (grep {$attr eq $_} @styleopts) {
147
1646
13289
            $ddo->$meth($cfg{$item});
148        }
149
76
513
        elsif (grep {$item eq $_} @ddmethods) {
150
140
1090
            $ddo->$meth($cfg{$item});
151        }
152        elsif (grep {$attr eq $_} @okPrefs) {
153
26
280
            $ddo->{$attr} = $cfg{$item};
154        }
155
12
98
        else { carp "illegal method <$item>" }
156    }
157
1642
12675
    $ezdd;
158}
159
160sub AUTOLOAD {
161
1462
1462
9537
    my ($ezdd, $arg) = @_;
162
1462
10392
    (my $meth = $AUTOLOAD) =~ s/.*:://;
163
1462
100
9608
    return if $meth eq 'DESTROY';
164
1384
8970
    my @vals = $ezdd->Set($meth => $arg);
165
1384
100
14262
    return $ezdd unless wantarray;
166
2
16
    return $ezdd, @vals;
167}
168
169#my $_privateFunc;
170
171sub new {
172
108
108
2142
    my ($cls, %cfg) = @_;
173
108
100
932
    my $prefs = $cliPrefs{caller()} || {};
174
175
108
957
    my $ddo = Data::Dumper->new([]); # inner obj w bogus data
176
108
5629
    Set($ddo, %$prefs, %cfg); # ctor-config overrides pkg-config
177
178    #print "EzDD::new() ", Data::Dumper::Dumper [$prefs, \%cfg];
179
180    my $code = sub { # closure on $ddo
181
2242
2242
15799
        my @args = @_;
182
183
2242
50
17717
        unless ($ddo->{_ezdd_noreset}) {
184
2242
15655
            $ddo->Reset; # clear seen
185
2242
18584
            $ddo->Names([]); # clear labels
186        }
187
2242
100
20895
        if (@args == 1) {
188            # test for AUTOLOADs special access
189
2142
100
67
41625
            return $ddo if defined $args[0] and $args[0] eq $magic;
190
191            # else Regular usage
192
602
4001
            $ddo->{todump} = \@args;
193
602
4494
            goto PrintIt;
194        }
195        # else
196
100
100
700
        if (@args % 2) {
197            # cant be a hash, must be array of data
198
12
76
            $ddo->{todump} = \@args;
199
12
140
            goto PrintIt;
200        }
201        else {
202            # possible labelled usage,
203            # check that all 'labels' are scalars
204
205
88
829
            my %rev = reverse @args;
206
88
122
50
566
840
            if (grep {ref $_} values %rev) {
207                # odd elements are refs, must print as array
208
0
0
                $ddo->{todump} = \@args;
209
0
0
                goto PrintIt;
210            }
211
88
481
            my (@labels,@vals);
212
88
650
            while (@args) {
213
122
738
                push @labels, shift @args;
214
122
1336
                push @vals, shift @args;
215            }
216
88
565
            $ddo->{names} = \@labels;
217
88
546
            $ddo->{todump} = \@vals;
218
88
1096
            goto PrintIt;
219        }
220
702
100
6402
      PrintIt:
221        # return dump-str unless void context
222        return $ddo->Dump() if defined wantarray;
223
224
22
100
188
        my $auto = (defined $ddo->{autoprint}) ? $ddo->{autoprint} : '';
225
226
22
100
175
        unless ($auto) {
227
6
50
            carp "called in void context, without autoprint set";
228
6
67
            return;
229        }
230        # autoprint to STDOUT, STDERR, or HANDLE (IO or GLOB)
231
232
16
50
50
100
75
324
        if ($auto == 1) {
233
0
0
            print STDOUT $ddo->Dump();
234        }
235        elsif ($auto == 2) {
236
0
0
            print STDERR $ddo->Dump();
237        }
238        elsif (ref $auto and (ref $auto eq 'GLOB' or $auto->can("print"))) {
239
14
127
            print $auto $ddo->Dump();
240        }
241        else {
242
2
42
            carp "illegal autoprint value: $ddo->{autoprint}";
243        }
244
16
1150
        return;
245
108
1934
    };
246
247    # copy constructor
248
108
67
1436
    bless $code, ref $cls || $cls;
249
250
108
100
749
    if (ref $cls) {
251        # clone its settings
252
6
38
        my $ddo = $cls->($magic);
253
6
34
        my %styles;
254
6
143
        @styles{@styleopts,@okPrefs} = @$ddo{@styleopts,@okPrefs};
255
6
82
        $code->Set(%styles,%cfg);
256    }
257
108
862
    return $code;
258}
259
260sub pp {
261
16
16
103
    my ($ezdd, @data) = @_;
262
16
99
    $ezdd->(@data);
263}
264
265*dump = \&pp;
266
2671;
268