File Coverage

blib/lib/SOAP/Transport/JABBER.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

# ======================================================================
#
# Copyright (C) 2000-2001 Paul Kulchenko ([e-mail])
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# $Id: JABBER.pm 353 2010-03-17 21:08:34Z kutterma $
#
# ======================================================================

package SOAP::Transport::JABBER;

use strict;
use warnings;

our $VERSION = 0.713;

use Net::Jabber 1.0021 qw(Client);
use URI::Escape;
use URI;

my $NAMESPACE = "http://namespaces.soaplite.com/transport/jabber";

{
    no warnings qw(redefine);
                                 # fix problem with printData in 1.0021
    *Net::Jabber::printData = sub { 'nothing' }
      if Net::Jabber->VERSION == 1.0021;

    # fix problem with Unicode encoding in EscapeXML.
    # Jabber ALWAYS converts latin to utf8
    *Net::Jabber::EscapeXML = *Net::Jabber::EscapeXML = # that's Jabber 1.0021
      *XML::Stream::EscapeXML =
      *XML::Stream::EscapeXML =                         # that's Jabber 1.0022
      \&SOAP::Utils::encode_data;

    # There is also an error in XML::Stream::UnescapeXML 1.12, but
    # we can't do anything there, except hack it also :(
}

# ======================================================================

package URI::jabber;    # ok, lets do 'jabber://' scheme
require URI::_server;
require URI::_userpass;
@URI::jabber::ISA = qw(URI::_server URI::_userpass);

# jabber://soaplite_client:[e-mail]:5222/[e-mail]/Home
# ^^^^^^   ^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^ ^^^^^^^^^^ ^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^

# ======================================================================

package SOAP::Transport::JABBER::Query;
our $VERSION = 0.713;
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;
our $VERSION = 0.713;
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;

    # nothing to do if new endpoint is the same as current one
    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',
    );

    # Get roster and announce presence
    $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;

    # Create a Jabber info/query message
    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;    # expect only one
    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;
our $VERSION = 0.713;
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);    # expect only one
                my $request = $query->GetPayload();

                SOAP::Trace::debug($request);

                # Set up response
                my $reply = $iq->Reply;
                my $x     = $reply->NewQuery($NAMESPACE);

                my $response = $self->SUPER::handle($request);
                $x->SetPayload($response);

                # Send 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__