File Coverage

blib/lib/AnyEvent/XMPP/SimpleConnection.pm

Criterion	Covered	Total	%
statement	21	66	31.8
branch	0	4	0.0
condition	0	3	0.0
subroutine	7	21	33.3
pod	0	10	0.0
total	28	104	26.9

package AnyEvent::XMPP::SimpleConnection;
use strict;
no warnings;

use AnyEvent;
use IO::Handle;
use Encode;
use AnyEvent::Socket;
use AnyEvent::Handle;

=head1 NAME

AnyEvent::XMPP::SimpleConnection - Low level TCP/TLS connection

=head1 SYNOPSIS

   package foo;
   use AnyEvent::XMPP::SimpleConnection;

   our @ISA = qw/AnyEvent::XMPP::SimpleConnection/;

=head1 DESCRIPTION

This module only implements the basic low level socket and SSL handling stuff.
It is used by L and you shouldn't mess with it :-)

(NOTE: This is the part of AnyEvent::XMPP which I feel least confident about :-)

=cut

sub new {
   my $this = shift;
   my $class = ref($this) || $this;
   my $self = {
      disconnect_cb => sub {},
      @_
   };
   bless $self, $class;
   return $self;
}

sub connect {
   my ($self, $host, $service, $timeout) = @_;

   $self->{handle}
      and return 1;

   $self->{handle} = tcp_connect $host, $service, sub {
      my ($fh, $peerhost, $peerport) = @_;

      unless ($fh) {
         $self->disconnect ("Couldn't create socket to $host:$service: $!");
         return;
      }

      $self->{peer_host} = $peerhost;
      $self->{peer_port} = $peerport;

      binmode $fh, ":raw";

      $self->{handle} =
         AnyEvent::Handle->new (
            fh => $fh,
            on_eof => sub {
               $self->disconnect ("EOF on connection to $self->{peer_host}:$self->{peer_port}: $!");
            },
            autocork => 1,
            on_error => sub {
               $self->disconnect ("Error on connection to $self->{peer_host}:$self->{peer_port}: $!");
            },
            on_read => sub {
               my ($hdl) = @_;
               my $data   = $hdl->rbuf;
               $hdl->rbuf = '';
               $data      = decode_utf8 $data;
               $self->handle_data (\$data);
            },
         );

      $self->connected

   }, sub {
      $timeout
   };

   return 1;
}

sub connected {
   # subclass responsibility
}

sub send_buffer_empty {
   # subclass responsibility
}

sub block_until_send_buffer_empty {
   # subclass responsibility
}

sub debug_wrote_data {
   # subclass responsibility
}

sub end_sockets {
   my ($self) = @_;
   delete $self->{handle};
}

sub write_data {
   my ($self, $data) = @_;

   $self->{handle}->push_write (encode_utf8 ($data));
   $self->debug_wrote_data (encode_utf8 ($data));
   $self->{handle}->on_drain (sub {
      $self->send_buffer_empty;
   });
}

sub enable_ssl {
   my ($self) = @_;

   $self->{handle}->starttls ('connect');
   $self->{ssl_enabled} = 1;
}

sub disconnect {
   my ($self, $msg) = @_;
   $self->end_sockets;
   $self->{disconnect_cb}->($self->{peer_host}, $self->{peer_port}, $msg);
   $self->remove_all_callbacks;
}

1;