1package Batter;
2
3use Thread::Apartment;
4use Thread::Apartment::Server;
5
6use base qw(Thread::Apartment::Server);
7
8use strict;
9use warnings;
10
11sub report_result {
12	my ($testtype, $testno, $result, $testmsg, $okmsg, $notokmsg) = @_;
13
14	if ($result) {
15
16		$okmsg = '' unless $okmsg;
17		print STDOUT (($result eq 'skip') ?
18			"ok $$testno # skip $testmsg for $testtype\n" :
19			"ok $$testno # $testmsg $okmsg for $testtype\n");
20	}
21	else {
22		$notokmsg = '' unless $notokmsg;
23		print "not ok $$testno # $testmsg $notokmsg for $testtype\n";
24	}
25	$$testno++;
26}
27
28sub new {
29	my ($class, $tac) = @_;
30	my $obj = bless { _ready => 0 }, $class;
31	$obj->set_client($tac);
32	return $obj;
33}
34#
35#	called by main harness to check if an async operation completed
36#
37sub async_ready { return $_[0]->{_ready}; }
38#
39#	called by main harness to install object under test
40#
41sub set_test_object { $_[0]->{_obj} = $_[1]; }
42
43sub remove_test_object { delete $_[0]->{_obj}; }
44
45sub run_simple_async {
46	my ($self, $testno, $testtype) = @_;
47
48#print STDERR "run simple async closure called with ", join(', ', @_),
49#	" on ", $self->{_obj}, "\n";
50
51	$self->{_ready} = undef;
52	my $obj = $self->{_obj};
53	my $id = $obj->ta_async_thirdBase(
54		sub {
55#			print STDERR "simple async closure called with ", join(', ', @_), "\n";
56			$self->{_ready} = 1;
57			my $res = shift;
58			report_result($testtype, $testno, defined($res) && ($res eq 'thirdbase'), 'async closure');
59		});
60	print STDERR "can't async: $@\n" unless defined($id);
61	return 1;
62}
63
64sub run_override_async {
65	my ($self, $testno, $testtype) = @_;
66
67	$self->{_ready} = undef;
68	my $obj = $self->{_obj};
69	my $id = $obj->ta_async_firstBase(
70		sub {
71			$self->{_ready} = 1;
72			my $res = shift;
73			report_result($testtype, $testno, ($res eq 'triple'), 'async override closure');
74		});
75	return 1;
76}
77
78sub run_inherited_async {
79	my ($self, $testno, $testtype) = @_;
80
81	$self->{_ready} = undef;
82	my $obj = $self->{_obj};
83	my $id = $obj->ta_async_secondBase(
84		sub {
85			$self->{_ready} = 1;
86			my $res = shift;
87			report_result($testtype, $testno, ($res eq 'secondbase'), 'async inherited closure');
88		});
89	return 1;
90}
91
92sub run_closure_args {
93	my ($self, $testno, $testtype) = @_;
94
95	$self->{_ready} = undef;
96	my $obj = $self->{_obj};
97	my $closure = $obj->get_closure();
98
99	$closure->('first', 'second', 'third', 'home');
100
101	report_result($testtype, $testno, 1, 'void closure w/ arguments');
102
103	my @results = $closure->('first', 'second', 'third', 'home');
104
105#	print STDERR "Result is ", join(', ', @results), "\n";
106
107	report_result($testtype, $testno, (($results[3] eq 'first') &&
108		($results[2] eq 'second') &&
109		($results[1] eq 'third') &&
110		($results[0] eq 'home')), 'wantarray closure w/ arguments');
111
112	my $result = $closure->('first', 'second', 'third', 'home');
113
114#	print STDERR "Result is $result\n";
115
116	report_result($testtype, $testno, ($result eq 'emohdrihtdnocestsrif'), 'scalar closure w/ arguments');
117#
118#	quick simplex test
119#
120	$closure = $obj->get_simplex_closure();
121
122	$closure->('first', 'second', 'third', 'home');
123
124	report_result($testtype, $testno, 1, 'simplex closure');
125	$self->{_ready} = 1;
126
127	return 1;
128}
129
1301;
131