DJabberd and Net::Jabber

Mika Raento mikie at iki.fi
Wed May 9 07:14:42 UTC 2007


Tim Keefer kirjoitti:
> I'm trying to do some simple client server communication with djabberd
> and Net::Jabber. The server starts fine, but when connecting with
> Net::Jabber or Net::XMPP it just hangs on the connect method.  Are
> there some other client libraries I should using when communicating
> with the djabberd server? Below is the djabberd conf and the
> Net::Jabber script.

Net::Jabber is not exactly the greatest. It has its own broken XML 
parser. See 
http://www.mail-archive.com/djabberd@lists.danga.com/msg00155.html for a 
'fix'. I wouldn't consider it a viable option for production code.

I did a very non-pretty client (as in I copied the code rather than 
refactoring) by combinging code from DJabberd::Connection and the 
djabberd test code. Attached in case anybody finds a use for it. I use 
it for load testing. The client script won't run out-of-the-box since it 
depends on local additions, but it shows you how to use the 
ClientConnection. It only does authentication, you have to add any other 
stanza handling you need.

> 
> Thanks,
> -Tim

	Mika
-------------- next part --------------
#!/usr/bin/perl

use lib 'lib';
use DJabberd::JID;
use strict;
use Digest::SHA1;

my $COUNT=200*5;
#my $initial_sleep=5;
my @children;
$Client::iterations=100;
my $wait_between=4*60;
my $initial_sleep=$wait_between;
#my $wait_between=10;

my @clients;

my $pass=Digest::SHA1::sha1_hex("password");

for (my $i=0; $i<$COUNT; $i++) {
	my $j=$i;
        Danga::Socket->AddTimer(rand($initial_sleep), sub {
	    my $jid=new DJabberd::JID('lt_' . $j . '@jaiku.com/Context');
	    my $c=new Client($jid, $pass);
	    $clients[$j]=$c;
        });
}

Danga::Socket->EventLoop();

package Client;
use base 'DJabberd::ClientConnection';
use IO::Handle;
use Socket;
use DJabberd::Util;
use Jaiku::Presence qw(mysql_datetime current_time current_timestamp format_datetime);
use strict;
use fields qw(suspended);

our $iterations;

sub new {
    my ($class, $jid, $password) = @_;
    my $sock;
    my $proto = getprotobyname('tcp');
    socket $sock, PF_INET, SOCK_STREAM, $proto;
    unless ($sock && defined fileno($sock)) {
	die "Cannot alloc socket";
	return;
    }
    my $ip="XXX.XXX.XXX.XXX";
    connect $sock, Socket::sockaddr_in(7224, Socket::inet_aton($ip));
    IO::Handle::blocking($sock, 0);

    my $self = $class->SUPER::new($sock, $jid, $pass);
    $self->{id}=$jid->node;
    $self->watch_write(1);

    return $self;
}

sub send_presence {
    my $self=shift;
    my $iter=shift;
    my $timestamp=format_datetime(current_time());
    my $presencev2="<presencev2><usergiven><since>20010101T010101</since><description>XXX</description></usergiven></presencev2>";
    my $pv2=$presencev2;
    $pv2=~s/XXX/$iter/;
    my $xml="<presence><status>" . $timestamp . DJabberd::Util::exml($pv2) . "</status></presence>";
    $self->log_outgoing_data($xml);
    $self->write($xml);
    if ($iter<$iterations) {
	if ( rand(100) < 15 ) {
		$self->resume;
	} else {
		$self->suspend;
   	} 
	Danga::Socket->AddTimer($wait_between+rand(5), sub {
		$self->send_presence($iter+1);
	});
    } else {
	$self->end_stream;
    }
}

sub on_logged_in {
    my $self=shift;
    $self->log_outgoing_data("<clientversion value='5' xmlns='http://www.cs.helsinki.fi/group/context' />");
    $self->write("<clientversion value='5' xmlns='http://www.cs.helsinki.fi/group/context' />");
    $self->send_presence(0);
}

