File: | blib/lib/Data/Dumper/EasyOO.pm |
Coverage: | 88.2% |
line | stmt | branch | cond | sub | time | code |
---|---|---|---|---|---|---|
1 | #!perl | |||||
2 | ||||||
3 | package Data::Dumper::EasyOO; # pod at __END__ | |||||
4 | 15 15 15 | 139 79 66 | use Data::Dumper(); | |||
5 | 15 15 15 | 169 66 169 | use Carp 'carp'; | |||
6 | ||||||
7 | 15 15 15 | 308 54 58 | use 5.005_03; | |||
8 | 15 15 15 | 140 56 119 | use vars qw($VERSION); | |||
9 | $VERSION = 0.04_01; | |||||
10 | ||||||
11 | ############## | |||||
12 | # this (private) reference is passed to the closure to recover | |||||
13 | # the underlying Data::Dumper object | |||||
14 | my $magic = []; | |||||
15 | my %cliPrefs; # stores style preferences for each client package | |||||
16 | ||||||
17 | # DD print-style options/methods/package-vars/attributes. | |||||
18 | # Theyre delegated to the inner DD object, and 'importable' too. | |||||
19 | ||||||
20 | my @styleopts; # used to validate methods in Set() | |||||
21 | ||||||
22 | # 5.00503 shipped with DD v2.101 | |||||
23 | @styleopts = qw( indent purity pad varname useqq terse freezer | |||||
24 | toaster deepcopy quotekeys bless ); | |||||
25 | ||||||
26 | push @styleopts, qw( maxdepth ) | |||||
27 | if $Data::Dumper::VERSION ge '2.102'; # with 5.6.1 | |||||
28 | ||||||
29 | push @styleopts, qw( pair useperl sortkeys deparse ) | |||||
30 | if $Data::Dumper::VERSION ge '2.121'; # with 5.6.2 | |||||
31 | ||||||
32 | # DD methods; also delegated | |||||
33 | my @ddmethods = qw ( Seen Values Names Reset ); | |||||
34 | ||||||
35 | # EzDD-specific importable style preferences | |||||
36 | my @okPrefs = qw( autoprint ); | |||||
37 | ||||||
38 | ############## | |||||
39 | sub import { | |||||
40 | # save EzDD client's preferences for use in new() | |||||
41 | 19 | 132 | my ($pkg, %args) = @_; | |||
42 | ||||||
43 | 19 | 136 | for my $prop (keys %args) { | |||
44 | 10 | 66 | if ($prop eq 'init') { | |||
45 | 4 | 33 | carp "wont construct a new EzDD object into non-undef variable" | |||
46 | 4 | 13 | if defined ${$args{$prop}}; | |||
47 | 4 | 33 | my $foo = delete $args{$prop}; | |||
48 | 4 | 27 | $$foo = Data::Dumper::EasyOO->new(%args); | |||
49 | 4 | 27 | next; | |||
50 | } | |||||
51 | 6 102 | 25 473 | unless (grep { $_ eq $prop} @styleopts, @okPrefs) { | |||
52 | 0 | 0 | delete $args{$prop}; | |||
53 | 0 | 0 | carp "unknown style-pref: $prop"; | |||
54 | } | |||||
55 | } | |||||
56 | 19 | 191 | $cliPrefs{caller()} = {%args}; # save the allowed ones | |||
57 | #print "EzDD client cache: ", Data::Dumper::Dumper \%cliPrefs; | |||||
58 | } | |||||
59 | ||||||
60 | sub Set { | |||||
61 | # sets internal state of private data dumper object | |||||
62 | 808 | 21096 | my ($ezdd, %cfg) = @_; | |||
63 | 808 | 2760 | my $ddo = $ezdd; | |||
64 | 808 | 6693 | $ddo = $ezdd->($magic) if ref $ezdd eq __PACKAGE__; | |||
65 | ||||||
66 | 808 | 5000 | for my $item (keys %cfg) { | |||
67 | #print "$item => $cfg{$item}\n"; | |||||
68 | 901 | 3758 | my $attr = lc $item; | |||
69 | 901 | 3546 | my $meth = ucfirst $item; | |||
70 | ||||||
71 | 901 14416 356 | 3431 139075 1805 | if (grep {$attr eq $_} @styleopts) { | |||
72 | 812 | 5587 | $ddo->$meth($cfg{$item}); | |||
73 | } | |||||
74 | 19 | 125 | elsif (grep {$item eq $_} @ddmethods) { | |||
75 | 70 | 482 | $ddo->$meth($cfg{$item}); | |||
76 | } | |||||
77 | elsif (grep {$attr eq $_} @okPrefs) { | |||||
78 | 13 | 139 | $ddo->{$attr} = $cfg{$item}; | |||
79 | } | |||||
80 | 6 | 42 | else { carp "illegal method <$item>" } | |||
81 | } | |||||
82 | 808 | 4852 | $ezdd; | |||
83 | } | |||||
84 | ||||||
85 | sub AUTOLOAD { | |||||
86 | 727 | 4010 | my ($ezdd, $arg) = @_; | |||
87 | 727 | 4229 | (my $meth = $AUTOLOAD) =~ s/.*:://; | |||
88 | 727 | 3605 | return if $meth eq 'DESTROY'; | |||
89 | 689 | 3426 | my @vals = $ezdd->Set($meth,$arg); | |||
90 | 689 | 3267 | print "wantarray, @vals\n" if wantarray; | |||
91 | 689 | 6251 | return $ezdd unless wantarray; | |||
92 | 0 | 0 | return $ezdd, @vals; | |||
93 | } | |||||
94 | ||||||
95 | sub new { | |||||
96 | 45 | 1190 | my ($cls, %cfg) = @_; | |||
97 | 45 | 324 | my $prefs = $cliPrefs{caller()} || {}; | |||
98 | ||||||
99 | 45 | 353 | my $ddo = Data::Dumper->new([]); # bogus data, required | |||
100 | 45 | 2295 | Set($ddo, %$prefs, %cfg); # ctor-config overrides pkg-config | |||
101 | ||||||
102 | #print "EzDD::new() ", Data::Dumper::Dumper [$prefs, \%cfg]; | |||||
103 | ||||||
104 | my $code = sub { # closure on $ddo | |||||
105 | 109788 | 2357466 | my @args = @_; | |||
106 | ||||||
107 | 109788 | 1130493 | unless ($ddo->{_ezdd_noreset}) { | |||
108 | 109788 | 795805 | $ddo->Reset; # clear seen | |||
109 | 109788 | 6773427 | $ddo->Names([]); # clear labels | |||
110 | } | |||||
111 | 109788 | 8175567 | if (@args == 1) { | |||
112 | # test for AUTOLOADs special access | |||||
113 | 109737 | 2319661 | return $ddo if defined $args[0] and $args[0] eq $magic; | |||
114 | ||||||
115 | # else Regular usage | |||||
116 | 108971 | 810417 | $ddo->{todump} = \@args; | |||
117 | 108971 | 875304 | goto PrintIt; | |||
118 | } | |||||
119 | # else | |||||
120 | 51 | 298 | if (@args % 2) { | |||
121 | # cant be a hash, must be array of data | |||||
122 | 6 | 29 | $ddo->{todump} = \@args; | |||
123 | 6 | 66 | goto PrintIt; | |||
124 | } | |||||
125 | else { | |||||
126 | # possible labelled usage, | |||||
127 | # check that all 'labels' are scalars | |||||
128 | ||||||
129 | 45 | 367 | my %rev = reverse @args; | |||
130 | 45 62 | 212 363 | if (grep {ref $_} values %rev) { | |||
131 | # odd elements are refs, must print as array | |||||
132 | 0 | 0 | $ddo->{todump} = \@args; | |||
133 | 0 | 0 | goto PrintIt; | |||
134 | } | |||||
135 | 45 | 175 | my (@labels,@vals); | |||
136 | 45 | 276 | while (@args) { | |||
137 | 62 | 267 | push @labels, shift @args; | |||
138 | 62 | 630 | push @vals, shift @args; | |||
139 | } | |||||
140 | 45 | 230 | $ddo->{names} = \@labels; | |||
141 | 45 | 212 | $ddo->{todump} = \@vals; | |||
142 | 45 | 525 | goto PrintIt; | |||
143 | } | |||||
144 | 109022 | 1013134 | PrintIt: | |||
145 | # return dump-str unless void context | |||||
146 | return $ddo->Dump() if defined wantarray; | |||||
147 | ||||||
148 | 33553 | 297586 | my $auto = (defined $ddo->{autoprint}) ? $ddo->{autoprint} : ''; | |||
149 | ||||||
150 | 33553 | 200503 | carp "called in void context, without autoprint set" | |||
151 | and return unless $auto; | |||||
152 | ||||||
153 | # autoprint to STDOUT, STDERR, or HANDLE (IO or GLOB) | |||||
154 | ||||||
155 | 33551 | 532807 | if ($auto == 1) { | |||
156 | 2 | 14 | print STDOUT $ddo->Dump(); | |||
157 | } | |||||
158 | elsif ($auto == 2) { | |||||
159 | 0 | 0 | print STDERR $ddo->Dump(); | |||
160 | } | |||||
161 | elsif (ref $auto eq 'GLOB' or $auto->can("print")) { | |||||
162 | 33549 | 265203 | print $auto $ddo->Dump(); | |||
163 | } | |||||
164 | else { | |||||
165 | 0 | 0 | carp "dunno whatis $ddo->{autoprint}"; | |||
166 | } | |||||
167 | 33551 | 7760763 | return; | |||
168 | 45 | 766 | }; | |||
169 | ||||||
170 | # copy constructor | |||||
171 | 45 | 544 | bless $code, ref $cls || $cls; | |||
172 | ||||||
173 | 45 | 349 | if (ref $cls) { | |||
174 | # clone its settings | |||||
175 | 3 | 17 | my $ddo = $cls->($magic); | |||
176 | 3 | 13 | my %styles; | |||
177 | 3 | 64 | @styles{@styleopts,@okPrefs} = @$ddo{@styleopts,@okPrefs}; | |||
178 | 3 | 36 | $code->Set(%styles,%cfg); | |||
179 | } | |||||
180 | 45 | 276 | return $code; | |||
181 | } | |||||
182 | ||||||
183 | sub pp { | |||||
184 | 8 | 42 | my ($ezdd, @data) = @_; | |||
185 | 8 | 36 | $ezdd->(@data); | |||
186 | } | |||||
187 | ||||||
188 | *dump = \&pp; | |||||
189 | ||||||
190 | 1; | |||||
191 |