File Coverage

blib/lib/Test/Run/Straps.pm
Criterion Covered Total %
statement 248 267 92.8
branch 33 42 78.5
condition n/a
subroutine 65 69 94.2
pod 3 3 100.0
total 349 381 91.6


line stmt bran cond sub pod time code
1             package Test::Run::Straps;
2              
3 14     14   86 use strict;
  14         28  
  14         432  
4 14     14   75 use warnings;
  14         30  
  14         515  
5              
6 14     14   278 use vars qw($VERSION);
  14         31  
  14         769  
7             $VERSION = '0.0304';
8              
9             =head1 NAME
10              
11             Test::Run::Straps - analyse the test results by using TAP::Parser.
12              
13             =head1 METHODS
14              
15             =cut
16              
17 14     14   71 use Moose;
  14         28  
  14         100  
18              
19 14     14   90207 use MRO::Compat;
  14         37  
  14         490  
20              
21             extends('Test::Run::Straps::Base');
22              
23 14     14   75 use Config;
  14         26  
  14         643  
24              
25 14     14   13744 use IPC::System::Simple qw( capturex );
  14         174199  
  14         970  
26              
27 14     14   15319 use TAP::Parser;
  14         728558  
  14         524  
28              
29 14     14   8772 use Test::Run::Straps::EventWrapper;
  14         65  
  14         583  
30 14     14   10461 use Test::Run::Straps::StrapsTotalsObj;
  14         59  
  14         651  
31              
32 14     14   78 use Test::Run::Obj::Error;
  14         34  
  14         44012  
