File: | blib/lib/Test/Mocha/PartialDump.pm |
Coverage: | 100.0% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package 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 | |||||||
18 | use constant { | ||||||
19 | 47 | 118 | ELLIPSIS => '...', | ||||
20 | ELLIPSIS_LEN => 3, | ||||||
21 | 47 47 | 36 29603 | }; | ||||
22 | |||||||
23 | sub 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 | |||||||
42 | sub 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 | |||||||
62 | sub 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 | |||||||
77 | sub 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 | |||||||
95 | sub _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 | |||||||
112 | sub 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 | |||||||
128 | sub 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 | |||||||
149 | sub format_key { | ||||||
150 | # uncoverable pod | ||||||
151 | 122 | 0 | 87 | my ( $self, $depth, $key ) = @_; | |||
152 | 122 | 223 | return $key; | ||||
153 | } | ||||||
154 | |||||||
155 | sub 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 | |||||||
178 | sub 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 | |||||||
188 | sub 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 | |||||||
202 | sub 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 | |||||||
212 | sub 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 | |||||||
224 | sub format_number { | ||||||
225 | # uncoverable pod | ||||||
226 | 397 | 0 | 262 | my ( $self, $depth, $value ) = @_; | |||
227 | 397 | 722 | return "$value"; | ||||
228 | } | ||||||
229 | |||||||
230 | sub 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 | |||||||
245 | sub format_undef { | ||||||
246 | # uncoverable pod | ||||||
247 | 3 | 0 | 12 | return 'undef'; | |||
248 | } | ||||||
249 | |||||||
250 | 1; |