#!/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 );
}