sub suspend {
    my $self=shift;
    return if($self->{suspended});
    $self->write("<suspend xmlns='http://www.cs.helsinki.fi/group/context' />");
    $self->{suspended}=1;
}

sub resume {
    my $self=shift;
    return unless ($self->{suspended});
    $self->write("<resume xmlns='http://www.cs.helsinki.fi/group/context' />");
    $self->{suspended}=0;
}

sub on_stanza_received {
    my $self=shift;
    my $node=shift;
    my $element=$node->element;
    if ($element=~/tuple/) {
	my $xml=$node->as_xml;
	$self->log->info("received tuple");
	if ($xml=~m!id>(\d+)</id!) {
		my $id=$1;
		$self->write("<ack xmlns='http://www.cs.helsinki.fi/group/context'>$id</ack>");
	}
	return;
    } 
    return if ($element=~/messagecount/);
    if ($element=~/presence/) {
	$self->log->info("server having problem: received presence");
	return;
    }
    $self->SUPER::on_stanza_received($node);
}
-------------- next part --------------
package DJabberd::ClientConnection;
use strict;
use warnings;
use base 'Danga::Socket';
use Compress::Zlib;
use fields (
            'saxhandler',
            'parser',

            'bound_jid',      # undef until resource binding - then DJabberd::JID object

            'stream_id',      # undef until set first time
            'version',        # the DJabberd::StreamVersion we negotiated
            'rcvd_features',  # the features stanza we've received from the other party
            'log',            # Log::Log4perl object for this connection
            'xmllog',         # Log::Log4perl object that controls raw xml logging
            'id',             # connection id, used for logging purposes
            'iqctr',          # iq counter.  incremented whenever we SEND an iq to the party (roster pushes, etc)
            'in_stream',      # bool:  true if we're in a stream tag
            'counted_close',  # bool:  temporary here to track down the overcounting of disconnects
            'not_read_yet',   # bool:  have we received anything yet
            'do_compress',    # bool:  are we using ZLib
            'ostream',        # ZLib object for output
	    'istream',	      # ZLib object for input
	    'state',	      # state of the connection
	    'password', 'stream_start'
            );

our $connection_id = 1;

use XML::SAX ();
use DJabberd::XMLParser;
use Digest::SHA1 qw(sha1_hex);

use DJabberd::SAXHandler;
use DJabberd::JID;
use DJabberd::IQ;
use DJabberd::Message;
use DJabberd::Util qw(exml tsub);

use Data::Dumper;
use Carp qw(croak);

use DJabberd::Log;
our $hook_logger = DJabberd::Log->get_logger("DJabberd::Hook");

use constant POLLIN        => 1;
use constant POLLOUT       => 4;

#use constant XMLDEBUG      => "/tmp/djabberd/";
use constant XMLDEBUG      => "";
our %LOGMAP;

sub new {
    my ($class, $sock, $jid, $pass) = @_;
    my $self = $class->SUPER::new($sock);
    $self->{bound_jid}=$jid;

    $self->{log}     = DJabberd::Log->get_logger($class);
    $self->log->info("creating");
    $self->{password}=$pass;

    # hack to inject XML after Connection:: in the logger category
    my $xml_category = $class;
    $xml_category =~ s/Connection::/Connection::XML::/;

    #$self->{xmllog}  = DJabberd::Log->get_logger($xml_category);
    $self->{xmllog} = $self->{log};

    my $fromip = $self->peer_ip_string || "<undef>";

    if (XMLDEBUG) {
        system("mkdir -p " . XMLDEBUG ."$$/");
        my $handle = IO::Handle->new;
        no warnings;
        my $from = $fromip || "outbound";
        my $filename = "+>" . XMLDEBUG . "/$$/$from-$self->{id}";
        open ($handle, $filename) || $self->log->logdie("Cannot open $filename: $!");
        $handle->autoflush(1);
        $LOGMAP{$self} = $handle;
    }
    $self->{not_read_yet}=1;
    $self->{do_compress}=0;
    $self->{state}="connecting";
    return $self;
}

