1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
#!/usr/bin/perl
use strict;
use warnings;
use IO::Async::Test;
use Test::More;
use Test::Identity;
use Test::Refcount;
use IO::Async::Loop;
use IO::Async::OS;
use IO::Async::Handle;
use IO::Async::Protocol;
my $loop = IO::Async::Loop->new_builtin;
testing_loop( $loop );
my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!";
# Need sockets in nonblocking mode
$S1->blocking( 0 );
$S2->blocking( 0 );
my $handle = IO::Async::Handle->new(
handle => $S1,
on_read_ready => sub {},
on_write_ready => sub {},
);
my @setup_args;
my @teardown_args;
my $readready;
my $writeready;
my $proto = TestProtocol->new;
ok( defined $proto, '$proto defined' );
isa_ok( $proto, "IO::Async::Protocol", '$proto isa IO::Async::Protocol' );
is_oneref( $proto, '$proto has refcount 1 initially' );
$proto->configure( transport => $handle );
identical( $proto->transport, $handle, '$proto->transport' );
is( scalar @setup_args, 1, '@setup_args after configure transport' );
identical( $setup_args[0], $handle, '$setup_args[0] after configure transport');
undef @setup_args;
is_oneref( $proto, '$proto has refcount 1 after configure transport' );
# lexical $handle, $proto->{transport}, $proto->{children} == 3
is_refcount( $handle, 3, '$handle has refcount 3 after proto configure transport' );
$loop->add( $proto );
is_refcount( $proto, 2, '$proto has refcount 2 after adding to Loop' );
is_refcount( $handle, 4, '$handle has refcount 4 after adding proto to Loop' );
$S2->syswrite( "hello\n" );
wait_for { $readready };
is( $readready, 1, '$readready after wait' );
# Just to shut poll/select/etc... up
$S1->sysread( my $dummy, 8192 );
my $newhandle = IO::Async::Handle->new(
handle => $S1,
on_read_ready => sub {},
on_write_ready => sub {},
);
$proto->configure( transport => $newhandle );
identical( $proto->transport, $newhandle, '$proto->transport after reconfigure' );
is( scalar @teardown_args, 1, '@teardown_args after reconfigure transport' );
identical( $teardown_args[0], $handle, '$teardown_args[0] after reconfigure transport');
is( scalar @setup_args, 1, '@setup_args after reconfigure transport' );
identical( $setup_args[0], $newhandle, '$setup_args[0] after reconfigure transport');
undef @teardown_args;
undef @setup_args;
is_oneref( $handle, '$handle has refcount 1 after reconfigure' );
my $closed = 0;
$proto->configure(
on_closed => sub { $closed++ },
);
$proto->transport->close;
wait_for { $closed };
is( $closed, 1, '$closed after stream close' );
is( $proto->transport, undef, '$proto->transport is undef after close' );
is_refcount( $proto, 2, '$proto has refcount 2 before removal from Loop' );
$loop->remove( $proto );
is_oneref( $proto, '$proto has refcount 1 before EOF' );
done_testing;
package TestProtocol;
use base qw( IO::Async::Protocol );
sub setup_transport
{
my $self = shift;
@setup_args = @_;
my ( $transport ) = @_;
$self->SUPER::setup_transport( $transport );
$transport->configure(
on_read_ready => sub { $readready = 1 },
on_write_ready => sub { $writeready = 1 },
);
}
sub teardown_transport
{
my $self = shift;
@teardown_args = @_;
my ( $transport ) = @_;
$transport->configure(
on_read_ready => sub {},
on_write_ready => sub {},
);
$self->SUPER::teardown_transport( $transport );
}
|
