The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
# this isn't meant to be used in production, but just for weird
# internal uses.  maybe you'll use it in production anyway.

package DJabberd::Connection::SimpleIn;
use strict;
use base 'DJabberd::Connection';
use fields (
            'read_buf',
            );

sub new {
    my ($class, $sock, $server) = @_;
    my $self = $class->SUPER::new($sock, $server);

    # set this later
    $self->{vhost}   = undef;
    $self->{read_buf} = '';

    warn "CONNECTION from " . $self->peer_ip_string . " == $self\n";

    return $self;
}

sub event_write {
    my $self = shift;
    $self->watch_write(0) if $self->write(undef);
}

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

    my $bref = $self->read(1024);
    return $self->close unless defined $bref;
    $self->{read_buf} .= $$bref;

    if ($self->{read_buf} =~ s/^(.*)\r?\n//) {
        my $line = $1;
        $self->process_line( $line );
    }
}

sub process_line {
    my DJabberd::Connection::SimpleIn $self = shift;
    my $line = shift;
    return $self->close unless $line =~ /^(\w+)\s*([^\n\r]*)/;
    my ($cmd, $rest) = ($1, $2);

    if ($cmd eq "set_vhost") {
        my $vhostname = $rest;
        my $vhost = $self->server->lookup_vhost($vhostname);
        unless ($vhost) {
            $self->write("ERROR no vhost '$vhostname'\n");
            return;
        }
        $self->{vhost} = $vhost;
        Scalar::Util::weaken($self->{vhost});
        $self->write("OK\n");
        return;
    }

    if ($cmd eq "send_xml") {
        my ($to, $enc_xml) = split(/\s+/, $rest);
        my $xml = durl($enc_xml);
        warn "SIMPLE: sending to '$to', the XML '$xml'\n";

        my $vhost = $self->vhost;
        unless ($vhost) {
            $self->write("ERROR must first 'set_vhost'\n");
            return;
        }

        my $dconn = $vhost->find_jid($to);
        unless ($dconn) {
            warn "error.\n";
            $self->write("ERROR\n");
            return;
        }

        warn "all good. dconn = $dconn\n";
        $dconn->write($xml);
        $self->write("OK\n");
        return;
    }

    $self->write("ERROR UNKNOWN_COMMAND\n");
}

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

sub durl {
    my ($a) = @_;
    $a =~ tr/+/ /;
    $a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
    return $a;
}




1;