sub log {
    return $_[0]->{log};
}

sub xmllog {
    return $_[0]->{xmllog};
}

sub handler {
    return $_[0]->{saxhandler};
}

sub bound_jid {
    my DJabberd::ClientConnection $self = $_[0];
    return $self->{bound_jid};
}

sub new_iq_id {
    my DJabberd::ClientConnection $self = shift;
    $self->{iqctr}++;
    return "iq$self->{iqctr}";
}

sub log_outgoing_data {
    my ($self, $text) = @_;
    if($self->xmllog->is_debug) {
        $self->xmllog->debug("$self->{id} > " . ($text || ""));
    } else {
        local $DJabberd::ASXML_NO_TEXT = 1;
        $self->xmllog->info( ($self->{id} || "") . " > " . ($text || ""));
    }
}

sub log_incoming_data {
    my ($self, $node) = @_;
    if($self->xmllog->is_debug) {
        $self->xmllog->debug( ($self->{id} || "") . " < " . $node->as_xml);
    } else {
        local $DJabberd::ASXML_NO_TEXT = 1;
        $self->xmllog->info("$self->{id} < " . $node->as_xml);
    }
}

sub discard_parser {
    my DJabberd::ClientConnection $self = shift;
    # TODOTEST: bunch of new connections speaking not-well-formed xml and getting booted, then watch for mem leaks
    my $p = $self->{parser}   or return;
    $self->{parser}        = undef;
    $self->{saxhandler}->cleanup;
    $self->{saxhandler} = undef;
    Danga::Socket->AddTimer(0, sub {
        $p->finish_push;
    });
}

my %free_parsers;  # $ns -> [ [parser,handler]* ]
sub borrow_a_parser {
    my DJabberd::ClientConnection $self = $_[0];

    # get a parser off the freelist
    if (0 && $self->{in_stream}) {
        my $ns = $self->namespace;
        my $freelist = $free_parsers{$ns} || [];
        if (my $ent = pop @$freelist) {
            ($self->{parser}, $self->{saxhandler}) = @$ent;
            $self->{saxhandler}->set_connection($self);
            # $self->log->logdie("ASSERT") unless $self->{parser}{LibParser};
            return $self->{parser};
        }
    }

    # no parser?  gotta make one.
    my $handler = DJabberd::SAXHandler->new;
    my $p       = DJabberd::XMLParser->new(Handler => $handler);

    if ($self->{in_stream}) {
        # gotta get it into stream-able state with an open root node
        # so client can send us multiple stanzas.  unless we're waiting for
        # the start stream, in which case it may also have an xml declaration
        # like <?xml ... ?> at top, which can only come at top, so we need
        # a virgin parser.
        my $ns = $self->namespace;

        # this is kinda a hack, in that it hard-codes the namespace
        # prefixes 'db' and 'stream',...  however, RFC 3920 seection
        # 11.2.1, 11.2.3, etc say it's okay for historical reasons to
        # force the prefixes for both 'stream' and 'db'
        my $other = $ns eq "jabber:server" ? "xmlns:db='jabber:server:dialback'" : "";
        $p->parse_chunk_scalarref(\ qq{<stream:stream
                                           xmlns='$ns'
                                           xmlns:stream='http://etherx.jabber.org/streams'
                                           $other>});
    }

    $handler->set_connection($self);
    $self->{saxhandler} = $handler;
    $self->{parser} = $p;
    return $p;
}

