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
73
73
73
301812
60
1379
use strict;
14
73
73
73
147
68
1234
use warnings;
15
16
73
73
73
158
63
2583
use Scalar::Util qw( looks_like_number reftype blessed );
17
18use constant {
19
73
179
    ELLIPSIS     => '...',
20    ELLIPSIS_LEN => 3,
21
73
73
56
45686
};
22
23sub new {
24    # uncoverable pod
25
118
0
352734
    my ( $class, %args ) = @_;
26
27    # attribute defaults
28    ## no critic (ProhibitMagicNumbers)
29
118
363
    $args{max_length}   = undef unless exists $args{max_length};
30
118
283
    $args{max_elements} = 6     unless exists $args{max_elements};
31
118
243
    $args{max_depth}    = 2     unless exists $args{max_depth};
32
118
254
    $args{stringify}    = 0     unless exists $args{stringify};
33
118
245
    $args{pairs}        = 1     unless exists $args{pairs};
34
118
202
    $args{objects}      = 1     unless exists $args{objects};
35
118
226
    $args{list_delim}   = ', '  unless exists $args{list_delim};
36
118
338
    $args{pair_delim}   = ': '  unless exists $args{pair_delim};
37    ## use critic
38
39
118
319
    return bless \%args, $class;
40}
41
42sub dump {  ## no critic (ProhibitBuiltinHomonyms)
43            # uncoverable pod
44
1078
0
2374
    my ( $self, @args ) = @_;
45
46
1078
1118
    my $method =
47      'dump_as_' . ( $self->should_dump_as_pairs(@args) ? 'pairs' : 'list' );
48
49
1078
1308
    my $dump = $self->$method( 1, @args );
50
51
1078
3462
    if ( defined $self->{max_length}
52        and length($dump) > $self->{max_length} )
53    {
54
10
16
        my $max_length = $self->{max_length} - ELLIPSIS_LEN;
55
10
20
        $max_length = 0 if $max_length < 0;
56
10
18
        substr $dump, $max_length, length($dump) - $max_length, ELLIPSIS;
57    }
58
59
1078
2626
    return $dump;
60}
61
62sub should_dump_as_pairs {
63    # uncoverable pod
64
1078
0
739
    my ( $self, @what ) = @_;
65
66
1078
1407
    return unless $self->{pairs};
67
68
1033
1828
    return if @what % 2 != 0;  # must be an even list
69
70
406
820
415
761
    for my $i ( grep { $_ % 2 == 0 } 0 .. @what ) {
71
550
850
        return if ref $what[$i];  # plain strings are keys
72    }
73
74
343
546
    return 1;
75}
76
77sub dump_as_pairs {
78    # uncoverable pod
79
444
0
356
    my ( $self, $depth, @what ) = @_;
80
81
444
227
    my $truncated;
82
444
1258
    if ( defined $self->{max_elements}
83        and ( @what / 2 ) > $self->{max_elements} )
84    {
85
10
7
        $truncated = 1;
86
10
23
        @what = splice @what, 0, $self->{max_elements} * 2;
87    }
88
89
444
554
    return join
90      $self->{list_delim},
91      $self->_dump_as_pairs( $depth, @what ),
92      ( $truncated ? ELLIPSIS : () );
93}
94
95sub _dump_as_pairs {
96
654
880
    my ( $self, $depth, @what ) = @_;
97
98
654
1623
    return unless @what;
99
100
210
247
    my ( $key, $value, @rest ) = @what;
101
102    return (
103        (
104
210
216
                $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
760
0
614
    my ( $self, $depth, @what ) = @_;
115
116
760
435
    my $truncated;
117
760
1886
    if ( defined $self->{max_elements} and @what > $self->{max_elements} ) {
118
10
11
        $truncated = 1;
119
10
21
        @what = splice @what, 0, $self->{max_elements};
120    }
121
122
1123
1267
    return join
123      $self->{list_delim},
124
760
715
      ( map { $self->format( $depth, $_ ) } @what ),
125      ( $truncated ? ELLIPSIS : () );
126}
127
128sub format {  ## no critic (ProhibitBuiltinHomonyms)
129              # uncoverable pod
130
1358
0
891
    my ( $self, $depth, $value ) = @_;
131
132
1358
3473
    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
210
0
152
    my ( $self, $depth, $key ) = @_;
152
210
367
    return $key;
153}
154
155sub format_ref {
156    # uncoverable pod
157
161
0
107
    my ( $self, $depth, $ref ) = @_;
158
159
161
202
    if ( $depth > $self->{max_depth} ) {
160
10
53
        return overload::StrVal($ref);
161    }
162    else {
163
151
183
        my $reftype = reftype($ref);
164
151
361
        $reftype = 'SCALAR'
165          if $reftype eq 'REF' || $reftype eq 'LVALUE';
166
151
167
        my $method = 'format_' . lc $reftype;
167
168        # uncoverable branch false
169
151
301
        if ( $self->can($method) ) {
170
151
200
            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
25
0
19
    my ( $self, $depth, $array ) = @_;
181
182
25
68
    my $class = blessed($array) || q{};
183
25
33
    $class .= q{=} if $class;
184
185
25
25
29
133
    return $class . '[ ' . $self->dump_as_list( $depth + 1, @{$array} ) . ' ]';
186}
187
188sub format_hash {
189    # uncoverable pod
190
101
0
69
    my ( $self, $depth, $hash ) = @_;
191
192
101
222
    my $class = blessed($hash) || q{};
193
101
129
    $class .= q{=} if $class;
194
195    return
196
101
183
      $class . '{ '
197      . $self->dump_as_pairs( $depth + 1,
198
101
101
100
223
        map { $_ => $hash->{$_} } sort keys %{$hash} )
199      . ' }';
200}
201
202sub format_scalar {
203    # uncoverable pod
204
25
0
24
    my ( $self, $depth, $scalar ) = @_;
205
206
25
65
    my $class = blessed($scalar) || q{};
207
25
34
    $class .= q{=} if $class;
208
209
25
25
32
125
    return $class . q{\\} . $self->format( $depth + 1, ${$scalar} );
210}
211
212sub format_object {
213    # uncoverable pod
214
309
0
224
    my ( $self, $depth, $object ) = @_;
215
216
309
321
    if ( $self->{objects} ) {
217
15
17
        return $self->format_ref( $depth, $object );
218    }
219    else {
220
294
618
        return $self->{stringify} ? "$object" : overload::StrVal($object);
221    }
222}
223
224sub format_number {
225    # uncoverable pod
226
755
0
488
    my ( $self, $depth, $value ) = @_;
227
755
1434
    return "$value";
228}
229
230sub format_string {
231    # uncoverable pod
232
143
0
206
    my ( $self, $depth, $str ) = @_;
233    # FIXME use String::Escape ?
234
235    # remove vertical whitespace
236
143
142
    $str =~ s/\n/\\n/smg;
237
143
113
    $str =~ s/\r/\\r/smg;
238
239    # reformat nonprintables
240
67
67
67
143
5
29146
483
759
181
25
    $str =~ s/ (\P{IsPrint}) /"\\x{" . sprintf("%x", ord($1)) . "}"/xsmge;
241
242
143
583
    return qq{"$str"};
243}
244
245sub format_undef {
246    # uncoverable pod
247
5
0
22
    return 'undef';
248}
249
2501;