view release on metacpan or  search on metacpan

lib/SOAP/Transport/JABBER.pm  view on Meta::CPAN

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;