sub return_parser {
    my DJabberd::ClientConnection $self = $_[0];
    return;

    my $freelist = $free_parsers{$self->namespace} ||= [];

    # BIG FAT WARNING:  with fields objects, you can't do:
    #   my $p = delete $self->{parser}.
    # You'd think you could, but it leaves $self->{parser} with some magic fucked up undef/but not
    # value and $p's refcount never goes down.  Some Perl bug due to fields, weakrefs, etc?  Who knows.
    # This affects Perl 5.8.4, but not Perl 5.8.8.
    my $p       = $self->{parser};     $self->{parser} = undef;
    my $handler = $self->{saxhandler}; $self->{saxhandler} = undef;
    $handler->set_connection(undef);

    if (@$freelist < 5) {
        push @$freelist, [$p, $handler];

    } else {
        Danga::Socket->AddTimer(0, sub {
            $p->finish_push;
        });
    }
}

sub set_rcvd_features {
    my ($self, $feat_stanza) = @_;
    $self->{rcvd_features} = $feat_stanza;
}

sub set_bound_jid {
    my ($self, $jid) = @_;
    $self->log->logdie("no jid") unless $jid && $jid->isa('DJabberd::JID');
    $self->{bound_jid} = $jid;
}

sub set_version {
    my ($self, $verob) = @_;
    $self->{version} = $verob;
}

sub version {
    my $self = shift;
    return $self->{version} or
        $self->log->logdie("Version accessed before it was set");
}

sub stream_id {
    my $self = shift;
    return $self->{stream_id} ||= Digest::SHA1::sha1_hex(rand() . rand() . rand());
}

sub state {
    return $_[0]->{state};
}

# called by DJabberd::SAXHandler
sub on_stanza_received {
    my ($self, $node) = @_;
    my $element=$node->element;
    #print STDERR "ELEMENT " . $element . "\n";
    $self->log_incoming_data($node);
    return if ($element =~ /feature/);
    #print STDERR "ELEMENT " . $element . "\n";
    if ($self->state eq "getting_auth") {
	$self->send_auth($node);
    } elsif ($self->state eq "sending_auth") {
	$self->on_auth_reply($node);
    } else {
       $self->log->logdie("SUBCLASSES MUST OVERRIDE 'on_stanza_received' for $self\n");
    }
}

# subclasses should override returning 0 or 1
sub is_server {
    return 0;
}

sub send_stanza {
    my ($self, $stanza) = @_;
    $self->write_stanza($stanza);
}

sub write_stanza {
    my ($self, $stanza) = @_;

    my $to_jid    = $stanza->to_jid  || $self->log->logdie("missing 'to' attribute in ".$stanza->element_name." stanza");
    my $from_jid  = $stanza->from_jid;  # this can be iq
    my $elename   = $stanza->element_name;

    my $other_attrs = "";
    my $attrs = $stanza->attrs;
    while (my ($k, $v) = each %$attrs) {
        $k =~ s/.+\}//; # get rid of the namespace
        next if $k eq "to" || $k eq "from";
        $other_attrs .= "$k=\"" . exml($v) . "\" ";
    }

    my $from = "";
    $self->log->logdie("no from") if ($elename ne 'iq' && !$from_jid);

    $from = $from_jid ? " from='" . $from_jid->as_string_exml . "'" : "";

    my $to_str = $to_jid->as_string_exml;
    my $ns = $self->namespace;

    my $xml = "<$elename $other_attrs to='$to_str'$from>" . $stanza->innards_as_xml . "</$elename>";

    if ($self->xmllog->is_info) {
        # refactor this out
        my $debug;
        if($self->xmllog->is_debug) {
            $debug = "<$elename $other_attrs to='$to_str'$from>" . $stanza->innards_as_xml . "</$elename>";
        } else {
            local $DJabberd::ASXML_NO_TEXT = 1;
            $debug = "<$elename $other_attrs to='$to_str'$from>" . $stanza->innards_as_xml . "</$elename>";
        }
        $self->log_outgoing_data($debug);
    }

    $self->write(\$xml);
}

sub namespace {
    my $self = shift;
    Carp::confess("namespace called on $self which has no namespace");
}

