1package My::Aggregator;
2use strict;
3use warnings;
4
5sub new {
6	my ($class) = @_;
7
8	my $self = { results => {} };
9	return bless( $self, $class );
10}
11
12sub start {}
13sub stop {}
14
15sub add {
16	my ($self, $description, $parser) = @_;
17	die "Test '$description' run twice" if exists $self->{results}{$description};
18	$self->{results}{$description} = $parser;
19}
20
211;
22
23package My::Session;
24use strict;
25use warnings;
26
27sub new {
28	my ($class, %args) = @_;
29
30	my $self = { %args };
31	return bless( $self, $class );
32}
33
34sub result {
35	my ($self, $result) = @_;
36	return $self->{result} = $result || $self->{result};
37}
38
39sub close_test {
40	shift->{closed} = 1;
41}
42
431;
44
45package My::Formatter;
46use strict;
47use warnings;
48
49sub new {
50	my ($class, $args) = @_;
51
52	my $self = { %$args };
53	return bless( $self, $class );
54}
55
56sub summary {
57	my ($self, $aggregator, $interrupted) = @_;
58
59	return sprintf(
60		"My %sinterrupted formatter summary for %s",
61		$interrupted ? '' : 'un',
62		ref $aggregator
63	);
64}
65sub verbosity { 0; }
66sub prepare {};
67sub open_test {
68	my ($self, $test_name, $parser) = @_;
69
70	return My::Session->new( name => $test_name, parser => $parser );
71};
72
731;
74package My::Multiplexer;
75use strict;
76use warnings;
77
78sub new {
79	my ($class) = @_;
80
81	my $self = { parsers => [] };
82	return bless( $self, $class );
83}
84
85sub add {
86	my ( $self, $parser, $stash ) = @_;
87	push @{ $self->{parsers} }, [ $parser, $stash ];
88}
89
90sub parsers { return scalar @{ shift->{parsers} }; }
91
92sub next {
93	my ($self) = @_;
94
95	return unless $self->parsers;
96	my ($parser, $stash) = @{ $self->{parsers}->[0] };
97	my $result = $parser->next;
98	shift @{ $self->{parsers} } unless $result;
99	return ( $parser, $stash, $result );
100}
101
1021;
103
104package My::Result;
105use strict;
106use warnings;
107
108sub new {
109	my ($class, %args) = @_;
110
111	my $self = { %args };
112	return bless( $self, $class );
113}
114
115sub is_bailout {
116	return ( (shift->{source} || '') =~ '^bailout' );
117}
118
119sub explanation {
120	return shift->{source};
121}
122
1231;
124
125package My::Parser;
126use strict;
127use warnings;
128
129sub new {
130	my ($class, $args) = @_;
131
132	my $self = { %$args, nexted => 0 };
133	return bless( $self, $class );
134}
135
136sub next {
137	my ($self) = @_;
138	return if $self->{nexted};
139	$self->{nexted} = 1;
140	return My::Result->new( source => $self->{source} );
141}
142
143sub delete_spool {}
144
145sub get_time { 0 }
146
147sub get_times { 0 }
148
149sub start_time {}
150
151sub start_times {}
152
1531;
154
155package My::Job;
156use strict;
157use warnings;
158
159our @finished_jobs;
160
161sub new {
162	my ($class, %args) = @_;
163
164	my $self = { %args };
165	return bless( $self, $class );
166}
167sub description { shift->{description} };
168sub filename { shift->{filename} };
169sub is_spinner {};
170sub as_array_ref { return [ shift->description ] };
171sub finish { push @finished_jobs, shift->filename; }
172
1731;
174
175package My::Scheduler;
176use strict;
177use warnings;
178
179sub new {
180	my ($class, %args) = @_;
181
182	my @jobs = map
183		{ My::Job->new( filename => $_->[0], description => $_->[1] ) }
184		@{ delete( $args{tests} ) || [] };
185
186	my $self = { %args, jobs => [ @jobs ] };
187	return bless( $self, $class );
188}
189
190sub get_all { @{ shift->{jobs} || [] }; }
191sub get_job { shift( @{ shift->{jobs} } ); }
1921;
193
194package main;
195use strict;
196use warnings;
197
198use Test::More;
199use TAP::Harness;
200
201sub create_harness {
202	my (%arg) = @_;
203
204	return TAP::Harness->new({
205		aggregator_class => 'My::Aggregator',
206		formatter_class => 'My::Formatter',
207		multiplexer_class => 'My::Multiplexer',
208		parser_class => 'My::Parser',
209		scheduler_class => 'My::Scheduler',
210		jobs => $arg{jobs} || 1,
211	});
212}
213
214my @after_test_callbacks;
215
216my $harness = create_harness( jobs => 1 );
217$harness->callback( after_test => sub { push @after_test_callbacks, $_[0] } );
218eval { $harness->runtests( qw( no-bailout bailout not-executed ) ); };
219my $err = $@;
220like $err, qr/FAILED--Further testing stopped: bailout/;
221
222$harness = create_harness( jobs => 2 );
223$harness->callback( after_test => sub { push @after_test_callbacks, $_[0] } );
224eval { $harness->runtests( qw( no-bailout-parallel bailout-parallel not-executed-parallel ) ); };
225$err = $@;
226like $err, qr/FAILED--Further testing stopped: bailout/;
227
228is_deeply(
229	[ @after_test_callbacks ],
230	[ [ 'no-bailout' ], [ 'bailout' ], [ 'no-bailout-parallel' ], [ 'bailout-parallel' ],  ],
231	'After test callbacks called OK'
232);
233is_deeply(
234	[ @My::Job::finished_jobs ],
235	[ 'no-bailout', 'bailout', 'no-bailout-parallel', 'bailout-parallel', ],
236	'Jobs finished OK'
237);
238
239done_testing();
240