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

# File Coverage

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

line | stmt | branch | cond | sub | time | code
--- | --- | --- | --- | --- | --- | ---
1 |  |  |  |  |  | #!perl
2 |
3 |  |  |  |  |  | package 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
72 |  |  |  |  |  | my $magic = [];
73 |  |  |  |  |  | my %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 |
78 |  |  |  |  |  | my @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 |
84 |  |  |  |  |  | push @styleopts, qw( maxdepth )
85 |  |  |  |  |  | if $Data::Dumper::VERSION ge '2.102'; # with 5.6.1
86 |
87 |  |  |  |  |  | push @styleopts, qw( pair useperl sortkeys deparse )
88 |  |  |  |  |  | if $Data::Dumper::VERSION ge '2.121'; # with 5.6.2
89 |
90 |  |  |  |  |  | # DD methods; also delegated
91 |  |  |  |  |  | my @ddmethods = qw ( Seen Values Names Reset );
92 |
93 |  |  |  |  |  | # EzDD-specific importable style preferences
94 |  |  |  |  |  | my @okPrefs = qw( autoprint init );
95 |
96 |  |  |  |  |  | ##############
97 |  |  |  |  |  | sub 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 |
135 |  |  |  |  |  | sub 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 |
160 |  |  |  |  |  | sub 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 |
171 |  |  |  |  |  | sub 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 |
260 |  |  |  |  |  | sub pp {
261 | 16 |  |  | 16 | 103 | my ($ezdd, @data) = @_;
262 | 16 |  |  |  | 99 | $ezdd->(@data);
263 |  |  |  |  |  | }
264 |
265 |  |  |  |  |  | *dump = \&pp;
266 |
267 |  |  |  |  |  | 1;
268 |