# called by Danga::Socket when a write doesn't fully go through.  by default it
# enables writability.  but we want to do nothing if we're waiting for a read for SSL
sub on_incomplete_write {
    my $self = shift;
    return if $self->{write_when_readable};
    $self->SUPER::on_incomplete_write;
}

# called by SSL machinery to let us know a write is stalled on readability.
# so we need to (at least temporarily) go readable and then process writes.
sub write_when_readable {
    my $self = shift;

    # enable readability, but remember old value so we can pop it back
    my $prev_readable = ($self->{event_watch} & POLLIN)  ? 1 : 0;
    $self->watch_read(1);
    $self->{write_when_readable} = [ $prev_readable ];

    # don't need to push/pop its state because Danga::Socket->write, called later,
    # will do the one final write, or if not all written, will turn on watch_write
    $self->watch_write(0);
}

sub restart_stream {
    my DJabberd::ClientConnection $self = shift;

    $self->{in_stream} = 0;

    # to be safe, we just discard the parser, as they might've sent,
    # say, "<starttls/><attack", knowing the next user will get that
    # parser with "<attack" open and get a parser error and be
    # disconnected.
    $self->discard_parser;
}


# this is a hack to get everything we print
# this is a slow down now, will fix later but
# eval is being annoying
sub write {
    my $self = shift;
    if ($self->{do_compress} && (ref($_[0]) ne 'CODE')) {
	my $data=$_[0];
        $data = $$data if (ref($data) eq 'SCALAR');
	unless (defined($data)) {
    		return $self->SUPER::write(@_);
	}
	my $debug=$data;
    utf8::encode($data);
	my ($r, $status) = $self->{ostream}->deflate($data);
	if ($status != Z_OK) { 
                open (DEBUG, ">>/tmp/z-stream-error");
                print DEBUG "deflate fails with $status:\n";
		if (defined($debug)) {
                	print DEBUG $debug, "\n";
		} else {
			print "undef\n";
		}
                close(DEBUG);
                $self->stream_error("error in deflate $status");
                return 1;
	}
	$data=$r;
	if ( defined($debug) ) {
		($r, $status) = $self->{ostream}->flush(Z_SYNC_FLUSH);
		if ($status != Z_OK) { 
			open (DEBUG, ">>/tmp/z-stream-error");
			print DEBUG "flush fails with $status:\n";
			print DEBUG $debug, "\n";
			close(DEBUG);
			$self->stream_error("error in flush $status");
			return 1;
		}
		$data .= $r;
	}
    	return $self->SUPER::write($data);
    }
    if (XMLDEBUG) {
        my $time = Time::HiRes::time;
        no warnings;
        my $data = $_[0];
        $data = $$data if (ref($data) eq 'SCALAR');
        $LOGMAP{$self}->print("$time\t> $data\n") if $LOGMAP{$self} &&  ref($data) ne 'CODE' ;
    }
    my $data=shift;
    $data=$$data if (ref $data);
    if ($data) {
    	#print STDERR "SENDING $data\n";
    }
    $self->SUPER::write($data);
}


