File Coverage

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

linestmtbranchcondsubtimecode
1#!perl
2
3package Data::Dumper::EasyOO; # pod at __END__
4
15
15
15
15
139
79
66
use Data::Dumper();
5
15
15
15
15
169
66
169
use Carp 'carp';
6
7
15
15
15
15
308
54
58
use 5.005_03;
8
15
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
14my $magic = [];
15my %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
20my @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
26push @styleopts, qw( maxdepth )
27    if $Data::Dumper::VERSION ge '2.102'; # with 5.6.1
28
29push @styleopts, qw( pair useperl sortkeys deparse )
30    if $Data::Dumper::VERSION ge '2.121'; # with 5.6.2
31
32# DD methods; also delegated
33my @ddmethods = qw ( Seen Values Names Reset );
34
35# EzDD-specific importable style preferences
36my @okPrefs = qw( autoprint );
37
38##############
39sub import {
40    # save EzDD client's preferences for use in new()
41
19
19
132
    my ($pkg, %args) = @_;
42
43
19
136
    for my $prop (keys %args) {
44
10
100
66
        if ($prop eq 'init') {
45
4
33
            carp "wont construct a new EzDD object into non-undef variable"
46
4
100
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
50
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
60sub Set {
61    # sets internal state of private data dumper object
62
808
808
21096
    my ($ezdd, %cfg) = @_;
63
808
2760
    my $ddo = $ezdd;
64
808
100
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
100
100
100
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
85sub AUTOLOAD {
86
727
727
4010
    my ($ezdd, $arg) = @_;
87
727
4229
    (my $meth = $AUTOLOAD) =~ s/.*:://;
88
727
100
3605
    return if $meth eq 'DESTROY';
89
689
3426
    my @vals = $ezdd->Set($meth,$arg);
90
689
50
3267
    print "wantarray, @vals\n" if wantarray;
91
689
50
6251
    return $ezdd unless wantarray;
92
0
0
    return $ezdd, @vals;
93}
94
95sub new {
96
45
45
1190
    my ($cls, %cfg) = @_;
97
45
100
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
109788
2357466
        my @args = @_;
106
107
109788
50
1130493
        unless ($ddo->{_ezdd_noreset}) {
108
109788
795805
            $ddo->Reset; # clear seen
109
109788
6773427
            $ddo->Names([]); # clear labels
110        }
111
109788
100
8175567
        if (@args == 1) {
112            # test for AUTOLOADs special access
113
109737
100
67
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
100
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
50
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
100
1013134
      PrintIt:
145        # return dump-str unless void context
146        return $ddo->Dump() if defined wantarray;
147
148
33553
100
297586
        my $auto = (defined $ddo->{autoprint}) ? $ddo->{autoprint} : '';
149
150
33553
100
33
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
100
50
50
67
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
67
544
    bless $code, ref $cls || $cls;
172
173
45
100
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
183sub pp {
184
8
8
42
    my ($ezdd, @data) = @_;
185
8
36
    $ezdd->(@data);
186}
187
188*dump = \&pp;
189
1901;
191