File Coverage

blib/lib/Test/Run/Plugin/CmdLine/Output.pm
Criterion Covered Total %
statement 173 187 92.5
branch 20 26 76.9
condition 2 5 40.0
subroutine 59 63 93.6
pod 1 1 100.0
total 255 282 90.4


line stmt bran cond sub pod time code
1             package Test::Run::Plugin::CmdLine::Output;
2              
3 13     13   73 use strict;
  13         28  
  13         456  
4 13     13   74 use warnings;
  13         31  
  13         438  
5              
6 13     13   71 use Carp;
  13         27  
  13         1109  
7 13     13   11628 use Benchmark qw(timestr);
  13         63246  
  13         93  
8 13     13   1679 use MRO::Compat;
  13         31  
  13         129  
9              
10 13     13   316 use Moose;
  13         29  
  13         112  
11             extends("Test::Run::Core");
12              
13 13     13   96847 use Test::Run::Output;
  13         49  
  13         321  
14              
15             =head1 NAME
16              
17             Test::Run::Plugin::CmdLine::Output - the default output plugin for
18             Test::Run::CmdLine.
19              
20             =head1 MOTIVATION
21              
22             This class has gradually re-implemented all of the
23             L<Test::Run::Plugin::CmdLine::Output::GplArt> functionality to
24             avoid license complications.
25              
26             =head1 METHODS
27              
28             =cut
29              
30             sub _get_new_output
31             {
32 50     50   102 my ($self, $args) = @_;
33              
34 50         1792 return Test::Run::Output->new({ Verbose => $self->Verbose(), NoTty => $self->NoTty()});
35             }
36              
37             sub _print
38             {
39 131     131   7905 my ($self, $string) = @_;
40              
41 131         5422 return $self->output()->print_message($string);
42             }
43              
44             sub _named_printf
45             {
46 60     60   495 my ($self, $format, $args) = @_;
47              
48             return
49 60         374 $self->_print(
50             $self->_format($format, $args),
51             );
52             }
53              
54             has "+output" => (lazy => 1, builder => "_get_new_output");
55              
56             =head2 BUILD
57              
58             For Moose.
59              
60             =cut
61              
62             sub BUILD
63             {
64 52     52 1 637 my $self = shift;
65              
66 52         129 my ($args) = @_;
67              
68             {
69 52         760 my %formatters =
70             (
71             "dubious_status" =>
72             "Test returned status %(estatus)s (wstat %(wstatus)d, 0x%(wstatus)x)",
73             "vms_status" =>
74             "\t\t(VMS status is %(estatus)s)",
75             "test_file_closing_error" =>
76             "can't close %(file)s. %(error)s",
77             "could_not_run_script" =>
78             "can't run %(file)s. %(error)s",
79             "test_file_opening_error" =>
80             "can't open %(file)s. %(error)s",
81             "premature_test_dubious_summary" =>
82             "DIED. %(canonfailed)s",
83             "report_skipped_test" =>
84             "%(ml)sok%(elapsed)s\n %(all_skipped_test_msgs)s",
85             "report_all_ok_test" =>
86             "%(ml)sok%(elapsed)s",
87             "start_env" =>
88             "# PERL5LIB=%(p5lib)s",
89             );
90              
91 52         308 while (my ($id, $format) = each(%formatters))
92             {
93 468         1438 $self->_register_formatter($id, $format);
94             }
95             }
96              
97             {
98 52         110 my %obj_formatters =
  52         112  
  52         358  
99             (
100             "skipped_msg" =>
101             "%(skipped)s/%(max)s skipped: %(skip_reason)s",
102             "bonus_msg" =>
103             "%(bonus)s/%(max)s unexpectedly succeeded",
104             "report_final_stats" =>
105             "Files=%(files)d, Tests=%(max)d, %(bench_timestr)s",
106             );
107              
108 52         239 while (my ($id, $format) = each(%obj_formatters))
109             {
110 156         718 $self->_register_obj_formatter(
111             { name => $id, format => $format,},
112             );
113             }
114             }
115              
116 52         213 return 0;
117             }
118              
119             sub _get_dubious_message_ml
120             {
121 6     6   17 my $self = shift;
122 6         215 return $self->last_test_obj->ml();
123             }
124              
125             sub _get_dubious_verdict_message
126             {
127 6     6   41 return "dubious";
128             }
129              
130             sub _calc__get_dubious_message_components__callbacks
131             {
132 6     6   18 my $self = shift;
133              
134 6         61 return [qw(
135             _get_dubious_message_ml
136             _get_dubious_verdict_message
137             _get_dubious_message_line_end
138             _get_dubious_status_message_indent_prefix
139             _get_dubious_status_message
140             )];
141             }
142              
143             sub _get_dubious_message_components
144             {
145 6     6   21 my $self = shift;
146              
147 6         44 return $self->_run_sequence([@_]);
148             }
149              
150             sub _get_dubious_message_line_end
151             {
152 6     6   30 return "\n";
153             }
154              
155             sub _get_dubious_status_message_indent_prefix
156             {
157 6     6   34 return "\t";
158             }
159              
160             sub _get_dubious_status_message
161             {
162 6     6   16 my $self = shift;
163              
164 6         51 return $self->_format("dubious_status",
165             {
166             estatus => $self->_get_estatus(),
167             wstatus => $self->_get_wstatus(),
168             }
169             );
170             }
171              
172             sub _get_dubious_message
173             {
174 6     6   22 my $self = shift;
175              
176             return join("",
177 6         27 @{$self->_get_dubious_message_components()}
  6         67  
178             );
179             }
180              
181             sub _report_dubious_summary_all_subtests_successful
182             {
183 1     1   7 my $self = shift;
184              
185 1         8 $self->_print("\tafter all the subtests complete successfully");
186             }
187              
188             sub _vms_specific_report_dubious
189             {
190 6     6   21 my ($self) = @_;
191              
192 6 50       67 if ($^O eq "VMS")
193             {
194 0         0 $self->_named_printf(
195             "vms_status",
196             { estatus => $self->_get_estatus() },
197             );
198             }
199             }
200              
201             sub _report_dubious
202             {
203 6     6   25 my ($self) = @_;
204              
205 6         66 $self->_print($self->_get_dubious_message());
206 6         50 $self->_vms_specific_report_dubious();
207             }
208              
209             sub _get_leaked_files_string
210             {
211 1     1   3 my ($self, $args) = @_;
212              
213 1         4 return join(" ", sort @{$args->{leaked_files}});
  1         9  
214             }
215              
216             sub _report_leaked_files
217             {
218 1     1   4 my ($self, $args) = @_;
219              
220 1         13 $self->_print("LEAKED FILES: " . $self->_get_leaked_files_string($args));
221             }
222              
223             sub _handle_test_file_closing_error
224             {
225 0     0   0 my ($self, $args) = @_;
226              
227 0         0 return $self->_named_printf(
228             "test_file_closing_error",
229             $args,
230             );
231             }
232              
233             sub _report_could_not_run_script
234             {
235 0     0   0 my ($self, $args) = @_;
236              
237 0         0 return $self->_named_printf(
238             "could_not_run_script",
239             $args,
240             );
241             }
242              
243             sub _handle_test_file_opening_error
244             {
245 0     0   0 my ($self, $args) = @_;
246              
247 0         0 return $self->_named_printf(
248             "test_file_opening_error",
249             $args,
250             );
251             }
252              
253             sub _get_defined_skipped_msgs
254             {
255 5     5   22 my ($self, $args) = @_;
256              
257 5         169 return $self->_format("skipped_msg", { obj => $self->last_test_obj});
258             }
259              
260             sub _get_skipped_msgs
261             {
262 11     11   27 my ($self, $args) = @_;
263              
264 11 100       359 if ($self->last_test_obj->skipped())
265             {
266 5         43 return [ $self->_get_defined_skipped_msgs() ];
267             }
268             else
269             {
270 6         21 return [];
271             }
272             }
273              
274             sub _get_defined_bonus_msg
275             {
276 7     7   17 my ($self, $args) = @_;
277              
278 7         264 return $self->_format("bonus_msg", { obj => $self->last_test_obj() });
279             }
280              
281             sub _get_bonus_msgs
282             {
283 11     11   25 my ($self, $args) = @_;
284              
285             return
286             [
287 11 100       379 ($self->last_test_obj->bonus()) ?
288             $self->_get_defined_bonus_msg() :
289             ()
290             ];
291             }
292              
293             sub _get_all_skipped_test_msgs
294             {
295 11     11   28 my ($self) = @_;
296             return
297             [
298 11         78 @{$self->_get_skipped_msgs()},
299 11         22 @{$self->_get_bonus_msgs()}
  11         137  
300             ];
301             }
302              
303             sub _reset_output_watch
304             {
305 57     57   114 my $self = shift;
306              
307 57         2517 $self->output()->last_test_print(0);
308              
309 57         113 return;
310             }
311              
312             sub _output__get_display_filename_param
313             {
314 60     60   118 my ($self, $args) = @_;
315              
316 60         302 return $self->_get_test_file_display_path($args->{test_file});
317             }
318              
319             sub _output_print_leader
320             {
321 60     60   122 my ($self, $args) = @_;
322              
323 60         2458 $self->output()->print_leader(
324             {
325             filename => $self->_output__get_display_filename_param($args),
326             width => $self->width(),
327             }
328             );
329              
330 60         287 return;
331             }
332              
333             sub _report_single_test_file_start_leader
334             {
335 57     57   118 my ($self, $args) = @_;
336              
337 57         279 $self->_reset_output_watch($args);
338 57         245 $self->_output_print_leader($args);
339             }
340              
341             sub _report_single_test_file_start_debug
342             {
343 57     57   112 my ($self, $args) = @_;
344              
345 57 100       2065 if ($self->Debug())
346             {
347 3         110 $self->_print(
348             "# Running: " . $self->Strap()->_command_line($self->_output_print_leader($args))
349             );
350             }
351             }
352              
353             sub _report_single_test_file_start
354             {
355 57     57   122 my ($self, $args) = @_;
356              
357 57         267 $self->_report_single_test_file_start_leader($args);
358              
359 57         247 $self->_report_single_test_file_start_debug($args);
360              
361 57         165 return;
362             }
363              
364             sub _calc_test_struct_ml
365             {
366 55     55   123 my $self = shift;
367              
368 55         2346 return $self->output->ml;
369             }
370              
371              
372             sub _report_premature_test_dubious_summary
373             {
374 2     2   11 my $self = shift;
375              
376 2         19 $self->_named_printf(
377             "premature_test_dubious_summary",
378             {
379             canonfailed => $self->_ser_failed_results(),
380             }
381             );
382              
383 2         19 return;
384             }
385              
386             sub _report_skipped_test
387             {
388 11     11   28 my $self = shift;
389              
390             $self->_named_printf(
391             "report_skipped_test",
392             {
393             ml => $self->last_test_obj->ml(),
394             elapsed => $self->last_test_elapsed,
395             all_skipped_test_msgs =>
396 11         398 join(', ', @{$self->_get_all_skipped_test_msgs()}),
  11         77  
397             }
398             );
399             }
400              
401             sub _report_all_ok_test
402             {
403 22     22   71 my ($self, $args) = @_;
404              
405 22         782 $self->_named_printf(
406             "report_all_ok_test",
407             {
408             ml => $self->last_test_obj->ml(),
409             elapsed => $self->last_test_elapsed,
410             }
411             );
412             }
413              
414             sub _report_failed_before_any_test_output
415             {
416 1     1   7 my $self = shift;
417              
418 1         16 $self->_print("FAILED before any test output arrived");
419             }
420              
421             sub _report_all_skipped_test
422             {
423 3     3   12 my ($self, $args) = @_;
424              
425 3         109 $self->_print(
426             "skipped\n all skipped: "
427             . $self->last_test_obj->get_reason()
428             );
429             }
430              
431             sub _namelenize_string
432             {
433 7     7   23 my ($self, $string) = @_;
434              
435 7         47 $string =~ s/\$\{max_namelen\}/$self->max_namelen()/ge;
  7         304  
436              
437 7         45 return $string;
438             }
439              
440             sub _obj_named_printf
441             {
442 7     7   29 my ($self, $string, $obj) = @_;
443              
444             return
445 7         52 $self->_print(
446             $self->_get_obj_formatter(
447             $self->_namelenize_string(
448             $string,
449             ),
450             )->obj_format($obj)
451             );
452             }
453              
454             sub _fail_other_report_tests_print_summary
455             {
456 7     7   23 my ($self, $args) = @_;
457              
458             return $self->_obj_named_printf(
459             ( "%(name)-\${max_namelen}s "
460             . "%(estat)3s %(wstat)5s %(max_str)5s %(failed_str)4s "
461             . "%(_defined_percent)6.2f%% %(first_canon_string)s"
462             ),
463             $args->{test},
464 7         70 );
465             }
466              
467             sub _fail_other_report_test_print_rest_of_canons
468             {
469 7     7   13 my ($self, $args) = @_;
470              
471 7         16 my $test = $args->{test};
472              
473 7         250 my $whitespace = (" " x ($self->format_columns() - $self->list_len()));
474              
475 7         13 foreach my $canon (@{$test->rest_of_canons()})
  7         45  
476             {
477 0         0 $self->_print($whitespace.$canon);
478             }
479             }
480              
481             sub _fail_other_report_test
482             {
483 7     7   15 my $self = shift;
484 7         13 my $script = shift;
485              
486 7         246 my $test = $self->failed_tests()->{$script};
487              
488 7         88 $test->_assign_canon_strings({ main => $self, });
489              
490 7         45 my $args_to_pass =
491             {
492             test => $test,
493             script => $script,
494             };
495              
496 7         62 $self->_fail_other_report_tests_print_summary($args_to_pass);
497              
498 7         81 $self->_fail_other_report_test_print_rest_of_canons($args_to_pass);
499             }
500              
501             sub _calc_fail_other_bonus_message
502             {
503 7     7   15 my $self = shift;
504              
505 7   50     271 my $message = $self->_bonusmsg() || "";
506 7         16 $message =~ s{\A,\s*}{};
507              
508 7 50       51 return $message ? "$message." : "";
509             }
510              
511             sub _fail_other_print_bonus_message
512             {
513 7     7   12 my $self = shift;
514              
515 7 50       38 if (my $bonusmsg = $self->_calc_fail_other_bonus_message())
516             {
517 0         0 $self->_print($bonusmsg);
518             }
519             }
520              
521             sub _report_failed_with_results_seen
522             {
523 12     12   38 my ($self) = @_;
524              
525 12         94 $self->_print($self->_get_failed_with_results_seen_msg());
526             }
527              
528             sub _report_test_progress__verdict
529             {
530 208     208   351 my ($self, $args) = @_;
531              
532 208         418 my $totals = $args->{totals};
533              
534 208 100       626 if ($totals->last_detail->ok)
535             {
536 180         7671 $self->output->print_ml_less(
537             "ok ". $totals->seen . "/" . $totals->max
538             );
539             }
540             else
541             {
542 28         1121 $self->output->print_ml("NOK " . $totals->seen);
543             }
544             }
545              
546             sub _report_test_progress__counter
547             {
548 208     208   416 my ($self, $args) = @_;
549              
550 208         415 my $totals = $args->{totals};
551              
552 208         8311 my $curr = $totals->seen;
553 208         7075 my $next = $self->Strap->next_test_num();
554              
555 208 100       1200 if ($curr > $next)
    100          
556             {
557 6         47 $self->_print("Test output counter mismatch [test $curr]");
558             }
559             elsif ($curr < $next)
560             {
561 9         31 $self->_print(
562 9         81 "Confused test output: test $curr answered after test @{[$next-1]}",
563             );
564             }
565             }
566              
567             sub _report_test_progress
568             {
569 208     208   374 my ($self, $args) = @_;
570 208         837 $self->_report_test_progress__verdict($args);
571 208         908 $self->_report_test_progress__counter($args);
572             }
573              
574             sub _report_tap_event
575             {
576 289     289   510 my ($self, $args) = @_;
577              
578 289         1276 my $raw_event = $args->{event}->raw();
579 289 50       14832 if ($self->Verbose())
580             {
581 0         0 chomp($raw_event);
582 0         0 $self->_print($raw_event);
583             }
584             }
585              
586             sub _calc_PERL5LIB
587             {
588 3     3   16 my $self = shift;
589              
590             return
591             +(exists($ENV{PERL5LIB}) && defined($ENV{PERL5LIB}))
592             ? $ENV{PERL5LIB}
593 3 50 33     115 : ""
594             ;
595             }
596              
597             sub _report_script_start_environment
598             {
599 57     57   220 my $self = shift;
600              
601 57 100       3165 if ($self->Debug())
602             {
603 3         62 $self->_named_printf(
604             "start_env",
605             { 'p5lib' => $self->_calc_PERL5LIB()},
606             );
607             }
608             }
609              
610             sub _report_final_stats
611             {
612 15     15   37 my $self = shift;
613              
614 15         511 return $self->_named_printf(
615             "report_final_stats",
616             { obj => $self->tot() },
617             );
618             }
619              
620             sub _report_success_event
621             {
622 15     15   29 my ($self, $args) = @_;
623              
624 15         96 $self->_print($self->_get_success_msg());
625             }
626              
627             sub _report_non_success_event
628             {
629 0     0   0 my ($self, $args) = @_;
630              
631 0         0 confess "Unknown \$event->{type} passed to _report!";
632             }
633              
634             sub _report
635             {
636 15     15   34 my ($self, $args) = @_;
637              
638 15         38 my $event = $args->{event};
639              
640 15 50       56 if ($event->{type} eq "success")
641             {
642 15         77 return $self->_report_success_event($args);
643             }
644             else
645             {
646 0         0 return $self->_report_non_success_event($args);
647             }
648             }
649              
650             sub _fail_other_print_top
651             {
652 7     7   43 my $self = shift;
653              
654 7         242 $self->_named_printf(
655             \("%(failed)-" . $self->max_namelen() . "s%(middle)s%(list)s") ,
656             {
657             failed => $self->_get_format_failed_str(),
658             middle => $self->_get_format_middle_str(),
659             list => $self->_get_format_list_str(),
660             }
661             );
662              
663 7         319 $self->_print("-" x $self->format_columns());
664             }
665              
666             =head1 LICENSE
667              
668             This file is licensed under the MIT X11 License.
669              
670             L<http://www.opensource.org/licenses/mit-license.php>
671              
672             =cut
673              
674             1;
675