# DJabberd::ClientConnection
sub event_read {
    my DJabberd::ClientConnection $self = shift;


    my $bref;
    # non-ssl mode:
    $bref = $self->read(20_000);
    return $self->close unless defined $bref;
    my $first_read=0;
    if (ref($bref) && $self->{not_read_yet}) {
        $first_read=1;
        $self->{not_read_yet}=0;
	if ( substr($$bref, 0, 1) ne "<" ) {
	    $self->{do_compress}=1;
	    my $status;
	    ($self->{ostream}, $status) = deflateInit();
	    if ($status != Z_OK) { 
		$self->log->logdie("error in deflateInit"); }
	    ($self->{istream}, $status) = inflateInit();
	    if ($status != Z_OK) { $self->log->logdie("error in inflateInit"); }
	}
    }
    if ($self->{do_compress}) {
	my ($r, $status) = $self->{istream}->inflate($$bref);
	if ($status != Z_OK) { 
                if (! $first_read ) {
		    $self->log->error("error in inflate");
        	    $self->close;
		    return;
                } else {
                    undef($self->{istream});
                    undef($self->{ostream});
                    $self->{do_compress}=0;
                }
	} else {
            $bref=\$r;
	}
    }


    # clients send whitespace between stanzas as keep-alives.  let's just ignore those,
    # not going through the bother to checkout a parser and all.
    return if ! $self->{parser} && $$bref !~ /\S/;

    Carp::confess if ($self->{closed});

    if (XMLDEBUG) {
        my $time = Time::HiRes::time;
        $LOGMAP{$self}->print("$time\t< $$bref\n");
    }

    my $p = $self->{parser} || $self->borrow_a_parser;
    my $len = length $$bref;
    #$self->log->debug("$self->{id} parsing $len bytes...") unless $len == 1;

    eval {
        $p->parse_chunk_scalarref($bref);
    };

    if ($@) {
	print STDERR "ERROR IN RECV: $@\n";
        # FIXME: give them stream error before closing them,
        # wait until they get the stream error written to them before closing
        $self->discard_parser;
	my $id=$self->{id} || "";
        $self->log->error("$id disconnected $self because: $@");
        $self->log->warn("$id parsing *****\n$$bref\n*******\n\n\n");
        $self->close;
        return;
    }

    # if we still have a handler and haven't already closed down (cleanly),
    # then let's consider giving our xml parser/sax pair back, if we're at
    # a good breaking point.
    if ((my $handler = $self->handler) && ! $self->{closed}) {
        my $depth = $handler->depth;
        if ($depth == 0 && $$bref =~ m!>\s*$!) {
            # if no errors and not inside a stanza, return our parser to save memory
            $self->return_parser;
        }
    }
}

sub send_auth {
    my $self = shift;
    my $authreply_stanza = shift;
    my $authreply = $authreply_stanza->as_xml;
    my $password = $self->{password};

    my $ss = $self->{stream_start};
    my $to = $self->bound_jid->domain;

    my $username = $self->bound_jid->node;

    $self->log->logdie("didn't get reply") unless $authreply =~ /id=.auth1\b/;
    my $response = "";
    if ($authreply =~ /\bpassword\b/) {
        $response = "<password>$password</password>";
    } elsif ($authreply =~ /\bdigest\b/) {
        use Digest::SHA1 qw(sha1_hex);
	$self->log->info("STREAM ID " . $ss->id);
        my $dig = lc(sha1_hex($ss->id . $password));
        $response = "<digest>$dig</digest>";
    } else {
        $self->log->logdie("can't do password nor digest auth: [$authreply]");
    }

    my $res = $self->bound_jid->resource;
    my $xml="<iq type='set' id='auth2'>
  <query xmlns='jabber:iq:auth'>
    <username>$username</username>
    $response
    <resource>$res</resource>
  </query>
</iq>";
    $self->{xmllog}->info($xml);
    $self->write(\$xml);
    $self->{state}="sending_auth";
}

sub on_auth_reply {

    my $self=shift;
    my $reply2=shift;
    my $authreply2 = $reply2->as_xml;
    warn "auth reply post-login: [$authreply2]\n" if $ENV{TESTDEBUG};

    $self->log->logdie("no reply") unless $authreply2 =~ /id=.auth2\b/;
    $self->log->logdie("bad password") unless $authreply2 =~ /type=.result\b/;

    $self->{stream_start} = undef;
    delete $self->{stream_start};

    $self->{state}="logged_in";
    $self->on_logged_in;
}

sub on_stream_start {
    my DJabberd::ClientConnection $self = shift;
    my $ss = shift;
    $self->{stream_start}=$ss;
    my $xml="<iq type='get' id='auth1'><query xmlns='jabber:iq:auth'/></iq>";
    $self->{xmllog}->info($xml);
    $self->{state}="getting_auth";
    $self->{in_stream}=1;
    $self->write($xml);
}

