1# ====================================================================== 2# 3# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com) 4# SOAP::Lite is free software; you can redistribute it 5# and/or modify it under the same terms as Perl itself. 6# 7# $Id: JABBER.pm 51 2004-11-14 19:30:50Z byrnereese $ 8# 9# ====================================================================== 10 11package SOAP::Transport::JABBER; 12 13use strict; 14use vars qw($VERSION); 15#$VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name$ =~ /-(\d+)_([\d_]+)/); 16$VERSION = $SOAP::Lite::VERSION; 17 18use Net::Jabber 1.0021 qw(Client); 19use URI::Escape; 20use URI; 21use SOAP::Lite; 22 23my $NAMESPACE = "http://namespaces.soaplite.com/transport/jabber"; 24 25{ local $^W; 26 # fix problem with printData in 1.0021 27 *Net::Jabber::printData = sub {'nothing'} if Net::Jabber->VERSION == 1.0021; 28 29 # fix problem with Unicode encoding in EscapeXML. Jabber ALWAYS convert latin to utf8 30 *Net::Jabber::EscapeXML = *Net::Jabber::EscapeXML = # that's Jabber 1.0021 31 *XML::Stream::EscapeXML = *XML::Stream::EscapeXML = # that's Jabber 1.0022 32 \&SOAP::Utils::encode_data; 33 34 # There is also an error in XML::Stream::UnescapeXML 1.12, but 35 # we can't do anything there, except hack it also :( 36} 37 38# ====================================================================== 39 40package URI::jabber; # ok, lets do 'jabber://' scheme 41require URI::_server; require URI::_userpass; 42@URI::jabber::ISA=qw(URI::_server URI::_userpass); 43 44 # jabber://soaplite_client:soapliteclient@jabber.org:5222/soaplite_server@jabber.org/Home 45 # ^^^^^^ ^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^ ^^^^^^^^^^ ^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^ 46 47# ====================================================================== 48 49package SOAP::Transport::JABBER::Query; 50 51sub new { 52 my $proto = shift; 53 bless {} => ref($proto) || $proto; 54} 55 56sub SetPayload { 57 shift; Net::Jabber::SetXMLData("single",shift->{QUERY},"payload",shift,{}); 58} 59 60sub GetPayload { 61 shift; Net::Jabber::GetXMLData("value",shift->{QUERY},"payload",""); 62} 63 64# ====================================================================== 65 66package SOAP::Transport::JABBER::Client; 67 68use vars qw(@ISA); 69@ISA = qw(SOAP::Client Net::Jabber::Client); 70 71sub DESTROY { SOAP::Trace::objects('()') } 72 73sub new { 74 my $self = shift; 75 76 unless (ref $self) { 77 my $class = ref($self) || $self; 78 my(@params, @methods); 79 while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } 80 $self = $class->SUPER::new(@params); 81 while (@methods) { my($method, $params) = splice(@methods,0,2); 82 $self->$method(ref $params eq 'ARRAY' ? @$params : $params) 83 } 84 SOAP::Trace::objects('()'); 85 } 86 return $self; 87} 88 89sub endpoint { 90 my $self = shift; 91 92 return $self->SUPER::endpoint unless @_; 93 94 my $endpoint = shift; 95 96 # nothing to do if new endpoint is the same as current one 97 return $self if $self->SUPER::endpoint && $self->SUPER::endpoint eq $endpoint; 98 99 my $uri = URI->new($endpoint); 100 my($undef, $to, $resource) = split m!/!, $uri->path, 3; 101 $self->Connect( 102 hostname => $uri->host, 103 port => $uri->port, 104 ) or Carp::croak "Can't connect to @{[$uri->host_port]}: $!"; 105 106 my @result = $self->AuthSend( 107 username => $uri->user, 108 password => $uri->password, 109 resource => 'soapliteClient', 110 ); 111 $result[0] eq "ok" or Carp::croak "Can't authenticate to @{[$uri->host_port]}: @result"; 112 113 $self->AddDelegate( 114 namespace => $NAMESPACE, 115 parent => 'Net::Jabber::Query', 116 parenttype => 'query', 117 delegate => 'SOAP::Transport::JABBER::Query', 118 ); 119 120 # Get roster and announce presence 121 $self->RosterGet(); 122 $self->PresenceSend(); 123 124 $self->SUPER::endpoint($endpoint); 125} 126 127sub send_receive { 128 my($self, %parameters) = @_; 129 my($envelope, $endpoint, $encoding) = 130 @parameters{qw(envelope endpoint encoding)}; 131 132 $self->endpoint($endpoint ||= $self->endpoint); 133 134 my($undef, $to, $resource) = split m!/!, URI->new($endpoint)->path, 3; 135 136 # Create a Jabber info/query message 137 my $iq = new Net::Jabber::IQ(); 138 $iq->SetIQ( 139 type => 'set', 140 to => join '/', $to => $resource || 'soapliteServer', 141 ); 142 my $query = $iq->NewQuery($NAMESPACE); 143 $query->SetPayload($envelope); 144 145 SOAP::Trace::debug($envelope); 146 147 my $iq_rcvd = $self->SendAndReceiveWithID($iq); 148 my($query_rcvd) = $iq_rcvd->GetQuery($NAMESPACE) if $iq_rcvd; # expect only one 149 my $msg = $query_rcvd->GetPayload() if $query_rcvd; 150 151 SOAP::Trace::debug($msg); 152 153 my $code = $self->GetErrorCode(); 154 155 $self->code($code); 156 $self->message($code); 157 $self->is_success(!defined $code || $code eq ''); 158 $self->status($code); 159 160 return $msg; 161} 162 163# ====================================================================== 164 165package SOAP::Transport::JABBER::Server; 166 167use Carp (); 168use vars qw(@ISA $AUTOLOAD); 169@ISA = qw(SOAP::Server); 170 171sub new { 172 my $self = shift; 173 174 unless (ref $self) { 175 my $class = ref($self) || $self; 176 my $uri = URI->new(shift); 177 $self = $class->SUPER::new(@_); 178 179 $self->{_jabberserver} = Net::Jabber::Client->new; 180 $self->{_jabberserver}->Connect( 181 hostname => $uri->host, 182 port => $uri->port, 183 ) or Carp::croak "Can't connect to @{[$uri->host_port]}: $!"; 184 185 my($undef, $resource) = split m!/!, $uri->path, 2; 186 my @result = $self->AuthSend( 187 username => $uri->user, 188 password => $uri->password, 189 resource => $resource || 'soapliteServer', 190 ); 191 $result[0] eq "ok" or Carp::croak "Can't authenticate to @{[$uri->host_port]}: @result"; 192 193 $self->{_jabberserver}->SetCallBacks( 194 iq => sub { 195 shift; 196 my $iq = new Net::Jabber::IQ(@_); 197 198 my($query) = $iq->GetQuery($NAMESPACE); # expect only one 199 my $request = $query->GetPayload(); 200 201 SOAP::Trace::debug($request); 202 203 # Set up response 204 my $reply = $iq->Reply; 205 my $x = $reply->NewQuery($NAMESPACE); 206 207 my $response = $self->SUPER::handle($request); 208 $x->SetPayload($response); 209 210 # Send response 211 $self->{_jabberserver}->Send($reply); 212 } 213 ); 214 215 $self->AddDelegate( 216 namespace => $NAMESPACE, 217 parent => 'Net::Jabber::Query', 218 parenttype => 'query', 219 delegate => 'SOAP::Transport::JABBER::Query', 220 ); 221 222 $self->RosterGet(); 223 $self->PresenceSend(); 224 } 225 return $self; 226} 227 228sub AUTOLOAD { 229 my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); 230 return if $method eq 'DESTROY'; 231 232 no strict 'refs'; 233 *$AUTOLOAD = sub { shift->{_jabberserver}->$method(@_) }; 234 goto &$AUTOLOAD; 235} 236 237sub handle { 238 shift->Process(); 239} 240 241# ====================================================================== 242 2431; 244 245__END__ 246