[0ff8d110] | 1 | ############################################################################## |
---|
| 2 | # |
---|
| 3 | # This library is free software; you can redistribute it and/or |
---|
| 4 | # modify it under the terms of the GNU Library General Public |
---|
| 5 | # License as published by the Free Software Foundation; either |
---|
| 6 | # version 2 of the License, or (at your option) any later version. |
---|
| 7 | # |
---|
| 8 | # This library is distributed in the hope that it will be useful, |
---|
| 9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
| 10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
---|
| 11 | # Library General Public License for more details. |
---|
| 12 | # |
---|
| 13 | # You should have received a copy of the GNU Library General Public |
---|
| 14 | # License along with this library; if not, write to the |
---|
| 15 | # Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
---|
| 16 | # Boston, MA 02111-1307, USA. |
---|
| 17 | # |
---|
| 18 | # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ |
---|
| 19 | # |
---|
| 20 | ############################################################################## |
---|
| 21 | |
---|
| 22 | package Net::Jabber::Protocol; |
---|
| 23 | |
---|
| 24 | =head1 NAME |
---|
| 25 | |
---|
| 26 | Net::Jabber::Protocol - Jabber Protocol Library |
---|
| 27 | |
---|
| 28 | =head1 SYNOPSIS |
---|
| 29 | |
---|
| 30 | Net::Jabber::Protocol is a module that provides a developer easy |
---|
| 31 | access to the Jabber Instant Messaging protocol. It provides high |
---|
| 32 | level functions to the Net::Jabber Client, Component, and Server |
---|
| 33 | objects. These functions are automatically indluded in those modules |
---|
| 34 | through AUTOLOAD and delegates. |
---|
| 35 | |
---|
| 36 | =head1 DESCRIPTION |
---|
| 37 | |
---|
| 38 | Protocol.pm seeks to provide enough high level APIs and automation of |
---|
| 39 | the low level APIs that writing a Jabber Client/Transport in Perl is |
---|
| 40 | trivial. For those that wish to work with the low level you can do |
---|
| 41 | that too, but those functions are covered in the documentation for |
---|
| 42 | each module. |
---|
| 43 | |
---|
| 44 | Net::Jabber::Protocol provides functions to login, send and receive |
---|
| 45 | messages, set personal information, create a new user account, manage |
---|
| 46 | the roster, and disconnect. You can use all or none of the functions, |
---|
| 47 | there is no requirement. |
---|
| 48 | |
---|
| 49 | For more information on how the details for how Net::Jabber is written |
---|
| 50 | please see the help for Net::Jabber itself. |
---|
| 51 | |
---|
| 52 | For more information on writing a Client see Net::Jabber::Client. |
---|
| 53 | |
---|
| 54 | For more information on writing a Transport see Net::Jabber::Transport. |
---|
| 55 | |
---|
| 56 | =head2 Modes |
---|
| 57 | |
---|
| 58 | Several of the functions take a mode argument that let you specify how |
---|
| 59 | the function should behave: |
---|
| 60 | |
---|
| 61 | block - send the packet with an ID, and then block until an answer |
---|
| 62 | comes back. You can optionally specify a timeout so that |
---|
| 63 | you do not block forever. |
---|
| 64 | |
---|
| 65 | nonblock - send the packet with an ID, but then return that id and |
---|
| 66 | control to the master program. Net::Jabber is still |
---|
| 67 | tracking this packet, so you must use the CheckID function |
---|
| 68 | to tell when it comes in. (This might not be very |
---|
| 69 | useful...) |
---|
| 70 | |
---|
| 71 | passthru - send the packet with an ID, but do NOT register it with |
---|
| 72 | Net::Jabber, then return the ID. This is useful when |
---|
| 73 | combined with the XPath function because you can register |
---|
| 74 | a one shot function tied to the id you get back. |
---|
| 75 | |
---|
| 76 | |
---|
| 77 | =head2 Basic Functions |
---|
| 78 | |
---|
| 79 | use Net::Jabber qw( Client ); |
---|
[cb54527] | 80 | $Con = Net::Jabber::Client->new(); # From |
---|
[0ff8d110] | 81 | $status = $Con->Connect(hostname=>"jabber.org"); # Net::Jabber::Client |
---|
| 82 | |
---|
| 83 | or |
---|
| 84 | |
---|
| 85 | use Net::Jabber qw( Component ); |
---|
[cb54527] | 86 | $Con = Net::Jabber::Component->new(); # |
---|
[0ff8d110] | 87 | $status = $Con->Connect(hostname=>"jabber.org", # From |
---|
| 88 | secret=>"bob"); # Net::Jabber::Component |
---|
| 89 | |
---|
| 90 | |
---|
| 91 | # |
---|
| 92 | # For callback setup, see Net::XMPP::Protocol |
---|
| 93 | # |
---|
| 94 | |
---|
| 95 | $Con->Info(name=>"Jarl", |
---|
| 96 | version=>"v0.6000"); |
---|
| 97 | |
---|
| 98 | =head2 ID Functions |
---|
| 99 | |
---|
| 100 | $id = $Con->SendWithID($sendObj); |
---|
| 101 | $id = $Con->SendWithID("<tag>XML</tag>"); |
---|
| 102 | $receiveObj = $Con->SendAndReceiveWithID($sendObj); |
---|
| 103 | $receiveObj = $Con->SendAndReceiveWithID($sendObj, |
---|
| 104 | 10); |
---|
| 105 | $receiveObj = $Con->SendAndReceiveWithID("<tag>XML</tag>"); |
---|
| 106 | $receiveObj = $Con->SendAndReceiveWithID("<tag>XML</tag>", |
---|
| 107 | 5); |
---|
| 108 | $yesno = $Con->ReceivedID($id); |
---|
| 109 | $receiveObj = $Con->GetID($id); |
---|
| 110 | $receiveObj = $Con->WaitForID($id); |
---|
| 111 | $receiveObj = $Con->WaitForID($id, |
---|
| 112 | 20); |
---|
| 113 | |
---|
| 114 | =head2 IQ Functions |
---|
| 115 | |
---|
| 116 | =head2 Agents Functions |
---|
| 117 | |
---|
| 118 | %agents = $Con->AgentsGet(); |
---|
| 119 | %agents = $Con->AgentsGet(to=>"transport.jabber.org"); |
---|
| 120 | |
---|
| 121 | =head2 Browse Functions |
---|
| 122 | |
---|
| 123 | %hash = $Con->BrowseRequest(jid=>"jabber.org"); |
---|
| 124 | %hash = $Con->BrowseRequest(jid=>"jabber.org", |
---|
| 125 | timeout=>10); |
---|
| 126 | |
---|
| 127 | $id = $Con->BrowseRequest(jid=>"jabber.org", |
---|
| 128 | mode=>"nonblock"); |
---|
| 129 | |
---|
| 130 | $id = $Con->BrowseRequest(jid=>"jabber.org", |
---|
| 131 | mode=>"passthru"); |
---|
| 132 | |
---|
| 133 | =head2 Browse DB Functions |
---|
| 134 | |
---|
| 135 | $Con->BrowseDBDelete("jabber.org"); |
---|
| 136 | $Con->BrowseDBDelete(Net::Jabber::JID); |
---|
| 137 | |
---|
| 138 | $presence = $Con->BrowseDBQuery(jid=>"bob\@jabber.org"); |
---|
| 139 | $presence = $Con->BrowseDBQuery(jid=>Net::Jabber::JID); |
---|
| 140 | $presence = $Con->BrowseDBQuery(jid=>"users.jabber.org", |
---|
| 141 | timeout=>10); |
---|
| 142 | $presence = $Con->BrowseDBQuery(jid=>"conference.jabber.org", |
---|
| 143 | refresh=>1); |
---|
| 144 | |
---|
| 145 | =head2 Bystreams Functions |
---|
| 146 | |
---|
| 147 | %hash = $Con->ByteStreamsProxyRequest(jid=>"proxy.server"); |
---|
| 148 | %hash = $Con->ByteStreamsProxyRequest(jid=>"proxy.server", |
---|
| 149 | timeout=>10); |
---|
| 150 | |
---|
| 151 | $id = $Con->ByteStreamsProxyRequest(jid=>"proxy.server", |
---|
| 152 | mode=>"nonblock"); |
---|
| 153 | |
---|
| 154 | $id = $Con->ByteStreamsProxyRequest(jid=>"proxy.server", |
---|
| 155 | mode=>"passthru"); |
---|
| 156 | |
---|
| 157 | |
---|
| 158 | %hash = $Con->ByteStreamsProxyParse($query); |
---|
| 159 | |
---|
| 160 | |
---|
| 161 | $status = $Con->ByteStreamsProxyActivate(sid=>"stream_id", |
---|
| 162 | jid=>"proxy.server"); |
---|
| 163 | $status = $Con->ByteStreamsProxyActivate(sid=>"stream_id", |
---|
| 164 | jid=>"proxy.server", |
---|
| 165 | timeout=>10); |
---|
| 166 | |
---|
| 167 | $id = $Con->ByteStreamsProxyActivate(sid=>"stream_id", |
---|
| 168 | jid=>"proxy.server", |
---|
| 169 | mode=>"nonblock"); |
---|
| 170 | |
---|
| 171 | $id = $Con->ByteStreamsProxyActivate(sid=>"stream_id", |
---|
| 172 | jid=>"proxy.server", |
---|
| 173 | mode=>"passthru"); |
---|
| 174 | |
---|
| 175 | |
---|
| 176 | $jid = $Con->ByteStreamsOffer(sid=>"stream_id", |
---|
| 177 | streamhosts=>[{jid=>"jid", |
---|
| 178 | host=>"host", |
---|
| 179 | port=>"port", |
---|
| 180 | zeroconf=>"zero", |
---|
| 181 | }, |
---|
| 182 | ... |
---|
| 183 | ], |
---|
| 184 | jid=>"bob\@jabber.org"); |
---|
| 185 | $jid = $Con->ByteStreamsOffer(sid=>"stream_id", |
---|
| 186 | streamhosts=>[{},{},...], |
---|
| 187 | jid=>"bob\@jabber.org", |
---|
| 188 | timeout=>10); |
---|
| 189 | |
---|
| 190 | $id = $Con->ByteStreamsOffer(sid=>"stream_id", |
---|
| 191 | streamhosts=>[{},{},...], |
---|
| 192 | jid=>"bob\@jabber.org", |
---|
| 193 | mode=>"nonblock"); |
---|
| 194 | |
---|
| 195 | $id = $Con->ByteStreamsOffer(sid=>"stream_id", |
---|
| 196 | streamhosts=>[{},{},...], |
---|
| 197 | jid=>"bob\@jabber.org", |
---|
| 198 | mode=>"passthru"); |
---|
| 199 | |
---|
| 200 | =head2 Disco Functions |
---|
| 201 | |
---|
| 202 | %hash = $Con->DiscoInfoRequest(jid=>"jabber.org"); |
---|
| 203 | %hash = $Con->DiscoInfoRequest(jid=>"jabber.org", |
---|
| 204 | node=>"node..."); |
---|
| 205 | %hash = $Con->DiscoInfoRequest(jid=>"jabber.org", |
---|
| 206 | node=>"node...", |
---|
| 207 | timeout=>10); |
---|
| 208 | |
---|
| 209 | $id = $Con->DiscoInfoRequest(jid=>"jabber.org", |
---|
| 210 | mode=>"nonblock"); |
---|
| 211 | $id = $Con->DiscoInfoRequest(jid=>"jabber.org", |
---|
| 212 | node=>"node...", |
---|
| 213 | mode=>"nonblock"); |
---|
| 214 | |
---|
| 215 | $id = $Con->DiscoInfoRequest(jid=>"jabber.org", |
---|
| 216 | mode=>"passthru"); |
---|
| 217 | $id = $Con->DiscoInfoRequest(jid=>"jabber.org", |
---|
| 218 | node=>"node...", |
---|
| 219 | mode=>"passthru"); |
---|
| 220 | |
---|
| 221 | |
---|
| 222 | %hash = $Con->DiscoInfoParse($query); |
---|
| 223 | |
---|
| 224 | |
---|
| 225 | %hash = $Con->DiscoItemsRequest(jid=>"jabber.org"); |
---|
| 226 | %hash = $Con->DiscoItemsRequest(jid=>"jabber.org", |
---|
| 227 | timeout=>10); |
---|
| 228 | |
---|
| 229 | $id = $Con->DiscoItemsRequest(jid=>"jabber.org", |
---|
| 230 | mode=>"nonblock"); |
---|
| 231 | |
---|
| 232 | $id = $Con->DiscoItemsRequest(jid=>"jabber.org", |
---|
| 233 | mode=>"passthru"); |
---|
| 234 | |
---|
| 235 | |
---|
| 236 | %hash = $Con->DiscoItemsParse($query); |
---|
| 237 | |
---|
| 238 | =head2 Feature Negotiation Functions |
---|
| 239 | |
---|
| 240 | |
---|
| 241 | %hash = $Con->FeatureNegRequest(jid=>"jabber.org", |
---|
| 242 | features=>{ feat1=>["opt1","opt2",...], |
---|
| 243 | feat2=>["optA","optB",...] |
---|
| 244 | } |
---|
| 245 | ); |
---|
| 246 | %hash = $Con->FeatureNegRequest(jid=>"jabber.org", |
---|
| 247 | features=>{ ... }, |
---|
| 248 | timeout=>10); |
---|
| 249 | |
---|
| 250 | $id = $Con->FeatureNegRequest(jid=>"jabber.org", |
---|
| 251 | features=>{ ... }, |
---|
| 252 | mode=>"nonblock"); |
---|
| 253 | |
---|
| 254 | $id = $Con->FeatureNegRequest(jid=>"jabber.org", |
---|
| 255 | features=>{ ... }, |
---|
| 256 | mode=>"passthru"); |
---|
| 257 | |
---|
| 258 | my $query = $self->FeatureNegQuery(\{ ... }); |
---|
| 259 | $iq->AddQuery($query); |
---|
| 260 | |
---|
| 261 | %hash = $Con->FeatureNegParse($query); |
---|
| 262 | |
---|
| 263 | =head2 File Transfer Functions |
---|
| 264 | |
---|
| 265 | $method = $Con->FileTransferOffer(jid=>"bob\@jabber.org", |
---|
| 266 | sid=>"stream_id", |
---|
| 267 | filename=>"/path/to/file", |
---|
| 268 | methods=>["http://jabber.org/protocol/si/profile/bytestreams", |
---|
| 269 | "jabber:iq:oob", |
---|
| 270 | ... |
---|
| 271 | ] |
---|
| 272 | ); |
---|
| 273 | $method = $Con->FileTransferOffer(jid=>"bob\@jabber.org", |
---|
| 274 | sid=>"stream_id", |
---|
| 275 | filename=>"/path/to/file", |
---|
| 276 | methods=>\@methods, |
---|
| 277 | timeout=>"10"); |
---|
| 278 | |
---|
| 279 | $id = $Con->FileTransferOffer(jid=>"bob\@jabber.org", |
---|
| 280 | sid=>"stream_id", |
---|
| 281 | filename=>"/path/to/file", |
---|
| 282 | methods=>\@methods, |
---|
| 283 | mode=>"nonblock"); |
---|
| 284 | |
---|
| 285 | $id = $Con->FileTransferOffer(jid=>"bob\@jabber.org", |
---|
| 286 | sid=>"stream_id", |
---|
| 287 | filename=>"/path/to/file", |
---|
| 288 | methods=>\@methods, |
---|
| 289 | mode=>"passthru"); |
---|
| 290 | |
---|
| 291 | =head2 Last Functions |
---|
| 292 | |
---|
| 293 | $Con->LastQuery(); |
---|
| 294 | $Con->LastQuery(to=>"bob@jabber.org"); |
---|
| 295 | |
---|
| 296 | %result = $Con->LastQuery(mode=>"block"); |
---|
| 297 | %result = $Con->LastQuery(to=>"bob@jabber.org", |
---|
| 298 | mode=>"block"); |
---|
| 299 | |
---|
| 300 | %result = $Con->LastQuery(to=>"bob@jabber.org", |
---|
| 301 | mode=>"block", |
---|
| 302 | timeout=>10); |
---|
| 303 | %result = $Con->LastQuery(mode=>"block", |
---|
| 304 | timeout=>10); |
---|
| 305 | |
---|
| 306 | $Con->LastSend(to=>"bob@jabber.org"); |
---|
| 307 | |
---|
| 308 | $seconds = $Con->LastActivity(); |
---|
| 309 | |
---|
| 310 | =head2 Multi-User Chat Functions |
---|
| 311 | |
---|
| 312 | $Con->MUCJoin(room=>"jabber", |
---|
| 313 | server=>"conference.jabber.org", |
---|
| 314 | nick=>"nick"); |
---|
| 315 | |
---|
| 316 | $Con->MUCJoin(room=>"jabber", |
---|
| 317 | server=>"conference.jabber.org", |
---|
| 318 | nick=>"nick", |
---|
| 319 | password=>"secret"); |
---|
| 320 | |
---|
| 321 | =head2 Register Functions |
---|
| 322 | |
---|
| 323 | @result = $Con->RegisterSendData("users.jabber.org", |
---|
| 324 | first=>"Bob", |
---|
| 325 | last=>"Smith", |
---|
| 326 | nick=>"bob", |
---|
| 327 | email=>"foo@bar.net"); |
---|
| 328 | |
---|
| 329 | |
---|
| 330 | =head2 RPC Functions |
---|
| 331 | |
---|
| 332 | $query = $Con->RPCEncode(type=>"methodCall", |
---|
| 333 | methodName=>"methodName", |
---|
| 334 | params=>[param,param,...]); |
---|
| 335 | $query = $Con->RPCEncode(type=>"methodResponse", |
---|
| 336 | params=>[param,param,...]); |
---|
| 337 | $query = $Con->RPCEncode(type=>"methodResponse", |
---|
| 338 | faultCode=>4, |
---|
| 339 | faultString=>"Too many params"); |
---|
| 340 | |
---|
| 341 | @response = $Con->RPCParse($iq); |
---|
| 342 | |
---|
| 343 | @response = $Con->RPCCall(to=>"dataHouse.jabber.org", |
---|
| 344 | methodname=>"numUsers", |
---|
| 345 | params=>[ param,param,... ] |
---|
| 346 | ); |
---|
| 347 | |
---|
| 348 | $Con->RPCResponse(to=>"you\@jabber.org", |
---|
| 349 | params=>[ param,param,... ]); |
---|
| 350 | |
---|
| 351 | $Con->RPCResponse(to=>"you\@jabber.org", |
---|
| 352 | faultCode=>"4", |
---|
| 353 | faultString=>"Too many parameters" |
---|
| 354 | ); |
---|
| 355 | |
---|
| 356 | $Con->RPCSetCallBacks(myMethodA=>\&methoda, |
---|
| 357 | myMethodB=>\&do_somthing, |
---|
| 358 | etc... |
---|
| 359 | ); |
---|
| 360 | |
---|
| 361 | =head2 Search Functions |
---|
| 362 | |
---|
| 363 | %fields = $Con->SearchRequest(); |
---|
| 364 | %fields = $Con->SearchRequest(to=>"users.jabber.org"); |
---|
| 365 | %fields = $Con->SearchRequest(to=>"users.jabber.org", |
---|
| 366 | timeout=>10); |
---|
| 367 | |
---|
| 368 | $Con->SearchSend(to=>"somewhere", |
---|
| 369 | name=>"", |
---|
| 370 | first=>"Bob", |
---|
| 371 | last=>"", |
---|
| 372 | nick=>"bob", |
---|
| 373 | email=>"", |
---|
| 374 | key=>"some key"); |
---|
| 375 | |
---|
| 376 | $Con->SearchSendData("users.jabber.org", |
---|
| 377 | first=>"Bob", |
---|
| 378 | last=>"", |
---|
| 379 | nick=>"bob", |
---|
| 380 | email=>""); |
---|
| 381 | |
---|
| 382 | =head2 Time Functions |
---|
| 383 | |
---|
| 384 | $Con->TimeQuery(); |
---|
| 385 | $Con->TimeQuery(to=>"bob@jabber.org"); |
---|
| 386 | |
---|
| 387 | %result = $Con->TimeQuery(mode=>"block"); |
---|
| 388 | %result = $Con->TimeQuery(to=>"bob@jabber.org", |
---|
| 389 | mode=>"block"); |
---|
| 390 | |
---|
| 391 | $Con->TimeSend(to=>"bob@jabber.org"); |
---|
| 392 | |
---|
| 393 | =head2 Version Functions |
---|
| 394 | |
---|
| 395 | $Con->VersionQuery(); |
---|
| 396 | $Con->VersionQuery(to=>"bob@jabber.org"); |
---|
| 397 | |
---|
| 398 | %result = $Con->VersionQuery(mode=>"block"); |
---|
| 399 | %result = $Con->VersionQuery(to=>"bob@jabber.org", |
---|
| 400 | mode=>"block"); |
---|
| 401 | |
---|
| 402 | $Con->VersionSend(to=>"bob@jabber.org", |
---|
| 403 | name=>"Net::Jabber", |
---|
| 404 | ver=>"1.0a", |
---|
| 405 | os=>"Perl"); |
---|
| 406 | |
---|
| 407 | =head1 METHODS |
---|
| 408 | |
---|
| 409 | =head2 Basic Functions |
---|
| 410 | |
---|
| 411 | Info(name=>string, - Set some information so that Net::Jabber |
---|
| 412 | version=>string) can auto-reply to some packets for you to |
---|
| 413 | reduce the work you have to do. |
---|
| 414 | |
---|
| 415 | NOTE: This requires that you use the |
---|
| 416 | SetIQCallBacks methodology and not the |
---|
| 417 | SetCallBacks for <iq/> packets. |
---|
| 418 | |
---|
| 419 | =head2 IQ Functions |
---|
| 420 | |
---|
| 421 | =head2 Agents Functions |
---|
| 422 | |
---|
| 423 | ******************************** |
---|
| 424 | * * |
---|
| 425 | * Deprecated in favor of Disco * |
---|
| 426 | * * |
---|
| 427 | ******************************** |
---|
| 428 | |
---|
| 429 | AgentsGet(to=>string, - takes all of the information and |
---|
| 430 | AgentsGet() builds a Net::Jabber::IQ::Agents packet. |
---|
| 431 | It then sends that packet either to the |
---|
| 432 | server, or to the specified transport, |
---|
| 433 | with an ID and waits for that ID to return. |
---|
| 434 | Then it looks in the resulting packet and |
---|
| 435 | builds a hash that contains the values |
---|
| 436 | of the agent list. The hash is layed out |
---|
| 437 | like this: (NOTE: the jid is the key to |
---|
| 438 | distinguish the various agents) |
---|
| 439 | |
---|
| 440 | $hash{<JID>}->{order} = 4 |
---|
| 441 | ->{name} = "ICQ Transport" |
---|
| 442 | ->{transport} = "ICQ #" |
---|
| 443 | ->{description} = "ICQ..blah.." |
---|
| 444 | ->{service} = "icq" |
---|
| 445 | ->{register} = 1 |
---|
| 446 | ->{search} = 1 |
---|
| 447 | etc... |
---|
| 448 | |
---|
| 449 | The order field determines the order that |
---|
| 450 | it came from the server in... in case you |
---|
| 451 | care. For more info on the valid fields |
---|
| 452 | see the Net::Jabber::Query jabber:iq:agent |
---|
| 453 | namespace. |
---|
| 454 | |
---|
| 455 | =head2 Browse Functions |
---|
| 456 | |
---|
| 457 | ******************************** |
---|
| 458 | * * |
---|
| 459 | * Deprecated in favor of Disco * |
---|
| 460 | * * |
---|
| 461 | ******************************** |
---|
| 462 | |
---|
| 463 | BrowseRequest(jid=>string, - sends a jabber:iq:browse request to |
---|
| 464 | mode=>string, the jid passed as an argument. |
---|
| 465 | timeout=>int) Returns a hash with the resulting |
---|
| 466 | tree if mode is set to "block": |
---|
| 467 | |
---|
| 468 | $browse{'category'} = "conference" |
---|
| 469 | $browse{'children'}->[0] |
---|
| 470 | $browse{'children'}->[1] |
---|
| 471 | $browse{'children'}->[11] |
---|
| 472 | $browse{'jid'} = "conference.jabber.org" |
---|
| 473 | $browse{'name'} = "Jabber.org Conferencing Center" |
---|
| 474 | $browse{'ns'}->[0] |
---|
| 475 | $browse{'ns'}->[1] |
---|
| 476 | $browse{'type'} = "public" |
---|
| 477 | |
---|
| 478 | The ns array is an array of the |
---|
| 479 | namespaces that this jid supports. |
---|
| 480 | The children array points to hashs |
---|
| 481 | of this form, and represent the fact |
---|
| 482 | that they can be browsed to. |
---|
| 483 | |
---|
| 484 | See MODES above for using the mode |
---|
| 485 | and timeout. |
---|
| 486 | |
---|
| 487 | =head2 Browse DB Functions |
---|
| 488 | |
---|
| 489 | BrowseDBDelete(string|Net::Jabber::JID) - delete thes JID browse |
---|
| 490 | data from the DB. |
---|
| 491 | |
---|
| 492 | BrowseDBQuery(jid=>string | NJ::JID, - returns the browse data |
---|
| 493 | timeout=>integer, for the requested JID. If |
---|
| 494 | refresh=>0|1) the DB does not contain |
---|
| 495 | the data for the JID, then |
---|
| 496 | it attempts to fetch the |
---|
| 497 | data via BrowseRequest(). |
---|
| 498 | The timeout is passed to |
---|
| 499 | the BrowseRequest() call, |
---|
| 500 | and refresh tells the DB |
---|
| 501 | to request the data, even |
---|
| 502 | if it already has some. |
---|
| 503 | |
---|
| 504 | =head2 Bytestreams Functions |
---|
| 505 | |
---|
| 506 | ByteStreamsProxyRequest(jid=>string, - sends a bytestreams request |
---|
| 507 | mode=>string, to the jid passed as an |
---|
| 508 | timeout=>int) argument. Returns an array |
---|
| 509 | ref with the resulting tree |
---|
| 510 | if mode is set to "block". |
---|
| 511 | |
---|
| 512 | See ByteStreamsProxyParse |
---|
| 513 | for the format of the |
---|
| 514 | resulting tree. |
---|
| 515 | |
---|
| 516 | See MODES above for using |
---|
| 517 | the mode and timeout. |
---|
| 518 | |
---|
| 519 | ByteStreamsProxyParse(Net::Jabber::Query) - parses the query and |
---|
| 520 | returns an array ref |
---|
| 521 | to the resulting tree: |
---|
| 522 | |
---|
| 523 | $host[0]->{jid} = "bytestreams1.proxy.server"; |
---|
| 524 | $host[0]->{host} = "proxy1.server"; |
---|
| 525 | $host[0]->{port} = "5006"; |
---|
| 526 | $host[1]->{jid} = "bytestreams2.proxy.server"; |
---|
| 527 | $host[1]->{host} = "proxy2.server"; |
---|
| 528 | $host[1]->{port} = "5007"; |
---|
| 529 | ... |
---|
| 530 | |
---|
| 531 | ByteStreamsProxyActivate(jid=>string, - sends a bytestreams activate |
---|
| 532 | sid=>string, to the jid passed as an |
---|
| 533 | mode=>string, argument. Returns 1 if the |
---|
| 534 | timeout=>int) proxy activated (undef if |
---|
| 535 | it did not) if mode is set |
---|
| 536 | to "block". |
---|
| 537 | |
---|
| 538 | sid is the stream id that |
---|
| 539 | is being used to talk about |
---|
| 540 | this stream. |
---|
| 541 | |
---|
| 542 | See MODES above for using |
---|
| 543 | the mode and timeout. |
---|
| 544 | |
---|
| 545 | ByteStreamsOffer(jid=>string, - sends a bytestreams offer |
---|
| 546 | sid=>string, to the jid passed as an |
---|
| 547 | streamhosts=>arrayref argument. Returns the jid |
---|
| 548 | mode=>string, of the streamhost that the |
---|
| 549 | timeout=>int) user selected if mode is set |
---|
| 550 | to "block". |
---|
| 551 | |
---|
| 552 | streamhosts is the same |
---|
| 553 | format as the array ref |
---|
| 554 | returned from |
---|
| 555 | ByteStreamsProxyParse. |
---|
| 556 | |
---|
| 557 | See MODES above for using |
---|
| 558 | the mode and timeout. |
---|
| 559 | |
---|
| 560 | =head2 Disco Functions |
---|
| 561 | |
---|
| 562 | DiscoInfoRequest(jid=>string, - sends a disco#info request to |
---|
| 563 | node=>string, the jid passed as an argument, |
---|
| 564 | mode=>string, and the node if specified. |
---|
| 565 | timeout=>int) Returns a hash with the resulting |
---|
| 566 | tree if mode is set to "block". |
---|
| 567 | |
---|
| 568 | See DiscoInfoParse for the format |
---|
| 569 | of the resulting tree. |
---|
| 570 | |
---|
| 571 | See MODES above for using the mode |
---|
| 572 | and timeout. |
---|
| 573 | |
---|
| 574 | DiscoInfoParse(Net::Jabber::Query) - parses the query and |
---|
| 575 | returns a hash ref |
---|
| 576 | to the resulting tree: |
---|
| 577 | |
---|
| 578 | $info{identity}->[0]->{category} = "groupchat"; |
---|
| 579 | $info{identity}->[0]->{name} = "Public Chatrooms"; |
---|
| 580 | $info{identity}->[0]->{type} = "public"; |
---|
| 581 | |
---|
| 582 | $info{identity}->[1]->{category} = "groupchat"; |
---|
| 583 | $info{identity}->[1]->{name} = "Private Chatrooms"; |
---|
| 584 | $info{identity}->[1]->{type} = "private"; |
---|
| 585 | |
---|
| 586 | $info{feature}->{http://jabber.org/protocol/disco#info} = 1; |
---|
| 587 | $info{feature}->{http://jabber.org/protocol/muc#admin} = 1; |
---|
| 588 | |
---|
| 589 | DiscoItemsRequest(jid=>string, - sends a disco#items request to |
---|
| 590 | mode=>string, the jid passed as an argument. |
---|
| 591 | timeout=>int) Returns a hash with the resulting |
---|
| 592 | tree if mode is set to "block". |
---|
| 593 | |
---|
| 594 | See DiscoItemsParse for the format |
---|
| 595 | of the resulting tree. |
---|
| 596 | |
---|
| 597 | See MODES above for using the mode |
---|
| 598 | and timeout. |
---|
| 599 | |
---|
| 600 | DiscoItemsParse(Net::Jabber::Query) - parses the query and |
---|
| 601 | returns a hash ref |
---|
| 602 | to the resulting tree: |
---|
| 603 | |
---|
| 604 | $items{jid}->{node} = name; |
---|
| 605 | |
---|
| 606 | $items{"proxy.server"}->{""} = "Bytestream Proxy Server"; |
---|
| 607 | $items{"conf.server"}->{"public"} = "Public Chatrooms"; |
---|
| 608 | $items{"conf.server"}->{"private"} = "Private Chatrooms"; |
---|
| 609 | |
---|
| 610 | =head2 Feature Negotiation Functions |
---|
| 611 | |
---|
| 612 | FeatureNegRequest(jid=>string, - sends a feature negotiation to |
---|
| 613 | features=>hash ref, the jid passed as an argument, |
---|
| 614 | mode=>string, using the features specified. |
---|
| 615 | timeout=>int) Returns a hash with the resulting |
---|
| 616 | tree if mode is set to "block". |
---|
| 617 | |
---|
| 618 | See DiscoInfoQuery for the format |
---|
| 619 | of the features hash ref. |
---|
| 620 | |
---|
| 621 | See DiscoInfoParse for the format |
---|
| 622 | of the resulting tree. |
---|
| 623 | |
---|
| 624 | See MODES above for using the mode |
---|
| 625 | and timeout. |
---|
| 626 | |
---|
| 627 | FeatureNegParse(Net::Jabber::Query) - parses the query and |
---|
| 628 | returns a hash ref |
---|
| 629 | to the resulting tree: |
---|
| 630 | |
---|
| 631 | $features->{feat1} = ["opt1","opt2",...]; |
---|
| 632 | $features->{feat2} = ["optA","optB",...]; |
---|
| 633 | .... |
---|
| 634 | |
---|
| 635 | If this is a result: |
---|
| 636 | |
---|
| 637 | $features->{feat1} = "opt2"; |
---|
| 638 | $features->{feat2} = "optA"; |
---|
| 639 | .... |
---|
| 640 | |
---|
| 641 | FeatureNeqQuery(hash ref) - takes a hash ref and turns it into a |
---|
| 642 | feature negotiation query that you can |
---|
| 643 | AddQuery into your packaet. The format |
---|
| 644 | of the hash ref is as follows: |
---|
| 645 | |
---|
| 646 | $features->{feat1} = ["opt1","opt2",...]; |
---|
| 647 | $features->{feat2} = ["optA","optB",...]; |
---|
| 648 | .... |
---|
| 649 | |
---|
| 650 | =head2 File Transfer Functions |
---|
| 651 | |
---|
| 652 | FileTransferOffer(jid=>string, - sends a file transfer stream |
---|
| 653 | sid=>string, initiation to the jid passed |
---|
| 654 | filename=>string, as an argument. Returns the |
---|
| 655 | mode=>string, method (if the users accepts), |
---|
| 656 | timeout=>int) undef (if the user declines), |
---|
| 657 | if the mode is set to "block". |
---|
| 658 | |
---|
| 659 | See MODES above for using |
---|
| 660 | the mode and timeout. |
---|
| 661 | |
---|
| 662 | =head2 Last Functions |
---|
| 663 | |
---|
| 664 | LastQuery(to=>string, - asks the jid specified for its last |
---|
| 665 | mode=>string, activity. If the to is blank, then it |
---|
| 666 | timeout=>int) queries the server. Returns a hash with |
---|
| 667 | LastQuery() the various items set if mode is set to |
---|
| 668 | "block": |
---|
| 669 | |
---|
| 670 | $last{seconds} - Seconds since activity |
---|
| 671 | $last{message} - Message for activity |
---|
| 672 | |
---|
| 673 | See MODES above for using the mode |
---|
| 674 | and timeout. |
---|
| 675 | |
---|
| 676 | LastSend(to=>string, - sends the specified last to the specified jid. |
---|
| 677 | hash) the hash is the seconds and message as shown |
---|
| 678 | in the Net::Jabber::Query man page. |
---|
| 679 | |
---|
| 680 | LastActivity() - returns the number of seconds since the last activity |
---|
| 681 | by the user. |
---|
| 682 | |
---|
| 683 | =head2 Multi-User Chat Functions |
---|
| 684 | |
---|
| 685 | MUCJoin(room=>string, - Sends the appropriate MUC protocol to join |
---|
| 686 | server=>string, the specified room with the specified nick. |
---|
| 687 | nick=>string, |
---|
| 688 | password=>string) |
---|
| 689 | |
---|
| 690 | =head2 Register Functions |
---|
| 691 | |
---|
| 692 | RegisterSendData(string|JID, - takes the contents of the hash and |
---|
| 693 | hash) builds a jabebr:x:data return packet |
---|
| 694 | which it sends in a Net::Jabber::Query |
---|
| 695 | jabber:iq:register namespace packet. |
---|
| 696 | The first argument is the JID to send |
---|
| 697 | the packet to. This function returns |
---|
| 698 | an array that looks like this: |
---|
| 699 | |
---|
| 700 | [ type , message ] |
---|
| 701 | |
---|
| 702 | If type is "ok" then registration was |
---|
| 703 | successful, otherwise message contains |
---|
| 704 | a little more detail about the error. |
---|
| 705 | |
---|
| 706 | =head2 RPC Functions |
---|
| 707 | |
---|
| 708 | RPCParse(IQ object) - returns an array. The first argument tells |
---|
| 709 | the status "ok" or "fault". The second |
---|
| 710 | argument is an array if "ok", or a hash if |
---|
| 711 | "fault". |
---|
| 712 | |
---|
| 713 | RPCCall(to=>jid|string, - takes the methodName and params, |
---|
| 714 | methodName=>string, builds the RPC calls and sends it |
---|
| 715 | params=>array, to the specified address. Returns |
---|
| 716 | mode=>string, the above data from RPCParse. |
---|
| 717 | timeout=>int) |
---|
| 718 | See MODES above for using the mode |
---|
| 719 | and timeout. |
---|
| 720 | |
---|
| 721 | RPCResponse(to=>jid|string, - generates a response back to |
---|
| 722 | params=>array, the caller. If any part of |
---|
| 723 | faultCode=>int, fault is specified, then it |
---|
| 724 | faultString=>string) wins. |
---|
| 725 | |
---|
| 726 | |
---|
| 727 | Note: To ensure that you get the correct type for a param sent |
---|
| 728 | back, you can specify the type by prepending the type to |
---|
| 729 | the value: |
---|
| 730 | |
---|
| 731 | "i4:5" or "int:5" |
---|
| 732 | "boolean:0" |
---|
| 733 | "string:56" |
---|
| 734 | "double:5.0" |
---|
| 735 | "datetime:20020415T11:11:11" |
---|
| 736 | "base64:...." |
---|
| 737 | |
---|
| 738 | RPCSetCallBacks(method=>function, - sets the callback functions |
---|
| 739 | method=>function, for the specified methods. |
---|
| 740 | etc...) The method comes from the |
---|
| 741 | <methodName/> and is case |
---|
| 742 | sensitive. The single |
---|
| 743 | arguemnt is a ref to an |
---|
| 744 | array that contains the |
---|
| 745 | <params/>. The function you |
---|
| 746 | write should return one of two |
---|
| 747 | things: |
---|
| 748 | |
---|
| 749 | ["ok", [...] ] |
---|
| 750 | |
---|
| 751 | The [...] is a list of the |
---|
| 752 | <params/> you want to return. |
---|
| 753 | |
---|
| 754 | ["fault", {faultCode=>1, |
---|
| 755 | faultString=>...} ] |
---|
| 756 | |
---|
| 757 | If you set the function to undef, |
---|
| 758 | then the method is removed from |
---|
| 759 | the list. |
---|
| 760 | |
---|
| 761 | =head2 Search Functions |
---|
| 762 | |
---|
| 763 | SearchRequest(to=>string, - send an <iq/> request to the specified |
---|
| 764 | mode=>string, server/transport, if not specified it |
---|
| 765 | timeout=>int) sends to the current active server. |
---|
| 766 | SearchRequest() The function returns a hash that |
---|
| 767 | contains the required fields. Here |
---|
| 768 | is an example of the hash: |
---|
| 769 | |
---|
| 770 | $hash{fields} - The raw fields from |
---|
| 771 | the iq:register. To |
---|
| 772 | be used if there is |
---|
| 773 | no x:data in the |
---|
| 774 | packet. |
---|
| 775 | $hash{instructions} - How to fill out |
---|
| 776 | the form. |
---|
| 777 | $hash{form} - The new dynamic forms. |
---|
| 778 | |
---|
| 779 | In $hash{form}, the fields that are |
---|
| 780 | present are the required fields the |
---|
| 781 | server needs. |
---|
| 782 | |
---|
| 783 | See MODES above for using the mode |
---|
| 784 | and timeout. |
---|
| 785 | |
---|
| 786 | SearchSend(to=>string|JID, - takes the contents of the hash and |
---|
| 787 | hash) passes it to the SetSearch function |
---|
| 788 | in the Net::Jabber::Query |
---|
| 789 | jabber:iq:search namespace. And then |
---|
| 790 | sends the packet. |
---|
| 791 | |
---|
| 792 | SearchSendData(string|JID, - takes the contents of the hash and |
---|
| 793 | hash) builds a jabebr:x:data return packet |
---|
| 794 | which it sends in a Net::Jabber::Query |
---|
| 795 | jabber:iq:search namespace packet. |
---|
| 796 | The first argument is the JID to send |
---|
| 797 | the packet to. |
---|
| 798 | |
---|
| 799 | =head2 Time Functions |
---|
| 800 | |
---|
| 801 | TimeQuery(to=>string, - asks the jid specified for its localtime. |
---|
| 802 | mode=>string, If the to is blank, then it queries the |
---|
| 803 | timeout=>int) server. Returns a hash with the various |
---|
| 804 | TimeQuery() items set if mode is set to "block": |
---|
| 805 | |
---|
| 806 | $time{utc} - Time in UTC |
---|
| 807 | $time{tz} - Timezone |
---|
| 808 | $time{display} - Display string |
---|
| 809 | |
---|
| 810 | See MODES above for using the mode |
---|
| 811 | and timeout. |
---|
| 812 | |
---|
| 813 | TimeSend(to=>string) - sends the current UTC time to the specified |
---|
| 814 | jid. |
---|
| 815 | |
---|
| 816 | =head2 Version Functions |
---|
| 817 | |
---|
| 818 | VersionQuery(to=>string, - asks the jid specified for its |
---|
| 819 | mode=>string, client version information. If the |
---|
| 820 | timeout=>int) to is blank, then it queries the |
---|
| 821 | VersionQuery() server. Returns ahash with the |
---|
| 822 | various items set if mode is set to |
---|
| 823 | "block": |
---|
| 824 | |
---|
| 825 | $version{name} - Name |
---|
| 826 | $version{ver} - Version |
---|
| 827 | $version{os} - Operating System/ |
---|
| 828 | Platform |
---|
| 829 | |
---|
| 830 | See MODES above for using the mode |
---|
| 831 | and timeout. |
---|
| 832 | |
---|
| 833 | VersionSend(to=>string, - sends the specified version information |
---|
| 834 | name=>string, to the jid specified in the to. |
---|
| 835 | ver=>string, |
---|
| 836 | os=>string) |
---|
| 837 | |
---|
| 838 | =head1 AUTHOR |
---|
| 839 | |
---|
| 840 | Ryan Eatmon |
---|
| 841 | |
---|
| 842 | =head1 COPYRIGHT |
---|
| 843 | |
---|
| 844 | This module is free software; you can redistribute it and/or modify |
---|
| 845 | it under the same terms as Perl itself. |
---|
| 846 | |
---|
| 847 | =cut |
---|
| 848 | |
---|
| 849 | use strict; |
---|
| 850 | use Carp; |
---|
| 851 | use vars qw($VERSION); |
---|
| 852 | |
---|
| 853 | $VERSION = "2.0"; |
---|
| 854 | |
---|
| 855 | ############################################################################## |
---|
| 856 | # BuildObject takes a root tag and builds the correct object. NEWOBJECT is |
---|
| 857 | # the table that maps tag to package. Override these, or provide new ones. |
---|
| 858 | #----------------------------------------------------------------------------- |
---|
| 859 | $Net::XMPP::Protocol::NEWOBJECT{'iq'} = "Net::Jabber::IQ"; |
---|
| 860 | $Net::XMPP::Protocol::NEWOBJECT{'message'} = "Net::Jabber::Message"; |
---|
| 861 | $Net::XMPP::Protocol::NEWOBJECT{'presence'} = "Net::Jabber::Presence"; |
---|
| 862 | $Net::XMPP::Protocol::NEWOBJECT{'jid'} = "Net::Jabber::JID"; |
---|
| 863 | ############################################################################## |
---|
| 864 | |
---|
| 865 | ############################################################################### |
---|
| 866 | #+----------------------------------------------------------------------------- |
---|
| 867 | #| |
---|
| 868 | #| Base API |
---|
| 869 | #| |
---|
| 870 | #+----------------------------------------------------------------------------- |
---|
| 871 | ############################################################################### |
---|
| 872 | |
---|
| 873 | ############################################################################### |
---|
| 874 | # |
---|
| 875 | # Info - set the base information about this Jabber Client/Component for |
---|
| 876 | # use in a default response. |
---|
| 877 | # |
---|
| 878 | ############################################################################### |
---|
| 879 | sub Info |
---|
| 880 | { |
---|
| 881 | my $self = shift; |
---|
| 882 | my %args; |
---|
| 883 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 884 | |
---|
| 885 | foreach my $arg (keys(%args)) |
---|
| 886 | { |
---|
| 887 | $self->{INFO}->{$arg} = $args{$arg}; |
---|
| 888 | } |
---|
| 889 | } |
---|
| 890 | |
---|
| 891 | |
---|
| 892 | ############################################################################### |
---|
| 893 | # |
---|
| 894 | # DefineNamespace - adds the namespace and corresponding functions onto the |
---|
| 895 | # of available functions based on namespace. |
---|
| 896 | # |
---|
| 897 | # Deprecated in favor of AddNamespace |
---|
| 898 | # |
---|
| 899 | ############################################################################### |
---|
| 900 | sub DefineNamespace |
---|
| 901 | { |
---|
| 902 | my $self = shift; |
---|
| 903 | my %args; |
---|
| 904 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 905 | |
---|
| 906 | croak("You must specify xmlns=>'' for the function call to DefineNamespace") |
---|
| 907 | if !exists($args{xmlns}); |
---|
| 908 | croak("You must specify type=>'' for the function call to DefineNamespace") |
---|
| 909 | if !exists($args{type}); |
---|
| 910 | croak("You must specify functions=>'' for the function call to DefineNamespace") |
---|
| 911 | if !exists($args{functions}); |
---|
| 912 | |
---|
| 913 | my %xpath; |
---|
| 914 | |
---|
| 915 | my $tag; |
---|
| 916 | if (exists($args{tag})) |
---|
| 917 | { |
---|
| 918 | $tag = $args{tag}; |
---|
| 919 | } |
---|
| 920 | else |
---|
| 921 | { |
---|
| 922 | $tag = "x" if ($args{type} eq "X"); |
---|
| 923 | $tag = "query" if ($args{type} eq "Query"); |
---|
| 924 | } |
---|
| 925 | |
---|
| 926 | foreach my $function (@{$args{functions}}) |
---|
| 927 | { |
---|
| 928 | my %tempHash = %{$function}; |
---|
| 929 | my %funcHash; |
---|
| 930 | foreach my $func (keys(%tempHash)) |
---|
| 931 | { |
---|
| 932 | $funcHash{lc($func)} = $tempHash{$func}; |
---|
| 933 | } |
---|
| 934 | |
---|
| 935 | croak("You must specify name=>'' for each function in call to DefineNamespace") |
---|
| 936 | if !exists($funcHash{name}); |
---|
| 937 | |
---|
| 938 | my $name = delete($funcHash{name}); |
---|
| 939 | |
---|
| 940 | if (!exists($funcHash{set}) && exists($funcHash{get})) |
---|
| 941 | { |
---|
| 942 | croak("The DefineNamespace arugments have changed, and I cannot determine the\nnew values automatically for name($name). Please read the man page\nfor Net::Jabber::Namespaces. I apologize for this incompatability.\n"); |
---|
| 943 | } |
---|
| 944 | |
---|
| 945 | if (exists($funcHash{type}) || exists($funcHash{path}) || |
---|
| 946 | exists($funcHash{child}) || exists($funcHash{calls})) |
---|
| 947 | { |
---|
| 948 | |
---|
| 949 | foreach my $type (keys(%funcHash)) |
---|
| 950 | { |
---|
| 951 | if ($type eq "child") |
---|
| 952 | { |
---|
| 953 | $xpath{$name}->{$type}->{ns} = $funcHash{$type}->[1]; |
---|
| 954 | my $i = 2; |
---|
| 955 | while( $i <= $#{$funcHash{$type}} ) |
---|
| 956 | { |
---|
| 957 | if ($funcHash{$type}->[$i] eq "__netjabber__:skip_xmlns") |
---|
| 958 | { |
---|
| 959 | $xpath{$name}->{$type}->{skip_xmlns} = 1; |
---|
| 960 | } |
---|
| 961 | |
---|
| 962 | if ($funcHash{$type}->[$i] eq "__netjabber__:specifyname") |
---|
| 963 | { |
---|
| 964 | $xpath{$name}->{$type}->{specify_name} = 1; |
---|
| 965 | $i++; |
---|
| 966 | $xpath{$name}->{$type}->{tag} = $funcHash{$type}->[$i+1]; |
---|
| 967 | } |
---|
| 968 | |
---|
| 969 | $i++; |
---|
| 970 | } |
---|
| 971 | } |
---|
| 972 | else |
---|
| 973 | { |
---|
| 974 | $xpath{$name}->{$type} = $funcHash{$type}; |
---|
| 975 | } |
---|
| 976 | } |
---|
| 977 | next; |
---|
| 978 | } |
---|
| 979 | |
---|
| 980 | my $type = $funcHash{set}->[0]; |
---|
| 981 | my $xpath = $funcHash{set}->[1]; |
---|
| 982 | if (exists($funcHash{hash})) |
---|
| 983 | { |
---|
| 984 | $xpath = "text()" if ($funcHash{hash} eq "data"); |
---|
| 985 | $xpath .= "/text()" if ($funcHash{hash} eq "child-data"); |
---|
| 986 | $xpath = "\@$xpath" if ($funcHash{hash} eq "att"); |
---|
| 987 | $xpath = "$1/\@$2" if ($funcHash{hash} =~ /^att-(\S+)-(.+)$/); |
---|
| 988 | } |
---|
| 989 | |
---|
| 990 | if ($type eq "master") |
---|
| 991 | { |
---|
| 992 | $xpath{$name}->{type} = $type; |
---|
| 993 | next; |
---|
| 994 | } |
---|
| 995 | |
---|
| 996 | if ($type eq "scalar") |
---|
| 997 | { |
---|
| 998 | $xpath{$name}->{path} = $xpath; |
---|
| 999 | next; |
---|
| 1000 | } |
---|
| 1001 | |
---|
| 1002 | if ($type eq "flag") |
---|
| 1003 | { |
---|
| 1004 | $xpath{$name}->{type} = 'flag'; |
---|
| 1005 | $xpath{$name}->{path} = $xpath; |
---|
| 1006 | next; |
---|
| 1007 | } |
---|
| 1008 | |
---|
| 1009 | if (($funcHash{hash} eq "child-add") && exists($funcHash{add})) |
---|
| 1010 | { |
---|
| 1011 | $xpath{$name}->{type} = "node"; |
---|
| 1012 | $xpath{$name}->{path} = $funcHash{add}->[3]; |
---|
| 1013 | $xpath{$name}->{child}->{ns} = $funcHash{add}->[1]; |
---|
| 1014 | $xpath{$name}->{calls} = [ 'Add' ]; |
---|
| 1015 | next; |
---|
| 1016 | } |
---|
| 1017 | } |
---|
| 1018 | |
---|
| 1019 | $self->AddNamespace(ns => $args{xmlns}, |
---|
| 1020 | tag => $tag, |
---|
| 1021 | xpath => \%xpath ); |
---|
| 1022 | } |
---|
| 1023 | |
---|
| 1024 | ############################################################################### |
---|
| 1025 | # |
---|
| 1026 | # AgentsGet - Sends an empty IQ to the server/transport to request that the |
---|
| 1027 | # list of supported Agents be sent to them. Returns a hash |
---|
| 1028 | # containing the values for the agents. |
---|
| 1029 | # |
---|
| 1030 | ############################################################################### |
---|
| 1031 | sub AgentsGet |
---|
| 1032 | { |
---|
| 1033 | my $self = shift; |
---|
| 1034 | |
---|
| 1035 | my $iq = $self->_iq(); |
---|
| 1036 | $iq->SetIQ(@_); |
---|
| 1037 | $iq->SetIQ(type=>"get"); |
---|
| 1038 | my $query = $iq->NewQuery("jabber:iq:agents"); |
---|
| 1039 | |
---|
| 1040 | $iq = $self->SendAndReceiveWithID($iq); |
---|
| 1041 | |
---|
| 1042 | return unless defined($iq); |
---|
| 1043 | |
---|
| 1044 | $query = $iq->GetQuery(); |
---|
| 1045 | my @agents = $query->GetAgents(); |
---|
| 1046 | |
---|
| 1047 | my %agents; |
---|
| 1048 | my $count = 0; |
---|
| 1049 | foreach my $agent (@agents) |
---|
| 1050 | { |
---|
| 1051 | my $jid = $agent->GetJID(); |
---|
| 1052 | $agents{$jid}->{name} = $agent->GetName(); |
---|
| 1053 | $agents{$jid}->{description} = $agent->GetDescription(); |
---|
| 1054 | $agents{$jid}->{transport} = $agent->GetTransport(); |
---|
| 1055 | $agents{$jid}->{service} = $agent->GetService(); |
---|
| 1056 | $agents{$jid}->{register} = $agent->DefinedRegister(); |
---|
| 1057 | $agents{$jid}->{search} = $agent->DefinedSearch(); |
---|
| 1058 | $agents{$jid}->{groupchat} = $agent->DefinedGroupChat(); |
---|
| 1059 | $agents{$jid}->{agents} = $agent->DefinedAgents(); |
---|
| 1060 | $agents{$jid}->{order} = $count++; |
---|
| 1061 | } |
---|
| 1062 | |
---|
| 1063 | return %agents; |
---|
| 1064 | } |
---|
| 1065 | |
---|
| 1066 | |
---|
| 1067 | ############################################################################### |
---|
| 1068 | # |
---|
| 1069 | # BrowseRequest - requests the browse information from the specified JID. |
---|
| 1070 | # |
---|
| 1071 | ############################################################################### |
---|
| 1072 | sub BrowseRequest |
---|
| 1073 | { |
---|
| 1074 | my $self = shift; |
---|
| 1075 | my %args; |
---|
| 1076 | $args{mode} = "block"; |
---|
| 1077 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 1078 | |
---|
| 1079 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 1080 | |
---|
| 1081 | my $iq = $self->_iq(); |
---|
| 1082 | $iq->SetIQ(to=>$args{jid}, |
---|
| 1083 | type=>"get"); |
---|
| 1084 | my $query = $iq->NewQuery("jabber:iq:browse"); |
---|
| 1085 | |
---|
| 1086 | #-------------------------------------------------------------------------- |
---|
| 1087 | # Send the IQ with the next available ID and wait for a reply with that |
---|
| 1088 | # id to be received. Then grab the IQ reply. |
---|
| 1089 | #-------------------------------------------------------------------------- |
---|
| 1090 | if ($args{mode} eq "passthru") |
---|
| 1091 | { |
---|
| 1092 | my $id = $self->UniqueID(); |
---|
| 1093 | $iq->SetIQ(id=>$id); |
---|
| 1094 | $self->Send($iq); |
---|
| 1095 | return $id; |
---|
| 1096 | } |
---|
| 1097 | |
---|
| 1098 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 1099 | |
---|
| 1100 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 1101 | |
---|
| 1102 | #-------------------------------------------------------------------------- |
---|
| 1103 | # Check if there was an error. |
---|
| 1104 | #-------------------------------------------------------------------------- |
---|
| 1105 | return unless defined($iq); |
---|
| 1106 | if ($iq->GetType() eq "error") |
---|
| 1107 | { |
---|
| 1108 | $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
---|
| 1109 | return; |
---|
| 1110 | } |
---|
| 1111 | |
---|
| 1112 | $query = $iq->GetQuery(); |
---|
| 1113 | |
---|
| 1114 | if (defined($query)) |
---|
| 1115 | { |
---|
| 1116 | my %browse = %{$self->BrowseParse($query)}; |
---|
| 1117 | return %browse; |
---|
| 1118 | } |
---|
| 1119 | else |
---|
| 1120 | { |
---|
| 1121 | return; |
---|
| 1122 | } |
---|
| 1123 | } |
---|
| 1124 | |
---|
| 1125 | |
---|
| 1126 | ############################################################################### |
---|
| 1127 | # |
---|
| 1128 | # BrowseParse - helper function for BrowseRequest to convert the object |
---|
| 1129 | # tree into a hash for better consumption. |
---|
| 1130 | # |
---|
| 1131 | ############################################################################### |
---|
| 1132 | sub BrowseParse |
---|
| 1133 | { |
---|
| 1134 | my $self = shift; |
---|
| 1135 | my $item = shift; |
---|
| 1136 | my %browse; |
---|
| 1137 | |
---|
| 1138 | if ($item->DefinedCategory()) |
---|
| 1139 | { |
---|
| 1140 | $browse{category} = $item->GetCategory(); |
---|
| 1141 | } |
---|
| 1142 | else |
---|
| 1143 | { |
---|
| 1144 | $browse{category} = $item->GetTag(); |
---|
| 1145 | } |
---|
| 1146 | $browse{type} = $item->GetType(); |
---|
| 1147 | $browse{name} = $item->GetName(); |
---|
| 1148 | $browse{jid} = $item->GetJID(); |
---|
| 1149 | $browse{ns} = [ $item->GetNS() ]; |
---|
| 1150 | |
---|
| 1151 | foreach my $subitem ($item->GetItems()) |
---|
| 1152 | { |
---|
| 1153 | my ($subbrowse) = $self->BrowseParse($subitem); |
---|
| 1154 | push(@{$browse{children}},$subbrowse); |
---|
| 1155 | } |
---|
| 1156 | |
---|
| 1157 | return \%browse; |
---|
| 1158 | } |
---|
| 1159 | |
---|
| 1160 | |
---|
| 1161 | ############################################################################### |
---|
| 1162 | # |
---|
| 1163 | # BrowseDBDelete - delete the JID from the DB completely. |
---|
| 1164 | # |
---|
| 1165 | ############################################################################### |
---|
| 1166 | sub BrowseDBDelete |
---|
| 1167 | { |
---|
| 1168 | my $self = shift; |
---|
| 1169 | my ($jid) = @_; |
---|
| 1170 | |
---|
| 1171 | my $indexJID = $jid; |
---|
| 1172 | $indexJID = $jid->GetJID() if (ref($jid) eq "Net::Jabber::JID"); |
---|
| 1173 | |
---|
| 1174 | return if !exists($self->{BROWSEDB}->{$indexJID}); |
---|
| 1175 | delete($self->{BROWSEDB}->{$indexJID}); |
---|
| 1176 | $self->{DEBUG}->Log1("BrowseDBDelete: delete ",$indexJID," from the DB"); |
---|
| 1177 | } |
---|
| 1178 | |
---|
| 1179 | |
---|
| 1180 | ############################################################################### |
---|
| 1181 | # |
---|
| 1182 | # BrowseDBQuery - retrieve the last Net::Jabber::Browse received with |
---|
| 1183 | # the highest priority. |
---|
| 1184 | # |
---|
| 1185 | ############################################################################### |
---|
| 1186 | sub BrowseDBQuery |
---|
| 1187 | { |
---|
| 1188 | my $self = shift; |
---|
| 1189 | my %args; |
---|
| 1190 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 1191 | |
---|
| 1192 | $args{timeout} = 10 unless exists($args{timeout}); |
---|
| 1193 | |
---|
| 1194 | my $indexJID = $args{jid}; |
---|
| 1195 | $indexJID = $args{jid}->GetJID() if (ref($args{jid}) eq "Net::Jabber::JID"); |
---|
| 1196 | |
---|
| 1197 | if ((exists($args{refresh}) && ($args{refresh} eq "1")) || |
---|
| 1198 | (!exists($self->{BROWSEDB}->{$indexJID}))) |
---|
| 1199 | { |
---|
| 1200 | my %browse = $self->BrowseRequest(jid=>$args{jid}, |
---|
| 1201 | timeout=>$args{timeout}); |
---|
| 1202 | |
---|
| 1203 | $self->{BROWSEDB}->{$indexJID} = \%browse; |
---|
| 1204 | } |
---|
| 1205 | return %{$self->{BROWSEDB}->{$indexJID}}; |
---|
| 1206 | } |
---|
| 1207 | |
---|
| 1208 | |
---|
| 1209 | ############################################################################### |
---|
| 1210 | # |
---|
| 1211 | # ByteStreamsProxyRequest - This queries a proxy server to get a list of |
---|
| 1212 | # |
---|
| 1213 | ############################################################################### |
---|
| 1214 | sub ByteStreamsProxyRequest |
---|
| 1215 | { |
---|
| 1216 | my $self = shift; |
---|
| 1217 | my %args; |
---|
| 1218 | $args{mode} = "block"; |
---|
| 1219 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 1220 | |
---|
| 1221 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 1222 | |
---|
| 1223 | my $iq = $self->_iq(); |
---|
| 1224 | $iq->SetIQ(to=>$args{jid}, |
---|
| 1225 | type=>"get"); |
---|
| 1226 | my $query = $iq->NewQuery("http://jabber.org/protocol/bytestreams"); |
---|
| 1227 | |
---|
| 1228 | #-------------------------------------------------------------------------- |
---|
| 1229 | # Send the IQ with the next available ID and wait for a reply with that |
---|
| 1230 | # id to be received. Then grab the IQ reply. |
---|
| 1231 | #-------------------------------------------------------------------------- |
---|
| 1232 | if ($args{mode} eq "passthru") |
---|
| 1233 | { |
---|
| 1234 | my $id = $self->UniqueID(); |
---|
| 1235 | $iq->SetIQ(id=>$id); |
---|
| 1236 | $self->Send($iq); |
---|
| 1237 | return $id; |
---|
| 1238 | } |
---|
| 1239 | |
---|
| 1240 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 1241 | |
---|
| 1242 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 1243 | |
---|
| 1244 | #-------------------------------------------------------------------------- |
---|
| 1245 | # Check if there was an error. |
---|
| 1246 | #-------------------------------------------------------------------------- |
---|
| 1247 | return unless defined($iq); |
---|
| 1248 | if ($iq->GetType() eq "error") |
---|
| 1249 | { |
---|
| 1250 | $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
---|
| 1251 | return; |
---|
| 1252 | } |
---|
| 1253 | |
---|
| 1254 | $query = $iq->GetQuery(); |
---|
| 1255 | |
---|
| 1256 | if (defined($query)) |
---|
| 1257 | { |
---|
| 1258 | my @hosts = @{$self->ByteStreamsProxyParse($query)}; |
---|
| 1259 | return @hosts; |
---|
| 1260 | } |
---|
| 1261 | else |
---|
| 1262 | { |
---|
| 1263 | return; |
---|
| 1264 | } |
---|
| 1265 | } |
---|
| 1266 | |
---|
| 1267 | |
---|
| 1268 | ############################################################################### |
---|
| 1269 | # |
---|
| 1270 | # ByteStreamsProxyParse - helper function for ByteStreamProxyRequest to convert |
---|
| 1271 | # the object tree into a hash for better consumption. |
---|
| 1272 | # |
---|
| 1273 | ############################################################################### |
---|
| 1274 | sub ByteStreamsProxyParse |
---|
| 1275 | { |
---|
| 1276 | my $self = shift; |
---|
| 1277 | my $item = shift; |
---|
| 1278 | |
---|
| 1279 | my @hosts; |
---|
| 1280 | |
---|
| 1281 | foreach my $host ($item->GetStreamHosts()) |
---|
| 1282 | { |
---|
| 1283 | my %host; |
---|
| 1284 | $host{jid} = $host->GetJID(); |
---|
| 1285 | $host{host} = $host->GetHost() if $host->DefinedHost(); |
---|
| 1286 | $host{port} = $host->GetPort() if $host->DefinedPort(); |
---|
| 1287 | $host{zeroconf} = $host->GetZeroConf() if $host->DefinedZeroConf(); |
---|
| 1288 | |
---|
| 1289 | push(@hosts,\%host); |
---|
| 1290 | } |
---|
| 1291 | |
---|
| 1292 | return \@hosts; |
---|
| 1293 | } |
---|
| 1294 | |
---|
| 1295 | |
---|
| 1296 | ############################################################################### |
---|
| 1297 | # |
---|
| 1298 | # ByteStreamsProxyActivate - This tells a proxy to activate the connection |
---|
| 1299 | # |
---|
| 1300 | ############################################################################### |
---|
| 1301 | sub ByteStreamsProxyActivate |
---|
| 1302 | { |
---|
| 1303 | my $self = shift; |
---|
| 1304 | my %args; |
---|
| 1305 | $args{mode} = "block"; |
---|
| 1306 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 1307 | |
---|
| 1308 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 1309 | |
---|
| 1310 | my $iq = $self->_iq(); |
---|
| 1311 | $iq->SetIQ(to=>$args{jid}, |
---|
| 1312 | type=>"set"); |
---|
| 1313 | my $query = $iq->NewQuery("http://jabber.org/protocol/bytestreams"); |
---|
| 1314 | $query->SetByteStreams(sid=>$args{sid}, |
---|
| 1315 | activate=>(ref($args{recipient}) eq "Net::Jabber::JID" ? $args{recipient}->GetJID("full") : $args{recipient}) |
---|
| 1316 | ); |
---|
| 1317 | |
---|
| 1318 | #-------------------------------------------------------------------------- |
---|
| 1319 | # Send the IQ with the next available ID and wait for a reply with that |
---|
| 1320 | # id to be received. Then grab the IQ reply. |
---|
| 1321 | #-------------------------------------------------------------------------- |
---|
| 1322 | if ($args{mode} eq "passthru") |
---|
| 1323 | { |
---|
| 1324 | my $id = $self->UniqueID(); |
---|
| 1325 | $iq->SetIQ(id=>$id); |
---|
| 1326 | $self->Send($iq); |
---|
| 1327 | return $id; |
---|
| 1328 | } |
---|
| 1329 | |
---|
| 1330 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 1331 | |
---|
| 1332 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 1333 | |
---|
| 1334 | #-------------------------------------------------------------------------- |
---|
| 1335 | # Check if there was an error. |
---|
| 1336 | #-------------------------------------------------------------------------- |
---|
| 1337 | return unless defined($iq); |
---|
| 1338 | if ($iq->GetType() eq "error") |
---|
| 1339 | { |
---|
| 1340 | $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
---|
| 1341 | return; |
---|
| 1342 | } |
---|
| 1343 | |
---|
| 1344 | return 1; |
---|
| 1345 | } |
---|
| 1346 | |
---|
| 1347 | |
---|
| 1348 | ############################################################################### |
---|
| 1349 | # |
---|
| 1350 | # ByteStreamsOffer - This offers a recipient a list of stream hosts to pick |
---|
| 1351 | # from. |
---|
| 1352 | # |
---|
| 1353 | ############################################################################### |
---|
| 1354 | sub ByteStreamsOffer |
---|
| 1355 | { |
---|
| 1356 | my $self = shift; |
---|
| 1357 | my %args; |
---|
| 1358 | $args{mode} = "block"; |
---|
| 1359 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 1360 | |
---|
| 1361 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 1362 | |
---|
| 1363 | my $iq = $self->_iq(); |
---|
| 1364 | $iq->SetIQ(to=>$args{jid}, |
---|
| 1365 | type=>"set"); |
---|
| 1366 | my $query = $iq->NewQuery("http://jabber.org/protocol/bytestreams"); |
---|
| 1367 | |
---|
| 1368 | $query->SetByteStreams(sid=>$args{sid}); |
---|
| 1369 | |
---|
| 1370 | foreach my $host (@{$args{streamhosts}}) |
---|
| 1371 | { |
---|
| 1372 | $query->AddStreamHost(jid=>$host->{jid}, |
---|
| 1373 | (exists($host->{host}) ? (host=>$host->{host}) : ()), |
---|
| 1374 | (exists($host->{port}) ? (port=>$host->{port}) : ()), |
---|
| 1375 | (exists($host->{zeroconf}) ? (zeroconf=>$host->{zeroconf}) : ()), |
---|
| 1376 | ); |
---|
| 1377 | } |
---|
| 1378 | |
---|
| 1379 | #-------------------------------------------------------------------------- |
---|
| 1380 | # Send the IQ with the next available ID and wait for a reply with that |
---|
| 1381 | # id to be received. Then grab the IQ reply. |
---|
| 1382 | #-------------------------------------------------------------------------- |
---|
| 1383 | if ($args{mode} eq "passthru") |
---|
| 1384 | { |
---|
| 1385 | my $id = $self->UniqueID(); |
---|
| 1386 | $iq->SetIQ(id=>$id); |
---|
| 1387 | $self->Send($iq); |
---|
| 1388 | return $id; |
---|
| 1389 | } |
---|
| 1390 | |
---|
| 1391 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 1392 | |
---|
| 1393 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 1394 | |
---|
| 1395 | #-------------------------------------------------------------------------- |
---|
| 1396 | # Check if there was an error. |
---|
| 1397 | #-------------------------------------------------------------------------- |
---|
| 1398 | return unless defined($iq); |
---|
| 1399 | if ($iq->GetType() eq "error") |
---|
| 1400 | { |
---|
| 1401 | $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
---|
| 1402 | return; |
---|
| 1403 | } |
---|
| 1404 | |
---|
| 1405 | $query = $iq->GetQuery(); |
---|
| 1406 | |
---|
| 1407 | if (defined($query)) |
---|
| 1408 | { |
---|
| 1409 | return $query->GetStreamHostUsedJID(); |
---|
| 1410 | } |
---|
| 1411 | else |
---|
| 1412 | { |
---|
| 1413 | return; |
---|
| 1414 | } |
---|
| 1415 | } |
---|
| 1416 | |
---|
| 1417 | |
---|
| 1418 | ############################################################################### |
---|
| 1419 | # |
---|
| 1420 | # DiscoInfoRequest - requests the disco information from the specified JID. |
---|
| 1421 | # |
---|
| 1422 | ############################################################################### |
---|
| 1423 | sub DiscoInfoRequest |
---|
| 1424 | { |
---|
| 1425 | my $self = shift; |
---|
| 1426 | my %args; |
---|
| 1427 | $args{mode} = "block"; |
---|
| 1428 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 1429 | |
---|
| 1430 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 1431 | |
---|
| 1432 | my $iq = $self->_iq(); |
---|
| 1433 | $iq->SetIQ(to=>$args{jid}, |
---|
| 1434 | type=>"get"); |
---|
| 1435 | my $query = $iq->NewQuery("http://jabber.org/protocol/disco#info"); |
---|
| 1436 | $query->SetDiscoInfo(node=>$args{node}) if exists($args{node}); |
---|
| 1437 | |
---|
| 1438 | #-------------------------------------------------------------------------- |
---|
| 1439 | # Send the IQ with the next available ID and wait for a reply with that |
---|
| 1440 | # id to be received. Then grab the IQ reply. |
---|
| 1441 | #-------------------------------------------------------------------------- |
---|
| 1442 | if ($args{mode} eq "passthru") |
---|
| 1443 | { |
---|
| 1444 | my $id = $self->UniqueID(); |
---|
| 1445 | $iq->SetIQ(id=>$id); |
---|
| 1446 | $self->Send($iq); |
---|
| 1447 | return $id; |
---|
| 1448 | } |
---|
| 1449 | |
---|
| 1450 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 1451 | |
---|
| 1452 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 1453 | |
---|
| 1454 | #-------------------------------------------------------------------------- |
---|
| 1455 | # Check if there was an error. |
---|
| 1456 | #-------------------------------------------------------------------------- |
---|
| 1457 | return unless defined($iq); |
---|
| 1458 | if ($iq->GetType() eq "error") |
---|
| 1459 | { |
---|
| 1460 | $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
---|
| 1461 | return; |
---|
| 1462 | } |
---|
| 1463 | return unless $iq->DefinedQuery(); |
---|
| 1464 | |
---|
| 1465 | $query = $iq->GetQuery(); |
---|
| 1466 | |
---|
| 1467 | return %{$self->DiscoInfoParse($query)}; |
---|
| 1468 | } |
---|
| 1469 | |
---|
| 1470 | |
---|
| 1471 | ############################################################################### |
---|
| 1472 | # |
---|
| 1473 | # DiscoInfoParse - helper function for DiscoInfoRequest to convert the object |
---|
| 1474 | # tree into a hash for better consumption. |
---|
| 1475 | # |
---|
| 1476 | ############################################################################### |
---|
| 1477 | sub DiscoInfoParse |
---|
| 1478 | { |
---|
| 1479 | my $self = shift; |
---|
| 1480 | my $item = shift; |
---|
| 1481 | |
---|
| 1482 | my %disco; |
---|
| 1483 | |
---|
| 1484 | foreach my $ident ($item->GetIdentities()) |
---|
| 1485 | { |
---|
| 1486 | my %identity; |
---|
| 1487 | $identity{category} = $ident->GetCategory(); |
---|
| 1488 | $identity{name} = $ident->GetName(); |
---|
| 1489 | $identity{type} = $ident->GetType(); |
---|
| 1490 | push(@{$disco{identity}},\%identity); |
---|
| 1491 | } |
---|
| 1492 | |
---|
| 1493 | foreach my $feat ($item->GetFeatures()) |
---|
| 1494 | { |
---|
| 1495 | $disco{feature}->{$feat->GetVar()} = 1; |
---|
| 1496 | } |
---|
| 1497 | |
---|
| 1498 | return \%disco; |
---|
| 1499 | } |
---|
| 1500 | |
---|
| 1501 | |
---|
| 1502 | ############################################################################### |
---|
| 1503 | # |
---|
| 1504 | # DiscoItemsRequest - requests the disco information from the specified JID. |
---|
| 1505 | # |
---|
| 1506 | ############################################################################### |
---|
| 1507 | sub DiscoItemsRequest |
---|
| 1508 | { |
---|
| 1509 | my $self = shift; |
---|
| 1510 | my %args; |
---|
| 1511 | $args{mode} = "block"; |
---|
| 1512 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 1513 | |
---|
| 1514 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 1515 | |
---|
| 1516 | my $iq = $self->_iq(); |
---|
| 1517 | $iq->SetIQ(to=>$args{jid}, |
---|
| 1518 | type=>"get"); |
---|
| 1519 | my $query = $iq->NewQuery("http://jabber.org/protocol/disco#items"); |
---|
| 1520 | $query->SetDiscoItems(node=>$args{node}) if exists($args{node}); |
---|
| 1521 | |
---|
| 1522 | #-------------------------------------------------------------------------- |
---|
| 1523 | # Send the IQ with the next available ID and wait for a reply with that |
---|
| 1524 | # id to be received. Then grab the IQ reply. |
---|
| 1525 | #-------------------------------------------------------------------------- |
---|
| 1526 | if ($args{mode} eq "passthru") |
---|
| 1527 | { |
---|
| 1528 | my $id = $self->UniqueID(); |
---|
| 1529 | $iq->SetIQ(id=>$id); |
---|
| 1530 | $self->Send($iq); |
---|
| 1531 | return $id; |
---|
| 1532 | } |
---|
| 1533 | |
---|
| 1534 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 1535 | |
---|
| 1536 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 1537 | |
---|
| 1538 | #-------------------------------------------------------------------------- |
---|
| 1539 | # Check if there was an error. |
---|
| 1540 | #-------------------------------------------------------------------------- |
---|
| 1541 | return unless defined($iq); |
---|
| 1542 | if ($iq->GetType() eq "error") |
---|
| 1543 | { |
---|
| 1544 | $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
---|
| 1545 | return; |
---|
| 1546 | } |
---|
| 1547 | |
---|
| 1548 | $query = $iq->GetQuery(); |
---|
| 1549 | |
---|
| 1550 | if (defined($query)) |
---|
| 1551 | { |
---|
| 1552 | my %disco = %{$self->DiscoItemsParse($query)}; |
---|
| 1553 | return %disco; |
---|
| 1554 | } |
---|
| 1555 | else |
---|
| 1556 | { |
---|
| 1557 | return; |
---|
| 1558 | } |
---|
| 1559 | } |
---|
| 1560 | |
---|
| 1561 | |
---|
| 1562 | ############################################################################### |
---|
| 1563 | # |
---|
| 1564 | # DiscoItemsParse - helper function for DiscoItemsRequest to convert the object |
---|
| 1565 | # tree into a hash for better consumption. |
---|
| 1566 | # |
---|
| 1567 | ############################################################################### |
---|
| 1568 | sub DiscoItemsParse |
---|
| 1569 | { |
---|
| 1570 | my $self = shift; |
---|
| 1571 | my $item = shift; |
---|
| 1572 | |
---|
| 1573 | my %disco; |
---|
| 1574 | |
---|
| 1575 | foreach my $item ($item->GetItems()) |
---|
| 1576 | { |
---|
| 1577 | $disco{$item->GetJID()}->{$item->GetNode()} = $item->GetName(); |
---|
| 1578 | } |
---|
| 1579 | |
---|
| 1580 | return \%disco; |
---|
| 1581 | } |
---|
| 1582 | |
---|
| 1583 | |
---|
| 1584 | ############################################################################### |
---|
| 1585 | # |
---|
| 1586 | # FeatureNegRequest - requests a feature negotiation from the specified JID. |
---|
| 1587 | # |
---|
| 1588 | ############################################################################### |
---|
| 1589 | sub FeatureNegRequest |
---|
| 1590 | { |
---|
| 1591 | my $self = shift; |
---|
| 1592 | my %args; |
---|
| 1593 | $args{mode} = "block"; |
---|
| 1594 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 1595 | |
---|
| 1596 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 1597 | |
---|
| 1598 | my $iq = $self->_iq(); |
---|
| 1599 | $iq->SetIQ(to=>$args{jid}, |
---|
| 1600 | type=>"get"); |
---|
| 1601 | |
---|
| 1602 | my $query = $self->FeatureNegQuery($args{features}); |
---|
| 1603 | |
---|
| 1604 | $iq->AddQuery($query); |
---|
| 1605 | |
---|
| 1606 | #-------------------------------------------------------------------------- |
---|
| 1607 | # Send the IQ with the next available ID and wait for a reply with that |
---|
| 1608 | # id to be received. Then grab the IQ reply. |
---|
| 1609 | #-------------------------------------------------------------------------- |
---|
| 1610 | if ($args{mode} eq "passthru") |
---|
| 1611 | { |
---|
| 1612 | my $id = $self->UniqueID(); |
---|
| 1613 | $iq->SetIQ(id=>$id); |
---|
| 1614 | $self->Send($iq); |
---|
| 1615 | return $id; |
---|
| 1616 | } |
---|
| 1617 | |
---|
| 1618 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 1619 | |
---|
| 1620 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 1621 | |
---|
| 1622 | #-------------------------------------------------------------------------- |
---|
| 1623 | # Check if there was an error. |
---|
| 1624 | #-------------------------------------------------------------------------- |
---|
| 1625 | return unless defined($iq); |
---|
| 1626 | if ($iq->GetType() eq "error") |
---|
| 1627 | { |
---|
| 1628 | $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
---|
| 1629 | return; |
---|
| 1630 | } |
---|
| 1631 | |
---|
| 1632 | $query = $iq->GetQuery(); |
---|
| 1633 | |
---|
| 1634 | if (defined($query)) |
---|
| 1635 | { |
---|
| 1636 | my %feats = %{$self->FeatureNegParse($query)}; |
---|
| 1637 | return %feats; |
---|
| 1638 | } |
---|
| 1639 | else |
---|
| 1640 | { |
---|
| 1641 | return; |
---|
| 1642 | } |
---|
| 1643 | } |
---|
| 1644 | |
---|
| 1645 | #xxx fneg needs to reutrn a type='submit' on the x:data in a result |
---|
| 1646 | |
---|
| 1647 | |
---|
| 1648 | ############################################################################### |
---|
| 1649 | # |
---|
| 1650 | # FeatureNegQuery - given a feature hash, return a query that contains it. |
---|
| 1651 | # |
---|
| 1652 | ############################################################################### |
---|
| 1653 | sub FeatureNegQuery |
---|
| 1654 | { |
---|
| 1655 | my $self = shift; |
---|
| 1656 | my $features = shift; |
---|
| 1657 | |
---|
| 1658 | my $tag = "query"; |
---|
| 1659 | $tag = $Net::Jabber::Query::TAGS{'http://jabber.org/protocol/feature-neg'} |
---|
| 1660 | if exists($Net::Jabber::Query::TAGS{'http://jabber.org/protocol/feature-neg'}); |
---|
| 1661 | |
---|
[cb54527] | 1662 | my $query = Net::Jabber::Query->new($tag); |
---|
[0ff8d110] | 1663 | $query->SetXMLNS("http://jabber.org/protocol/feature-neg"); |
---|
| 1664 | my $xdata = $query->NewX("jabber:x:data"); |
---|
| 1665 | |
---|
| 1666 | foreach my $feature (keys(%{$features})) |
---|
| 1667 | { |
---|
| 1668 | my $field = $xdata->AddField(type=>"list-single", |
---|
| 1669 | var=>$feature); |
---|
| 1670 | foreach my $value (@{$features->{$feature}}) |
---|
| 1671 | { |
---|
| 1672 | $field->AddOption(value=>$value); |
---|
| 1673 | } |
---|
| 1674 | } |
---|
| 1675 | |
---|
| 1676 | return $query; |
---|
| 1677 | } |
---|
| 1678 | |
---|
| 1679 | |
---|
| 1680 | ############################################################################### |
---|
| 1681 | # |
---|
| 1682 | # FeatureNegParse - helper function for FeatureNegRequest to convert the object |
---|
| 1683 | # tree into a hash for better consumption. |
---|
| 1684 | # |
---|
| 1685 | ############################################################################### |
---|
| 1686 | sub FeatureNegParse |
---|
| 1687 | { |
---|
| 1688 | my $self = shift; |
---|
| 1689 | my $item = shift; |
---|
| 1690 | |
---|
| 1691 | my %feats; |
---|
| 1692 | |
---|
| 1693 | my $xdata = $item->GetX("jabber:x:data"); |
---|
| 1694 | |
---|
| 1695 | foreach my $field ($xdata->GetFields()) |
---|
| 1696 | { |
---|
| 1697 | my @options; |
---|
| 1698 | |
---|
| 1699 | foreach my $option ($field->GetOptions()) |
---|
| 1700 | { |
---|
| 1701 | push(@options,$option->GetValue()); |
---|
| 1702 | } |
---|
| 1703 | |
---|
| 1704 | if ($#options == -1) |
---|
| 1705 | { |
---|
| 1706 | |
---|
| 1707 | $feats{$field->GetVar()} = $field->GetValue(); |
---|
| 1708 | } |
---|
| 1709 | else |
---|
| 1710 | { |
---|
| 1711 | $feats{$field->GetVar()} = \@options; |
---|
| 1712 | } |
---|
| 1713 | } |
---|
| 1714 | |
---|
| 1715 | return \%feats; |
---|
| 1716 | } |
---|
| 1717 | |
---|
| 1718 | #XXX - need a feature-neg answer function... |
---|
| 1719 | |
---|
| 1720 | ############################################################################### |
---|
| 1721 | # |
---|
| 1722 | # FileTransferOffer - offer a file transfer JEP-95 |
---|
| 1723 | # |
---|
| 1724 | ############################################################################### |
---|
| 1725 | sub FileTransferOffer |
---|
| 1726 | { |
---|
| 1727 | my $self = shift; |
---|
| 1728 | my %args; |
---|
| 1729 | $args{mode} = "block"; |
---|
| 1730 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 1731 | |
---|
| 1732 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 1733 | |
---|
| 1734 | my $iq = $self->_iq(); |
---|
| 1735 | $iq->SetIQ(to=>$args{jid}, |
---|
| 1736 | type=>"set"); |
---|
| 1737 | my $query = $iq->NewQuery("http://jabber.org/protocol/si"); |
---|
| 1738 | my $profile = $query->NewQuery("http://jabber.org/protocol/si/profile/file-transfer"); |
---|
| 1739 | |
---|
| 1740 | # XXX support hashing via MD5 |
---|
| 1741 | # XXX support date via JEP-82 |
---|
| 1742 | |
---|
| 1743 | my ($filename) = ($args{filename} =~ /\/?([^\/]+)$/); |
---|
| 1744 | |
---|
| 1745 | $profile->SetFile(name=>$filename, |
---|
| 1746 | size=>(-s $args{filename}) |
---|
| 1747 | ); |
---|
| 1748 | |
---|
| 1749 | $profile->SetFile(desc=>$args{desc}) if exists($args{desc}); |
---|
| 1750 | |
---|
| 1751 | $query->SetStream(mimetype=>(-B $args{filename} ? |
---|
| 1752 | "application/octect-stream" : |
---|
| 1753 | "text/plain" |
---|
| 1754 | ), |
---|
| 1755 | id=>$args{sid}, |
---|
| 1756 | profile=>"http://jabber.org/protocol/si/profile/file-transfer" |
---|
| 1757 | ); |
---|
| 1758 | |
---|
| 1759 | if (!exists($args{skip_methods})) |
---|
| 1760 | { |
---|
| 1761 | if ($#{$args{methods}} == -1) |
---|
| 1762 | { |
---|
| 1763 | print STDERR "You did not provide any valid methods for file transfer.\n"; |
---|
| 1764 | return; |
---|
| 1765 | } |
---|
| 1766 | |
---|
| 1767 | my $fneg = $self->FeatureNegQuery({'stream-method'=>$args{methods}}); |
---|
| 1768 | |
---|
| 1769 | $query->AddQuery($fneg); |
---|
| 1770 | } |
---|
| 1771 | |
---|
| 1772 | #-------------------------------------------------------------------------- |
---|
| 1773 | # Send the IQ with the next available ID and wait for a reply with that |
---|
| 1774 | # id to be received. Then grab the IQ reply. |
---|
| 1775 | #-------------------------------------------------------------------------- |
---|
| 1776 | if ($args{mode} eq "passthru") |
---|
| 1777 | { |
---|
| 1778 | my $id = $self->UniqueID(); |
---|
| 1779 | $iq->SetIQ(id=>$id); |
---|
| 1780 | $self->Send($iq); |
---|
| 1781 | return $id; |
---|
| 1782 | } |
---|
| 1783 | |
---|
| 1784 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 1785 | |
---|
| 1786 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 1787 | |
---|
| 1788 | #-------------------------------------------------------------------------- |
---|
| 1789 | # Check if there was an error. |
---|
| 1790 | #-------------------------------------------------------------------------- |
---|
| 1791 | return unless defined($iq); |
---|
| 1792 | if ($iq->GetType() eq "error") |
---|
| 1793 | { |
---|
| 1794 | $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
---|
| 1795 | return; |
---|
| 1796 | } |
---|
| 1797 | |
---|
| 1798 | $query = $iq->GetQuery(); |
---|
| 1799 | |
---|
| 1800 | if (defined($query)) |
---|
| 1801 | { |
---|
| 1802 | my @fneg = $query->GetQuery("http://jabber.org/protocol/feature-neg"); |
---|
| 1803 | my @xdata = $fneg[0]->GetX("jabber:x:data"); |
---|
| 1804 | my @fields = $xdata[0]->GetFields(); |
---|
| 1805 | return $fields[0]->GetValue(); |
---|
| 1806 | # XXX need better error handling |
---|
| 1807 | } |
---|
| 1808 | else |
---|
| 1809 | { |
---|
| 1810 | return; |
---|
| 1811 | } |
---|
| 1812 | } |
---|
| 1813 | |
---|
| 1814 | |
---|
| 1815 | ############################################################################### |
---|
| 1816 | # |
---|
| 1817 | # TreeTransferOffer - offer a file transfer JEP-95 |
---|
| 1818 | # |
---|
| 1819 | ############################################################################### |
---|
| 1820 | sub TreeTransferOffer |
---|
| 1821 | { |
---|
| 1822 | my $self = shift; |
---|
| 1823 | my %args; |
---|
| 1824 | $args{mode} = "block"; |
---|
| 1825 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 1826 | |
---|
| 1827 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 1828 | |
---|
| 1829 | my $iq = $self->_iq(); |
---|
| 1830 | $iq->SetIQ(to=>$args{jid}, |
---|
| 1831 | type=>"set"); |
---|
| 1832 | my $query = $iq->NewQuery("http://jabber.org/protocol/si"); |
---|
| 1833 | my $profile = $query->NewQuery("http://jabber.org/protocol/si/profile/tree-transfer"); |
---|
| 1834 | |
---|
| 1835 | my ($root) = ($args{directory} =~ /\/?([^\/]+)$/); |
---|
| 1836 | |
---|
| 1837 | my $rootDir = $profile->AddDirectory(name=>$root); |
---|
| 1838 | |
---|
| 1839 | my %tree; |
---|
| 1840 | $tree{counter} = 0; |
---|
| 1841 | $self->TreeTransferDescend($args{sidbase}, |
---|
| 1842 | $args{directory}, |
---|
| 1843 | $rootDir, |
---|
| 1844 | \%tree |
---|
| 1845 | ); |
---|
| 1846 | |
---|
| 1847 | $profile->SetTree(numfiles=>$tree{counter}, |
---|
| 1848 | size=>$tree{size} |
---|
| 1849 | ); |
---|
| 1850 | |
---|
| 1851 | $query->SetStream(id=>$args{sidbase}, |
---|
| 1852 | profile=>"http://jabber.org/protocol/si/profile/tree-transfer" |
---|
| 1853 | ); |
---|
| 1854 | |
---|
| 1855 | if ($#{$args{methods}} == -1) |
---|
| 1856 | { |
---|
| 1857 | print STDERR "You did not provide any valid methods for the tree transfer.\n"; |
---|
| 1858 | return; |
---|
| 1859 | } |
---|
| 1860 | |
---|
| 1861 | my $fneg = $self->FeatureNegQuery({'stream-method'=>$args{methods}}); |
---|
| 1862 | |
---|
| 1863 | $query->AddQuery($fneg); |
---|
| 1864 | |
---|
| 1865 | #-------------------------------------------------------------------------- |
---|
| 1866 | # Send the IQ with the next available ID and wait for a reply with that |
---|
| 1867 | # id to be received. Then grab the IQ reply. |
---|
| 1868 | #-------------------------------------------------------------------------- |
---|
| 1869 | if ($args{mode} eq "passthru") |
---|
| 1870 | { |
---|
| 1871 | my $id = $self->UniqueID(); |
---|
| 1872 | $iq->SetIQ(id=>$id); |
---|
| 1873 | $self->Send($iq); |
---|
| 1874 | $tree{id} = $id; |
---|
| 1875 | return %tree; |
---|
| 1876 | } |
---|
| 1877 | |
---|
| 1878 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 1879 | |
---|
| 1880 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 1881 | |
---|
| 1882 | #-------------------------------------------------------------------------- |
---|
| 1883 | # Check if there was an error. |
---|
| 1884 | #-------------------------------------------------------------------------- |
---|
| 1885 | return unless defined($iq); |
---|
| 1886 | if ($iq->GetType() eq "error") |
---|
| 1887 | { |
---|
| 1888 | $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
---|
| 1889 | return; |
---|
| 1890 | } |
---|
| 1891 | |
---|
| 1892 | $query = $iq->GetQuery(); |
---|
| 1893 | |
---|
| 1894 | if (defined($query)) |
---|
| 1895 | { |
---|
| 1896 | my @fneg = $query->GetQuery("http://jabber.org/protocol/feature-neg"); |
---|
| 1897 | my @xdata = $fneg[0]->GetX("jabber:x:data"); |
---|
| 1898 | my @fields = $xdata[0]->GetFields(); |
---|
| 1899 | return $fields[0]->GetValue(); |
---|
| 1900 | # XXX need better error handling |
---|
| 1901 | } |
---|
| 1902 | else |
---|
| 1903 | { |
---|
| 1904 | return; |
---|
| 1905 | } |
---|
| 1906 | } |
---|
| 1907 | |
---|
| 1908 | |
---|
| 1909 | ############################################################################### |
---|
| 1910 | # |
---|
| 1911 | # TreeTransferDescend - descend a directory structure and build the packet. |
---|
| 1912 | # |
---|
| 1913 | ############################################################################### |
---|
| 1914 | sub TreeTransferDescend |
---|
| 1915 | { |
---|
| 1916 | my $self = shift; |
---|
| 1917 | my $sidbase = shift; |
---|
| 1918 | my $path = shift; |
---|
| 1919 | my $parent = shift; |
---|
| 1920 | my $tree = shift; |
---|
| 1921 | |
---|
| 1922 | $tree->{size} += (-s $path); |
---|
| 1923 | |
---|
| 1924 | opendir(DIR, $path); |
---|
| 1925 | foreach my $file ( sort {$a cmp $b} readdir(DIR) ) |
---|
| 1926 | { |
---|
| 1927 | next if ($file =~ /^\.\.?$/); |
---|
| 1928 | |
---|
| 1929 | if (-d "$path/$file") |
---|
| 1930 | { |
---|
| 1931 | my $tempParent = $parent->AddDirectory(name=>$file); |
---|
| 1932 | $self->TreeTransferDescend($sidbase, |
---|
| 1933 | "$path/$file", |
---|
| 1934 | $tempParent, |
---|
| 1935 | $tree |
---|
| 1936 | ); |
---|
| 1937 | } |
---|
| 1938 | else |
---|
| 1939 | { |
---|
| 1940 | $tree->{size} += (-s "$path/$file"); |
---|
| 1941 | |
---|
| 1942 | $tree->{tree}->{"$path/$file"}->{order} = $tree->{counter}; |
---|
| 1943 | $tree->{tree}->{"$path/$file"}->{sid} = |
---|
| 1944 | $sidbase."-".$tree->{counter}; |
---|
| 1945 | $tree->{tree}->{"$path/$file"}->{name} = $file; |
---|
| 1946 | |
---|
| 1947 | $parent->AddFile(name=>$tree->{tree}->{"$path/$file"}->{name}, |
---|
| 1948 | sid=>$tree->{tree}->{"$path/$file"}->{sid}); |
---|
| 1949 | $tree->{counter}++; |
---|
| 1950 | } |
---|
| 1951 | } |
---|
| 1952 | closedir(DIR); |
---|
| 1953 | } |
---|
| 1954 | |
---|
| 1955 | |
---|
| 1956 | ############################################################################### |
---|
| 1957 | # |
---|
| 1958 | # LastQuery - Sends an iq:last query to either the server or the specified |
---|
| 1959 | # JID. |
---|
| 1960 | # |
---|
| 1961 | ############################################################################### |
---|
| 1962 | sub LastQuery |
---|
| 1963 | { |
---|
| 1964 | my $self = shift; |
---|
| 1965 | my %args; |
---|
| 1966 | $args{mode} = "passthru"; |
---|
| 1967 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 1968 | |
---|
| 1969 | $args{waitforid} = 0 unless exists($args{waitforid}); |
---|
| 1970 | my $waitforid = delete($args{waitforid}); |
---|
| 1971 | $args{mode} = "block" if $waitforid; |
---|
| 1972 | |
---|
| 1973 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 1974 | |
---|
| 1975 | my $iq = $self->_iq(); |
---|
| 1976 | $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); |
---|
| 1977 | $iq->SetIQ(type=>'get'); |
---|
| 1978 | my $last = $iq->NewQuery("jabber:iq:last"); |
---|
| 1979 | |
---|
| 1980 | if ($args{mode} eq "passthru") |
---|
| 1981 | { |
---|
| 1982 | my $id = $self->UniqueID(); |
---|
| 1983 | $iq->SetIQ(id=>$id); |
---|
| 1984 | $self->Send($iq); |
---|
| 1985 | return $id; |
---|
| 1986 | } |
---|
| 1987 | |
---|
| 1988 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 1989 | |
---|
| 1990 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 1991 | |
---|
| 1992 | return unless defined($iq); |
---|
| 1993 | |
---|
| 1994 | $last = $iq->GetQuery(); |
---|
| 1995 | |
---|
| 1996 | return unless defined($last); |
---|
| 1997 | |
---|
| 1998 | return $last->GetLast(); |
---|
| 1999 | } |
---|
| 2000 | |
---|
| 2001 | |
---|
| 2002 | ############################################################################### |
---|
| 2003 | # |
---|
| 2004 | # LastSend - sends an iq:last packet to the specified user. |
---|
| 2005 | # |
---|
| 2006 | ############################################################################### |
---|
| 2007 | sub LastSend |
---|
| 2008 | { |
---|
| 2009 | my $self = shift; |
---|
| 2010 | my %args; |
---|
| 2011 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 2012 | |
---|
| 2013 | $args{ignoreactivity} = 0 unless exists($args{ignoreactivity}); |
---|
| 2014 | my $ignoreActivity = delete($args{ignoreactivity}); |
---|
| 2015 | |
---|
| 2016 | my $iq = $self->_iq(); |
---|
| 2017 | $iq->SetIQ(to=>delete($args{to}), |
---|
| 2018 | type=>'result'); |
---|
| 2019 | my $last = $iq->NewQuery("jabber:iq:last"); |
---|
| 2020 | $last->SetLast(%args); |
---|
| 2021 | |
---|
| 2022 | $self->Send($iq,$ignoreActivity); |
---|
| 2023 | } |
---|
| 2024 | |
---|
| 2025 | |
---|
| 2026 | ############################################################################### |
---|
| 2027 | # |
---|
| 2028 | # LastActivity - returns number of seconds since the last activity. |
---|
| 2029 | # |
---|
| 2030 | ############################################################################### |
---|
| 2031 | sub LastActivity |
---|
| 2032 | { |
---|
| 2033 | my $self = shift; |
---|
| 2034 | |
---|
| 2035 | return (time - $self->{STREAM}->LastActivity($self->{SESSION}->{id})); |
---|
| 2036 | } |
---|
| 2037 | |
---|
| 2038 | |
---|
| 2039 | ############################################################################### |
---|
| 2040 | # |
---|
| 2041 | # RegisterSendData - This is a self contained function to send a register iq |
---|
| 2042 | # tag with an id. It uses the jabber:x:data method to |
---|
| 2043 | # return the data. |
---|
| 2044 | # |
---|
| 2045 | ############################################################################### |
---|
| 2046 | sub RegisterSendData |
---|
| 2047 | { |
---|
| 2048 | my $self = shift; |
---|
| 2049 | my $to = shift; |
---|
| 2050 | my %args; |
---|
| 2051 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 2052 | |
---|
| 2053 | #-------------------------------------------------------------------------- |
---|
| 2054 | # Create a Net::Jabber::IQ object to send to the server |
---|
| 2055 | #-------------------------------------------------------------------------- |
---|
| 2056 | my $iq = $self->_iq(); |
---|
| 2057 | $iq->SetIQ(to=>$to) if (defined($to) && ($to ne "")); |
---|
| 2058 | $iq->SetIQ(type=>"set"); |
---|
| 2059 | my $iqRegister = $iq->NewQuery("jabber:iq:register"); |
---|
| 2060 | my $xForm = $iqRegister->NewX("jabber:x:data"); |
---|
| 2061 | foreach my $var (keys(%args)) |
---|
| 2062 | { |
---|
| 2063 | next if ($args{$var} eq ""); |
---|
| 2064 | $xForm->AddField(var=>$var, |
---|
| 2065 | value=>$args{$var} |
---|
| 2066 | ); |
---|
| 2067 | } |
---|
| 2068 | |
---|
| 2069 | #-------------------------------------------------------------------------- |
---|
| 2070 | # Send the IQ with the next available ID and wait for a reply with that |
---|
| 2071 | # id to be received. Then grab the IQ reply. |
---|
| 2072 | #-------------------------------------------------------------------------- |
---|
| 2073 | $iq = $self->SendAndReceiveWithID($iq); |
---|
| 2074 | |
---|
| 2075 | #-------------------------------------------------------------------------- |
---|
| 2076 | # From the reply IQ determine if we were successful or not. If yes then |
---|
| 2077 | # return "". If no then return error string from the reply. |
---|
| 2078 | #-------------------------------------------------------------------------- |
---|
| 2079 | return unless defined($iq); |
---|
| 2080 | return ( $iq->GetErrorCode() , $iq->GetError() ) |
---|
| 2081 | if ($iq->GetType() eq "error"); |
---|
| 2082 | return ("ok",""); |
---|
| 2083 | } |
---|
| 2084 | |
---|
| 2085 | |
---|
| 2086 | ############################################################################### |
---|
| 2087 | # |
---|
| 2088 | # RPCSetCallBacks - place to register a callback for RPC calls. This is |
---|
| 2089 | # used in conjunction with the default IQ callback. |
---|
| 2090 | # |
---|
| 2091 | ############################################################################### |
---|
| 2092 | sub RPCSetCallBacks |
---|
| 2093 | { |
---|
| 2094 | my $self = shift; |
---|
| 2095 | while($#_ >= 0) { |
---|
| 2096 | my $func = pop(@_); |
---|
| 2097 | my $method = pop(@_); |
---|
| 2098 | $self->{DEBUG}->Log2("RPCSetCallBacks: method($method) func($func)"); |
---|
| 2099 | if (defined($func)) |
---|
| 2100 | { |
---|
| 2101 | $self->{RPCCB}{$method} = $func; |
---|
| 2102 | } |
---|
| 2103 | else |
---|
| 2104 | { |
---|
| 2105 | delete($self->{RPCCB}{$method}); |
---|
| 2106 | } |
---|
| 2107 | } |
---|
| 2108 | } |
---|
| 2109 | |
---|
| 2110 | |
---|
| 2111 | ############################################################################### |
---|
| 2112 | # |
---|
| 2113 | # RPCCall - Make an RPC call to the specified JID. |
---|
| 2114 | # |
---|
| 2115 | ############################################################################### |
---|
| 2116 | sub RPCCall |
---|
| 2117 | { |
---|
| 2118 | my $self = shift; |
---|
| 2119 | my %args; |
---|
| 2120 | $args{mode} = "block"; |
---|
| 2121 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 2122 | |
---|
| 2123 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 2124 | |
---|
| 2125 | my $iq = $self->_iq(); |
---|
| 2126 | $iq->SetIQ(type=>"set", |
---|
| 2127 | to=>delete($args{to})); |
---|
| 2128 | $iq->AddQuery($self->RPCEncode(type=>"methodCall", |
---|
| 2129 | %args)); |
---|
| 2130 | |
---|
| 2131 | if ($args{mode} eq "passthru") |
---|
| 2132 | { |
---|
| 2133 | my $id = $self->UniqueID(); |
---|
| 2134 | $iq->SetIQ(id=>$id); |
---|
| 2135 | $self->Send($iq); |
---|
| 2136 | return $id; |
---|
| 2137 | } |
---|
| 2138 | |
---|
| 2139 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 2140 | |
---|
| 2141 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 2142 | |
---|
| 2143 | return unless defined($iq); |
---|
| 2144 | |
---|
| 2145 | return $self->RPCParse($iq); |
---|
| 2146 | } |
---|
| 2147 | |
---|
| 2148 | |
---|
| 2149 | ############################################################################### |
---|
| 2150 | # |
---|
| 2151 | # RPCResponse - Send back an RPC response, or fault, to the specified JID. |
---|
| 2152 | # |
---|
| 2153 | ############################################################################### |
---|
| 2154 | sub RPCResponse |
---|
| 2155 | { |
---|
| 2156 | my $self = shift; |
---|
| 2157 | my %args; |
---|
| 2158 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 2159 | |
---|
| 2160 | my $iq = $self->_iq(); |
---|
| 2161 | $iq->SetIQ(type=>"result", |
---|
| 2162 | to=>delete($args{to})); |
---|
| 2163 | $iq->AddQuery($self->RPCEncode(type=>"methodResponse", |
---|
| 2164 | %args)); |
---|
| 2165 | |
---|
| 2166 | $iq = $self->SendAndReceiveWithID($iq); |
---|
| 2167 | return unless defined($iq); |
---|
| 2168 | |
---|
| 2169 | return $self->RPCParse($iq); |
---|
| 2170 | } |
---|
| 2171 | |
---|
| 2172 | |
---|
| 2173 | ############################################################################### |
---|
| 2174 | # |
---|
| 2175 | # RPCEncode - Returns a Net::Jabber::Query with the arguments encoded for the |
---|
| 2176 | # RPC packet. |
---|
| 2177 | # |
---|
| 2178 | ############################################################################### |
---|
| 2179 | sub RPCEncode |
---|
| 2180 | { |
---|
| 2181 | my $self = shift; |
---|
| 2182 | my %args; |
---|
| 2183 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 2184 | |
---|
[cb54527] | 2185 | my $query = Net::Jabber::Stanza->new("query"); |
---|
[0ff8d110] | 2186 | $query->SetXMLNS("jabber:iq:rpc"); |
---|
| 2187 | |
---|
| 2188 | my $source; |
---|
| 2189 | |
---|
| 2190 | if ($args{type} eq "methodCall") |
---|
| 2191 | { |
---|
| 2192 | $source = $query->AddMethodCall(); |
---|
| 2193 | $source->SetMethodName($args{methodname}); |
---|
| 2194 | } |
---|
| 2195 | |
---|
| 2196 | if ($args{type} eq "methodResponse") |
---|
| 2197 | { |
---|
| 2198 | $source = $query->AddMethodResponse(); |
---|
| 2199 | } |
---|
| 2200 | |
---|
| 2201 | if (exists($args{faultcode}) || exists($args{faultstring})) |
---|
| 2202 | { |
---|
| 2203 | my $struct = $source->AddFault()->AddValue()->AddStruct(); |
---|
| 2204 | $struct->AddMember(name=>"faultCode")->AddValue(i4=>$args{faultcode}); |
---|
| 2205 | $struct->AddMember(name=>"faultString")->AddValue(string=>$args{faultstring}); |
---|
| 2206 | } |
---|
| 2207 | elsif (exists($args{params})) |
---|
| 2208 | { |
---|
| 2209 | my $params = $source->AddParams(); |
---|
| 2210 | foreach my $param (@{$args{params}}) |
---|
| 2211 | { |
---|
| 2212 | $self->RPCEncode_Value($params->AddParam(),$param); |
---|
| 2213 | } |
---|
| 2214 | } |
---|
| 2215 | |
---|
| 2216 | return $query; |
---|
| 2217 | } |
---|
| 2218 | |
---|
| 2219 | |
---|
| 2220 | ############################################################################### |
---|
| 2221 | # |
---|
| 2222 | # RPCEncode_Value - Run through the value, and encode it into XML. |
---|
| 2223 | # |
---|
| 2224 | ############################################################################### |
---|
| 2225 | sub RPCEncode_Value |
---|
| 2226 | { |
---|
| 2227 | my $self = shift; |
---|
| 2228 | my $obj = shift; |
---|
| 2229 | my $value = shift; |
---|
| 2230 | |
---|
| 2231 | if (ref($value) eq "ARRAY") |
---|
| 2232 | { |
---|
| 2233 | my $array = $obj->AddValue()->AddArray(); |
---|
| 2234 | foreach my $data (@{$value}) |
---|
| 2235 | { |
---|
| 2236 | $self->RPCEncode_Value($array->AddData(),$data); |
---|
| 2237 | } |
---|
| 2238 | } |
---|
| 2239 | elsif (ref($value) eq "HASH") |
---|
| 2240 | { |
---|
| 2241 | my $struct = $obj->AddValue()->AddStruct(); |
---|
| 2242 | foreach my $key (keys(%{$value})) |
---|
| 2243 | { |
---|
| 2244 | $self->RPCEncode_Value($struct->AddMember(name=>$key),$value->{$key}); |
---|
| 2245 | } |
---|
| 2246 | } |
---|
| 2247 | else |
---|
| 2248 | { |
---|
| 2249 | if ($value =~ /^(int|i4|boolean|string|double|datetime|base64):/i) |
---|
| 2250 | { |
---|
| 2251 | my $type = $1; |
---|
| 2252 | my($val) = ($value =~ /^$type:(.*)$/); |
---|
| 2253 | $obj->AddValue($type=>$val); |
---|
| 2254 | } |
---|
| 2255 | elsif ($value =~ /^[+-]?\d+$/) |
---|
| 2256 | { |
---|
| 2257 | $obj->AddValue(i4=>$value); |
---|
| 2258 | } |
---|
| 2259 | elsif ($value =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/) |
---|
| 2260 | { |
---|
| 2261 | $obj->AddValue(double=>$value); |
---|
| 2262 | } |
---|
| 2263 | else |
---|
| 2264 | { |
---|
| 2265 | $obj->AddValue(string=>$value); |
---|
| 2266 | } |
---|
| 2267 | } |
---|
| 2268 | } |
---|
| 2269 | |
---|
| 2270 | |
---|
| 2271 | ############################################################################### |
---|
| 2272 | # |
---|
| 2273 | # RPCParse - Returns an array of the params sent in the RPC packet. |
---|
| 2274 | # |
---|
| 2275 | ############################################################################### |
---|
| 2276 | sub RPCParse |
---|
| 2277 | { |
---|
| 2278 | my $self = shift; |
---|
| 2279 | my($iq) = @_; |
---|
| 2280 | |
---|
| 2281 | my $query = $iq->GetQuery(); |
---|
| 2282 | |
---|
| 2283 | my $source; |
---|
| 2284 | $source = $query->GetMethodCall() if $query->DefinedMethodCall(); |
---|
| 2285 | $source = $query->GetMethodResponse() if $query->DefinedMethodResponse(); |
---|
| 2286 | |
---|
| 2287 | if (defined($source)) |
---|
| 2288 | { |
---|
| 2289 | if (($source->GetTag() eq "methodResponse") && ($source->DefinedFault())) |
---|
| 2290 | { |
---|
| 2291 | my %response = |
---|
| 2292 | $self->RPCParse_Struct($source->GetFault()->GetValue()->GetStruct()); |
---|
| 2293 | return ("fault",\%response); |
---|
| 2294 | } |
---|
| 2295 | |
---|
| 2296 | if ($source->DefinedParams()) |
---|
| 2297 | { |
---|
| 2298 | #------------------------------------------------------------------ |
---|
| 2299 | # The <param/>s part |
---|
| 2300 | #------------------------------------------------------------------ |
---|
| 2301 | my @response; |
---|
| 2302 | foreach my $param ($source->GetParams()->GetParams()) |
---|
| 2303 | { |
---|
| 2304 | push(@response,$self->RPCParse_Value($param->GetValue())); |
---|
| 2305 | } |
---|
| 2306 | return ("ok",\@response); |
---|
| 2307 | } |
---|
| 2308 | } |
---|
| 2309 | else |
---|
| 2310 | { |
---|
| 2311 | print "AAAAHHHH!!!!\n"; |
---|
| 2312 | } |
---|
| 2313 | } |
---|
| 2314 | |
---|
| 2315 | |
---|
| 2316 | ############################################################################### |
---|
| 2317 | # |
---|
| 2318 | # RPCParse_Value - Takes a <value/> and returns the data it represents |
---|
| 2319 | # |
---|
| 2320 | ############################################################################### |
---|
| 2321 | sub RPCParse_Value |
---|
| 2322 | { |
---|
| 2323 | my $self = shift; |
---|
| 2324 | my($value) = @_; |
---|
| 2325 | |
---|
| 2326 | if ($value->DefinedStruct()) |
---|
| 2327 | { |
---|
| 2328 | my %struct = $self->RPCParse_Struct($value->GetStruct()); |
---|
| 2329 | return \%struct; |
---|
| 2330 | } |
---|
| 2331 | |
---|
| 2332 | if ($value->DefinedArray()) |
---|
| 2333 | { |
---|
| 2334 | my @array = $self->RPCParse_Array($value->GetArray()); |
---|
| 2335 | return \@array; |
---|
| 2336 | } |
---|
| 2337 | |
---|
| 2338 | return $value->GetI4() if $value->DefinedI4(); |
---|
| 2339 | return $value->GetInt() if $value->DefinedInt(); |
---|
| 2340 | return $value->GetBoolean() if $value->DefinedBoolean(); |
---|
| 2341 | return $value->GetString() if $value->DefinedString(); |
---|
| 2342 | return $value->GetDouble() if $value->DefinedDouble(); |
---|
| 2343 | return $value->GetDateTime() if $value->DefinedDateTime(); |
---|
| 2344 | return $value->GetBase64() if $value->DefinedBase64(); |
---|
| 2345 | |
---|
| 2346 | return $value->GetValue(); |
---|
| 2347 | } |
---|
| 2348 | |
---|
| 2349 | |
---|
| 2350 | ############################################################################### |
---|
| 2351 | # |
---|
| 2352 | # RPCParse_Struct - Takes a <struct/> and returns the hash of values. |
---|
| 2353 | # |
---|
| 2354 | ############################################################################### |
---|
| 2355 | sub RPCParse_Struct |
---|
| 2356 | { |
---|
| 2357 | my $self = shift; |
---|
| 2358 | my($struct) = @_; |
---|
| 2359 | |
---|
| 2360 | my %struct; |
---|
| 2361 | foreach my $member ($struct->GetMembers()) |
---|
| 2362 | { |
---|
| 2363 | $struct{$member->GetName()} = $self->RPCParse_Value($member->GetValue()); |
---|
| 2364 | } |
---|
| 2365 | |
---|
| 2366 | return %struct; |
---|
| 2367 | } |
---|
| 2368 | |
---|
| 2369 | |
---|
| 2370 | ############################################################################### |
---|
| 2371 | # |
---|
| 2372 | # RPCParse_Array - Takes a <array/> and returns the hash of values. |
---|
| 2373 | # |
---|
| 2374 | ############################################################################### |
---|
| 2375 | sub RPCParse_Array |
---|
| 2376 | { |
---|
| 2377 | my $self = shift; |
---|
| 2378 | my($array) = @_; |
---|
| 2379 | |
---|
| 2380 | my @array; |
---|
| 2381 | foreach my $data ($array->GetDatas()) |
---|
| 2382 | { |
---|
| 2383 | push(@array,$self->RPCParse_Value($data->GetValue())); |
---|
| 2384 | } |
---|
| 2385 | |
---|
| 2386 | return @array; |
---|
| 2387 | } |
---|
| 2388 | |
---|
| 2389 | |
---|
| 2390 | ############################################################################### |
---|
| 2391 | # |
---|
| 2392 | # SearchRequest - This is a self contained function to send an iq tag |
---|
| 2393 | # an id that requests the target address to send back |
---|
| 2394 | # the required fields. It waits for a reply what the |
---|
| 2395 | # same id to come back and tell the caller what the |
---|
| 2396 | # fields are. |
---|
| 2397 | # |
---|
| 2398 | ############################################################################### |
---|
| 2399 | sub SearchRequest |
---|
| 2400 | { |
---|
| 2401 | my $self = shift; |
---|
| 2402 | my %args; |
---|
| 2403 | $args{mode} = "block"; |
---|
| 2404 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 2405 | |
---|
| 2406 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 2407 | |
---|
| 2408 | #-------------------------------------------------------------------------- |
---|
| 2409 | # Create a Net::Jabber::IQ object to send to the server |
---|
| 2410 | #-------------------------------------------------------------------------- |
---|
| 2411 | my $iq = $self->_iq(); |
---|
| 2412 | $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); |
---|
| 2413 | $iq->SetIQ(type=>"get"); |
---|
| 2414 | my $query = $iq->NewQuery("jabber:iq:search"); |
---|
| 2415 | |
---|
| 2416 | $self->{DEBUG}->Log1("SearchRequest: sent(",$iq->GetXML(),")"); |
---|
| 2417 | |
---|
| 2418 | #-------------------------------------------------------------------------- |
---|
| 2419 | # Send the IQ with the next available ID and wait for a reply with that |
---|
| 2420 | # id to be received. Then grab the IQ reply. |
---|
| 2421 | #-------------------------------------------------------------------------- |
---|
| 2422 | if ($args{mode} eq "passthru") |
---|
| 2423 | { |
---|
| 2424 | my $id = $self->UniqueID(); |
---|
| 2425 | $iq->SetIQ(id=>$id); |
---|
| 2426 | $self->Send($iq); |
---|
| 2427 | return $id; |
---|
| 2428 | } |
---|
| 2429 | |
---|
| 2430 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 2431 | |
---|
| 2432 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 2433 | |
---|
| 2434 | $self->{DEBUG}->Log1("SearchRequest: received(",$iq->GetXML(),")") |
---|
| 2435 | if defined($iq); |
---|
| 2436 | |
---|
| 2437 | #-------------------------------------------------------------------------- |
---|
| 2438 | # Check if there was an error. |
---|
| 2439 | #-------------------------------------------------------------------------- |
---|
| 2440 | return unless defined($iq); |
---|
| 2441 | if ($iq->GetType() eq "error") |
---|
| 2442 | { |
---|
| 2443 | $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); |
---|
| 2444 | $self->{DEBUG}->Log1("SearchRequest: error(",$self->GetErrorCode(),")"); |
---|
| 2445 | return; |
---|
| 2446 | } |
---|
| 2447 | |
---|
| 2448 | my %search; |
---|
| 2449 | #-------------------------------------------------------------------------- |
---|
| 2450 | # From the reply IQ determine what fields are required and send a hash |
---|
| 2451 | # back with the fields and any values that are already defined (like key) |
---|
| 2452 | #-------------------------------------------------------------------------- |
---|
| 2453 | $query = $iq->GetQuery(); |
---|
| 2454 | $search{fields} = { $query->GetSearch() }; |
---|
| 2455 | |
---|
| 2456 | #-------------------------------------------------------------------------- |
---|
| 2457 | # Get any forms so that we have the option of showing a nive dynamic form |
---|
| 2458 | # to the user and not just a bunch of fields. |
---|
| 2459 | #-------------------------------------------------------------------------- |
---|
| 2460 | &ExtractForms(\%search,$query->GetX("jabber:x:data")); |
---|
| 2461 | |
---|
| 2462 | #-------------------------------------------------------------------------- |
---|
| 2463 | # Get any oobs so that we have the option of sending the user to the http |
---|
| 2464 | # form and not a dynamic one. |
---|
| 2465 | #-------------------------------------------------------------------------- |
---|
| 2466 | &ExtractOobs(\%search,$query->GetX("jabber:x:oob")); |
---|
| 2467 | |
---|
| 2468 | return %search; |
---|
| 2469 | } |
---|
| 2470 | |
---|
| 2471 | |
---|
| 2472 | ############################################################################### |
---|
| 2473 | # |
---|
| 2474 | # SearchSend - This is a self contained function to send a search |
---|
| 2475 | # iq tag with an id. Then wait for a reply what the same |
---|
| 2476 | # id to come back and tell the caller what the result was. |
---|
| 2477 | # |
---|
| 2478 | ############################################################################### |
---|
| 2479 | sub SearchSend |
---|
| 2480 | { |
---|
| 2481 | my $self = shift; |
---|
| 2482 | my %args; |
---|
| 2483 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 2484 | |
---|
| 2485 | #-------------------------------------------------------------------------- |
---|
| 2486 | # Create a Net::Jabber::IQ object to send to the server |
---|
| 2487 | #-------------------------------------------------------------------------- |
---|
| 2488 | my $iq = $self->_iq(); |
---|
| 2489 | $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); |
---|
| 2490 | $iq->SetIQ(type=>"set"); |
---|
| 2491 | my $iqSearch = $iq->NewQuery("jabber:iq:search"); |
---|
| 2492 | $iqSearch->SetSearch(%args); |
---|
| 2493 | |
---|
| 2494 | #-------------------------------------------------------------------------- |
---|
| 2495 | # Send the IQ. |
---|
| 2496 | #-------------------------------------------------------------------------- |
---|
| 2497 | $self->Send($iq); |
---|
| 2498 | } |
---|
| 2499 | |
---|
| 2500 | |
---|
| 2501 | ############################################################################### |
---|
| 2502 | # |
---|
| 2503 | # SearchSendData - This is a self contained function to send a search iq tag |
---|
| 2504 | # with an id. It uses the jabber:x:data method to return the |
---|
| 2505 | # data. |
---|
| 2506 | # |
---|
| 2507 | ############################################################################### |
---|
| 2508 | sub SearchSendData |
---|
| 2509 | { |
---|
| 2510 | my $self = shift; |
---|
| 2511 | my $to = shift; |
---|
| 2512 | my %args; |
---|
| 2513 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 2514 | |
---|
| 2515 | #-------------------------------------------------------------------------- |
---|
| 2516 | # Create a Net::Jabber::IQ object to send to the server |
---|
| 2517 | #-------------------------------------------------------------------------- |
---|
| 2518 | my $iq = $self->_iq(); |
---|
| 2519 | $iq->SetIQ(to=>$to) if (defined($to) && ($to ne "")); |
---|
| 2520 | $iq->SetIQ(type=>"set"); |
---|
| 2521 | my $iqSearch = $iq->NewQuery("jabber:iq:search"); |
---|
| 2522 | my $xForm = $iqSearch->NewX("jabber:x:data"); |
---|
| 2523 | foreach my $var (keys(%args)) |
---|
| 2524 | { |
---|
| 2525 | next if ($args{$var} eq ""); |
---|
| 2526 | $xForm->AddField(var=>$var, |
---|
| 2527 | value=>$args{$var} |
---|
| 2528 | ); |
---|
| 2529 | } |
---|
| 2530 | |
---|
| 2531 | #-------------------------------------------------------------------------- |
---|
| 2532 | # Send the IQ. |
---|
| 2533 | #-------------------------------------------------------------------------- |
---|
| 2534 | $self->Send($iq); |
---|
| 2535 | } |
---|
| 2536 | |
---|
| 2537 | |
---|
| 2538 | ############################################################################### |
---|
| 2539 | # |
---|
| 2540 | # TimeQuery - Sends an iq:time query to either the server or the specified |
---|
| 2541 | # JID. |
---|
| 2542 | # |
---|
| 2543 | ############################################################################### |
---|
| 2544 | sub TimeQuery |
---|
| 2545 | { |
---|
| 2546 | my $self = shift; |
---|
| 2547 | my %args; |
---|
| 2548 | $args{mode} = "passthru"; |
---|
| 2549 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 2550 | |
---|
| 2551 | $args{waitforid} = 0 unless exists($args{waitforid}); |
---|
| 2552 | my $waitforid = delete($args{waitforid}); |
---|
| 2553 | $args{mode} = "block" if $waitforid; |
---|
| 2554 | |
---|
| 2555 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 2556 | |
---|
| 2557 | my $iq = $self->_iq(); |
---|
| 2558 | $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); |
---|
| 2559 | $iq->SetIQ(type=>'get',%args); |
---|
| 2560 | my $time = $iq->NewQuery("jabber:iq:time"); |
---|
| 2561 | |
---|
| 2562 | if ($args{mode} eq "passthru") |
---|
| 2563 | { |
---|
| 2564 | my $id = $self->UniqueID(); |
---|
| 2565 | $iq->SetIQ(id=>$id); |
---|
| 2566 | $self->Send($iq); |
---|
| 2567 | return $id; |
---|
| 2568 | } |
---|
| 2569 | |
---|
| 2570 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 2571 | |
---|
| 2572 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 2573 | |
---|
| 2574 | return unless defined($iq); |
---|
| 2575 | |
---|
| 2576 | my $query = $iq->GetQuery(); |
---|
| 2577 | |
---|
| 2578 | return unless defined($query); |
---|
| 2579 | |
---|
| 2580 | my %result; |
---|
| 2581 | $result{utc} = $query->GetUTC(); |
---|
| 2582 | $result{display} = $query->GetDisplay(); |
---|
| 2583 | $result{tz} = $query->GetTZ(); |
---|
| 2584 | return %result; |
---|
| 2585 | } |
---|
| 2586 | |
---|
| 2587 | |
---|
| 2588 | ############################################################################### |
---|
| 2589 | # |
---|
| 2590 | # TimeSend - sends an iq:time packet to the specified user. |
---|
| 2591 | # |
---|
| 2592 | ############################################################################### |
---|
| 2593 | sub TimeSend |
---|
| 2594 | { |
---|
| 2595 | my $self = shift; |
---|
| 2596 | my %args; |
---|
| 2597 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 2598 | |
---|
| 2599 | my $iq = $self->_iq(); |
---|
| 2600 | $iq->SetIQ(to=>delete($args{to}), |
---|
| 2601 | type=>'result'); |
---|
| 2602 | my $time = $iq->NewQuery("jabber:iq:time"); |
---|
| 2603 | $time->SetTime(%args); |
---|
| 2604 | |
---|
| 2605 | $self->Send($iq); |
---|
| 2606 | } |
---|
| 2607 | |
---|
| 2608 | |
---|
| 2609 | |
---|
| 2610 | ############################################################################### |
---|
| 2611 | # |
---|
| 2612 | # VersionQuery - Sends an iq:version query to either the server or the |
---|
| 2613 | # specified JID. |
---|
| 2614 | # |
---|
| 2615 | ############################################################################### |
---|
| 2616 | sub VersionQuery |
---|
| 2617 | { |
---|
| 2618 | my $self = shift; |
---|
| 2619 | my %args; |
---|
| 2620 | $args{mode} = "passthru"; |
---|
| 2621 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 2622 | |
---|
| 2623 | $args{waitforid} = 0 unless exists($args{waitforid}); |
---|
| 2624 | my $waitforid = delete($args{waitforid}); |
---|
| 2625 | $args{mode} = "block" if $waitforid; |
---|
| 2626 | |
---|
| 2627 | my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; |
---|
| 2628 | |
---|
| 2629 | my $iq = $self->_iq(); |
---|
| 2630 | $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); |
---|
| 2631 | $iq->SetIQ(type=>'get',%args); |
---|
| 2632 | my $version = $iq->NewQuery("jabber:iq:version"); |
---|
| 2633 | |
---|
| 2634 | if ($args{mode} eq "passthru") |
---|
| 2635 | { |
---|
| 2636 | my $id = $self->UniqueID(); |
---|
| 2637 | $iq->SetIQ(id=>$id); |
---|
| 2638 | $self->Send($iq); |
---|
| 2639 | return $id; |
---|
| 2640 | } |
---|
| 2641 | |
---|
| 2642 | return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); |
---|
| 2643 | |
---|
| 2644 | $iq = $self->SendAndReceiveWithID($iq,$timeout); |
---|
| 2645 | |
---|
| 2646 | return unless defined($iq); |
---|
| 2647 | |
---|
| 2648 | my $query = $iq->GetQuery(); |
---|
| 2649 | |
---|
| 2650 | return unless defined($query); |
---|
| 2651 | |
---|
| 2652 | my %result; |
---|
| 2653 | $result{name} = $query->GetName(); |
---|
| 2654 | $result{ver} = $query->GetVer(); |
---|
| 2655 | $result{os} = $query->GetOS(); |
---|
| 2656 | return %result; |
---|
| 2657 | } |
---|
| 2658 | |
---|
| 2659 | |
---|
| 2660 | ############################################################################### |
---|
| 2661 | # |
---|
| 2662 | # VersionSend - sends an iq:version packet to the specified user. |
---|
| 2663 | # |
---|
| 2664 | ############################################################################### |
---|
| 2665 | sub VersionSend |
---|
| 2666 | { |
---|
| 2667 | my $self = shift; |
---|
| 2668 | my %args; |
---|
| 2669 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 2670 | |
---|
| 2671 | my $iq = $self->_iq(); |
---|
| 2672 | $iq->SetIQ(to=>delete($args{to}), |
---|
| 2673 | type=>'result'); |
---|
| 2674 | my $version = $iq->NewQuery("jabber:iq:version"); |
---|
| 2675 | $version->SetVersion(%args); |
---|
| 2676 | |
---|
| 2677 | $self->Send($iq); |
---|
| 2678 | } |
---|
| 2679 | |
---|
| 2680 | |
---|
| 2681 | ############################################################################### |
---|
| 2682 | # |
---|
| 2683 | # MUCJoin - join a MUC room |
---|
| 2684 | # |
---|
| 2685 | ############################################################################### |
---|
| 2686 | sub MUCJoin |
---|
| 2687 | { |
---|
| 2688 | my $self = shift; |
---|
| 2689 | my %args; |
---|
| 2690 | while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } |
---|
| 2691 | |
---|
| 2692 | my $presence = $self->_presence(); |
---|
| 2693 | $presence->SetTo($args{room}.'@'.$args{server}.'/'.$args{nick}); |
---|
| 2694 | my $x = $presence->NewChild("http://jabber.org/protocol/muc"); |
---|
| 2695 | |
---|
| 2696 | if (exists($args{password}) && ($args{password} ne "")) |
---|
| 2697 | { |
---|
| 2698 | $x->SetMUC(password=>$args{password}); |
---|
| 2699 | } |
---|
| 2700 | |
---|
| 2701 | return $presence->GetXML() if exists($args{'__netjabber__:test'}); |
---|
| 2702 | $self->Send($presence); |
---|
| 2703 | } |
---|
| 2704 | |
---|
| 2705 | |
---|
| 2706 | ############################################################################### |
---|
| 2707 | #+----------------------------------------------------------------------------- |
---|
| 2708 | #| |
---|
| 2709 | #| Helper Functions |
---|
| 2710 | #| |
---|
| 2711 | #+----------------------------------------------------------------------------- |
---|
| 2712 | ############################################################################### |
---|
| 2713 | |
---|
| 2714 | |
---|
| 2715 | ############################################################################### |
---|
| 2716 | # |
---|
| 2717 | # ExtractForms - Helper function to make extracting jabber:x:data for forms |
---|
| 2718 | # more centrally definable. |
---|
| 2719 | # |
---|
| 2720 | ############################################################################### |
---|
| 2721 | sub ExtractForms |
---|
| 2722 | { |
---|
| 2723 | my ($target,@xForms) = @_; |
---|
| 2724 | |
---|
| 2725 | my $tempVar = "1"; |
---|
| 2726 | foreach my $xForm (@xForms) { |
---|
| 2727 | $target->{instructions} = $xForm->GetInstructions(); |
---|
| 2728 | my $order = 0; |
---|
| 2729 | foreach my $field ($xForm->GetFields()) |
---|
| 2730 | { |
---|
| 2731 | $target->{form}->[$order]->{type} = $field->GetType() |
---|
| 2732 | if $field->DefinedType(); |
---|
| 2733 | $target->{form}->[$order]->{label} = $field->GetLabel() |
---|
| 2734 | if $field->DefinedLabel(); |
---|
| 2735 | $target->{form}->[$order]->{desc} = $field->GetDesc() |
---|
| 2736 | if $field->DefinedDesc(); |
---|
| 2737 | $target->{form}->[$order]->{var} = $field->GetVar() |
---|
| 2738 | if $field->DefinedVar(); |
---|
| 2739 | $target->{form}->[$order]->{var} = "__netjabber__:tempvar:".$tempVar++ |
---|
| 2740 | if !$field->DefinedVar(); |
---|
| 2741 | if ($field->DefinedValue()) |
---|
| 2742 | { |
---|
| 2743 | if ($field->GetType() eq "list-multi") |
---|
| 2744 | { |
---|
| 2745 | $target->{form}->[$order]->{value} = [ $field->GetValue() ]; |
---|
| 2746 | } |
---|
| 2747 | else |
---|
| 2748 | { |
---|
| 2749 | $target->{form}->[$order]->{value} = ($field->GetValue())[0]; |
---|
| 2750 | } |
---|
| 2751 | } |
---|
| 2752 | my $count = 0; |
---|
| 2753 | foreach my $option ($field->GetOptions()) |
---|
| 2754 | { |
---|
| 2755 | $target->{form}->[$order]->{options}->[$count]->{value} = |
---|
| 2756 | $option->GetValue(); |
---|
| 2757 | $target->{form}->[$order]->{options}->[$count]->{label} = |
---|
| 2758 | $option->GetLabel(); |
---|
| 2759 | $count++; |
---|
| 2760 | } |
---|
| 2761 | $order++; |
---|
| 2762 | } |
---|
| 2763 | foreach my $reported ($xForm->GetReported()) |
---|
| 2764 | { |
---|
| 2765 | my $order = 0; |
---|
| 2766 | foreach my $field ($reported->GetFields()) |
---|
| 2767 | { |
---|
| 2768 | $target->{reported}->[$order]->{label} = $field->GetLabel(); |
---|
| 2769 | $target->{reported}->[$order]->{var} = $field->GetVar(); |
---|
| 2770 | $order++; |
---|
| 2771 | } |
---|
| 2772 | } |
---|
| 2773 | } |
---|
| 2774 | } |
---|
| 2775 | |
---|
| 2776 | |
---|
| 2777 | ############################################################################### |
---|
| 2778 | # |
---|
| 2779 | # ExtractOobs - Helper function to make extracting jabber:x:oob for forms |
---|
| 2780 | # more centrally definable. |
---|
| 2781 | # |
---|
| 2782 | ############################################################################### |
---|
| 2783 | sub ExtractOobs |
---|
| 2784 | { |
---|
| 2785 | my ($target,@xOobs) = @_; |
---|
| 2786 | |
---|
| 2787 | foreach my $xOob (@xOobs) |
---|
| 2788 | { |
---|
| 2789 | $target->{oob}->{url} = $xOob->GetURL(); |
---|
| 2790 | $target->{oob}->{desc} = $xOob->GetDesc(); |
---|
| 2791 | } |
---|
| 2792 | } |
---|
| 2793 | |
---|
| 2794 | |
---|
| 2795 | ############################################################################### |
---|
| 2796 | #+----------------------------------------------------------------------------- |
---|
| 2797 | #| |
---|
| 2798 | #| Default CallBacks |
---|
| 2799 | #| |
---|
| 2800 | #+----------------------------------------------------------------------------- |
---|
| 2801 | ############################################################################### |
---|
| 2802 | |
---|
| 2803 | |
---|
| 2804 | ############################################################################### |
---|
| 2805 | # |
---|
| 2806 | # callbackInit - initialize the default callbacks |
---|
| 2807 | # |
---|
| 2808 | ############################################################################### |
---|
| 2809 | sub callbackInit |
---|
| 2810 | { |
---|
| 2811 | my $self = shift; |
---|
| 2812 | |
---|
| 2813 | $self->SUPER::callbackInit(); |
---|
| 2814 | |
---|
| 2815 | $self->SetIQCallBacks("jabber:iq:last"=> |
---|
| 2816 | { |
---|
| 2817 | get=>sub{ $self->callbackGetIQLast(@_) }, |
---|
| 2818 | result=>sub{ $self->callbackResultIQLast(@_) } |
---|
| 2819 | }, |
---|
| 2820 | "jabber:iq:rpc"=> |
---|
| 2821 | { |
---|
| 2822 | set=>sub{ $self->callbackSetIQRPC(@_) }, |
---|
| 2823 | }, |
---|
| 2824 | "jabber:iq:time"=> |
---|
| 2825 | { |
---|
| 2826 | get=>sub{ $self->callbackGetIQTime(@_) }, |
---|
| 2827 | result=>sub{ $self->callbackResultIQTime(@_) } |
---|
| 2828 | }, |
---|
| 2829 | "jabber:iq:version"=> |
---|
| 2830 | { |
---|
| 2831 | get=>sub{ $self->callbackGetIQVersion(@_) }, |
---|
| 2832 | result=>sub{ $self->callbackResultIQVersion(@_) } |
---|
| 2833 | }, |
---|
| 2834 | ); |
---|
| 2835 | } |
---|
| 2836 | |
---|
| 2837 | |
---|
| 2838 | ############################################################################### |
---|
| 2839 | # |
---|
| 2840 | # callbackSetIQRPC - callback to handle auto-replying to an iq:rpc by calling |
---|
| 2841 | # the user registered functions. |
---|
| 2842 | # |
---|
| 2843 | ############################################################################### |
---|
| 2844 | sub callbackSetIQRPC |
---|
| 2845 | { |
---|
| 2846 | my $self = shift; |
---|
| 2847 | my $sid = shift; |
---|
| 2848 | my $iq = shift; |
---|
| 2849 | |
---|
| 2850 | my $query = $iq->GetQuery(); |
---|
| 2851 | |
---|
| 2852 | my $reply = $iq->Reply(type=>"result"); |
---|
| 2853 | my $replyQuery = $reply->GetQuery(); |
---|
| 2854 | |
---|
| 2855 | if (!$query->DefinedMethodCall()) |
---|
| 2856 | { |
---|
| 2857 | my $methodResponse = $replyQuery->AddMethodResponse(); |
---|
| 2858 | my $struct = $methodResponse->AddFault()->AddValue()->AddStruct(); |
---|
| 2859 | $struct->AddMember(name=>"faultCode")->AddValue(int=>400); |
---|
| 2860 | $struct->AddMember(name=>"faultString")->AddValue(string=>"Missing methodCall."); |
---|
| 2861 | $self->Send($reply,1); |
---|
| 2862 | return; |
---|
| 2863 | } |
---|
| 2864 | |
---|
| 2865 | if (!$query->GetMethodCall()->DefinedMethodName()) |
---|
| 2866 | { |
---|
| 2867 | my $methodResponse = $replyQuery->AddMethodResponse(); |
---|
| 2868 | my $struct = $methodResponse->AddFault()->AddValue()->AddStruct(); |
---|
| 2869 | $struct->AddMember(name=>"faultCode")->AddValue(int=>400); |
---|
| 2870 | $struct->AddMember(name=>"faultString")->AddValue(string=>"Missing methodName."); |
---|
| 2871 | $self->Send($reply,1); |
---|
| 2872 | return; |
---|
| 2873 | } |
---|
| 2874 | |
---|
| 2875 | my $methodName = $query->GetMethodCall()->GetMethodName(); |
---|
| 2876 | |
---|
| 2877 | if (!exists($self->{RPCCB}->{$methodName})) |
---|
| 2878 | { |
---|
| 2879 | my $methodResponse = $replyQuery->AddMethodResponse(); |
---|
| 2880 | my $struct = $methodResponse->AddFault()->AddValue()->AddStruct(); |
---|
| 2881 | $struct->AddMember(name=>"faultCode")->AddValue(int=>404); |
---|
| 2882 | $struct->AddMember(name=>"faultString")->AddValue(string=>"methodName $methodName not defined."); |
---|
| 2883 | $self->Send($reply,1); |
---|
| 2884 | return; |
---|
| 2885 | } |
---|
| 2886 | |
---|
| 2887 | my @params = $self->RPCParse($iq); |
---|
| 2888 | |
---|
| 2889 | my @return = &{$self->{RPCCB}->{$methodName}}($iq,$params[1]); |
---|
| 2890 | |
---|
| 2891 | if ($return[0] ne "ok") { |
---|
| 2892 | my $methodResponse = $replyQuery->AddMethodResponse(); |
---|
| 2893 | my $struct = $methodResponse->AddFault()->AddValue()->AddStruct(); |
---|
| 2894 | $struct->AddMember(name=>"faultCode")->AddValue(int=>$return[1]->{faultCode}); |
---|
| 2895 | $struct->AddMember(name=>"faultString")->AddValue(string=>$return[1]->{faultString}); |
---|
| 2896 | $self->Send($reply,1); |
---|
| 2897 | return; |
---|
| 2898 | } |
---|
| 2899 | $reply->RemoveQuery(); |
---|
| 2900 | $reply->AddQuery($self->RPCEncode(type=>"methodResponse", |
---|
| 2901 | params=>$return[1])); |
---|
| 2902 | |
---|
| 2903 | $self->Send($reply,1); |
---|
| 2904 | } |
---|
| 2905 | |
---|
| 2906 | |
---|
| 2907 | ############################################################################### |
---|
| 2908 | # |
---|
| 2909 | # callbackGetIQTime - callback to handle auto-replying to an iq:time get. |
---|
| 2910 | # |
---|
| 2911 | ############################################################################### |
---|
| 2912 | sub callbackGetIQTime |
---|
| 2913 | { |
---|
| 2914 | my $self = shift; |
---|
| 2915 | my $sid = shift; |
---|
| 2916 | my $iq = shift; |
---|
| 2917 | |
---|
| 2918 | my $query = $iq->GetQuery(); |
---|
| 2919 | |
---|
| 2920 | my $reply = $iq->Reply(type=>"result"); |
---|
| 2921 | my $replyQuery = $reply->GetQuery(); |
---|
| 2922 | $replyQuery->SetTime(); |
---|
| 2923 | |
---|
| 2924 | $self->Send($reply,1); |
---|
| 2925 | } |
---|
| 2926 | |
---|
| 2927 | |
---|
| 2928 | ############################################################################### |
---|
| 2929 | # |
---|
| 2930 | # callbackResultIQTime - callback to handle formatting iq:time result into |
---|
| 2931 | # a message. |
---|
| 2932 | # |
---|
| 2933 | ############################################################################### |
---|
| 2934 | sub callbackResultIQTime |
---|
| 2935 | { |
---|
| 2936 | my $self = shift; |
---|
| 2937 | my $sid = shift; |
---|
| 2938 | my $iq = shift; |
---|
| 2939 | |
---|
| 2940 | my $fromJID = $iq->GetFrom("jid"); |
---|
| 2941 | my $query = $iq->GetQuery(); |
---|
| 2942 | |
---|
| 2943 | my $body = "UTC: ".$query->GetUTC()."\n"; |
---|
| 2944 | $body .= "Time: ".$query->GetDisplay()."\n"; |
---|
| 2945 | $body .= "Timezone: ".$query->GetTZ()."\n"; |
---|
| 2946 | |
---|
| 2947 | my $message = $self->_message(); |
---|
| 2948 | $message->SetMessage(to=>$iq->GetTo(), |
---|
| 2949 | from=>$iq->GetFrom(), |
---|
| 2950 | subject=>"CTCP: Time", |
---|
| 2951 | body=>$body); |
---|
| 2952 | |
---|
| 2953 | |
---|
| 2954 | $self->CallBack($sid,$message); |
---|
| 2955 | } |
---|
| 2956 | |
---|
| 2957 | |
---|
| 2958 | ############################################################################### |
---|
| 2959 | # |
---|
| 2960 | # callbackGetIQVersion - callback to handle auto-replying to an iq:time |
---|
| 2961 | # get. |
---|
| 2962 | # |
---|
| 2963 | ############################################################################### |
---|
| 2964 | sub callbackGetIQVersion |
---|
| 2965 | { |
---|
| 2966 | my $self = shift; |
---|
| 2967 | my $sid = shift; |
---|
| 2968 | my $iq = shift; |
---|
| 2969 | |
---|
| 2970 | my $query = $iq->GetQuery(); |
---|
| 2971 | |
---|
| 2972 | my $reply = $iq->Reply(type=>"result"); |
---|
| 2973 | my $replyQuery = $reply->GetQuery(); |
---|
| 2974 | $replyQuery->SetVersion(name=>$self->{INFO}->{name}, |
---|
| 2975 | ver=>$self->{INFO}->{version}, |
---|
| 2976 | os=>""); |
---|
| 2977 | |
---|
| 2978 | $self->Send($reply,1); |
---|
| 2979 | } |
---|
| 2980 | |
---|
| 2981 | |
---|
| 2982 | ############################################################################### |
---|
| 2983 | # |
---|
| 2984 | # callbackResultIQVersion - callback to handle formatting iq:time result |
---|
| 2985 | # into a message. |
---|
| 2986 | # |
---|
| 2987 | ############################################################################### |
---|
| 2988 | sub callbackResultIQVersion |
---|
| 2989 | { |
---|
| 2990 | my $self = shift; |
---|
| 2991 | my $sid = shift; |
---|
| 2992 | my $iq = shift; |
---|
| 2993 | |
---|
| 2994 | my $query = $iq->GetQuery(); |
---|
| 2995 | |
---|
| 2996 | my $body = "Program: ".$query->GetName()."\n"; |
---|
| 2997 | $body .= "Version: ".$query->GetVer()."\n"; |
---|
| 2998 | $body .= "OS: ".$query->GetOS()."\n"; |
---|
| 2999 | |
---|
| 3000 | my $message = $self->_message(); |
---|
| 3001 | $message->SetMessage(to=>$iq->GetTo(), |
---|
| 3002 | from=>$iq->GetFrom(), |
---|
| 3003 | subject=>"CTCP: Version", |
---|
| 3004 | body=>$body); |
---|
| 3005 | |
---|
| 3006 | $self->CallBack($sid,$message); |
---|
| 3007 | } |
---|
| 3008 | |
---|
| 3009 | |
---|
| 3010 | ############################################################################### |
---|
| 3011 | # |
---|
| 3012 | # callbackGetIQLast - callback to handle auto-replying to an iq:last get. |
---|
| 3013 | # |
---|
| 3014 | ############################################################################### |
---|
| 3015 | sub callbackGetIQLast |
---|
| 3016 | { |
---|
| 3017 | my $self = shift; |
---|
| 3018 | my $sid = shift; |
---|
| 3019 | my $iq = shift; |
---|
| 3020 | |
---|
| 3021 | my $query = $iq->GetQuery(); |
---|
| 3022 | my $reply = $iq->Reply(type=>"result"); |
---|
| 3023 | my $replyQuery = $reply->GetQuery(); |
---|
| 3024 | $replyQuery->SetLast(seconds=>$self->LastActivity()); |
---|
| 3025 | |
---|
| 3026 | $self->Send($reply,1); |
---|
| 3027 | } |
---|
| 3028 | |
---|
| 3029 | |
---|
| 3030 | ############################################################################### |
---|
| 3031 | # |
---|
| 3032 | # callbackResultIQLast - callback to handle formatting iq:last result into |
---|
| 3033 | # a message. |
---|
| 3034 | # |
---|
| 3035 | ############################################################################### |
---|
| 3036 | sub callbackResultIQLast |
---|
| 3037 | { |
---|
| 3038 | my $self = shift; |
---|
| 3039 | my $sid = shift; |
---|
| 3040 | my $iq = shift; |
---|
| 3041 | |
---|
| 3042 | my $fromJID = $iq->GetFrom("jid"); |
---|
| 3043 | my $query = $iq->GetQuery(); |
---|
| 3044 | my $seconds = $query->GetSeconds(); |
---|
| 3045 | |
---|
| 3046 | my $lastTime = &Net::Jabber::GetTimeStamp("local",(time - $seconds),"long"); |
---|
| 3047 | |
---|
| 3048 | my $elapsedTime = &Net::Jabber::GetHumanTime($seconds); |
---|
| 3049 | |
---|
| 3050 | my $body; |
---|
| 3051 | if ($fromJID->GetUserID() eq "") |
---|
| 3052 | { |
---|
| 3053 | $body = "Start Time: $lastTime\n"; |
---|
| 3054 | $body .= "Up time: $elapsedTime\n"; |
---|
| 3055 | $body .= "Message: ".$query->GetMessage()."\n" |
---|
| 3056 | if ($query->DefinedMessage()); |
---|
| 3057 | } |
---|
| 3058 | elsif ($fromJID->GetResource() eq "") |
---|
| 3059 | { |
---|
| 3060 | $body = "Logout Time: $lastTime\n"; |
---|
| 3061 | $body .= "Elapsed time: $elapsedTime\n"; |
---|
| 3062 | $body .= "Message: ".$query->GetMessage()."\n" |
---|
| 3063 | if ($query->DefinedMessage()); |
---|
| 3064 | } |
---|
| 3065 | else |
---|
| 3066 | { |
---|
| 3067 | $body = "Last activity: $lastTime\n"; |
---|
| 3068 | $body .= "Elapsed time: $elapsedTime\n"; |
---|
| 3069 | $body .= "Message: ".$query->GetMessage()."\n" |
---|
| 3070 | if ($query->DefinedMessage()); |
---|
| 3071 | } |
---|
| 3072 | |
---|
| 3073 | my $message = $self->_message(); |
---|
| 3074 | $message->SetMessage(from=>$iq->GetFrom(), |
---|
| 3075 | subject=>"Last Activity", |
---|
| 3076 | body=>$body); |
---|
| 3077 | |
---|
| 3078 | $self->CallBack($sid,$message); |
---|
| 3079 | } |
---|
| 3080 | |
---|
| 3081 | |
---|
| 3082 | 1; |
---|