1 package Test2::Formatter::TAP;
5 our $VERSION = '1.302022';
8 use Test2::Util::HashBase qw{
9 no_numbers handles _encoding
17 BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) }
20 'Test2::Event::Ok' => 'event_ok',
21 'Test2::Event::Skip' => 'event_skip',
22 'Test2::Event::Note' => 'event_note',
23 'Test2::Event::Diag' => 'event_diag',
24 'Test2::Event::Bail' => 'event_bail',
25 'Test2::Event::Exception' => 'event_exception',
26 'Test2::Event::Subtest' => 'event_subtest',
27 'Test2::Event::Plan' => 'event_plan',
30 # Initial list of converters are safe for direct hash access cause we control them.
31 my %SAFE_TO_ACCESS_HASH = %CONVERTERS;
35 my ($type, $convert) = @_;
36 croak "Event type is a required argument" unless $type;
37 croak "Event type '$type' already registered" if $CONVERTERS{$type};
38 croak "The second argument to register_event() must be a code reference or method name"
39 unless $convert && (ref($convert) eq 'CODE' || $class->can($convert));
40 $CONVERTERS{$type} = $convert;
49 $self->{+HANDLES} ||= $self->_open_handles;
50 if(my $enc = delete $self->{encoding}) {
51 $self->encoding($enc);
55 sub hide_buffered { 1 }
62 my $handles = $self->{+HANDLES};
64 # https://rt.perl.org/Public/Bug/Display.html?id=31923
65 # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in
66 # order to avoid the thread segfault.
67 if ($enc =~ m/^utf-?8$/i) {
68 binmode($_, ":utf8") for @$handles;
71 binmode($_, ":encoding($enc)") for @$handles;
73 $self->{+_ENCODING} = $enc;
76 return $self->{+_ENCODING};
80 no warnings 'redefine';
84 my ($self, $e, $num) = @_;
88 my $converter = $CONVERTERS{$type} || 'event_other';
89 my @tap = $self->$converter($e, $self->{+NO_NUMBERS} ? undef : $num) or return;
91 my $handles = $self->{+HANDLES};
92 my $nesting = ($SAFE_TO_ACCESS_HASH{$type} ? $e->{nested} : $e->nested) || 0;
93 my $indent = ' ' x $nesting;
95 # Local is expensive! Only do it if we really need to.
96 local($\, $,) = (undef, '') if $\ || $,;
98 no warnings 'uninitialized';
99 my ($hid, $msg) = @$set;
101 my $io = $handles->[$hid] or next;
103 $msg =~ s/^/$indent/mg if $nesting;
111 open( my $out, '>&', STDOUT ) or die "Can't dup STDOUT: $!";
112 open( my $err, '>&', STDERR ) or die "Can't dup STDERR: $!";
122 my $old_fh = select $fh;
131 my $converter = $CONVERTERS{ref($e)} or return;
133 $num = undef if $self->{+NO_NUMBERS};
135 return $self->$converter($e, $num);
142 # We use direct hash access for performance. OK events are so common we
143 # need this to be fast.
144 my ($name, $todo) = @{$e}{qw/name todo/};
145 my $in_todo = defined($todo);
148 $out .= "not " unless $e->{pass};
150 $out .= " $num" if defined($num);
151 $out .= " - $name" if defined $name;
152 $out .= " # TODO" if $in_todo;
153 $out .= " $todo" if defined($todo) && length($todo);
155 # The primary line of TAP, if the test passed this is all we need.
156 return([OUT_STD, "$out\n"]);
164 my $reason = $e->reason;
168 $out .= "not " unless $e->{pass};
170 $out .= " $num" if defined $num;
171 $out .= " - $name" if $name;
172 if (defined($todo)) {
173 $out .= " # TODO & SKIP"
178 $out .= " $reason" if defined($reason) && length($reason);
180 return([OUT_STD, "$out\n"]);
187 chomp(my $msg = $e->message);
191 return [OUT_STD, "$msg\n"];
198 chomp(my $msg = $e->message);
202 return [OUT_ERR, "$msg\n"];
209 return if $e->nested;
213 "Bail out! " . $e->reason . "\n",
217 sub event_exception {
220 return [ OUT_ERR, $e->error ];
227 # A 'subtest' is a subclass of 'ok'. Let the code that renders 'ok' render
229 my ($ok, @diag) = $self->event_ok($e, $num);
231 # If the subtest is not buffered then the sub-events have already been
232 # rendered, we can go ahead and return.
233 return ($ok, @diag) unless $e->buffered;
235 # In a verbose harness we indent the diagnostics from the 'Ok' event since
236 # they will appear inside the subtest braces. This helps readability. In a
237 # non-verbose harness we do not do this because it is less readable.
238 if ($ENV{HARNESS_IS_VERBOSE}) {
239 # index 0 is the filehandle, index 1 is the message we want to indent.
240 $_->[1] =~ s/^(.*\S.*)$/ $1/mg for @diag;
243 # Add the trailing ' {' to the 'ok' line of TAP output.
244 $ok->[1] =~ s/\n/ {\n/;
246 # Render the sub-events, we use our own counter for these.
249 # Bump the count for any event that should bump it.
250 $count++ if $_->increments_count;
252 # This indents all output lines generated for the sub-events.
253 # index 0 is the filehandle, index 1 is the message we want to indent.
254 map { $_->[1] =~ s/^(.*\S.*)$/ $1/mg; $_ } $self->event_tap($_, $count);
258 $ok, # opening ok - name {
259 @diag, # diagnostics if the subtest failed
260 @subs, # All the inner-event lines
261 [OUT_STD(), "}\n"], # } (closing brace)
269 my $directive = $e->directive;
270 return if $directive && $directive eq 'NO PLAN';
272 my $reason = $e->reason;
273 $reason =~ s/\n/\n# /g if $reason;
275 my $plan = "1.." . $e->max;
277 $plan .= " # $directive";
278 $plan .= " $reason" if defined $reason;
281 return [OUT_STD, "$plan\n"];
287 return if $e->no_display;
291 if (my ($max, $directive, $reason) = $e->sets_plan) {
292 my $plan = "1..$max";
293 $plan .= " # $directive" if $directive;
294 $plan .= " $reason" if defined $reason;
295 push @out => [OUT_STD, "$plan\n"];
298 if ($e->increments_count) {
300 $ok .= "not " if $e->causes_fail;
302 $ok .= " $num" if defined($num);
303 $ok .= " - " . $e->summary if $e->summary;
305 push @out => [OUT_STD, "$ok\n"];
308 my $handle = ($e->causes_fail || $e->diagnostics) ? OUT_ERR : OUT_STD;
309 my $summary = $e->summary || ref($e);
311 $summary =~ s/^/# /smg;
312 push @out => [$handle, "$summary\n"];
328 Test2::Formatter::TAP - Standard TAP formatter
332 This is what takes events and turns them into TAP.
336 use Test2::Formatter::TAP;
337 my $tap = Test2::Formatter::TAP->new();
340 $tap->encoding('utf8');
342 $tap->write($event, $number); # Output an event
348 =item $bool = $tap->no_numbers
350 =item $tap->set_no_numbers($bool)
352 Use to turn numbers on and off.
354 =item $arrayref = $tap->handles
356 =item $tap->set_handles(\@handles);
358 Can be used to get/set the filehandles. Indexes are identified by the
359 C<OUT_STD> and C<OUT_ERR> constants.
361 =item $encoding = $tap->encoding
363 =item $tap->encoding($encoding)
365 Get or set the encoding. By default no encoding is set, the original settings
366 of STDOUT and STDERR are used.
368 This directly modifies the stored filehandles, it does not create new ones.
370 =item $tap->write($e, $num)
372 Write an event to the console.
374 =item Test2::Formatter::TAP->register_event($pkg, sub { ... });
376 In general custom events are not supported. There are however occasions where
377 you might want to write a custom event type that results in TAP output. In
378 order to do this you use the C<register_event()> class method.
381 use Test2::Formatter::TAP;
383 use base 'Test2::Event';
384 use Test2::Util::HashBase accessors => [qw/pass name diag note/];
386 Test2::Formatter::TAP->register_event(
392 [Test2::Formatter::TAP::OUT_STD, "ok $num - " . $e->name . "\n"],
393 [Test2::Formatter::TAP::OUT_ERR, "# " . $e->name . " " . $e->diag . "\n"],
394 [Test2::Formatter::TAP::OUT_STD, "# " . $e->name . " " . $e->note . "\n"],
405 All these methods require the event itself. Optionally they can all except a
408 All methods return a list of array-refs. Each array-ref will have 2 items, the
409 first is an integer identifying an output handle, the second is a string that
410 should be written to the handle.
414 =item @out = $TAP->event_ok($e)
416 =item @out = $TAP->event_ok($e, $num)
418 Process an L<Test2::Event::Ok> event.
420 =item @out = $TAP->event_plan($e)
422 =item @out = $TAP->event_plan($e, $num)
424 Process an L<Test2::Event::Plan> event.
426 =item @out = $TAP->event_note($e)
428 =item @out = $TAP->event_note($e, $num)
430 Process an L<Test2::Event::Note> event.
432 =item @out = $TAP->event_diag($e)
434 =item @out = $TAP->event_diag($e, $num)
436 Process an L<Test2::Event::Diag> event.
438 =item @out = $TAP->event_bail($e)
440 =item @out = $TAP->event_bail($e, $num)
442 Process an L<Test2::Event::Bail> event.
444 =item @out = $TAP->event_exception($e)
446 =item @out = $TAP->event_exception($e, $num)
448 Process an L<Test2::Event::Exception> event.
450 =item @out = $TAP->event_skip($e)
452 =item @out = $TAP->event_skip($e, $num)
454 Process an L<Test2::Event::Skip> event.
456 =item @out = $TAP->event_subtest($e)
458 =item @out = $TAP->event_subtest($e, $num)
460 Process an L<Test2::Event::Subtest> event.
462 =item @out = $TAP->event_other($e, $num)
464 Fallback for unregistered event types. It uses the L<Test2::Event> API to
465 convert the event to TAP.
471 The source code repository for Test2 can be found at
472 F<http://github.com/Test-More/test-more/>.
478 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
486 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
488 =item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
494 Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
496 This program is free software; you can redistribute it and/or
497 modify it under the same terms as Perl itself.
499 See F<http://dev.perl.org/licenses/>