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 | 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 | |||||||
18 | use constant { | ||||||
19 | 60 | 146 | ELLIPSIS => '...', | ||||
20 | ELLIPSIS_LEN => 3, | ||||||
21 | 60 60 | 45 37454 | }; | ||||
22 | |||||||
23 | sub 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 | |||||||
42 | sub 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 | |||||||
62 | sub 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 | |||||||
77 | sub 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 | |||||||
95 | sub _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 | |||||||
112 | sub 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 | |||||||
128 | sub 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 | |||||||
149 | sub format_key { | ||||||
150 | # uncoverable pod | ||||||
151 | 166 | 0 | 118 | my ( $self, $depth, $key ) = @_; | |||
152 | 166 | 302 | return $key; | ||||
153 | } | ||||||
154 | |||||||
155 | sub 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 | |||||||
178 | sub 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 | |||||||
188 | sub 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 | |||||||
202 | sub 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 | |||||||
212 | sub 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 | |||||||
224 | sub format_number { | ||||||
225 | # uncoverable pod | ||||||
226 | 576 | 0 | 381 | my ( $self, $depth, $value ) = @_; | |||
227 | 576 | 1066 | return "$value"; | ||||
228 | } | ||||||
229 | |||||||
230 | sub 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 | |||||||
245 | sub format_undef { | ||||||
246 | # uncoverable pod | ||||||
247 | 4 | 0 | 16 | return 'undef'; | |||
248 | } | ||||||
249 | |||||||
250 | 1; |