cpan/Test-Simple/lib/Test2/Formatter/TAP.pm

   1 package Test2::Formatter::TAP;
   2 use strict;
   3 use warnings;
   4 require PerlIO;
   5
   6 our $VERSION = '1.302059';
   7
   8
   9 use Test2::Util::HashBase qw{
  10     no_numbers handles _encoding
  11 };
  12
  13 sub OUT_STD() { 0 }
  14 sub OUT_ERR() { 1 }
  15
  16 use Carp qw/croak/;
  17
  18 BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) }
  19
  20 my %CONVERTERS = (
  21     'Test2::Event::Ok'        => 'event_ok',
  22     'Test2::Event::Skip'      => 'event_skip',
  23     'Test2::Event::Note'      => 'event_note',
  24     'Test2::Event::Diag'      => 'event_diag',
  25     'Test2::Event::Bail'      => 'event_bail',
  26     'Test2::Event::Exception' => 'event_exception',
  27     'Test2::Event::Subtest'   => 'event_subtest',
  28     'Test2::Event::Plan'      => 'event_plan',
  29 );
  30
  31 # Initial list of converters are safe for direct hash access cause we control them.
  32 my %SAFE_TO_ACCESS_HASH = %CONVERTERS;
  33
  34 sub register_event {
  35     my $class = shift;
  36     my ($type, $convert) = @_;
  37     croak "Event type is a required argument" unless $type;
  38     croak "Event type '$type' already registered" if $CONVERTERS{$type};
  39     croak "The second argument to register_event() must be a code reference or method name"
  40         unless $convert && (ref($convert) eq 'CODE' || $class->can($convert));
  41     $CONVERTERS{$type} = $convert;
  42 }
  43
  44 _autoflush(\*STDOUT);
  45 _autoflush(\*STDERR);
  46
  47 sub init {
  48     my $self = shift;
  49
  50     $self->{+HANDLES} ||= $self->_open_handles;
  51     if(my $enc = delete $self->{encoding}) {
  52         $self->encoding($enc);
  53     }
  54 }
  55
  56 sub hide_buffered { 1 }
  57
  58 sub encoding {
  59     my $self = shift;
  60
  61     if (@_) {
  62         my ($enc) = @_;
  63         my $handles = $self->{+HANDLES};
  64
  65         # https://rt.perl.org/Public/Bug/Display.html?id=31923
  66         # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in
  67         # order to avoid the thread segfault.
  68         if ($enc =~ m/^utf-?8$/i) {
  69             binmode($_, ":utf8") for @$handles;
  70         }
  71         else {
  72             binmode($_, ":encoding($enc)") for @$handles;
  73         }
  74         $self->{+_ENCODING} = $enc;
  75     }
  76
  77     return $self->{+_ENCODING};
  78 }
  79
  80 if ($^C) {
  81     no warnings 'redefine';
  82     *write = sub {};
  83 }
  84 sub write {
  85     my ($self, $e, $num) = @_;
  86
  87     my $type = ref($e);
  88
  89     my $converter = $CONVERTERS{$type} || 'event_other';
  90     my @tap = $self->$converter($e, $self->{+NO_NUMBERS} ? undef : $num) or return;
  91
  92     my $handles = $self->{+HANDLES};
  93     my $nesting = ($SAFE_TO_ACCESS_HASH{$type} ? $e->{nested} : $e->nested) || 0;
  94     my $indent = '    ' x $nesting;
  95
  96     # Local is expensive! Only do it if we really need to.
  97     local($\, $,) = (undef, '') if $\ || $,;
  98     for my $set (@tap) {
  99         no warnings 'uninitialized';
 100         my ($hid, $msg) = @$set;
 101         next unless $msg;
 102         my $io = $handles->[$hid] or next;
 103
 104         $msg =~ s/^/$indent/mg if $nesting;
 105         print $io $msg;
 106     }
 107 }
 108
 109 sub _open_handles {
 110     my $self = shift;
 111
 112     my %seen;
 113     open(my $out, '>&', STDOUT) or die "Can't dup STDOUT:  $!";
 114     binmode($out, join(":", "", "raw", grep { $_ ne 'unix' and !$seen{$_}++ } PerlIO::get_layers(STDOUT)));
 115
 116     %seen = ();
 117     open(my $err, '>&', STDERR) or die "Can't dup STDERR:  $!";
 118     binmode($err, join(":", "", "raw", grep { $_ ne 'unix' and !$seen{$_}++ } PerlIO::get_layers(STDERR)));
 119
 120     _autoflush($out);
 121     _autoflush($err);
 122
 123     return [$out, $err];
 124 }
 125
 126 sub _autoflush {
 127     my($fh) = pop;
 128     my $old_fh = select $fh;
 129     $| = 1;
 130     select $old_fh;
 131 }
 132
 133 sub event_tap {
 134     my $self = shift;
 135     my ($e, $num) = @_;
 136
 137     my $converter = $CONVERTERS{ref($e)} or return;
 138
 139     $num = undef if $self->{+NO_NUMBERS};
 140
 141     return $self->$converter($e, $num);
 142 }
 143
 144 sub event_ok {
 145     my $self = shift;
 146     my ($e, $num) = @_;
 147
 148     # We use direct hash access for performance. OK events are so common we
 149     # need this to be fast.
 150     my ($name, $todo) = @{$e}{qw/name todo/};
 151     my $in_todo = defined($todo);
 152
 153     my $out = "";
 154     $out .= "not " unless $e->{pass};
 155     $out .= "ok";
 156     $out .= " $num" if defined($num);
 157
 158     # The regex form is ~250ms, the index form is ~50ms
 159     my @extra;
 160     defined($name) && (
 161         (index($name, "\n") != -1 && (($name, @extra) = split(/\n\r?/, $name, -1))),
 162         ((index($name, "#" ) != -1  || substr($name, -1) eq '\\') && (($name =~ s|\\|\\\\|g), ($name =~ s|#|\\#|g)))
 163     );
 164
 165     my $space = @extra ? ' ' x (length($out) + 2) : '';
 166
 167     $out .= " - $name" if defined $name;
 168     $out .= " # TODO" if $in_todo;
 169     $out .= " $todo" if defined($todo) && length($todo);
 170
 171     # The primary line of TAP, if the test passed this is all we need.
 172     return([OUT_STD, "$out\n"]) unless @extra;
 173
 174     return $self->event_ok_multiline($out, $space, @extra);
 175 }
 176
 177 sub event_ok_multiline {
 178     my $self = shift;
 179     my ($out, $space, @extra) = @_;
 180
 181     return(
 182         [OUT_STD, "$out\n"],
 183         map {[OUT_STD, "#${space}$_\n"]} @extra,
 184     );
 185 }
 186
 187 sub event_skip {
 188     my $self = shift;
 189     my ($e, $num) = @_;
 190
 191     my $name   = $e->name;
 192     my $reason = $e->reason;
 193     my $todo   = $e->todo;
 194
 195     my $out = "";
 196     $out .= "not " unless $e->{pass};
 197     $out .= "ok";
 198     $out .= " $num" if defined $num;
 199     $out .= " - $name" if $name;
 200     if (defined($todo)) {
 201         $out .= " # TODO & SKIP"
 202     }
 203     else {
 204         $out .= " # skip";
 205     }
 206     $out .= " $reason" if defined($reason) && length($reason);
 207
 208     return([OUT_STD, "$out\n"]);
 209 }
 210
 211 sub event_note {
 212     my $self = shift;
 213     my ($e, $num) = @_;
 214
 215     chomp(my $msg = $e->message);
 216     $msg =~ s/^/# /;
 217     $msg =~ s/\n/\n# /g;
 218
 219     return [OUT_STD, "$msg\n"];
 220 }
 221
 222 sub event_diag {
 223     my $self = shift;
 224     my ($e, $num) = @_;
 225
 226     chomp(my $msg = $e->message);
 227     $msg =~ s/^/# /;
 228     $msg =~ s/\n/\n# /g;
 229
 230     return [OUT_ERR, "$msg\n"];
 231 }
 232
 233 sub event_bail {
 234     my $self = shift;
 235     my ($e, $num) = @_;
 236
 237     return if $e->nested;
 238
 239     return [
 240         OUT_STD,
 241         "Bail out!  " . $e->reason . "\n",
 242     ];
 243 }
 244
 245 sub event_exception {
 246     my $self = shift;
 247     my ($e, $num) = @_;
 248     return [ OUT_ERR, $e->error ];
 249 }
 250
 251 sub event_subtest {
 252     my $self = shift;
 253     my ($e, $num) = @_;
 254
 255     # A 'subtest' is a subclass of 'ok'. Let the code that renders 'ok' render
 256     # this event.
 257     my ($ok, @diag) = $self->event_ok($e, $num);
 258
 259     # If the subtest is not buffered then the sub-events have already been
 260     # rendered, we can go ahead and return.
 261     return ($ok, @diag) unless $e->buffered;
 262
 263     # In a verbose harness we indent the diagnostics from the 'Ok' event since
 264     # they will appear inside the subtest braces. This helps readability. In a
 265     # non-verbose harness we do not do this because it is less readable.
 266     if ($ENV{HARNESS_IS_VERBOSE}) {
 267         # index 0 is the filehandle, index 1 is the message we want to indent.
 268         $_->[1] =~ s/^(.*\S.*)$/    $1/mg for @diag;
 269     }
 270
 271     # Add the trailing ' {' to the 'ok' line of TAP output.
 272     $ok->[1] =~ s/\n/ {\n/;
 273
 274     # Render the sub-events, we use our own counter for these.
 275     my $count = 0;
 276     my @subs = map {
 277         # Bump the count for any event that should bump it.
 278         $count++ if $_->increments_count;
 279
 280         # This indents all output lines generated for the sub-events.
 281         # index 0 is the filehandle, index 1 is the message we want to indent.
 282         map { $_->[1] =~ s/^(.*\S.*)$/    $1/mg; $_ } $self->event_tap($_, $count);
 283     } @{$e->subevents};
 284
 285     return (
 286         $ok,                # opening ok - name {
 287         @diag,              #   diagnostics if the subtest failed
 288         @subs,              #   All the inner-event lines
 289         [OUT_STD(), "}\n"], # } (closing brace)
 290     );
 291 }
 292
 293 sub event_plan {
 294     my $self = shift;
 295     my ($e, $num) = @_;
 296
 297     my $directive = $e->directive;
 298     return if $directive && $directive eq 'NO PLAN';
 299
 300     my $reason = $e->reason;
 301     $reason =~ s/\n/\n# /g if $reason;
 302
 303     my $plan = "1.." . $e->max;
 304     if ($directive) {
 305         $plan .= " # $directive";
 306         $plan .= " $reason" if defined $reason;
 307     }
 308
 309     return [OUT_STD, "$plan\n"];
 310 }
 311
 312 sub event_other {
 313     my $self = shift;
 314     my ($e, $num) = @_;
 315     return if $e->no_display;
 316
 317     my @out;
 318
 319     if (my ($max, $directive, $reason) = $e->sets_plan) {
 320         my $plan = "1..$max";
 321         $plan .= " # $directive" if $directive;
 322         $plan .= " $reason" if defined $reason;
 323         push @out => [OUT_STD, "$plan\n"];
 324     }
 325
 326     if ($e->increments_count) {
 327         my $ok = "";
 328         $ok .= "not " if $e->causes_fail;
 329         $ok .= "ok";
 330         $ok .= " $num" if defined($num);
 331         $ok .= " - " . $e->summary if $e->summary;
 332
 333         push @out => [OUT_STD, "$ok\n"];
 334     }
 335     else { # Comment
 336         my $handle =  ($e->causes_fail || $e->diagnostics) ? OUT_ERR : OUT_STD;
 337         my $summary = $e->summary || ref($e);
 338         chomp($summary);
 339         $summary =~ s/^/# /smg;
 340         push @out => [$handle, "$summary\n"];
 341     }
 342
 343     return @out;
 344 }
 345
 346 1;
 347
 348 __END__
 349
 350 =pod
 351
 352 =encoding UTF-8
 353
 354 =head1 NAME
 355
 356 Test2::Formatter::TAP - Standard TAP formatter
 357
 358 =head1 DESCRIPTION
 359
 360 This is what takes events and turns them into TAP.
 361
 362 =head1 SYNOPSIS
 363
 364     use Test2::Formatter::TAP;
 365     my $tap = Test2::Formatter::TAP->new();
 366
 367     # Switch to utf8
 368     $tap->encoding('utf8');
 369
 370     $tap->write($event, $number); # Output an event
 371
 372 =head1 METHODS
 373
 374 =over 4
 375
 376 =item $bool = $tap->no_numbers
 377
 378 =item $tap->set_no_numbers($bool)
 379
 380 Use to turn numbers on and off.
 381
 382 =item $arrayref = $tap->handles
 383
 384 =item $tap->set_handles(\@handles);
 385
 386 Can be used to get/set the filehandles. Indexes are identified by the
 387 C<OUT_STD> and C<OUT_ERR> constants.
 388
 389 =item $encoding = $tap->encoding
 390
 391 =item $tap->encoding($encoding)
 392
 393 Get or set the encoding. By default no encoding is set, the original settings
 394 of STDOUT and STDERR are used.
 395
 396 This directly modifies the stored filehandles, it does not create new ones.
 397
 398 =item $tap->write($e, $num)
 399
 400 Write an event to the console.
 401
 402 =item Test2::Formatter::TAP->register_event($pkg, sub { ... });
 403
 404 In general custom events are not supported. There are however occasions where
 405 you might want to write a custom event type that results in TAP output. In
 406 order to do this you use the C<register_event()> class method.
 407
 408     package My::Event;
 409     use Test2::Formatter::TAP;
 410
 411     use base 'Test2::Event';
 412     use Test2::Util::HashBase qw/pass name diag note/;
 413
 414     Test2::Formatter::TAP->register_event(
 415         __PACKAGE__,
 416         sub {
 417             my $self = shift;
 418             my ($e, $num) = @_;
 419             return (
 420                 [Test2::Formatter::TAP::OUT_STD, "ok $num - " . $e->name . "\n"],
 421                 [Test2::Formatter::TAP::OUT_ERR, "# " . $e->name . " " . $e->diag . "\n"],
 422                 [Test2::Formatter::TAP::OUT_STD, "# " . $e->name . " " . $e->note . "\n"],
 423             );
 424         }
 425     );
 426
 427     1;
 428
 429 =back
 430
 431 =head2 EVENT METHODS
 432
 433 All these methods require the event itself. Optionally they can all except a
 434 test number.
 435
 436 All methods return a list of array-refs. Each array-ref will have 2 items, the
 437 first is an integer identifying an output handle, the second is a string that
 438 should be written to the handle.
 439
 440 =over 4
 441
 442 =item @out = $TAP->event_ok($e)
 443
 444 =item @out = $TAP->event_ok($e, $num)
 445
 446 Process an L<Test2::Event::Ok> event.
 447
 448 =item @out = $TAP->event_plan($e)
 449
 450 =item @out = $TAP->event_plan($e, $num)
 451
 452 Process an L<Test2::Event::Plan> event.
 453
 454 =item @out = $TAP->event_note($e)
 455
 456 =item @out = $TAP->event_note($e, $num)
 457
 458 Process an L<Test2::Event::Note> event.
 459
 460 =item @out = $TAP->event_diag($e)
 461
 462 =item @out = $TAP->event_diag($e, $num)
 463
 464 Process an L<Test2::Event::Diag> event.
 465
 466 =item @out = $TAP->event_bail($e)
 467
 468 =item @out = $TAP->event_bail($e, $num)
 469
 470 Process an L<Test2::Event::Bail> event.
 471
 472 =item @out = $TAP->event_exception($e)
 473
 474 =item @out = $TAP->event_exception($e, $num)
 475
 476 Process an L<Test2::Event::Exception> event.
 477
 478 =item @out = $TAP->event_skip($e)
 479
 480 =item @out = $TAP->event_skip($e, $num)
 481
 482 Process an L<Test2::Event::Skip> event.
 483
 484 =item @out = $TAP->event_subtest($e)
 485
 486 =item @out = $TAP->event_subtest($e, $num)
 487
 488 Process an L<Test2::Event::Subtest> event.
 489
 490 =item @out = $TAP->event_other($e, $num)
 491
 492 Fallback for unregistered event types. It uses the L<Test2::Event> API to
 493 convert the event to TAP.
 494
 495 =back
 496
 497 =head1 SOURCE
 498
 499 The source code repository for Test2 can be found at
 500 F<http://github.com/Test-More/test-more/>.
 501
 502 =head1 MAINTAINERS
 503
 504 =over 4
 505
 506 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 507
 508 =back
 509
 510 =head1 AUTHORS
 511
 512 =over 4
 513
 514 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 515
 516 =item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
 517
 518 =back
 519
 520 =head1 COPYRIGHT
 521
 522 Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
 523
 524 This program is free software; you can redistribute it and/or
 525 modify it under the same terms as Perl itself.
 526
 527 See F<http://dev.perl.org/licenses/>
 528
 529 =cut