package SOAP::Transport::JABBER;
use strict;
use vars qw($VERSION);
$VERSION = $SOAP::Lite::VERSION;
use Net::Jabber 1.0021 qw(Client);
use URI::Escape;
use URI;
use SOAP::Lite;
my $NAMESPACE = "http://namespaces.soaplite.com/transport/jabber";
{ local $^W;
*Net::Jabber::printData = sub {'nothing'} if Net::Jabber->VERSION == 1.0021;
*Net::Jabber::EscapeXML = *Net::Jabber::EscapeXML = *XML::Stream::EscapeXML = *XML::Stream::EscapeXML = \&SOAP::Utils::encode_data;
}
package URI::jabber; require URI::_server; require URI::_userpass;
@URI::jabber::ISA=qw(URI::_server URI::_userpass);
package SOAP::Transport::JABBER::Query;
sub new {
my $proto = shift;
bless {} => ref($proto) || $proto;
}
sub SetPayload {
shift; Net::Jabber::SetXMLData("single",shift->{QUERY},"payload",shift,{});
}
sub GetPayload {
shift; Net::Jabber::GetXMLData("value",shift->{QUERY},"payload","");
}
package SOAP::Transport::JABBER::Client;
use vars qw(@ISA);
@ISA = qw(SOAP::Client Net::Jabber::Client);
sub DESTROY { SOAP::Trace::objects('()') }
sub new {
my $self = shift;
unless (ref $self) {
my $class = ref($self) || $self;
my(@params, @methods);
while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
$self = $class->SUPER::new(@params);
while (@methods) { my($method, $params) = splice(@methods,0,2);
$self->$method(ref $params eq 'ARRAY' ? @$params : $params)
}
SOAP::Trace::objects('()');
}
return $self;
}
sub endpoint {
my $self = shift;
return $self->SUPER::endpoint unless @_;
my $endpoint = shift;
return $self if $self->SUPER::endpoint && $self->SUPER::endpoint eq $endpoint;
my $uri = URI->new($endpoint);
my($undef, $to, $resource) = split m!/!, $uri->path, 3;
$self->Connect(
hostname => $uri->host,
port => $uri->port,
) or Carp::croak "Can't connect to @{[$uri->host_port]}: $!";
my @result = $self->AuthSend(
username => $uri->user,
password => $uri->password,
resource => 'soapliteClient',
);
$result[0] eq "ok" or Carp::croak "Can't authenticate to @{[$uri->host_port]}: @result";
$self->AddDelegate(
namespace => $NAMESPACE,
parent => 'Net::Jabber::Query',
parenttype => 'query',
delegate => 'SOAP::Transport::JABBER::Query',
);
$self->RosterGet();
$self->PresenceSend();
$self->SUPER::endpoint($endpoint);
}
sub send_receive {
my($self, %parameters) = @_;
my($envelope, $endpoint, $encoding) =
@parameters{qw(envelope endpoint encoding)};
$self->endpoint($endpoint ||= $self->endpoint);
my($undef, $to, $resource) = split m!/!, URI->new($endpoint)->path, 3;
my $iq = new Net::Jabber::IQ();
$iq->SetIQ(
type => 'set',
to => join '/', $to => $resource || 'soapliteServer',
);
my $query = $iq->NewQuery($NAMESPACE);
$query->SetPayload($envelope);
SOAP::Trace::debug($envelope);
my $iq_rcvd = $self->SendAndReceiveWithID($iq);
my($query_rcvd) = $iq_rcvd->GetQuery($NAMESPACE) if $iq_rcvd; my $msg = $query_rcvd->GetPayload() if $query_rcvd;
SOAP::Trace::debug($msg);
my $code = $self->GetErrorCode();
$self->code($code);
$self->message($code);
$self->is_success(!defined $code || $code eq '');
$self->status($code);
return $msg;
}
package SOAP::Transport::JABBER::Server;
use Carp ();
use vars qw(@ISA $AUTOLOAD);
@ISA = qw(SOAP::Server);
sub new {
my $self = shift;
unless (ref $self) {
my $class = ref($self) || $self;
my $uri = URI->new(shift);
$self = $class->SUPER::new(@_);
$self->{_jabberserver} = Net::Jabber::Client->new;
$self->{_jabberserver}->Connect(
hostname => $uri->host,
port => $uri->port,
) or Carp::croak "Can't connect to @{[$uri->host_port]}: $!";
my($undef, $resource) = split m!/!, $uri->path, 2;
my @result = $self->AuthSend(
username => $uri->user,
password => $uri->password,
resource => $resource || 'soapliteServer',
);
$result[0] eq "ok" or Carp::croak "Can't authenticate to @{[$uri->host_port]}: @result";
$self->{_jabberserver}->SetCallBacks(
iq => sub {
shift;
my $iq = new Net::Jabber::IQ(@_);
my($query) = $iq->GetQuery($NAMESPACE); my $request = $query->GetPayload();
SOAP::Trace::debug($request);
my $reply = $iq->Reply;
my $x = $reply->NewQuery($NAMESPACE);
my $response = $self->SUPER::handle($request);
$x->SetPayload($response);
$self->{_jabberserver}->Send($reply);
}
);
$self->AddDelegate(
namespace => $NAMESPACE,
parent => 'Net::Jabber::Query',
parenttype => 'query',
delegate => 'SOAP::Transport::JABBER::Query',
);
$self->RosterGet();
$self->PresenceSend();
}
return $self;
}
sub AUTOLOAD {
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
return if $method eq 'DESTROY';
no strict 'refs';
*$AUTOLOAD = sub { shift->{_jabberserver}->$method(@_) };
goto &$AUTOLOAD;
}
sub handle {
shift->Process();
}
1;
__END__