33              
34             has 'bailout_reason' => (is => "rw", isa => "Str");
35             has 'callback' => (is => "rw", isa => "Maybe[CodeRef]");
36             has 'Debug' => (is => "rw", isa => "Bool");
37             has 'error' => (is => "rw", isa => "Any");
38             has 'exception' => (is => "rw", isa => "Any");
39             has 'file' => (is => "rw", isa => "Str");
40             has '_file_totals' =>
41             (is => "rw", isa => "Test::Run::Straps::StrapsTotalsObj");
42             has '_is_macos' => (is => "rw", isa => "Bool",
43             default => sub { return ($^O eq "MacOS"); },
44             );
45             has '_is_win32' => (is => "rw", isa => "Bool",
46             default => sub { return ($^O =~ m{\A(?:MS)?Win32\z}); },
47             );
48             has '_is_vms' => (is => "rw", isa => "Bool",
49             default => sub { return ($^O eq "VMS"); },
50             );
51             has 'last_test_print' => (is => "rw", isa => "Bool");
52             has 'next_test_num' => (is => "rw", isa => "Num");
53             has '_old5lib' => (is => "rw", isa => "Maybe[Str]");
54             has '_parser' => (is => "rw", isa => "Maybe[TAP::Parser]");
55             has 'results' =>
56             (is => "rw", isa => "Test::Run::Straps::StrapsTotalsObj");
57             has 'saw_bailout' => (is => "rw", isa => "Bool");
58             has 'saw_header' => (is => "rw", isa => "Bool");
59             has '_seen_header' => (is => "rw", isa => "Num");
60             has 'Switches' => (is => "rw", isa => "Maybe[Str]");
61             has 'Switches_Env' => (is => "rw", isa => "Maybe[Str]");
62             has 'Test_Interpreter' => (is => "rw", isa => "Maybe[Str]");
63             has 'todo' => (is => "rw", isa => "HashRef", default => sub { +{} },);
64             has 'too_many_tests' => (is => "rw", isa => "Bool");
65             has 'totals' =>
66             (is => "rw", isa => "HashRef", default => sub { +{} },);
67              
68              
69             =head2 my $strap = Test::Run::Straps->new();
70              
71             Initialize a new strap.
72              
73             =cut
74              
75             sub _start_new_file
76             {
77 57     57   291 my $self = shift;
78              
79 57         544 $self->_reset_file_state;
80 57         443 my $totals =
81             $self->_init_totals_obj_instance(
82             $self->_get_initial_totals_obj_params(),
83             );
84              
85 57         15099 $self->_file_totals($totals);
86              
87             # Set them up here so callbacks can have them.
88 57         2697 $self->totals()->{$self->file()} = $totals;
89              
90 57         281 return;
91             }
92              
93             sub _calc_next_event
94             {
95 344     344   628 my $self = shift;
96              
97 344         12214 my $event = scalar($self->_parser->next());
98              
99 344 100       470029 if (defined($event))
100             {
101             return
102 289         2365 Test::Run::Straps::EventWrapper->new(
103             {
104             event => $event,
105             },
106             );
107             }
108             else
109             {
110 55         2700 return undef;
111             }
112             }
113              
114             sub _get_next_event
115             {
116 344     344   709 my ($self) = @_;
117              
118 344         1184 return $self->_event($self->_calc_next_event());
119             }
120              
121             sub _get_event_types_cascade
122             {
123 289     289   1441 return [qw(test plan bailout comment)];
124             }
125              
126             =head2 $strap->_inc_seen_header()
127              
128             Increment the _seen_header field. Used by L<Test::Run::Core>.
129              
130             =cut
131              
132             sub _inc_seen_header
133             {
134 52     52   129 my $self = shift;
135              
136 52         242 $self->inc_field('_seen_header');
137              
138 52         154 return;
139             }
140              
141             sub _inc_saw_header
142             {
143 52     52   119 my $self = shift;
144              
145 52         585 $self->inc_field('saw_header');
146              
147 52         189 return;
148             }
149              
150             sub _plan_set_max
151             {
152 52     52   127 my $self = shift;
153              
154 52         2216 $self->_file_totals->max($self->_event->tests_planned());
155              
156 52         211 return;
157             }
158              
159             sub _handle_plan_skip_all
160             {
161 52     52   120 my $self = shift;
162              
163             # If it's a skip-all line.
164 52 100       2108 if ($self->_event->tests_planned() == 0)
165             {
166 3         305 $self->_file_totals->skip_all($self->_event->explanation());
167             }
168              
169 52         925 return;
170             }
171              
172             sub _calc__handle_plan_event__callbacks
173             {
174 52     52   132 my $self = shift;
175              
176 52         484 return [qw(
177             _inc_saw_header
178             _plan_set_max
179             _handle_plan_skip_all
180             )];
181             }
182              
183             sub _handle_plan_event
184             {
185 52     52   256 shift->_run_sequence();
186              
187 52         145 return;
188             }
189              
190             sub _handle_bailout_event
191             {
192 2     2   15 my $self = shift;
193              
194 2         73 $self->bailout_reason($self->_event->explanation());
195 2         78 $self->saw_bailout(1);
196              
197 2         5 return;
198             }
199              
200             sub _handle_comment_event
201             {
202 26     26   69 my $self = shift;
203              
204 26         922 my $test = $self->_file_totals->last_detail();
205 26 100       125 if (defined($test))
206             {
207 19         637 $test->append_to_diag($self->_event->comment());
208             }
209              
210 26         69 return;
211             }
212              
213             sub _handle_labeled_test_event
214             {
215 0     0   0 my $self = shift;
216              
217 0         0 return;
218             }
219              
220             sub _on_first_too_many_tests
221             {
222 2     2   9 my $self = shift;
223              
224 2         82 warn "Enormous test number seen [test ", $self->_event->number(), "]\n";
225 2         101 warn "Can't detailize, too big.\n";
226              
227 2         14 return;
228             }
229              
230             sub _handle_enormous_event_num
231             {
232 7     7   11 my $self = shift;
233              
234 7 100       297 if (! $self->too_many_tests())
235             {
236 2         26 $self->_on_first_too_many_tests();
237 2         69 $self->too_many_tests(1);
238             }
239              
240 7         30 return;
241             }
242              
243             sub _handle_test_event
244             {
245 208     208   384 my $self = shift;
246             return $self->_file_totals->handle_event(
247             {
248             event => $self->_event,
249             enormous_num_cb =>
250 7     7   41 sub { return $self->_handle_enormous_event_num(); },
251             }
252 208         7715 );
253              
254 0         0 return;
255             }
256              
257             =head2 $self->_handle_event()
258              
259             Handles the current event according to the list of types in the cascade. It
260             checks each type and if matches calls the appropriate
261             C<_handle_${type}_event> callback. Returns the type of the event that matched.
262              
263             =cut
264              
265             sub _handle_event
266             {
267 289     289   485 my $self = shift;
268              
269 289         11540 my $event = $self->_event;
270              
271 289         512 foreach my $type (@{$self->_get_event_types_cascade()})
  289         1120  
272             {
273 426         5392 my $is_type = "is_" . $type;
274 426 100       2051 if ($event->$is_type())
275             {
276 288         5868 my $handle_type = "_handle_${type}_event";
277 288         1201 $self->$handle_type();
278              
279 288         2347 return $type;
280             }
281             }
282              
283 1         36 return;
284             }
285              
286             sub _invoke_cb
287             {
288 347     347   745 my $self = shift;
289 347         659 my $args = shift;
290              
291 347 100       17273 if ($self->callback())
292             {
293 346         12344 $self->callback()->(
294             $args
295             );
296             }
297             }
298              
299             sub _call_callback
300             {
301 289     289   563 my $self = shift;
302 289         10689 return $self->_invoke_cb(
303             {
304             type => "tap_event",
305             event => $self->_event(),
306             totals => $self->_file_totals(),
307             }
308             );
309             }
310              
311             sub _bump_next
312             {
313 287     287   501 my $self = shift;
314              
315 287 100       10691 if (defined(my $n = $self->_event->get_next_test_number()))
316             {
317 208         9963 $self->next_test_num($n);
318             }
319              
320 287         2786 return;
321             }
322              
323              
324             sub _calc__analyze_event__callbacks
325             {
326 289     289   525 my $self = shift;
327              
328 289         1419 return [qw(
329             _handle_event
330             _call_callback
331             _bump_next
332             )];
333             }
334              
335             sub _analyze_event
336             {
337 289     289   1171 shift->_run_sequence();
338              
339 287         853 return;
340             }
341              
342             sub _events_loop
343             {
344 57     57   144 my $self = shift;
345              
346 57         639 while ($self->_get_next_event())
347             {
348 289         32003 $self->_analyze_event();
349 287 50       10446 last if $self->saw_bailout();
350             }
351              
352 55         5953 return;
353             }
354              
355             sub _end_file
356             {
357 55     55   122 my $self = shift;
358              
359 55         2065 $self->_file_totals->determine_passing();
360              
361 55         2076 $self->_parser(undef);
362 55         2029 $self->_event(undef);
363              
364 55         237 return;
365             }
366              
367             sub _calc__analyze_with_parser__callbacks
368             {
369 57     57   164 my $self = shift;
370              
371 57         589 return [qw(
372             _start_new_file
373             _events_loop
374             _end_file
375             )];
376             }
377              
378             sub _analyze_with_parser
379             {
380 57     57   177 my $self = shift;
381              
382 57         1907 $self->_run_sequence();
383              
384 55         2049 return $self->_file_totals();
385             }
386              
387             sub _get_command_and_switches
388             {
389 60     60   212 my $self = shift;
390              
391 60         652 return [$self->_command(), @{$self->_switches()}];
  60         520  
392             }
393              
394             sub _get_full_exec_command
395             {
396 60     60   168 my $self = shift;
397              
398 60         198 return [ @{$self->_get_command_and_switches()}, $self->file()];
  60         574  
399             }
400              
401             sub _command_line
402             {
403 3     3   8 my $self = shift;
404              
405 3         7 return join(" ", @{$self->_get_full_exec_command()});
  3         13  
406             }
407              
408             sub _create_parser
409             {
410 57     57   109 my $self = shift;
411              
412 57         263 local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
413 57         2978 $self->_invoke_cb({type => "report_start_env"});
414              
415 57         656 my $ret = TAP::Parser->new(
416             {
417             exec => $self->_get_full_exec_command(),
418             }
419             );
420              
421 57         714571 $self->_restore_PERL5LIB();
422              
423 57         4439 return $ret;
424             }
425              
426             =head2 my $results = $self->analyze( $name, \@output_lines)
427              
428             Analyzes the output @output_lines of a given test, to which the name
429             $name is assigned. Returns the results $results of the test - an object of
430             type L<Test::Run::Straps::StrapsTotalsObj> .
431              
432             @output_lines should be the output of the test including newlines.
433              
434             =cut
435              
436             sub analyze
437             {
438 0     0 1 0 my($self, $name, $test_output_orig) = @_;
439              
440             # Assign it here so it won't be passed around.
441 0         0 $self->file($name);
442              
443 0         0 $self->_parser($self->_create_parser($test_output_orig));
444              
445 0         0 return $self->_analyze_with_parser();
446             }
447              
448             sub _init_totals_obj_instance
449             {
450 57     57   195 my ($self, $args) = @_;
451 57         1756 return Test::Run::Straps::StrapsTotalsObj->new($args);
452             }
453              
454             sub _get_initial_totals_obj_params
455             {
456 57     57   138 my $self = shift;
457              
458             return
459             {
460 57         177 (map { $_ => 0 } qw(max seen ok todo skip bonus)),
  342         3665  
461             filename => $self->file(),
462             details => [],
463             _is_vms => $self->_is_vms(),
464             };
465             }
466              
467             sub _is_event_todo
468             {
469 0     0   0 my $self = shift;
470              
471 0         0 return $self->_event->has_todo();
472             }
473              
474             =head2 $strap->analyze_fh()
475              
476             Analyzes a TAP stream based on the TAP::Parser from $self->_create_parser().
477              
478             =cut
479              
480             sub analyze_fh
481             {
482 57     57 1 90 my $self = shift;
483              
484 57         248 $self->_parser($self->_create_parser());
485              
486 57         631 return $self->_analyze_with_parser();
487             }
488              
489             sub _analyze_fh_wrapper
490             {
491 57     57   200 my $self = shift;
492              
493             eval
494 57         98 {
495 57         245 $self->results($self->analyze_fh());
496             };
497 57         2946 $self->exception($@);
498              
499 57         128 return;
500             }
501              
502             sub _throw_trapped_exception
503             {
504 57     57   207 my $self = shift;
505              
506 57 100       1961 if ($self->exception() ne "")
507             {
508 2         75 die $self->exception();
509             }
510              
511 55         116 return;
512             }
513              
514             sub _cleanup_analysis
515             {
516 57     57   128 my ($self) = @_;
517              
518 57         258 $self->_throw_trapped_exception();
519              
520 55         1817 $self->results()->_calc_all_process_status();
521              
522 55         116 return;
523             }
524              
525             =head2 $strap->analyze_file($filename)
526              
527             Runs and analyzes the program file C<$filename>. It will also use it
528             as the name in the final report.
529              
530             =cut
531              
532             sub analyze_file
533             {
534 57     57 1 128 my ($self, $file) = @_;
535              
536             # Assign it here so it won't be passed around.
537 57         2025 $self->file($file);
538              
539 57         299 $self->_analyze_fh_wrapper();
540              
541 57         468 $self->_cleanup_analysis();
542              
543 55         1909 return $self->results();
544             }
545              
546             sub _default_inc
547             {
548 60     60   99 my $self = shift;
549              
550             # Temporarily nullify PERL5LIB so Perl will not report the paths
551             # that it contains.
552 60         404 local $ENV{PERL5LIB};
553              
554 60         103 my $perl_includes;
555              
556 60         617 my @includes = capturex( $^X, "-e", qq{print join("\\n", \@INC);} );
557 60         672485 chomp(@includes);
558              
559 60         2219 return \@includes;
560             }
561              
562             =head2 $strap->_filtered_INC(\@inc)
563              
564             Filters @inc so it will fit into the environment of some operating systems
565             which limit it (such as VMS).
566              
567             =cut
568              
569             sub _filtered_INC
570             {
571 60     60   129 my ($self, $inc_param) = @_;
572              
573 60 50       1119 my @inc = $inc_param ? @$inc_param : @INC;
574              
575 60 50       2230 if ($self->_is_vms())
    50          
576             {
577 0         0 @inc = grep { !m{perl_root}i } @inc;
  0         0  
578             }
579             elsif ($self->_is_win32())
580             {
581 0         0 foreach my $path (@inc)
582             {
583 0         0 $path =~ s{[\\/]+\z}{}ms;
584             }
585             }
586              
587 60         121 my %seen;
588              
589 60         105 %seen = (map { $_ => 1} @{$self->_default_inc()});
  300         2890  
  60         253  
590 60         568 @inc = (grep { ! $seen{$_}++ } @inc);
  752         5894  
591              
592 60         1545 return \@inc;
593             }
594              
595             =head2 [@filtered] = $strap->_clean_switches(\@switches)
596              
597             Returns trimmed and blank-filtered switches from the user.
598              
599             =cut
600              
601             sub _trim
602             {
603 398     398   688 my $s = shift;
604              
605 398 50       971 if (!defined($s))
606             {
607 0         0 return ();
608             }
609 398         964 $s =~ s{\A\s+}{}ms;
610 398         794 $s =~ s{\s+\z}{}ms;
611              
612 398         1168 return ($s);
613             }
614              
615             sub _split_switches
616             {
617 60     60   169 my $self = shift;
618 60         131 my $switches = shift;
619              
620             return
621             [
622             map
623 398         793 { my $s = $_; $s =~ s{\A"(.*)"\z}{$1}; $s }
  398         1881  
  398         1733  
624             map
625 62         952 { split(/\s+/, $_) }
626             grep
627 60         184 { defined($_) }
  120         375  
628             @$switches
629             ];
630             }
631              
632             sub _clean_switches
633             {
634 60     60   159 my ($self, $switches) = @_;
635              
636 60         153 return [grep { length($_) } map { _trim($_) } @$switches];
  398         1032  
  398         905  
637             }
638              
639             sub _get_shebang
640             {
641 60     60   154 my($self) = @_;
642              
643 60         2912 my $file = $self->file();
644              
645 60         134 my $test_fh;
646 60 100       4970 if (!open($test_fh, $file))
647             {
648 1         81 $self->_handle_test_file_opening_error(
649             {
650             file => $file,
651             error => $!,
652             }
653             );
654 1         10 return "";
655             }
656 59         1138 my $shebang = <$test_fh>;
657 59 50       784 if (!close($test_fh))
658             {
659 0         0 $self->_handle_test_file_closing_error(
660             {
661             file => $file,
662             error => $!,
663             }
664             );
665             }
666 59         448 return $shebang;
667             }
668              
669             =head2 $self->_command()
670              
671             Returns the command (the command-line executable) that will run the test
672             along with L<_switches()>.
673              
674             Normally returns $^X, but can be over-rided using the C<Test_Interpreter>
675             accessor.
676              
677             This method can be over-rided in custom test harnesses in order to run
678             using different TAP producers than Perl.
679              
680             =cut
681              
682             sub _command
683             {
684 60     60   222 my $self = shift;
685              
686 60 100       3160 if (defined(my $interp = $self->Test_Interpreter()))
687             {
688             return
689 1 50       31 +(ref($interp) eq "ARRAY")
690             ? (@$interp)
691             : (split(/\s+/, $interp))
692             ;
693             }
694             else
695             {
696 59         487 return $self->_default_command($^X);
697             }
698             }
699              
700             sub _default_command
701             {
702 59     59   174 my $self = shift;
703 59         200 my $path = shift;
704              
705 59 50       2914 if ($self->_is_win32())
706             {
707 0         0 return Win32::GetShortPathName($path);
708             }
709             else
710             {
711 59         220 return $path;
712             }
713             }
714              
715             sub _handle_test_file_opening_error
716             {
717 1     1   3 my ($self, $args) = @_;
718              
719 1         12 $self->_invoke_cb({type => "test_file_opening_error", %$args});
720             }
721              
722             sub _handle_test_file_closing_error
723             {
724 0     0   0 my ($self, $args) = @_;
725              
726 0         0 $self->_invoke_cb({type => "test_file_closing_error", %$args});
727             }
728              
729             =head2 $strap->_restore_PERL5LIB()
730              
731             Restores the old value of PERL5LIB. This is necessary on VMS. Does not
732             do anything on other platforms.
733              
734             =cut
735              
736             sub _restore_PERL5LIB
737             {
738 106     106   457 my $self = shift;
739              
740 106 50       8176 if ($self->_is_vms())
741             {
742 0         0 $ENV{PERL5LIB} = $self->_old5lib();
743             }
744              
745 106         545 return;
746             }
747              
748             =head2 $self->_reset_file_state()
749              
750             Reset some fields so it will be ready to process the next file.
751              
752             =cut
753              
754             sub _calc_reset_file_state
755             {
756 57     57   140 my $self = shift;
757              
758             return
759             {
760 57         1363 too_many_tests => undef(),
761             todo => +{},
762             saw_header => 0,
763             saw_bailout => 0,
764             bailout_reason => "",
765             next_test_num => 1,
766             };
767             }
768              
769             sub _reset_file_state
770             {
771 57     57   140 my $self = shift;
772              
773 57         402 my $to = $self->_calc_reset_file_state();
774              
775 57         407 while (my ($field, $value) = each(%$to))
776             {
777 342         17667 $self->$field($value);
778             }
779              
780 57         249 return;
781             }
782              
783             sub _calc_existing_switches
784             {
785 60     60   150 my $self = shift;
786              
787 60         2772 return $self->_clean_switches(
788             $self->_split_switches(
789             [$self->Switches(), $self->Switches_Env()]
790             )
791             );
792             }
793              
794             sub _calc_taint_flag
795             {
796 60     60   160 my $self = shift;
797              
798 60         312 my $shebang = $self->_get_shebang();
799              
800 60 100       478 if ($shebang =~ m{^#!.*\bperl.*\s-\w*([Tt]+)})
801             {
802 3         27 return ($1);
803             }
804             else
805             {
806 57         280 return;
807             }
808             }
809              
810             sub _calc_derived_switches
811             {
812 60     60   143 my $self = shift;
813              
814 60 100       375 if (my ($t) = $self->_calc_taint_flag())
815             {
816 3         18 return ["-$t", map { "-I$_" } @{$self->_filtered_INC()}];
  19         556  
  3         22  
817             }
818             else
819             {
820 57         3176 return [];
821             }
822             }
823              
824             =head2 $self->_switches()
825              
826             Calculates and returns the switches necessary to run the test.
827              
828             =cut
829              
830             sub _switches
831             {
832 60     60   158 my $self = shift;
833              
834             return
835             [
836 60         512 @{$self->_calc_existing_switches()},
837 60         145 @{$self->_calc_derived_switches()},
  60         410  
838             ];
839             }
840              
841             =head2 local $ENV{PERL5LIB} = $self->_INC2PERL5LIB()
842              
843             Takes the calculated library paths for running the test scripts and returns
844             it as something that one can assign to the PERL5LIB environment variable.
845              
846             =cut
847              
848             sub _INC2PERL5LIB
849             {
850 57     57   90 my $self = shift;
851              
852 57         2143 $self->_old5lib($ENV{PERL5LIB});
853              
854 57         1534 return join($Config{path_sep}, @{$self->_filtered_INC()});
  57         329  
855             }
856              
857              
858             1;
859              
860             =head1 LICENSE
861              
862             This file is licensed under the MIT X11 License:
863              
864             http://www.opensource.org/licenses/mit-license.php
865              
866             =head1 AUTHOR
867              
868             Shlomi Fish, L<http://www.shlomifish.org/> .