File Coverage

blib/lib/Test2/Tools/EventDumper.pm
Criterion Covered Total %
statement 159 160 99.3
branch 84 88 95.4
condition 56 74 75.6
subroutine 18 18 100.0
pod 3 13 23.0
total 320 353 90.6


line stmt bran cond sub pod time code
1             package Test2::Tools::EventDumper;
2 4     4   759977 use strict;
  4         23  
  4         102  
3 4     4   19 use warnings;
  4         7  
  4         146  
4              
5             our $VERSION = '0.000011';
6              
7 4     4   21 use Carp qw/croak/;
  4         7  
  4         162  
8 4     4   20 use Scalar::Util qw/blessed/;
  4         7  
  4         206  
9              
10             our @EXPORT = qw/dump_event dump_events/;
11 4     4   21 use base 'Exporter';
  4         8  
  4         11591  
12              
13             my %QUOTE_MATCH = (
14             '{' => '}',
15             '(' => ')',
16             '[' => ']',
17             '/' => '/',
18             );
19              
20             my %DEFAULTS = (
21             qualify_functions => 0,
22             paren_functions => 0,
23             use_full_event_type => 0,
24             show_empty => 0,
25             add_line_numbers => 0,
26             call_when_can => 1,
27             convert_trace => 1,
28             shorten_single_field => 1,
29             clean_fail_messages => 1,
30              
31             field_order => {
32             name => 1,
33             pass => 2,
34             effective_pass => 3,
35             todo => 4,
36             max => 5,
37             directive => 6,
38             reason => 7,
39             trace => 9999,
40             },
41             array_sort_order => 10000,
42             other_sort_order => 9000,
43              
44             include_fields => undef,
45             exclude_fields => {buffered => 1, nested => 1, in_subtest => 1, is_subtest => 1, subtest_id => 1, hubs => 1},
46              
47             indent_sequence => ' ',
48              
49             adjust_filename => \&adjust_filename,
50             );
51              
52             sub adjust_filename {
53 30729     30729 1 108405 my $file = shift;
54 30729         117698 $file =~ s{^.*[/\\]}{}g;
55 30729         71923 return "match qr{\\Q$file\\E\$}";
56             }
57              
58             sub dump_event {
59 12305     12305 1 18930302 my ($event, %settings) = @_;
60              
61 12305 100       32846 croak "No event to dump"
62             unless $event;
63              
64 12304 100 66     80101 croak "dump_event() requires a Test2::Event (or subclass) instance, Got: $event"
65             unless blessed($event) && $event->isa('Test2::Event');
66              
67 12303 50       41468 my $settings = keys %settings ? parse_settings(\%settings) : \%DEFAULTS;
68              
69 12303         25311 my $out = do_event_dump($event, $settings);
70              
71 12303         27228 return finalize($out, $settings);
72             }
73              
74             sub dump_events {
75 12301     12301 1 149964302 my ($events, %settings) = @_;
76              
77 12301 100       37119 croak "No events to dump"
78             unless $events;
79              
80 12300 100       35200 croak "dump_events() requires an array reference, Got: $events"
81             unless ref($events) eq 'ARRAY';
82              
83             croak "dump_events() requires an array reference of Test2::Event (or subclass) instances, some array elements are not Test2::Event instances"
84 12299 100 66     26463 if grep { !$_ || !blessed($_) || !$_->isa('Test2::Event') } @$events;
  86044         427294  
85              
86 12298 100       51598 my $settings = keys %settings ? parse_settings(\%settings) : \%DEFAULTS;
87              
88 12298         38666 my $out = do_array_dump($events, $settings);
89              
90 12298         31272 return finalize($out, $settings);
91             }
92              
93             sub finalize {
94 24602     24602 0 49598 my ($out, $settings) = @_;
95              
96 24602         187962 $out =~ s[(\s+)$][join '' => grep { $_ eq "\n" } split //, $1]msge;
  172113         442166  
  715548         1821677  
97              
98 24602 100       94964 if ($settings->{add_line_numbers}) {
99 12290         18627 my $line = 1;
100 12290         140310 my $count = length( 0 + map { 1 } split /\n/, $out );
  529199         592230  
101 12290         54264 $out =~ s/^/sprintf("L%0${count}i: ", $line++)/gmse;
  529199         1317186  
102 12290         208220 $out =~ s/^L\d+: $//gms;
103             }
104              
105 24602         170906 return $out;
106             }
107              
108             sub parse_settings {
109 24604     24604 0 48665 my $settings = shift;
110              
111 24604         34594 my %out;
112 24604         97362 my %clone = %$settings;
113              
114 24604         63466 for my $field (qw/field_order include_fields exclude_fields/) {
115 73812 100       152083 next unless exists $clone{$field}; # Nothing to do.
116 24652 100       54533 next unless defined $clone{$field}; # Do not modify an undef
117              
118             # Remove it from the clone
119 24629         41222 my $order = delete $clone{$field};
120              
121 24629 50       119221 croak "settings field '$field' must be either an arrayref or hashref, got: $order"
122             unless ref($order) =~ m/^(ARRAY|HASH)$/;
123              
124 24629         38299 my $count = 1;
125 24629 100       74853 $out{$field} = ref($order) eq 'HASH' ? $order : {map { $_ => $count++ } @$order};
  14         31  
126             }
127              
128             return {
129 24604         277425 %DEFAULTS,
130             %clone,
131             %out,
132             };
133             }
134              
135             sub do_event_dump {
136 135229     135229 0 206764 my ($event, $settings) = @_;
137              
138 135229 100 100     417053 my ($ps, $pe) = ($settings->{qualify_functions} || $settings->{paren_functions}) ? ('(', ')') : (' ', '');
139 135229 100       241551 my $qf = $settings->{qualify_functions} ? "Test2::Tools::Compare::" : "";
140              
141 135229         270394 my $start = "${qf}event${ps}" . render_event($event, $settings);
142              
143 135229         280090 my @fields = get_fields($event, $settings);
144              
145 135229         214057 my @rows = map { get_rows($event, $_, $settings) } @fields;
  497884         884557  
146 135229   33     391577 shift @rows while @rows && !@{$rows[0]}; # Strip leading empty rows
  135229         322508  
147              
148 135229         207827 my $nest = "";
149 135229 50 100     371299 if (@rows == 0) {
    100 66        
150 0         0 $start .= " => {";
151             }
152             elsif (@rows == 1 && $settings->{shorten_single_field} && !$rows[0]->[3]) {
153 2308         3823 $start .= " => {";
154 2308         3788 my ($row) = @rows;
155 2308         4488 $nest = quote_key($row->[1]) . " => $row->[2]";
156             }
157             else {
158 132921         172333 $start .= " => sub {\n";
159              
160 132921         199871 for my $row (@rows) {
161 630852 100       917264 unless (@$row) {
162 73787         97043 $nest .= "\n";
163 73787         111332 next;
164             }
165              
166 557065         886071 my ($func, $field, $qval, $comment) = @$row;
167 557065         750129 my $key = quote_key($field);
168 557065         1231794 $nest .= "${qf}${func}${ps}${key} => ${qval}${pe};";
169 557065 100       905593 $nest .= " # $comment" if $comment;
170 557065         815540 $nest .= "\n";
171             }
172              
173 132921         1231824 $nest =~ s/^/$settings->{indent_sequence}/mg;
174             }
175              
176 135229         733688 return "${start}${nest}}${pe}";
177             }
178              
179             sub do_array_dump {
180 24596     24596 0 46647 my ($array, $settings) = @_;
181              
182 24596 100 100     94364 my ($ps, $pe) = ($settings->{qualify_functions} || $settings->{paren_functions}) ? ('(sub ', ')') : (' ', '');
183 24596 100       52232 my $qf = $settings->{qualify_functions} ? "Test2::Tools::Compare::" : "";
184              
185 24596         51201 my $out = "${qf}array${ps}\{\n";
186              
187 24596         35380 my $nest = "";
188 24596         30259 my $not_first = 0;
189 24596         43238 for my $event (@$array) {
190 122926 100       239232 $nest .= "\n" if $not_first++;
191 122926         204747 $nest .= do_event_dump($event, $settings) . ";\n"
192             }
193 24596         61472 $nest .= "${qf}end();\n";
194 24596         1077875 $nest =~ s/^/$settings->{indent_sequence}/mg;
195              
196 24596         57739 $out .= $nest;
197 24596         37796 $out .= "}${pe}";
198              
199 24596         106897 return $out;
200             }
201              
202             sub quote_val {
203 282780     282780 0 412976 my ($val, $settings) = @_;
204              
205 282780 100       473926 return 'undef' unless defined $val;
206              
207 270490 100       892662 return $val if $val =~ m/^\d+$/;
208              
209             return 'match qr{^\\n?Failed test}'
210 122935 100 100     319178 if $settings->{clean_fail_messages} && $val =~ m/^\n?Failed test/;
211              
212 116787         185056 return quote_str(@_);
213             }
214              
215             sub quote_key {
216 694608     694608 0 1015532 my ($val, $settings) = @_;
217              
218 694608 100       1353711 return $val if $val =~ m/^\d+$/;
219 694607 100       1661765 return $val if $val =~ m/^\w+$/;
220              
221 67592         111551 return quote_str(@_);
222             }
223              
224             sub quote_str {
225 184388     184388 0 272535 my ($val, $settings) = @_;
226              
227 184388         216686 my $use_qq = 0;
228 184388 100       388679 $use_qq = 1 if $val =~ s/\n/\\n/g;
229 184388 100       296356 $use_qq = 1 if $val =~ s/\r/\\r/g;
230 184388 100       312097 $use_qq = 1 if $val =~ s/[\b]/\\b/g;
231              
232 184388         286830 my @delims = ('"', grep {$QUOTE_MATCH{$_}} qw<{ ( [ />);
  737552         1154488  
233 184388 100       436151 unshift @delims => "'" unless $use_qq;
234 184388         243769 my ($s1) = grep { $val !~ m/\Q$_\E/ } @delims;
  1100181         6443361  
235              
236 184388 100       369172 unless($s1) {
237 12290         19030 $s1 = $delims[0];
238 12290         48239 $val =~ s/$s1/\\$s1/g;
239             }
240              
241 184388   66     493093 my $s2 = $QUOTE_MATCH{$s1} || $s1;
242              
243 184388 100       328060 $use_qq = 0 if $s1 eq '"';
244              
245 184388 100 66     468311 my $qq = ($QUOTE_MATCH{$s1} || $use_qq) ? 'qq' : '';
246              
247 184388         693452 return "${qq}${s1}${val}${s2}";
248             }
249              
250             sub render_event {
251 135232     135232 0 207723 my ($event, $settings) = @_;
252 135232         318439 my $type = blessed($event);
253              
254             return quote_key("+$type", $settings)
255             if $settings->{use_full_event_type}
256 135232 100 100     554136 || $type !~ m/^Test2::Event::(.+)$/;
257              
258 67641         122166 return quote_key($1, $settings);
259             }
260              
261             sub get_fields {
262 135229     135229 0 199747 my ($event, $settings) = @_;
263              
264 135229         339331 my @fields = grep { $_ !~ m/^_/ } keys %$event;
  762225         1373897  
265              
266 67589         133128 push @fields => keys %{$settings->{include_fields}}
267 135229 100       300985 if $settings->{include_fields};
268              
269 135229         174684 my %seen;
270 135229   50     248480 my $exclude = $settings->{exclude_fields} || {};
271 135229   100     175485 @fields = grep { !$seen{$_}++ && !$exclude->{$_} } @fields;
  694589         1899147  
272              
273 264404 100 100     875935 @fields = grep { exists $event->{$_} && defined $event->{$_} && length $event->{$_} } @fields
274 135229 100       261556 unless $settings->{show_empty};
275              
276             return sort {
277 135229         350851 my $a_has_array = ref($event->{$a}) eq 'ARRAY';
  588566         877483  
278 588566         757054 my $b_has_array = ref($event->{$b}) eq 'ARRAY';
279              
280 588566 100 66     1101823 my $av = $a_has_array ? $settings->{array_sort_order} : ($settings->{field_order}->{$a} || $settings->{other_sort_order});
281 588566 100 66     1021546 my $bv = $b_has_array ? $settings->{array_sort_order} : ($settings->{field_order}->{$b} || $settings->{other_sort_order});
282              
283 588566   66     1316882 return $av <=> $bv || $a cmp $b;
284             } @fields;
285             }
286              
287             sub get_rows {
288 497884     497884 0 731008 my ($event, $field, $settings) = @_;
289              
290             return ['field', $field, 'DNE()']
291 497884 100       870260 unless exists $event->{$field};
292              
293 485591         589257 my ($func, $val);
294 485591 100 66     1286348 if ($settings->{call_when_can} && $event->can($field)) {
295 242884         327763 $func = 'call';
296 242884         526373 $val = $event->$field;
297             }
298             else {
299 242707         290782 $func = 'field';
300 242707         314646 $val = $event->{$field};
301             }
302              
303 485591 50 100     1914212 if ($settings->{convert_trace} && $field eq 'trace' && blessed($val) && ($val->isa('Test2::Util::Trace') || $val->isa('Test2::EventFacet::Trace'))) {
      66        
      33        
      66        
304 61489         159622 my $file = $settings->{adjust_filename}->($val->file);
305             return (
306 61489         274553 [],
307             [ 'prop', 'file', $file ],
308             [ 'prop', 'line', $val->line ],
309             );
310             }
311              
312 424102         586602 my $ref = ref $val;
313              
314 424102 100       736573 return [ $func, $field, quote_val($val, $settings) ]
315             unless $ref;
316              
317             return ( [], [ $func, $field, do_array_dump($val, $settings) ] )
318 141327 100 66     296660 if $ref eq 'ARRAY' && !grep { !blessed($_) || !$_->isa('Test2::Event') } @$val;
  104469   100     436100  
319              
320 129029   66     554279 return [ $func, $field, 'T()', "Unknown value: " . (blessed($val) || $ref) ];
321             }
322              
323             __END__