File Coverage

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

linestmtbranchcondsubtimecode
1#!perl
2
3package 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
68my $magic = [];
69my %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
74my @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
80push @styleopts, qw( maxdepth )
81    if $Data::Dumper::VERSION ge '2.102'; # with 5.6.1
82
83push @styleopts, qw( pair useperl sortkeys deparse )
84    if $Data::Dumper::VERSION ge '2.121'; # with 5.6.2
85
86# DD methods; also delegated
87my @ddmethods = qw ( Seen Values Names Reset );
88
89# EzDD-specific importable style preferences
90my @okPrefs = qw( autoprint init _ezdd_noreset );
91
92##############
93sub 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
131sub 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
156sub 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
165sub pp {
166
8
55
    my ($ezdd, @data) = @_;
167
8
55
    $ezdd->(@data);
168}
169
170*dump = \&pp;
171
172my $_privatePrinter; # visible only to new and closure object it makes
173
174sub 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
2701;
271