# 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;