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 | 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 | |||||||
18 | use constant { | ||||||
19 | 73 | 179 | ELLIPSIS => '...', | ||||
20 | ELLIPSIS_LEN => 3, | ||||||
21 | 73 73 | 56 45686 | }; | ||||
22 | |||||||
23 | sub 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 | |||||||
42 | sub 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 | |||||||
62 | sub 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 | |||||||
77 | sub 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 | |||||||
95 | sub _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 | |||||||
112 | sub 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 | |||||||
128 | sub 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 | |||||||
149 | sub format_key { | ||||||
150 | # uncoverable pod | ||||||
151 | 210 | 0 | 152 | my ( $self, $depth, $key ) = @_; | |||
152 | 210 | 367 | return $key; | ||||
153 | } | ||||||
154 | |||||||
155 | sub 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 | |||||||
178 | sub 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 | |||||||
188 | sub 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 | |||||||
202 | sub 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 | |||||||
212 | sub 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 | |||||||
224 | sub format_number { | ||||||
225 | # uncoverable pod | ||||||
226 | 755 | 0 | 488 | my ( $self, $depth, $value ) = @_; | |||
227 | 755 | 1434 | return "$value"; | ||||
228 | } | ||||||
229 | |||||||
230 | sub 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 | |||||||
245 | sub format_undef { | ||||||
246 | # uncoverable pod | ||||||
247 | 5 | 0 | 22 | return 'undef'; | |||
248 | } | ||||||
249 | |||||||
250 | 1; |