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
47
47
47
182429
37
875
use strict;
14
47
47
47
97
47
788
use warnings;
15
16
47
47
47
101
35
1632
use Scalar::Util qw( looks_like_number reftype blessed );
17
18use constant {
19
47
118
    ELLIPSIS     => '...',
20    ELLIPSIS_LEN => 3,
21
47
47
36
29603
};
22
23sub new {
24    # uncoverable pod
25
74
0
217881
    my ( $class, %args ) = @_;
26
27    # attribute defaults
28    ## no critic (ProhibitMagicNumbers)
29
74
232
    $args{max_length}   = undef unless exists $args{max_length};
30
74
184
    $args{max_elements} = 6     unless exists $args{max_elements};
31
74
156
    $args{max_depth}    = 2     unless exists $args{max_depth};
32
74
167
    $args{stringify}    = 0     unless exists $args{stringify};
33
74
158
    $args{pairs}        = 1     unless exists $args{pairs};
34
74
128
    $args{objects}      = 1     unless exists $args{objects};
35
74
146
    $args{list_delim}   = ', '  unless exists $args{list_delim};
36
74
217
    $args{pair_delim}   = ': '  unless exists $args{pair_delim};
37    ## use critic
38
39
74
202
    return bless \%args, $class;
40}
41
42sub dump {  ## no critic (ProhibitBuiltinHomonyms)
43            # uncoverable pod
44
546
0
1332
    my ( $self, @args ) = @_;
45
46
546
586
    my $method =
47      'dump_as_' . ( $self->should_dump_as_pairs(@args) ? 'pairs' : 'list' );
48
49
546
688
    my $dump = $self->$method( 1, @args );
50
51
546
1780
    if ( defined $self->{max_length}
52        and length($dump) > $self->{max_length} )
53    {
54
6
10
        my $max_length = $self->{max_length} - ELLIPSIS_LEN;
55
6
11
        $max_length = 0 if $max_length < 0;
56
6
11
        substr $dump, $max_length, length($dump) - $max_length, ELLIPSIS;
57    }
58
59
546
1374
    return $dump;
60}
61
62sub should_dump_as_pairs {
63    # uncoverable pod
64
546
0
388
    my ( $self, @what ) = @_;
65
66
546
759
    return unless $self->{pairs};
67
68
519
938
    return if @what % 2 != 0;  # must be an even list
69
70
214
408
219
418
    for my $i ( grep { $_ % 2 == 0 } 0 .. @what ) {
71
296
471
        return if ref $what[$i];  # plain strings are keys
72    }
73
74
199
306
    return 1;
75}
76
77sub dump_as_pairs {
78    # uncoverable pod
79
260
0
217
    my ( $self, $depth, @what ) = @_;
80
81
260
136
    my $truncated;
82
260
743
    if ( defined $self->{max_elements}
83        and ( @what / 2 ) > $self->{max_elements} )
84    {
85
6
5
        $truncated = 1;
86
6
14
        @what = splice @what, 0, $self->{max_elements} * 2;
87    }
88
89
260
330
    return join
90      $self->{list_delim},
91      $self->_dump_as_pairs( $depth, @what ),
92      ( $truncated ? ELLIPSIS : () );
93}
94
95sub _dump_as_pairs {
96
382
546
    my ( $self, $depth, @what ) = @_;
97
98
382
988
    return unless @what;
99
100
122
165
    my ( $key, $value, @rest ) = @what;
101
102    return (
103        (
104
122
130
                $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
362
0
303
    my ( $self, $depth, @what ) = @_;
115
116
362
227
    my $truncated;
117
362
955
    if ( defined $self->{max_elements} and @what > $self->{max_elements} ) {
118
6
7
        $truncated = 1;
119
6
14
        @what = splice @what, 0, $self->{max_elements};
120    }
121
122
557
704
    return join
123      $self->{list_delim},
124
362
348
      ( map { $self->format( $depth, $_ ) } @what ),
125      ( $truncated ? ELLIPSIS : () );
126}
127
128sub format {  ## no critic (ProhibitBuiltinHomonyms)
129              # uncoverable pod
130
694
0
455
    my ( $self, $depth, $value ) = @_;
131
132
694
1877
    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
122
0
87
    my ( $self, $depth, $key ) = @_;
152
122
223
    return $key;
153}
154
155sub format_ref {
156    # uncoverable pod
157
97
0
63
    my ( $self, $depth, $ref ) = @_;
158
159
97
121
    if ( $depth > $self->{max_depth} ) {
160
6
33
        return overload::StrVal($ref);
161    }
162    else {
163
91
117
        my $reftype = reftype($ref);
164
91
225
        $reftype = 'SCALAR'
165          if $reftype eq 'REF' || $reftype eq 'LVALUE';
166
91
102
        my $method = 'format_' . lc $reftype;
167
168        # uncoverable branch false
169
91
185
        if ( $self->can($method) ) {
170
91
119
            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
15
0
14
    my ( $self, $depth, $array ) = @_;
181
182
15
41
    my $class = blessed($array) || q{};
183
15
20
    $class .= q{=} if $class;
184
185
15
15
18
83
    return $class . '[ ' . $self->dump_as_list( $depth + 1, @{$array} ) . ' ]';
186}
187
188sub format_hash {
189    # uncoverable pod
190
61
0
45
    my ( $self, $depth, $hash ) = @_;
191
192
61
138
    my $class = blessed($hash) || q{};
193
61
87
    $class .= q{=} if $class;
194
195    return
196
61
117
      $class . '{ '
197      . $self->dump_as_pairs( $depth + 1,
198
61
61
63
139
        map { $_ => $hash->{$_} } sort keys %{$hash} )
199      . ' }';
200}
201
202sub format_scalar {
203    # uncoverable pod
204
15
0
14
    my ( $self, $depth, $scalar ) = @_;
205
206
15
37
    my $class = blessed($scalar) || q{};
207
15
21
    $class .= q{=} if $class;
208
209
15
15
20
74
    return $class . q{\\} . $self->format( $depth + 1, ${$scalar} );
210}
211
212sub format_object {
213    # uncoverable pod
214
131
0
114
    my ( $self, $depth, $object ) = @_;
215
216
131
150
    if ( $self->{objects} ) {
217
9
10
        return $self->format_ref( $depth, $object );
218    }
219    else {
220
122
286
        return $self->{stringify} ? "$object" : overload::StrVal($object);
221    }
222}
223
224sub format_number {
225    # uncoverable pod
226
397
0
262
    my ( $self, $depth, $value ) = @_;
227
397
722
    return "$value";
228}
229
230sub format_string {
231    # uncoverable pod
232
75
0
64
    my ( $self, $depth, $str ) = @_;
233    # FIXME use String::Escape ?
234
235    # remove vertical whitespace
236
75
74
    $str =~ s/\n/\\n/smg;
237
75
58
    $str =~ s/\r/\\r/smg;
238
239    # reformat nonprintables
240
43
43
43
75
3
18961
320
558
98
15
    $str =~ s/ (\P{IsPrint}) /"\\x{" . sprintf("%x", ord($1)) . "}"/xsmge;
241
242
75
302
    return qq{"$str"};
243}
244
245sub format_undef {
246    # uncoverable pod
247
3
0
12
    return 'undef';
248}
249
2501;