File Coverage

blib/lib/Data/Tersify.pm
Criterion Covered Total %
statement 125 126 99.2
branch 52 54 96.3
condition 8 12 66.6
subroutine 16 16 100.0
pod 2 2 100.0
total 203 210 96.6


line stmt bran cond sub pod time code
1             package Data::Tersify;
2              
3 2     2   88005 use strict;
  2         14  
  2         61  
4 2     2   10 use warnings;
  2         4  
  2         52  
5 2     2   9 no warnings 'uninitialized';
  2         4  
  2         78  
6              
7 2     2   907 use parent 'Exporter';
  2         641  
  2         10  
8             our @EXPORT_OK = qw(tersify tersify_many);
9              
10             # Have you updated the version number in the POD below?
11             our $VERSION = '1.001';
12             $VERSION = eval $VERSION;
13              
14 2     2   173 use Carp;
  2         4  
  2         120  
15 2     2   990 use Devel::OverloadInfo 0.005;
  2         28750  
  2         96  
16 2     2   931 use Module::Pluggable require => 1, force_search_all_paths => 1;
  2         17452  
  2         16  
17 2     2   213 use Scalar::Util qw(blessed refaddr reftype);
  2         4  
  2         2502  
18              
19             =head1 NAME
20              
21             Data::Tersify - generate terse equivalents of complex data structures
22              
23             =head1 VERSION
24              
25             This is version 1.001 of Data::Tersify.
26              
27             =head1 SYNOPSIS
28              
29             use Data::Dumper;
30             use Data::Tersify qw(tersify);
31            
32             my $complicated_data_structure = ...;
33            
34             print Dumper(tersify($complicated_data_structure));
35             # Your scrollback is not full of DateTime, DBIx::Class, Moose etc.
36             # spoor which you weren't interested in.
37              
38             =head1 DESCRIPTION
39              
40             Complex data structures are useful; necessary, even. But they're not
41             I. In particular, when you're buried in the guts of some code
42             you don't fully understand and you have a variable you want to inspect,
43             and you say C in the debugger, or C from
44             your code, or something very similar with the dumper module of your choice,
45             and you then get I because C<$foo>
46             contained, I one or more references to a DateTime, DBIx::Class,
47             Moose or other verbose object ... you didn't need that.
48              
49             Data::Tersify looks at any data structure it's given, and if it finds a
50             blessed object that it knows about, anywhere, it replaces it in the data
51             structure by a terser equivalent, designed to (a) not use up all of your
52             scrollback, but (b) be blatantly clear that this is I the original object
53             that was in that data structure originally, but a terser equivalent.
54              
55             Do not use Data::Tersify as part of any serialisation implementation! By
56             design, Data::Tersify is lossy and will throw away information! That's because
57             it supposes that that if you're using it, you want to dump information about a
58             complex data structure, and you don't I about the fine details.
59              
60             If you find yourself saying C in the debugger a lot, consider adding
61             Data::Tersify::perldb to your .perldb file, or something like it.
62              
63             =head2 tersify
64              
65             In: $data_structure
66             In: $terser_data_structure
67              
68             Supplied with a data structure, returns a data structure with the complicated
69             bits summarised. Every attempt is made to preserve those parts of the data
70             structure that don't need summarising.
71              
72             Objects are only summarised if (1) they're blessed objects, (2) they're
73             not the root structure passed to tersify (so if you actually to want to dump a
74             complex DBIx::Class object, for instance, you still can), and (3) a
75             plugin has been registered that groks that type of object, I they
76             contain as an element one such object.
77              
78             Summaries are either scalar references of the form "I (I)
79             I", e.g. "DateTime (0xdeadbeef) 2017-08-15 12:34:56", blessed into the
80             Data::Tersify::Summary class, I copies of the
81             object's internal state with any sub-objects tersified as above, blessed into
82             the Data::Tersify::Summary::I::0xI class, where I is the
83             class the object was originally blessed into and I the object's
84             original address.
85              
86             So, if you had the plugin Data::Tersify::Plugin::DateTime installed,
87             passing a DateTime object to tersify would return that same object, untouched;
88             but passing
89              
90             {
91             name => 'Now',
92             description => 'The time it currently is, not a time in the future',
93             datetime => DateTime->now
94             }
95              
96             to tersify would return something like this:
97              
98             {
99             name => 'Now',
100             description => 'The time it currently is, not a time in the future',
101             datetime => bless \"DateTime (0xdeadbeef) 2018-08-12 17:15:00",
102             "Data::Tersify::Summary",
103             }
104              
105             If the hashref had been blessed into the class "Time::Description",
106             and had a refaddr of 0xcafebabe, you would get back a hash as above, but
107             blessed into the class
108             C.
109              
110             Note that point 2 above (objects aren't tersified if they're the root
111             structure) applies only to plugins. If the object contains other objects
112             that could be tersified, they will be. One design consequence of this is that
113             you should consider writing plugins for I, rather
114             than the ur-object that they might be part of.
115              
116             =cut
117              
118             my (%seen_refaddr, %refaddr_tersified_as, %safe_to_mess_with_refaddr);
119              
120             sub tersify {
121 37     37 1 60224 my ($data_structure) = @_;
122              
123 37         85 %seen_refaddr = ();
124 37         57 %refaddr_tersified_as = ();
125 37         65 %safe_to_mess_with_refaddr = ();
126 37         66 ($data_structure) = _tersify($data_structure);
127 37         88 while (%refaddr_tersified_as) {
128 22         56 my @known_refaddrs = keys %refaddr_tersified_as;
129 22         48 %seen_refaddr = ();
130 22         39 ($data_structure) = _tersify($data_structure);
131 22         86 delete @refaddr_tersified_as{@known_refaddrs};
132             }
133 37         105 return $data_structure;
134             }
135              
136             sub _tersify {
137 285     285   410 my ($data_structure) = @_;
138              
139             # If this is a data structure that we've tersified already, replace it.
140 285 100       744 if (my $terse_object = $refaddr_tersified_as{refaddr($data_structure)}) {
141 13         27 return ($terse_object, 1);
142             }
143              
144             # If this is a simple scalar, there's nothing to change.
145 272 100       545 if (!ref($data_structure)) {
146 64         130 return ($data_structure, 0);
147             }
148              
149             # If it's a reference to something, tersify *that* and take a reference
150             # to it.
151 208 100       389 if (ref($data_structure) eq 'REF') {
152 2         4 my $referenced_data_structure = $$data_structure;
153 2         5 my ($maybe_new_data_structure, $changed)
154             = _tersify($referenced_data_structure);
155 2 100       16 if (!$changed) {
156 1         7 return ($data_structure, 0);
157             }
158 1         2 my $ref = \$maybe_new_data_structure;
159 1         3 return ($ref, 1);
160             }
161              
162             # Don't loop infinitely through a complex structure.
163 206 100       559 return ($data_structure, 0) if $seen_refaddr{refaddr($data_structure)}++;
164            
165             # If this is a blessed object, see if we know how to tersify it.
166 192 100       408 if (blessed($data_structure)) {
167 67         108 my ($object, $changed) = _tersify_object($data_structure);
168 67 100       135 if ($changed) {
169 32         101 $refaddr_tersified_as{refaddr($data_structure)} = $object;
170             }
171 67         178 return ($object, $changed);
172             }
173              
174             # For arrays and hashes, check if any of the elements changed, and if so
175             # create a fresh array or hash.
176 125         154 my $changed;
177             my $get_new_value = sub {
178 208     208   305 my ($old_value) = @_;
179 208         363 my ($new_value, $this_value_changed) = _tersify($old_value);
180 208         312 $changed += $this_value_changed;
181 208 100       510 return $this_value_changed ? $new_value : $old_value;
182 125         415 };
183 125         188 my $new_structure;
184 125 100       299 if (ref($data_structure) eq 'ARRAY') {
    100          
185 14         20 my @new_array;
186 14         23 for my $element (@$data_structure) {
187 55         84 push @new_array, $get_new_value->($element);
188             }
189 14 100       31 if (!$changed) {
190 10         39 return ($data_structure, 0);
191             }
192 4         7 $new_structure = \@new_array;
193             } elsif (ref($data_structure) eq 'HASH') {
194 110         144 my %new_hash;
195 110         245 for my $key (keys %$data_structure) {
196 153         252 $new_hash{$key} = $get_new_value->($data_structure->{$key});
197             }
198 110 100       202 if (!$changed) {
199 71         253 return ($data_structure, 0);
200             }
201 39         63 $new_structure = \%new_hash;
202             } else {
203 1         6 return ($data_structure, 0);
204             }
205              
206             # If it's safe to mess with the existing data structure (e.g. because this
207             # is the second pass, or later, that we've done through a data structure
208             # and this is an arrayref or hashref that we already anonymised earlier),
209             # just update its contents. Otherwise mark it as a new data structure.
210 43 100       109 if (!$safe_to_mess_with_refaddr{refaddr($data_structure)}) {
211 41         80 $refaddr_tersified_as{ refaddr($data_structure) } = $new_structure;
212 41         84 $safe_to_mess_with_refaddr{refaddr($new_structure)} = 1;
213 41         158 return ($new_structure, 1);
214             } else {
215 2         6 _replace_contents_of_structure_with($data_structure,
216             $new_structure);
217 2         10 return ($data_structure, 0);
218             }
219             }
220              
221             sub _tersify_object {
222 67     67   99 my ($data_structure) = @_;
223              
224             # A summary has, by definition, already been tersified.
225 67 100       132 if (ref($data_structure) eq 'Data::Tersify::Summary') {
226 24         54 return ($data_structure, 0);
227             }
228              
229             # We might know how to tersify such an object directly, via a
230             # plugin.
231 43         72 my $terse_object = _tersify_via_plugin($data_structure);
232 43   66     381 my $changed = blessed($terse_object)
233             && $terse_object->isa('Data::Tersify::Summary');
234              
235             # OK, but does it overload stringification?
236 43 100       99 if (!$changed) {
237 19 50       54 if (my $overload_info
238             = Devel::OverloadInfo::overload_info($data_structure))
239             {
240 19 100       21329 if ($overload_info->{'""'}) {
241             return (
242 2         29 _summarise_object_as_string(
243             $data_structure, "$data_structure"
244             ),
245             1
246             );
247             }
248             }
249             }
250              
251             # Although if this is the root structure passed to tersify, we want
252             # to pass it through as-is; we only tersify complicated objects
253             # that feature somewhere deeper in the data structure, possibly
254             # unexpectedly.
255 41         206 my ($caller_sub) = (caller(2))[3];
256 41 100 100     135 if ($changed && $caller_sub ne 'Data::Tersify::tersify') {
257 22         63 return ($terse_object, $changed);
258             }
259              
260             # If we didn't tersify this object, maybe we can tersify its internal
261             # structure?
262 19         27 my $object_contents;
263 19 100       78 if (reftype($data_structure) eq 'HASH') {
    100          
264 14         89 $object_contents = {%$data_structure};
265             } elsif (reftype($data_structure) eq 'ARRAY') {
266 2         5 $object_contents = [@$data_structure];
267             }
268 19 100       41 if ($object_contents) {
269 16         22 my $maybe_new_structure;
270 16         30 ($maybe_new_structure, $changed) = _tersify($object_contents);
271 16 100       37 if ($changed) {
272             # We might need to build a new Data::Tersify::Summary object.
273 8 100       21 if (!$safe_to_mess_with_refaddr{refaddr($data_structure)}) {
274             # No need to remember that we messed with $object_contents;
275             # that was a temporary variable we created purely to see if
276             # we could tersify it, and it's not referenced anywhere.
277 5         13 delete $refaddr_tersified_as{refaddr($object_contents)};
278             # Just create a new blessed object; the calling code will
279             # realise that we created a new object and update
280             # %refaddr_tersified_as with the proper values.
281 5         8 $terse_object = $maybe_new_structure;
282 5         47 bless $terse_object =>
283             sprintf('Data::Tersify::Summary::%s::0x%x',
284             ref($data_structure), refaddr($data_structure));
285 5         13 $safe_to_mess_with_refaddr{refaddr($terse_object)}++;
286             } else {
287             # We can reuse the existing one, which is now *even terser*!
288             # There's no danger of blatting existing data structures,
289             # because we've *already* replaced the previous data structure
290             # with one of ours, as part of generating a new object.
291 3         7 _replace_contents_of_structure_with($data_structure,
292             $maybe_new_structure);
293             }
294 8         28 return ($terse_object, $changed);
295             }
296             }
297              
298             # OK, return this object unchanged.
299 11         33 return ($data_structure, 0);
300             }
301              
302             sub _replace_contents_of_structure_with {
303 5     5   8 my ($safe_structure, $new_contents) = @_;
304              
305 5 100 66     33 if (reftype($safe_structure) eq 'HASH'
    50 33        
306             && reftype($new_contents) eq 'HASH')
307             {
308 3         14 %$safe_structure = %$new_contents;
309             } elsif (reftype($safe_structure) eq 'ARRAY'
310             && reftype($new_contents) eq 'ARRAY')
311             {
312 2         7 @$safe_structure = @$new_contents;
313             } else {
314 0         0 croak sprintf(q{Want to put %s in existing %s, but that's a %s?!},
315             $new_contents, $safe_structure, reftype($new_contents));
316             }
317             }
318              
319             =head2 tersify_many
320              
321             In: @data_structures
322             Out: @terser_data_structures
323              
324             A simple wrapper around L that expects to be passed one or more
325             variables. Note that as each value is passed to L, none of the values
326             in @data_structures will be tersified if they're objects recognised by plugins.
327             (Whereas they would have been if you'd said C.
328              
329             This is intended to be used by e.g. the Perl debugger's x command.
330              
331             =cut
332              
333             sub tersify_many {
334 1     1 1 2588 return map { tersify($_) } @_;
  4         7  
335             }
336              
337             =head2 PLUGINS
338              
339             Data::Tersify can be extended by plugins. See L for
340             a general description of plugins; for examples of plugins, see
341             L and L,
342             provided in separate distributions.
343              
344             =cut
345              
346             {
347             my (%handled_by_plugin);
348              
349             sub _tersify_via_plugin {
350 43     43   63 my ($object) = @_;
351              
352 43 100       102 if (!keys %handled_by_plugin) {
353 1         5 for my $plugin (plugins()) {
354 2         3050 for my $class ($plugin->handles) {
355 3         12 $handled_by_plugin{$class} = $plugin;
356             }
357             }
358             }
359              
360             ### FIXME: subclasses also. Loop the other way, go through
361             ### the types we know about and see if $object->isa(...)
362             ### rather than hard-coding the ref($object).
363 43 100       101 if (my $plugin = $handled_by_plugin{ref($object)}) {
364 24         61 return _summarise_object_as_string($object,
365             $plugin->tersify($object));
366             }
367 19         59 return $object;
368             }
369             }
370              
371             sub _summarise_object_as_string {
372 26     26   317 my ($object, $string) = @_;
373 26         126 my $summary
374             = sprintf('%s (0x%x) %s', ref($object), refaddr($object), $string);
375 26         91 return bless \$summary => 'Data::Tersify::Summary';
376             }
377              
378             =head1 LICENSE
379              
380             This is free software; you can redistribute it and/or modify it under the same
381             terms as Perl 5.
382              
383             =head1 BUGS
384              
385             If you find any bugs, or have any feature suggestions, please report them
386             via L.
387              
388             =head1 SEE ALSO
389              
390             L will tersify data structures as part of its standard
391             output.
392              
393             =cut
394              
395             1;