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