# when we're the client of a stream (we're talking first)
sub start_init_stream {
    my DJabberd::ClientConnection  $self = shift;
    my %opts = @_;
    my $extra_attr = delete $opts{'extra_attr'} || "";
    my $to         = delete $opts{'to'} || Carp::croak("need 'to' domain");
    $self->log->logdie(extra opts) if %opts;

    # {=init-version-is-max} -- we must announce the highest version we support
    my $our_version = DJabberd::StreamVersion->new("1.0");
    my $ver_attr    = $our_version->as_attr_string;

    # by default we send the optional to='' attribute in our stream, but we have support for
    # disabling it for our test suite.
    $to = "to='$to'";
    $to = "" if $DJabberd::_T_NO_TO_IN_DIALBACKVERIFY_STREAM;

    # {=xml-lang}
    my $xml = qq{<?xml version="1.0" encoding="UTF-8"?><stream:stream $to xmlns:stream='http://etherx.jabber.org/streams' xmlns='jabber:client' xml:lang='en' $extra_attr $ver_attr>};
    $self->log_outgoing_data($xml);
    $self->write($xml);
}

sub end_stream {
    my DJabberd::ClientConnection $self = shift;
    $self->write("</stream:stream>");
    $self->write(sub { $self->close; });
}

sub event_write {
    my $self = shift;
    if ($self->{state} eq "connecting") {
        $self->{state}="connected";
	$self->on_connected;
    } else {
    	$self->watch_write(0) if $self->write(undef);
    }
}

# info is optional descriptive text
sub stream_error {
    my ($self, $err, $info) = @_;
    $info ||= "";

    # {=stream-errors}
    $self->log->warn( ($self->{id} || "") . " stream error '$err': $info");
    my $infoxml = "";
    if ($info) {
        $infoxml = "<text xmlns='urn:ietf:params:xml:ns:xmpp-streams'>" . exml($info) . "</text>";
    }
    unless ($self->{in_stream}) {
        $self->write(qq{<?xml version='1.0'?><stream:stream xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' id='bye' xml:lang='en'>});
    }

    $self->write("<stream:error><$err xmlns='urn:ietf:params:xml:ns:xmpp-streams'/>$infoxml</stream:error>");
    # {=error-must-close-stream}
    $self->close_stream;
}

sub close_stream {
    my ($self, $err) = @_;
    $self->write("</stream:stream>");
    $self->write(sub { $self->close; });
}

sub close {
    #print STDERR "CONNECTION::CLOSE\n";
    my DJabberd::ClientConnection $self = shift;
    return if $self->{closed};


    if ($self->{counted_close}++) {
        $self->log->logcluck("We are about to increment the diconnect counter one time too many, but we didn't");
    } else {
        $DJabberd::Stats::counter{disconnect}++;
    }

    $self->log->debug("DISCONNECT: $self->{id}\n") if $self->{id};

    if (my $p = $self->{parser}) {
        # libxml isn't reentrant apparently, so we can't finish_push
        # from inside an existint callback.  so schedule immediately,
        # after event loop.
        Danga::Socket->AddTimer(0, sub {
            $p->finish_push;
            $self->{saxhandler}->cleanup if $self->{saxhandler};
            $self->{saxhandler} = undef;
            $self->{parser}     = undef;
        });
    }
    if (XMLDEBUG) {
        $LOGMAP{$self}->close;
        delete $LOGMAP{$self};
    }
    $self->SUPER::close;
}

# DJabberd::ClientConnection
sub event_err { my $self = shift; $self->close; }
sub event_hup { my $self = shift; $self->close; }

sub on_connected {
    my $self = shift;
    $self->log->info("connected");
    $self->start_init_stream( to=>$self->bound_jid->domain );
    $self->watch_read(1);
}

# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

1;


More information about the Djabberd mailing list