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