Merge branch 'Test-Builder1.5' into issue/242

lib/TB2/Event.pm

@@ -3,6 +3,8 @@ package TB2::Event;
 use TB2::Mouse ();
 use TB2::Mouse::Role;
 use TB2::Types;
+with 'TB2::HasObjectID';
+
 requires qw( build_event_type );
 
 our $VERSION = '1.005000_002';
@@ -106,32 +108,6 @@ Used to build C<event_type>
 
 =head2 Provided Methods
 
-=head3 event_id
-
-    my $id = $event->event_id;
-
-Returns an identifier for this event unique to this process.
-
-Useful if an EventHandler posts its own events and doesn't want to
-process them twice.
-
-=cut
-
-my $Counter = int rand(1_000_000);
-has event_id =>
-  is            => 'ro',
-  isa           => 'Str',
-  lazy          => 1,
-  default       => sub {
-      my $self = shift;
-
-      # Include the class in case somebody else decides to use
-      # just an integer.
-      return ref($self) . '-' . $Counter++;
-  }
-;
-
-
 =head3 as_hash
 
     my $data = $event->as_hash;
@@ -176,6 +152,14 @@ sub keys_for_as_hash {
     ];
 }
 
+=head3 object_id
+
+    my $id = $thing->object_id;
+
+Returns an identifier for this object unique to the running process.
+The identifier is fairly simple and easily predictable.
+
+See L<TB2::HasObjectID>
 
 =head1 SEE ALSO
 

lib/TB2/EventCoordinator.pm

@@ -2,7 +2,7 @@ package TB2::EventCoordinator;
 
 use TB2::Mouse;
 use TB2::Types;
-with 'TB2::CanLoad', 'TB2::CanThread';
+with 'TB2::CanLoad', 'TB2::CanThread', 'TB2::HasObjectID';
 
 our $VERSION = '1.005000_002';
 $VERSION = eval $VERSION;    ## no critic (BuiltinFunctions::ProhibitStringyEval)
@@ -234,6 +234,15 @@ Removes all handlers of their respective types.
 
 Use this instead of manipulating the list of handlers directly.
 
+=head3 object_id
+
+    my $id = $thing->object_id;
+
+Returns an identifier for this object unique to the running process.
+The identifier is fairly simple and easily predictable.
+
+See L<TB2::HasObjectID>
+
 =cut
 
 # Create add_ and clear_ methods for all the handlers except history

lib/TB2/EventHandler.pm

@@ -2,6 +2,7 @@ package TB2::EventHandler;
 
 use TB2::Mouse ();
 use TB2::Mouse::Role;
+with 'TB2::HasObjectID';
 
 our $VERSION = '1.005000_002';
 $VERSION = eval $VERSION;    ## no critic (BuiltinFunctions::ProhibitStringyEval)
@@ -124,6 +125,14 @@ sub subtest_handler {
     return $class->new;
 }
 
+=head3 object_id
+
+    my $id = $thing->object_id;
+
+Returns an identifier for this object unique to the running process.
+The identifier is fairly simple and easily predictable.
+
+See L<TB2::HasObjectID>
 
 =head2 Event handlers
 

lib/TB2/Formatter.pm

@@ -12,7 +12,7 @@ $VERSION = eval $VERSION;    ## no critic (BuiltinFunctions::ProhibitStringyEval
 
 =head1 NAME
 
-TB2::Formatter - Base class for formating test results
+TB2::Formatter - Base class for formatting test results
 
 =head1 SYNOPSIS
 
@@ -114,6 +114,16 @@ sub reset_streamer {
     $_[0]->streamer( $_[0]->_build_streamer );
 }
 
+=head3 object_id
+
+    my $id = $thing->object_id;
+
+Returns an identifier for this object unique to the running process.
+The identifier is fairly simple and easily predictable.
+
+See L<TB2::HasObjectID>
+
+=cut
 
 
 1;

lib/TB2/Formatter/TAP/Base.pm

