File Coverage

File:blib/lib/Test/Mocha/PartialDump.pm
Coverage:100.0%

linestmtbrancondsubpodtimecode
1package Test::Mocha::PartialDump;
2# ABSTRACT: Partial dumping of data structures, optimized for argument printing
3$Test::Mocha::PartialDump::VERSION = '0.61';
4# ===================================================================
5# This code was copied and adapted from Devel::PartialDump 0.15.
6#
7#   Copyright (c) 2008, 2009 Yuval Kogman. All rights reserved
8#   This program is free software; you can redistribute
9#   it and/or modify it under the same terms as Perl itself.
10#
11# ===================================================================
12
13
60
60
60
243554
49
1120
use strict;
14
60
60
60
121
57
982
use warnings;
15
16
60
60
60
126
44
2087
use Scalar::Util qw( looks_like_number reftype blessed );
17
18use constant {
19
60
146
    ELLIPSIS     => '...',
20    ELLIPSIS_LEN => 3,
21
60
60
45
37454
};
22
23sub new {
24    # uncoverable pod
25
96
0
286060
    my ( $class, %args ) = @_;
26
27    # attribute defaults
28    ## no critic (ProhibitMagicNumbers)
29
96
299
    $args{max_length}   = undef unless exists $args{max_length};
30
96
234
    $args{max_elements} = 6     unless exists $args{max_elements};
31
96
198
    $args{max_depth}    = 2     unless exists $args{max_depth};
32
96
212
    $args{stringify}    = 0     unless exists $args{stringify};
33
96
203
    $args{pairs}        = 1     unless exists $args{pairs};
34
96
165
    $args{objects}      = 1     unless exists $args{objects};
35
96
187
    $args{list_delim}   = ', '  unless exists $args{list_delim};
36
96
278
    $args{pair_delim}   = ': '  unless exists $args{pair_delim};
37    ## use critic
38
39
96
262
    return bless \%args, $class;
40}
41
42sub dump {  ## no critic (ProhibitBuiltinHomonyms)
43            # uncoverable pod
44
812
0
1927
    my ( $self, @args ) = @_;
45
46
812
857
    my $method =
47      'dump_as_' . ( $self->should_dump_as_pairs(@args) ? 'pairs' : 'list' );
48
49
812
1008
    my $dump = $self->$method( 1, @args );
50
51
812
2610
    if ( defined $self->{max_length}
52        and length($dump) > $self->{max_length} )
53    {
54
8
13
        my $max_length = $self->{max_length} - ELLIPSIS_LEN;
55
8
16
        $max_length = 0 if $max_length < 0;
56
8
15
        substr $dump, $max_length, length($dump) - $max_length, ELLIPSIS;
57    }
58
59
812
1985
    return $dump;
60}
61
62sub should_dump_as_pairs {
63    # uncoverable pod
64
812
0
555
    my ( $self, @what ) = @_;
65
66
812
1093
    return unless $self->{pairs};
67
68
776
1367
    return if @what % 2 != 0;  # must be an even list
69
70
310
614
313
598
    for my $i ( grep { $_ % 2 == 0 } 0 .. @what ) {
71
423
664
        return if ref $what[$i];  # plain strings are keys
72    }
73
74
271
418
    return 1;
75}
76
77sub dump_as_pairs {
78    # uncoverable pod
79
352
0
279
    my ( $self, $depth, @what ) = @_;
80
81
352
187
    my $truncated;
82
352
997
    if ( defined $self->{max_elements}
83        and ( @what / 2 ) > $self->{max_elements} )
84    {
85
8
6
        $truncated = 1;
86
8
19
        @what = splice @what, 0, $self->{max_elements} * 2;
87    }
88
89
352
442
    return join
90      $self->{list_delim},
91      $self->_dump_as_pairs( $depth, @what ),
92      ( $truncated ? ELLIPSIS : () );
93}
94
95sub _dump_as_pairs {
96
518
714
    my ( $self, $depth, @what ) = @_;
97
98
518
1307
    return unless @what;
99
100
166
203
    my ( $key, $value, @rest ) = @what;
101
102    return (
103        (
104
166
176
                $self->format_key( $depth, $key )
105              . $self->{pair_delim}
106              . $self->format( $depth, $value )
107        ),
108        $self->_dump_as_pairs( $depth, @rest ),
109    );
110}
111
112sub dump_as_list {
113    # uncoverable pod
114
561
0
454
    my ( $self, $depth, @what ) = @_;
115
116
561
329
    my $truncated;
117
561
1410
    if ( defined $self->{max_elements} and @what > $self->{max_elements} ) {
118
8
9
        $truncated = 1;
119
8
18
        @what = splice @what, 0, $self->{max_elements};
120    }
121
122
840
988
    return join
123      $self->{list_delim},
124
561
526
      ( map { $self->format( $depth, $_ ) } @what ),
125      ( $truncated ? ELLIPSIS : () );
126}
127
128sub format {  ## no critic (ProhibitBuiltinHomonyms)
129              # uncoverable pod
130
1026
0
678
    my ( $self, $depth, $value ) = @_;
131
132
1026
2687
    return defined($value)
133      ? (
134        ref($value)
135        ? (
136            blessed($value)
137            ? $self->format_object( $depth, $value )
138            : $self->format_ref( $depth, $value )
139          )
140        : (
141            looks_like_number($value)
142            ? $self->format_number( $depth, $value )
143            : $self->format_string( $depth, $value )
144        )
145      )
146      : $self->format_undef( $depth, $value );
147}
148
149sub format_key {
150    # uncoverable pod
151
166
0
118
    my ( $self, $depth, $key ) = @_;
152
166
302
    return $key;
153}
154
155sub format_ref {
156    # uncoverable pod
157
129
0
87
    my ( $self, $depth, $ref ) = @_;
158
159
129
163
    if ( $depth > $self->{max_depth} ) {
160
8
43
        return overload::StrVal($ref);
161    }
162    else {
163
121
152
        my $reftype = reftype($ref);
164
121
295
        $reftype = 'SCALAR'
165          if $reftype eq 'REF' || $reftype eq 'LVALUE';
166
121
136
        my $method = 'format_' . lc $reftype;
167
168        # uncoverable branch false
169
121
249
        if ( $self->can($method) ) {
170
121
160
            return $self->$method( $depth, $ref );
171        }
172        else {
173
0
0
            return overload::StrVal($ref);  # uncoverable statement
174        }
175    }
176}
177
178sub format_array {
179    # uncoverable pod
180
20
0
17
    my ( $self, $depth, $array ) = @_;
181
182
20
56
    my $class = blessed($array) || q{};
183
20
27
    $class .= q{=} if $class;
184
185
20
20
23
110
    return $class . '[ ' . $self->dump_as_list( $depth + 1, @{$array} ) . ' ]';
186}
187
188sub format_hash {
189    # uncoverable pod
190
81
0
58
    my ( $self, $depth, $hash ) = @_;
191
192
81
181
    my $class = blessed($hash) || q{};
193
81
107
    $class .= q{=} if $class;
194
195    return
196
81
154
      $class . '{ '
197      . $self->dump_as_pairs( $depth + 1,
198
81
81
80
181
        map { $_ => $hash->{$_} } sort keys %{$hash} )
199      . ' }';
200}
201
202sub format_scalar {
203    # uncoverable pod
204
20
0
20
    my ( $self, $depth, $scalar ) = @_;
205
206
20
54
    my $class = blessed($scalar) || q{};
207
20
28
    $class .= q{=} if $class;
208
209
20
20
27
101
    return $class . q{\\} . $self->format( $depth + 1, ${$scalar} );
210}
211
212sub format_object {
213    # uncoverable pod
214
220
0
174
    my ( $self, $depth, $object ) = @_;
215
216
220
232
    if ( $self->{objects} ) {
217
12
13
        return $self->format_ref( $depth, $object );
218    }
219    else {
220
208
457
        return $self->{stringify} ? "$object" : overload::StrVal($object);
221    }
222}
223
224sub format_number {
225    # uncoverable pod
226
576
0
381
    my ( $self, $depth, $value ) = @_;
227
576
1066
    return "$value";
228}
229
230sub format_string {
231    # uncoverable pod
232
109
0
130
    my ( $self, $depth, $str ) = @_;
233    # FIXME use String::Escape ?
234
235    # remove vertical whitespace
236
109
108
    $str =~ s/\n/\\n/smg;
237
109
83
    $str =~ s/\r/\\r/smg;
238
239    # reformat nonprintables
240
55
55
55
109
4
23921
398
657
142
21
    $str =~ s/ (\P{IsPrint}) /"\\x{" . sprintf("%x", ord($1)) . "}"/xsmge;
241
242
109
441
    return qq{"$str"};
243}
244
245sub format_undef {
246    # uncoverable pod
247
4
0
16
    return 'undef';
248}
249
2501;