| 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 | ||||||