@@ -109,7 +109,9 @@ Like L<diag> but goes to the output handle.
 
 sub diag {
     my $self = shift;
-    $self->err($self->comment( @_ ));
+
+    my $out_method = ($self->test_is_todo) ? "out" : "err";
+    $self->$out_method($self->comment( @_ ));
 }
 
 sub note {
@@ -429,6 +431,13 @@ has show_empty_result_names =>
   default       => 0;
 
 
+# Indicates that the whole test is in a todo state.  Used for subtests.
+has test_is_todo =>
+  is            => 'rw',
+  isa           => 'Bool',
+  default       => 0;
+
+
 sub handle_result {
     my $self  = shift;
     my $result = shift;
@@ -481,11 +490,10 @@ sub _comment_diagnostics {
 
     my $msg = '  ';
 
-    $msg .= $result->is_todo ? "Failed (TODO) test" : "Failed test";
+    my $is_todo = $result->is_todo;
+    $msg .= $is_todo ? "Failed (TODO) test" : "Failed test";
 
     # Failing TODO tests are not displayed to the user.
-    my $out_method = $result->is_todo ? "out" : "err";
-
     my($file, $line, $name) = map { $result->$_ } qw(file line name);
 
     if( defined $name ) {
@@ -497,11 +505,16 @@ sub _comment_diagnostics {
     if( defined $line ) {
         $msg .= " line $line";
     }
+    $msg .= ".";
+
+    # Send todo test output to the out handle
+    my $diag_method = $is_todo ? "note" : "diag";
+    my $out_method  = $is_todo ? "out"  : "err";
 
     # Start on a new line if we're being output by Test::Harness.
     # Makes it easier to read
-    $self->$out_method("\n") if $ENV{HARNESS_ACTIVE};
-    $self->$out_method($self->comment("$msg.\n"));
+    $self->$out_method("\n") if ($out_method eq 'err') and $ENV{HARNESS_ACTIVE};
+    $self->$diag_method($msg);
 
     return;
 }
@@ -572,6 +585,8 @@ sub subtest_handler {
 
     my $subformatter = $self->SUPER::subtest_handler($event);
 
+    my $is_todo = scalar grep { $_ eq 'todo' } @{$event->directives};
+    $subformatter->test_is_todo( $is_todo );
     $subformatter->show_tap_version( $self->show_tap_version );
     $subformatter->indent('    '.$self->indent);
 

lib/TB2/HasObjectID.pm

@@ -0,0 +1,57 @@
+package TB2::HasObjectID;
+
+require TB2::Mouse;
+use TB2::Mouse::Role;
+
+our $VERSION = '1.005000_001';
+$VERSION = eval $VERSION;    ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+
+=head1 NAME
+
+TB2::HasObjectID - a unique id in the current process
+
+=head1 SYNOPSIS
+
+    package My::Thing;
+
+    use TB2::Mouse;
+    with "TB2::HasObjectID";
+
+    my $thing = My::Thing->new;
+    my $id = $thing->object_id;
+
+=head1 DESCRIPTION
+
+Provides a method for generating unique ids for many TB2 objects.
+
+Useful if, for example, an EventHandler posts its own events and
+doesn't want to process them twice.
+
+=head3 object_id
+
+    my $id = $thing->object_id;
+
+Returns an identifier for this object unique to the running process.
+The identifier is fairly simple and easily predictable.
+
+=cut
+
+my $Counter = int rand(1_000_000);
+has object_id =>
+  is            => 'ro',
+  isa           => 'Str',
+  lazy          => 1,
+  default       => sub {
+      my $self = shift;
+
+      # Include the class in case somebody else decides to use
+      # just an integer.
+      return ref($self) . '-' . $Counter++;
+  }
+;
+
+no TB2::Mouse;
+no TB2::Mouse::Role;
+
+1;

lib/TB2/History.pm

@@ -50,6 +50,17 @@ It is a L<TB2::EventHandler>.
 
 Creates a new, unique History object.
 
+=head2 Misc
+
+=head3 object_id
+
+    my $id = $thing->object_id;
+
+Returns an identifier for this object unique to the running process.
+The identifier is fairly simple and easily predictable.
+
+See L<TB2::HasObjectID>
+
 =head2 Accessors
 
 Unless otherwise stated, these are all accessor methods of the form:

lib/TB2/TestState.pm

@@ -10,7 +10,8 @@ use Carp;
 
 with 'TB2::HasDefault',
      'TB2::CanLoad',
-     'TB2::CanThread';
+     'TB2::CanThread',
+     'TB2::HasObjectID';
 
 has _coordinators =>
   is            => 'rw',
@@ -138,6 +139,17 @@ sub make_default {
     return $state->shared_clone($state);
 }
 
+=head2 Misc
+
+=head3 object_id
+
+    my $id = $thing->object_id;
+
+Returns an identifier for this object unique to the running process.
+The identifier is fairly simple and easily predictable.
+
+See L<TB2::HasObjectID>
+
 
 =head2 EventCoordinator methods
 

lib/Test/Builder.pm

@@ -13,7 +13,9 @@ use TB2::TestState;
 
 with 'TB2::CanDupFilehandles',
      'TB2::CanTry',
-     'TB2::CanLoad';
+     'TB2::CanLoad',
+     'TB2::HasObjectID';
+
 
 
 =head1 NAME
@@ -152,11 +154,6 @@ sub subtest {
     {
         local $Test::Builder::Level = $self->{Set_Level};
 
-        # If the subtest is in a TODO, error output should not be seen like
-        # any other TODO test.
-        my $streamer = $self->formatter->streamer;
-        $streamer->error_fh( $streamer->output_fh ) if $in_todo;
-
         # The subtest gets its own TODO state
         $self->_reset_todo_state;
 
@@ -292,6 +289,16 @@ sub counter {
     return $counter;
 }
 
+=item B<object_id>
+
+    my $id = $thing->object_id;
+
+Returns an identifier for this object unique to the running process.
+The identifier is fairly simple and easily predictable.
+
+See L<TB2::HasObjectID>
+
+=cut
 
 =back
 

lib/Test/Builder2.pm

@@ -7,7 +7,9 @@ use TB2::Events;
 
 with 'TB2::HasDefault',
      'TB2::CanTry',
-     'TB2::CanLoad';
+     'TB2::CanLoad',
+     'TB2::HasObjectID';
+
 
 use Carp qw(confess);
 sub sanity ($) { confess "Assert failed" unless $_[0] };
@@ -421,6 +423,16 @@ sub subtest {
     return;
 }
 
+=head3 object_id
+
+    my $id = $thing->object_id;
+
+Returns an identifier for this object unique to the running process.
+The identifier is fairly simple and easily predictable.
+
+See L<TB2::HasObjectID>
+
+=cut
 
 no TB2::Mouse;
 

t/Builder/context.t

@@ -22,7 +22,7 @@ sub check_events {
     my @have = @{$events}[ $from_idx .. $#{$events} ]; 
 
     for my $event ( @have ) {
-        note sprintf "Type: %s ID: %s", $event->event_type, $event->event_id;
+        note sprintf "Type: %s ID: %s", $event->event_type, $event->object_id;
         is $event->file, __FILE__;
         is $event->line, $line;
     }

t/Builder2/context.t

@@ -20,7 +20,7 @@ sub check_events {
     my @have = @{$events}[ $from_idx .. $#{$events} ]; 
 
     for my $event ( @have ) {
-        note sprintf "Type: %s ID: %s", $event->event_type, $event->event_id;
+        note sprintf "Type: %s ID: %s", $event->event_type, $event->object_id;
         is $event->file, __FILE__;
         is $event->line, $line;
     }

t/Event/Abort.t

@@ -16,7 +16,7 @@ note "defaults"; {
 
     is_deeply $abort->as_hash, {
         event_type      => 'abort',
-        event_id        => $abort->event_id,
+        object_id        => $abort->object_id,
         reason          => ''
     };
 }