File Coverage

blib/lib/Net/Jabber/Protocol.pm
Criterion Covered Total %
statement 112 935 11.9
branch 47 370 12.7
condition 14 36 38.8
subroutine 7 62 11.2
pod 0 52 0.0
total 180 1455 12.3


line stmt bran cond sub pod time code
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 );
80             $Con = new Net::Jabber::Client(); # From
81             $status = $Con->Connect(hostname=>"jabber.org"); # Net::Jabber::Client
82              
83             or
84              
85             use Net::Jabber qw( Component );
86             $Con = new Net::Jabber::Component(); #
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("XML");
102             $receiveObj = $Con->SendAndReceiveWithID($sendObj);
103             $receiveObj = $Con->SendAndReceiveWithID($sendObj,
104             10);
105             $receiveObj = $Con->SendAndReceiveWithID("XML");
106             $receiveObj = $Con->SendAndReceiveWithID("XML",
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 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{}->{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             and is case
742             sensitive. The single
743             arguemnt is a ref to an
744             array that contains the
745             . The function you
746             write should return one of two
747             things:
748              
749             ["ok", [...] ]
750              
751             The [...] is a list of the
752             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 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 49     49   299 use strict;
  49         96  
  49         2101  
850 49     49   276 use Carp;
  49         104  
  49         3425  
851 49     49   284 use vars qw($VERSION);
  49         97  
  49         627823  
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 0     0 0 0 my $self = shift;
882 0         0 my %args;
883 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
884              
885 0         0 foreach my $arg (keys(%args))
886             {
887 0         0 $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 5     5 0 76247 my $self = shift;
903 5         7 my %args;
904 5         20 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  15         53  
905              
906 5 50       15 croak("You must specify xmlns=>'' for the function call to DefineNamespace")
907             if !exists($args{xmlns});
908 5 50       20 croak("You must specify type=>'' for the function call to DefineNamespace")
909             if !exists($args{type});
910 5 50       14 croak("You must specify functions=>'' for the function call to DefineNamespace")
911             if !exists($args{functions});
912            
913 5         8 my %xpath;
914              
915             my $tag;
916 5 50       20 if (exists($args{tag}))
917             {
918 0         0 $tag = $args{tag};
919             }
920             else
921             {
922 5 50       19 $tag = "x" if ($args{type} eq "X");
923 5 50       23 $tag = "query" if ($args{type} eq "Query");
924             }
925              
926 5         8 foreach my $function (@{$args{functions}})
  5         13  
927             {
928 29         34 my %tempHash = %{$function};
  29         105  
929 29         40 my %funcHash;
930 29         55 foreach my $func (keys(%tempHash))
931             {
932 100         175 $funcHash{lc($func)} = $tempHash{$func};
933             }
934              
935 29 50       82 croak("You must specify name=>'' for each function in call to DefineNamespace")
936             if !exists($funcHash{name});
937              
938 29         47 my $name = delete($funcHash{name});
939              
940 29 100 100     101 if (!exists($funcHash{set}) && exists($funcHash{get}))
941             {
942 1         177 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 28 50 100     158 if (exists($funcHash{type}) || exists($funcHash{path}) ||
      66        
      66        
946             exists($funcHash{child}) || exists($funcHash{calls}))
947             {
948              
949 16         28 foreach my $type (keys(%funcHash))
950             {
951 23 100       39 if ($type eq "child")
952             {
953 2         7 $xpath{$name}->{$type}->{ns} = $funcHash{$type}->[1];
954 2         3 my $i = 2;
955 2         3 while( $i <= $#{$funcHash{$type}} )
  2         10  
956             {
957 0 0       0 if ($funcHash{$type}->[$i] eq "__netjabber__:skip_xmlns")
958             {
959 0         0 $xpath{$name}->{$type}->{skip_xmlns} = 1;
960             }
961            
962 0 0       0 if ($funcHash{$type}->[$i] eq "__netjabber__:specifyname")
963             {
964 0         0 $xpath{$name}->{$type}->{specify_name} = 1;
965 0         0 $i++;
966 0         0 $xpath{$name}->{$type}->{tag} = $funcHash{$type}->[$i+1];
967             }
968              
969 0         0 $i++;
970             }
971             }
972             else
973             {
974 21         70 $xpath{$name}->{$type} = $funcHash{$type};
975             }
976             }
977 16         123 next;
978             }
979            
980 12         25 my $type = $funcHash{set}->[0];
981 12         17 my $xpath = $funcHash{set}->[1];
982 12 100       26 if (exists($funcHash{hash}))
983             {
984 11 100       22 $xpath = "text()" if ($funcHash{hash} eq "data");
985 11 100       23 $xpath .= "/text()" if ($funcHash{hash} eq "child-data");
986 11 100       31 $xpath = "\@$xpath" if ($funcHash{hash} eq "att");
987 11 100       45 $xpath = "$1/\@$2" if ($funcHash{hash} =~ /^att-(\S+)-(.+)$/);
988             }
989              
990 12 100       27 if ($type eq "master")
991             {
992 1         5 $xpath{$name}->{type} = $type;
993 1         5 next;
994             }
995            
996 11 100       26 if ($type eq "scalar")
997             {
998 8         23 $xpath{$name}->{path} = $xpath;
999 8         29 next;
1000             }
1001            
1002 3 100       15 if ($type eq "flag")
1003             {
1004 2         8 $xpath{$name}->{type} = 'flag';
1005 2         4 $xpath{$name}->{path} = $xpath;
1006 2         7 next;
1007             }
1008              
1009 1 50 33     9 if (($funcHash{hash} eq "child-add") && exists($funcHash{add}))
1010             {
1011 1         4 $xpath{$name}->{type} = "node";
1012 1         3 $xpath{$name}->{path} = $funcHash{add}->[3];
1013 1         4 $xpath{$name}->{child}->{ns} = $funcHash{add}->[1];
1014 1         3 $xpath{$name}->{calls} = [ 'Add' ];
1015 1         4 next;
1016             }
1017             }
1018              
1019 4         35 $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 0     0 0 0 my $self = shift;
1034              
1035 0         0 my $iq = $self->_iq();
1036 0         0 $iq->SetIQ(@_);
1037 0         0 $iq->SetIQ(type=>"get");
1038 0         0 my $query = $iq->NewQuery("jabber:iq:agents");
1039              
1040 0         0 $iq = $self->SendAndReceiveWithID($iq);
1041              
1042 0 0       0 return unless defined($iq);
1043              
1044 0         0 $query = $iq->GetQuery();
1045 0         0 my @agents = $query->GetAgents();
1046              
1047 0         0 my %agents;
1048 0         0 my $count = 0;
1049 0         0 foreach my $agent (@agents)
1050             {
1051 0         0 my $jid = $agent->GetJID();
1052 0         0 $agents{$jid}->{name} = $agent->GetName();
1053 0         0 $agents{$jid}->{description} = $agent->GetDescription();
1054 0         0 $agents{$jid}->{transport} = $agent->GetTransport();
1055 0         0 $agents{$jid}->{service} = $agent->GetService();
1056 0         0 $agents{$jid}->{register} = $agent->DefinedRegister();
1057 0         0 $agents{$jid}->{search} = $agent->DefinedSearch();
1058 0         0 $agents{$jid}->{groupchat} = $agent->DefinedGroupChat();
1059 0         0 $agents{$jid}->{agents} = $agent->DefinedAgents();
1060 0         0 $agents{$jid}->{order} = $count++;
1061             }
1062              
1063 0         0 return %agents;
1064             }
1065              
1066              
1067             ###############################################################################
1068             #
1069             # BrowseRequest - requests the browse information from the specified JID.
1070             #
1071             ###############################################################################
1072             sub BrowseRequest
1073             {
1074 0     0 0 0 my $self = shift;
1075 0         0 my %args;
1076 0         0 $args{mode} = "block";
1077 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
1078              
1079 0 0       0 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
1080              
1081 0         0 my $iq = $self->_iq();
1082 0         0 $iq->SetIQ(to=>$args{jid},
1083             type=>"get");
1084 0         0 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 0 0       0 if ($args{mode} eq "passthru")
1091             {
1092 0         0 my $id = $self->UniqueID();
1093 0         0 $iq->SetIQ(id=>$id);
1094 0         0 $self->Send($iq);
1095 0         0 return $id;
1096             }
1097            
1098 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
1099              
1100 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
1101              
1102             #--------------------------------------------------------------------------
1103             # Check if there was an error.
1104             #--------------------------------------------------------------------------
1105 0 0       0 return unless defined($iq);
1106 0 0       0 if ($iq->GetType() eq "error")
1107             {
1108 0         0 $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError());
1109 0         0 return;
1110             }
1111              
1112 0         0 $query = $iq->GetQuery();
1113              
1114 0 0       0 if (defined($query))
1115             {
1116 0         0 my %browse = %{$self->BrowseParse($query)};
  0         0  
1117 0         0 return %browse;
1118             }
1119             else
1120             {
1121 0         0 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 0     0 0 0 my $self = shift;
1135 0         0 my $item = shift;
1136 0         0 my %browse;
1137              
1138 0 0       0 if ($item->DefinedCategory())
1139             {
1140 0         0 $browse{category} = $item->GetCategory();
1141             }
1142             else
1143             {
1144 0         0 $browse{category} = $item->GetTag();
1145             }
1146 0         0 $browse{type} = $item->GetType();
1147 0         0 $browse{name} = $item->GetName();
1148 0         0 $browse{jid} = $item->GetJID();
1149 0         0 $browse{ns} = [ $item->GetNS() ];
1150              
1151 0         0 foreach my $subitem ($item->GetItems())
1152             {
1153 0         0 my ($subbrowse) = $self->BrowseParse($subitem);
1154 0         0 push(@{$browse{children}},$subbrowse);
  0         0  
1155             }
1156              
1157 0         0 return \%browse;
1158             }
1159              
1160              
1161             ###############################################################################
1162             #
1163             # BrowseDBDelete - delete the JID from the DB completely.
1164             #
1165             ###############################################################################
1166             sub BrowseDBDelete
1167             {
1168 0     0 0 0 my $self = shift;
1169 0         0 my ($jid) = @_;
1170              
1171 0         0 my $indexJID = $jid;
1172 0 0       0 $indexJID = $jid->GetJID() if (ref($jid) eq "Net::Jabber::JID");
1173              
1174 0 0       0 return if !exists($self->{BROWSEDB}->{$indexJID});
1175 0         0 delete($self->{BROWSEDB}->{$indexJID});
1176 0         0 $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 0     0 0 0 my $self = shift;
1189 0         0 my %args;
1190 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
1191              
1192 0 0       0 $args{timeout} = 10 unless exists($args{timeout});
1193              
1194 0         0 my $indexJID = $args{jid};
1195 0 0       0 $indexJID = $args{jid}->GetJID() if (ref($args{jid}) eq "Net::Jabber::JID");
1196              
1197 0 0 0     0 if ((exists($args{refresh}) && ($args{refresh} eq "1")) ||
      0        
1198             (!exists($self->{BROWSEDB}->{$indexJID})))
1199             {
1200 0         0 my %browse = $self->BrowseRequest(jid=>$args{jid},
1201             timeout=>$args{timeout});
1202              
1203 0         0 $self->{BROWSEDB}->{$indexJID} = \%browse;
1204             }
1205 0         0 return %{$self->{BROWSEDB}->{$indexJID}};
  0         0  
1206             }
1207              
1208              
1209             ###############################################################################
1210             #
1211             # ByteStreamsProxyRequest - This queries a proxy server to get a list of
1212             #
1213             ###############################################################################
1214             sub ByteStreamsProxyRequest
1215             {
1216 0     0 0 0 my $self = shift;
1217 0         0 my %args;
1218 0         0 $args{mode} = "block";
1219 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
1220              
1221 0 0       0 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
1222              
1223 0         0 my $iq = $self->_iq();
1224 0         0 $iq->SetIQ(to=>$args{jid},
1225             type=>"get");
1226 0         0 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 0 0       0 if ($args{mode} eq "passthru")
1233             {
1234 0         0 my $id = $self->UniqueID();
1235 0         0 $iq->SetIQ(id=>$id);
1236 0         0 $self->Send($iq);
1237 0         0 return $id;
1238             }
1239            
1240 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
1241              
1242 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
1243              
1244             #--------------------------------------------------------------------------
1245             # Check if there was an error.
1246             #--------------------------------------------------------------------------
1247 0 0       0 return unless defined($iq);
1248 0 0       0 if ($iq->GetType() eq "error")
1249             {
1250 0         0 $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError());
1251 0         0 return;
1252             }
1253              
1254 0         0 $query = $iq->GetQuery();
1255              
1256 0 0       0 if (defined($query))
1257             {
1258 0         0 my @hosts = @{$self->ByteStreamsProxyParse($query)};
  0         0  
1259 0         0 return @hosts;
1260             }
1261             else
1262             {
1263 0         0 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 0     0 0 0 my $self = shift;
1277 0         0 my $item = shift;
1278              
1279 0         0 my @hosts;
1280              
1281 0         0 foreach my $host ($item->GetStreamHosts())
1282             {
1283 0         0 my %host;
1284 0         0 $host{jid} = $host->GetJID();
1285 0 0       0 $host{host} = $host->GetHost() if $host->DefinedHost();
1286 0 0       0 $host{port} = $host->GetPort() if $host->DefinedPort();
1287 0 0       0 $host{zeroconf} = $host->GetZeroConf() if $host->DefinedZeroConf();
1288              
1289 0         0 push(@hosts,\%host);
1290             }
1291            
1292 0         0 return \@hosts;
1293             }
1294              
1295              
1296             ###############################################################################
1297             #
1298             # ByteStreamsProxyActivate - This tells a proxy to activate the connection
1299             #
1300             ###############################################################################
1301             sub ByteStreamsProxyActivate
1302             {
1303 0     0 0 0 my $self = shift;
1304 0         0 my %args;
1305 0         0 $args{mode} = "block";
1306 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
1307              
1308 0 0       0 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
1309              
1310 0         0 my $iq = $self->_iq();
1311 0         0 $iq->SetIQ(to=>$args{jid},
1312             type=>"set");
1313 0         0 my $query = $iq->NewQuery("http://jabber.org/protocol/bytestreams");
1314 0 0       0 $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 0 0       0 if ($args{mode} eq "passthru")
1323             {
1324 0         0 my $id = $self->UniqueID();
1325 0         0 $iq->SetIQ(id=>$id);
1326 0         0 $self->Send($iq);
1327 0         0 return $id;
1328             }
1329            
1330 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
1331            
1332 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
1333              
1334             #--------------------------------------------------------------------------
1335             # Check if there was an error.
1336             #--------------------------------------------------------------------------
1337 0 0       0 return unless defined($iq);
1338 0 0       0 if ($iq->GetType() eq "error")
1339             {
1340 0         0 $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError());
1341 0         0 return;
1342             }
1343              
1344 0         0 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 0     0 0 0 my $self = shift;
1357 0         0 my %args;
1358 0         0 $args{mode} = "block";
1359 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
1360              
1361 0 0       0 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
1362              
1363 0         0 my $iq = $self->_iq();
1364 0         0 $iq->SetIQ(to=>$args{jid},
1365             type=>"set");
1366 0         0 my $query = $iq->NewQuery("http://jabber.org/protocol/bytestreams");
1367              
1368 0         0 $query->SetByteStreams(sid=>$args{sid});
1369              
1370 0         0 foreach my $host (@{$args{streamhosts}})
  0         0  
1371             {
1372 0 0       0 $query->AddStreamHost(jid=>$host->{jid},
    0          
    0          
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 0 0       0 if ($args{mode} eq "passthru")
1384             {
1385 0         0 my $id = $self->UniqueID();
1386 0         0 $iq->SetIQ(id=>$id);
1387 0         0 $self->Send($iq);
1388 0         0 return $id;
1389             }
1390            
1391 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
1392              
1393 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
1394              
1395             #--------------------------------------------------------------------------
1396             # Check if there was an error.
1397             #--------------------------------------------------------------------------
1398 0 0       0 return unless defined($iq);
1399 0 0       0 if ($iq->GetType() eq "error")
1400             {
1401 0         0 $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError());
1402 0         0 return;
1403             }
1404              
1405 0         0 $query = $iq->GetQuery();
1406              
1407 0 0       0 if (defined($query))
1408             {
1409 0         0 return $query->GetStreamHostUsedJID();
1410             }
1411             else
1412             {
1413 0         0 return;
1414             }
1415             }
1416              
1417              
1418             ###############################################################################
1419             #
1420             # DiscoInfoRequest - requests the disco information from the specified JID.
1421             #
1422             ###############################################################################
1423             sub DiscoInfoRequest
1424             {
1425 0     0 0 0 my $self = shift;
1426 0         0 my %args;
1427 0         0 $args{mode} = "block";
1428 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
1429              
1430 0 0       0 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
1431              
1432 0         0 my $iq = $self->_iq();
1433 0         0 $iq->SetIQ(to=>$args{jid},
1434             type=>"get");
1435 0         0 my $query = $iq->NewQuery("http://jabber.org/protocol/disco#info");
1436 0 0       0 $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 0 0       0 if ($args{mode} eq "passthru")
1443             {
1444 0         0 my $id = $self->UniqueID();
1445 0         0 $iq->SetIQ(id=>$id);
1446 0         0 $self->Send($iq);
1447 0         0 return $id;
1448             }
1449            
1450 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
1451              
1452 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
1453              
1454             #--------------------------------------------------------------------------
1455             # Check if there was an error.
1456             #--------------------------------------------------------------------------
1457 0 0       0 return unless defined($iq);
1458 0 0       0 if ($iq->GetType() eq "error")
1459             {
1460 0         0 $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError());
1461 0         0 return;
1462             }
1463 0 0       0 return unless $iq->DefinedQuery();
1464              
1465 0         0 $query = $iq->GetQuery();
1466              
1467 0         0 return %{$self->DiscoInfoParse($query)};
  0         0  
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 0     0 0 0 my $self = shift;
1480 0         0 my $item = shift;
1481              
1482 0         0 my %disco;
1483              
1484 0         0 foreach my $ident ($item->GetIdentities())
1485             {
1486 0         0 my %identity;
1487 0         0 $identity{category} = $ident->GetCategory();
1488 0         0 $identity{name} = $ident->GetName();
1489 0         0 $identity{type} = $ident->GetType();
1490 0         0 push(@{$disco{identity}},\%identity);
  0         0  
1491             }
1492              
1493 0         0 foreach my $feat ($item->GetFeatures())
1494             {
1495 0         0 $disco{feature}->{$feat->GetVar()} = 1;
1496             }
1497            
1498 0         0 return \%disco;
1499             }
1500              
1501              
1502             ###############################################################################
1503             #
1504             # DiscoItemsRequest - requests the disco information from the specified JID.
1505             #
1506             ###############################################################################
1507             sub DiscoItemsRequest
1508             {
1509 0     0 0 0 my $self = shift;
1510 0         0 my %args;
1511 0         0 $args{mode} = "block";
1512 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
1513              
1514 0 0       0 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
1515              
1516 0         0 my $iq = $self->_iq();
1517 0         0 $iq->SetIQ(to=>$args{jid},
1518             type=>"get");
1519 0         0 my $query = $iq->NewQuery("http://jabber.org/protocol/disco#items");
1520 0 0       0 $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 0 0       0 if ($args{mode} eq "passthru")
1527             {
1528 0         0 my $id = $self->UniqueID();
1529 0         0 $iq->SetIQ(id=>$id);
1530 0         0 $self->Send($iq);
1531 0         0 return $id;
1532             }
1533            
1534 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
1535              
1536 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
1537              
1538             #--------------------------------------------------------------------------
1539             # Check if there was an error.
1540             #--------------------------------------------------------------------------
1541 0 0       0 return unless defined($iq);
1542 0 0       0 if ($iq->GetType() eq "error")
1543             {
1544 0         0 $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError());
1545 0         0 return;
1546             }
1547              
1548 0         0 $query = $iq->GetQuery();
1549              
1550 0 0       0 if (defined($query))
1551             {
1552 0         0 my %disco = %{$self->DiscoItemsParse($query)};
  0         0  
1553 0         0 return %disco;
1554             }
1555             else
1556             {
1557 0         0 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 0     0 0 0 my $self = shift;
1571 0         0 my $item = shift;
1572              
1573 0         0 my %disco;
1574              
1575 0         0 foreach my $item ($item->GetItems())
1576             {
1577 0         0 $disco{$item->GetJID()}->{$item->GetNode()} = $item->GetName();
1578             }
1579            
1580 0         0 return \%disco;
1581             }
1582              
1583              
1584             ###############################################################################
1585             #
1586             # FeatureNegRequest - requests a feature negotiation from the specified JID.
1587             #
1588             ###############################################################################
1589             sub FeatureNegRequest
1590             {
1591 0     0 0 0 my $self = shift;
1592 0         0 my %args;
1593 0         0 $args{mode} = "block";
1594 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
1595              
1596 0 0       0 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
1597              
1598 0         0 my $iq = $self->_iq();
1599 0         0 $iq->SetIQ(to=>$args{jid},
1600             type=>"get");
1601              
1602 0         0 my $query = $self->FeatureNegQuery($args{features});
1603              
1604 0         0 $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 0 0       0 if ($args{mode} eq "passthru")
1611             {
1612 0         0 my $id = $self->UniqueID();
1613 0         0 $iq->SetIQ(id=>$id);
1614 0         0 $self->Send($iq);
1615 0         0 return $id;
1616             }
1617            
1618 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
1619              
1620 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
1621              
1622             #--------------------------------------------------------------------------
1623             # Check if there was an error.
1624             #--------------------------------------------------------------------------
1625 0 0       0 return unless defined($iq);
1626 0 0       0 if ($iq->GetType() eq "error")
1627             {
1628 0         0 $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError());
1629 0         0 return;
1630             }
1631              
1632 0         0 $query = $iq->GetQuery();
1633              
1634 0 0       0 if (defined($query))
1635             {
1636 0         0 my %feats = %{$self->FeatureNegParse($query)};
  0         0  
1637 0         0 return %feats;
1638             }
1639             else
1640             {
1641 0         0 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 0     0 0 0 my $self = shift;
1656 0         0 my $features = shift;
1657              
1658 0         0 my $tag = "query";
1659 0 0       0 $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            
1662 0         0 my $query = new Net::Jabber::Query($tag);
1663 0         0 $query->SetXMLNS("http://jabber.org/protocol/feature-neg");
1664 0         0 my $xdata = $query->NewX("jabber:x:data");
1665            
1666 0         0 foreach my $feature (keys(%{$features}))
  0         0  
1667             {
1668 0         0 my $field = $xdata->AddField(type=>"list-single",
1669             var=>$feature);
1670 0         0 foreach my $value (@{$features->{$feature}})
  0         0  
1671             {
1672 0         0 $field->AddOption(value=>$value);
1673             }
1674             }
1675              
1676 0         0 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 0     0 0 0 my $self = shift;
1689 0         0 my $item = shift;
1690              
1691 0         0 my %feats;
1692              
1693 0         0 my $xdata = $item->GetX("jabber:x:data");
1694            
1695 0         0 foreach my $field ($xdata->GetFields())
1696             {
1697 0         0 my @options;
1698            
1699 0         0 foreach my $option ($field->GetOptions())
1700             {
1701 0         0 push(@options,$option->GetValue());
1702             }
1703              
1704 0 0       0 if ($#options == -1)
1705             {
1706            
1707 0         0 $feats{$field->GetVar()} = $field->GetValue();
1708             }
1709             else
1710             {
1711 0         0 $feats{$field->GetVar()} = \@options;
1712             }
1713             }
1714            
1715 0         0 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 0     0 0 0 my $self = shift;
1728 0         0 my %args;
1729 0         0 $args{mode} = "block";
1730 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
1731              
1732 0 0       0 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
1733              
1734 0         0 my $iq = $self->_iq();
1735 0         0 $iq->SetIQ(to=>$args{jid},
1736             type=>"set");
1737 0         0 my $query = $iq->NewQuery("http://jabber.org/protocol/si");
1738 0         0 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 0         0 my ($filename) = ($args{filename} =~ /\/?([^\/]+)$/);
1744              
1745 0         0 $profile->SetFile(name=>$filename,
1746             size=>(-s $args{filename})
1747             );
1748              
1749 0 0       0 $profile->SetFile(desc=>$args{desc}) if exists($args{desc});
1750              
1751 0 0       0 $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 0 0       0 if (!exists($args{skip_methods}))
1760             {
1761 0 0       0 if ($#{$args{methods}} == -1)
  0         0  
1762             {
1763 0         0 print STDERR "You did not provide any valid methods for file transfer.\n";
1764 0         0 return;
1765             }
1766              
1767 0         0 my $fneg = $self->FeatureNegQuery({'stream-method'=>$args{methods}});
1768              
1769 0         0 $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 0 0       0 if ($args{mode} eq "passthru")
1777             {
1778 0         0 my $id = $self->UniqueID();
1779 0         0 $iq->SetIQ(id=>$id);
1780 0         0 $self->Send($iq);
1781 0         0 return $id;
1782             }
1783            
1784 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
1785              
1786 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
1787              
1788             #--------------------------------------------------------------------------
1789             # Check if there was an error.
1790             #--------------------------------------------------------------------------
1791 0 0       0 return unless defined($iq);
1792 0 0       0 if ($iq->GetType() eq "error")
1793             {
1794 0         0 $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError());
1795 0         0 return;
1796             }
1797              
1798 0         0 $query = $iq->GetQuery();
1799              
1800 0 0       0 if (defined($query))
1801             {
1802 0         0 my @fneg = $query->GetQuery("http://jabber.org/protocol/feature-neg");
1803 0         0 my @xdata = $fneg[0]->GetX("jabber:x:data");
1804 0         0 my @fields = $xdata[0]->GetFields();
1805 0         0 return $fields[0]->GetValue();
1806             # XXX need better error handling
1807             }
1808             else
1809             {
1810 0         0 return;
1811             }
1812             }
1813              
1814              
1815             ###############################################################################
1816             #
1817             # TreeTransferOffer - offer a file transfer JEP-95
1818             #
1819             ###############################################################################
1820             sub TreeTransferOffer
1821             {
1822 0     0 0 0 my $self = shift;
1823 0         0 my %args;
1824 0         0 $args{mode} = "block";
1825 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
1826              
1827 0 0       0 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
1828              
1829 0         0 my $iq = $self->_iq();
1830 0         0 $iq->SetIQ(to=>$args{jid},
1831             type=>"set");
1832 0         0 my $query = $iq->NewQuery("http://jabber.org/protocol/si");
1833 0         0 my $profile = $query->NewQuery("http://jabber.org/protocol/si/profile/tree-transfer");
1834              
1835 0         0 my ($root) = ($args{directory} =~ /\/?([^\/]+)$/);
1836              
1837 0         0 my $rootDir = $profile->AddDirectory(name=>$root);
1838              
1839 0         0 my %tree;
1840 0         0 $tree{counter} = 0;
1841 0         0 $self->TreeTransferDescend($args{sidbase},
1842             $args{directory},
1843             $rootDir,
1844             \%tree
1845             );
1846              
1847 0         0 $profile->SetTree(numfiles=>$tree{counter},
1848             size=>$tree{size}
1849             );
1850              
1851 0         0 $query->SetStream(id=>$args{sidbase},
1852             profile=>"http://jabber.org/protocol/si/profile/tree-transfer"
1853             );
1854              
1855 0 0       0 if ($#{$args{methods}} == -1)
  0         0  
1856             {
1857 0         0 print STDERR "You did not provide any valid methods for the tree transfer.\n";
1858 0         0 return;
1859             }
1860              
1861 0         0 my $fneg = $self->FeatureNegQuery({'stream-method'=>$args{methods}});
1862              
1863 0         0 $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 0 0       0 if ($args{mode} eq "passthru")
1870             {
1871 0         0 my $id = $self->UniqueID();
1872 0         0 $iq->SetIQ(id=>$id);
1873 0         0 $self->Send($iq);
1874 0         0 $tree{id} = $id;
1875 0         0 return %tree;
1876             }
1877            
1878 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
1879              
1880 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
1881              
1882             #--------------------------------------------------------------------------
1883             # Check if there was an error.
1884             #--------------------------------------------------------------------------
1885 0 0       0 return unless defined($iq);
1886 0 0       0 if ($iq->GetType() eq "error")
1887             {
1888 0         0 $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError());
1889 0         0 return;
1890             }
1891              
1892 0         0 $query = $iq->GetQuery();
1893              
1894 0 0       0 if (defined($query))
1895             {
1896 0         0 my @fneg = $query->GetQuery("http://jabber.org/protocol/feature-neg");
1897 0         0 my @xdata = $fneg[0]->GetX("jabber:x:data");
1898 0         0 my @fields = $xdata[0]->GetFields();
1899 0         0 return $fields[0]->GetValue();
1900             # XXX need better error handling
1901             }
1902             else
1903             {
1904 0         0 return;
1905             }
1906             }
1907              
1908              
1909             ###############################################################################
1910             #
1911             # TreeTransferDescend - descend a directory structure and build the packet.
1912             #
1913             ###############################################################################
1914             sub TreeTransferDescend
1915             {
1916 0     0 0 0 my $self = shift;
1917 0         0 my $sidbase = shift;
1918 0         0 my $path = shift;
1919 0         0 my $parent = shift;
1920 0         0 my $tree = shift;
1921              
1922 0         0 $tree->{size} += (-s $path);
1923            
1924 0         0 opendir(DIR, $path);
1925 0         0 foreach my $file ( sort {$a cmp $b} readdir(DIR) )
  0         0  
1926             {
1927 0 0       0 next if ($file =~ /^\.\.?$/);
1928              
1929 0 0       0 if (-d "$path/$file")
1930             {
1931 0         0 my $tempParent = $parent->AddDirectory(name=>$file);
1932 0         0 $self->TreeTransferDescend($sidbase,
1933             "$path/$file",
1934             $tempParent,
1935             $tree
1936             );
1937             }
1938             else
1939             {
1940 0         0 $tree->{size} += (-s "$path/$file");
1941            
1942 0         0 $tree->{tree}->{"$path/$file"}->{order} = $tree->{counter};
1943 0         0 $tree->{tree}->{"$path/$file"}->{sid} =
1944             $sidbase."-".$tree->{counter};
1945 0         0 $tree->{tree}->{"$path/$file"}->{name} = $file;
1946              
1947 0         0 $parent->AddFile(name=>$tree->{tree}->{"$path/$file"}->{name},
1948             sid=>$tree->{tree}->{"$path/$file"}->{sid});
1949 0         0 $tree->{counter}++;
1950             }
1951             }
1952 0         0 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 0     0 0 0 my $self = shift;
1965 0         0 my %args;
1966 0         0 $args{mode} = "passthru";
1967 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
1968              
1969 0 0       0 $args{waitforid} = 0 unless exists($args{waitforid});
1970 0         0 my $waitforid = delete($args{waitforid});
1971 0 0       0 $args{mode} = "block" if $waitforid;
1972            
1973 0 0       0 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
1974              
1975 0         0 my $iq = $self->_iq();
1976 0 0       0 $iq->SetIQ(to=>delete($args{to})) if exists($args{to});
1977 0         0 $iq->SetIQ(type=>'get');
1978 0         0 my $last = $iq->NewQuery("jabber:iq:last");
1979              
1980 0 0       0 if ($args{mode} eq "passthru")
1981             {
1982 0         0 my $id = $self->UniqueID();
1983 0         0 $iq->SetIQ(id=>$id);
1984 0         0 $self->Send($iq);
1985 0         0 return $id;
1986             }
1987            
1988 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
1989              
1990 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
1991              
1992 0 0       0 return unless defined($iq);
1993              
1994 0         0 $last = $iq->GetQuery();
1995              
1996 0 0       0 return unless defined($last);
1997              
1998 0         0 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 0     0 0 0 my $self = shift;
2010 0         0 my %args;
2011 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2012              
2013 0 0       0 $args{ignoreactivity} = 0 unless exists($args{ignoreactivity});
2014 0         0 my $ignoreActivity = delete($args{ignoreactivity});
2015              
2016 0         0 my $iq = $self->_iq();
2017 0         0 $iq->SetIQ(to=>delete($args{to}),
2018             type=>'result');
2019 0         0 my $last = $iq->NewQuery("jabber:iq:last");
2020 0         0 $last->SetLast(%args);
2021              
2022 0         0 $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 0     0 0 0 my $self = shift;
2034              
2035 0         0 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 0     0 0 0 my $self = shift;
2049 0         0 my $to = shift;
2050 0         0 my %args;
2051 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2052              
2053             #--------------------------------------------------------------------------
2054             # Create a Net::Jabber::IQ object to send to the server
2055             #--------------------------------------------------------------------------
2056 0         0 my $iq = $self->_iq();
2057 0 0 0     0 $iq->SetIQ(to=>$to) if (defined($to) && ($to ne ""));
2058 0         0 $iq->SetIQ(type=>"set");
2059 0         0 my $iqRegister = $iq->NewQuery("jabber:iq:register");
2060 0         0 my $xForm = $iqRegister->NewX("jabber:x:data");
2061 0         0 foreach my $var (keys(%args))
2062             {
2063 0 0       0 next if ($args{$var} eq "");
2064 0         0 $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 0         0 $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 0 0       0 return unless defined($iq);
2080 0 0       0 return ( $iq->GetErrorCode() , $iq->GetError() )
2081             if ($iq->GetType() eq "error");
2082 0         0 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 0     0 0 0 my $self = shift;
2095 0         0 while($#_ >= 0) {
2096 0         0 my $func = pop(@_);
2097 0         0 my $method = pop(@_);
2098 0         0 $self->{DEBUG}->Log2("RPCSetCallBacks: method($method) func($func)");
2099 0 0       0 if (defined($func))
2100             {
2101 0         0 $self->{RPCCB}{$method} = $func;
2102             }
2103             else
2104             {
2105 0         0 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 0     0 0 0 my $self = shift;
2119 0         0 my %args;
2120 0         0 $args{mode} = "block";
2121 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2122              
2123 0 0       0 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
2124              
2125 0         0 my $iq = $self->_iq();
2126 0         0 $iq->SetIQ(type=>"set",
2127             to=>delete($args{to}));
2128 0         0 $iq->AddQuery($self->RPCEncode(type=>"methodCall",
2129             %args));
2130              
2131 0 0       0 if ($args{mode} eq "passthru")
2132             {
2133 0         0 my $id = $self->UniqueID();
2134 0         0 $iq->SetIQ(id=>$id);
2135 0         0 $self->Send($iq);
2136 0         0 return $id;
2137             }
2138            
2139 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
2140              
2141 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
2142              
2143 0 0       0 return unless defined($iq);
2144              
2145 0         0 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 0     0 0 0 my $self = shift;
2157 0         0 my %args;
2158 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2159              
2160 0         0 my $iq = $self->_iq();
2161 0         0 $iq->SetIQ(type=>"result",
2162             to=>delete($args{to}));
2163 0         0 $iq->AddQuery($self->RPCEncode(type=>"methodResponse",
2164             %args));
2165              
2166 0         0 $iq = $self->SendAndReceiveWithID($iq);
2167 0 0       0 return unless defined($iq);
2168              
2169 0         0 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 4     4 0 35984 my $self = shift;
2182 4         13 my %args;
2183 4         23 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  13         64  
2184              
2185 4         35 my $query = new Net::Jabber::Stanza("query");
2186 4         76 $query->SetXMLNS("jabber:iq:rpc");
2187              
2188 4         3706 my $source;
2189              
2190 4 100       24 if ($args{type} eq "methodCall")
2191             {
2192 1         9 $source = $query->AddMethodCall();
2193 1         613 $source->SetMethodName($args{methodname});
2194             }
2195              
2196 4 100       1027 if ($args{type} eq "methodResponse")
2197             {
2198 3         27 $source = $query->AddMethodResponse();
2199             }
2200              
2201 4 100 66     94 if (exists($args{faultcode}) || exists($args{faultstring}))
    50          
2202             {
2203 1         12 my $struct = $source->AddFault()->AddValue()->AddStruct();
2204 1         24 $struct->AddMember(name=>"faultCode")->AddValue(i4=>$args{faultcode});
2205 1         1618 $struct->AddMember(name=>"faultString")->AddValue(string=>$args{faultstring});
2206             }
2207             elsif (exists($args{params}))
2208             {
2209 3         24 my $params = $source->AddParams();
2210 3         51 foreach my $param (@{$args{params}})
  3         12  
2211             {
2212 13         26160 $self->RPCEncode_Value($params->AddParam(),$param);
2213             }
2214             }
2215              
2216 4         7320 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 20     20 0 6454 my $self = shift;
2228 20         34 my $obj = shift;
2229 20         41 my $value = shift;
2230              
2231 20 100       88 if (ref($value) eq "ARRAY")
    100          
2232             {
2233 1         6 my $array = $obj->AddValue()->AddArray();
2234 1         20 foreach my $data (@{$value})
  1         6  
2235             {
2236 3         3282 $self->RPCEncode_Value($array->AddData(),$data);
2237             }
2238             }
2239             elsif (ref($value) eq "HASH")
2240             {
2241 2         15 my $struct = $obj->AddValue()->AddStruct();
2242 2         35 foreach my $key (keys(%{$value}))
  2         12  
2243             {
2244 4         3311 $self->RPCEncode_Value($struct->AddMember(name=>$key),$value->{$key});
2245             }
2246             }
2247             else
2248             {
2249 17 100       173 if ($value =~ /^(int|i4|boolean|string|double|datetime|base64):/i)
    100          
    50          
2250             {
2251 6         22 my $type = $1;
2252 6         185 my($val) = ($value =~ /^$type:(.*)$/);
2253 6         196 $obj->AddValue($type=>$val);
2254             }
2255             elsif ($value =~ /^[+-]?\d+$/)
2256             {
2257 5         33 $obj->AddValue(i4=>$value);
2258             }
2259             elsif ($value =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/)
2260             {
2261 0         0 $obj->AddValue(double=>$value);
2262             }
2263             else
2264             {
2265 6         50 $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 0     0 0 0 my $self = shift;
2279 0         0 my($iq) = @_;
2280              
2281 0         0 my $query = $iq->GetQuery();
2282              
2283 0         0 my $source;
2284 0 0       0 $source = $query->GetMethodCall() if $query->DefinedMethodCall();
2285 0 0       0 $source = $query->GetMethodResponse() if $query->DefinedMethodResponse();
2286              
2287 0 0       0 if (defined($source))
2288             {
2289 0 0 0     0 if (($source->GetTag() eq "methodResponse") && ($source->DefinedFault()))
2290             {
2291 0         0 my %response =
2292             $self->RPCParse_Struct($source->GetFault()->GetValue()->GetStruct());
2293 0         0 return ("fault",\%response);
2294             }
2295              
2296 0 0       0 if ($source->DefinedParams())
2297             {
2298             #------------------------------------------------------------------
2299             # The s part
2300             #------------------------------------------------------------------
2301 0         0 my @response;
2302 0         0 foreach my $param ($source->GetParams()->GetParams())
2303             {
2304 0         0 push(@response,$self->RPCParse_Value($param->GetValue()));
2305             }
2306 0         0 return ("ok",\@response);
2307             }
2308             }
2309             else
2310             {
2311 0         0 print "AAAAHHHH!!!!\n";
2312             }
2313             }
2314              
2315              
2316             ###############################################################################
2317             #
2318             # RPCParse_Value - Takes a and returns the data it represents
2319             #
2320             ###############################################################################
2321             sub RPCParse_Value
2322             {
2323 0     0 0 0 my $self = shift;
2324 0         0 my($value) = @_;
2325              
2326 0 0       0 if ($value->DefinedStruct())
2327             {
2328 0         0 my %struct = $self->RPCParse_Struct($value->GetStruct());
2329 0         0 return \%struct;
2330             }
2331              
2332 0 0       0 if ($value->DefinedArray())
2333             {
2334 0         0 my @array = $self->RPCParse_Array($value->GetArray());
2335 0         0 return \@array;
2336             }
2337              
2338 0 0       0 return $value->GetI4() if $value->DefinedI4();
2339 0 0       0 return $value->GetInt() if $value->DefinedInt();
2340 0 0       0 return $value->GetBoolean() if $value->DefinedBoolean();
2341 0 0       0 return $value->GetString() if $value->DefinedString();
2342 0 0       0 return $value->GetDouble() if $value->DefinedDouble();
2343 0 0       0 return $value->GetDateTime() if $value->DefinedDateTime();
2344 0 0       0 return $value->GetBase64() if $value->DefinedBase64();
2345              
2346 0         0 return $value->GetValue();
2347             }
2348              
2349              
2350             ###############################################################################
2351             #
2352             # RPCParse_Struct - Takes a and returns the hash of values.
2353             #
2354             ###############################################################################
2355             sub RPCParse_Struct
2356             {
2357 0     0 0 0 my $self = shift;
2358 0         0 my($struct) = @_;
2359              
2360 0         0 my %struct;
2361 0         0 foreach my $member ($struct->GetMembers())
2362             {
2363 0         0 $struct{$member->GetName()} = $self->RPCParse_Value($member->GetValue());
2364             }
2365              
2366 0         0 return %struct;
2367             }
2368              
2369              
2370             ###############################################################################
2371             #
2372             # RPCParse_Array - Takes a and returns the hash of values.
2373             #
2374             ###############################################################################
2375             sub RPCParse_Array
2376             {
2377 0     0 0 0 my $self = shift;
2378 0         0 my($array) = @_;
2379              
2380 0         0 my @array;
2381 0         0 foreach my $data ($array->GetDatas())
2382             {
2383 0         0 push(@array,$self->RPCParse_Value($data->GetValue()));
2384             }
2385              
2386 0         0 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 0     0 0 0 my $self = shift;
2402 0         0 my %args;
2403 0         0 $args{mode} = "block";
2404 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2405              
2406 0 0       0 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 0         0 my $iq = $self->_iq();
2412 0 0       0 $iq->SetIQ(to=>delete($args{to})) if exists($args{to});
2413 0         0 $iq->SetIQ(type=>"get");
2414 0         0 my $query = $iq->NewQuery("jabber:iq:search");
2415              
2416 0         0 $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 0 0       0 if ($args{mode} eq "passthru")
2423             {
2424 0         0 my $id = $self->UniqueID();
2425 0         0 $iq->SetIQ(id=>$id);
2426 0         0 $self->Send($iq);
2427 0         0 return $id;
2428             }
2429            
2430 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
2431              
2432 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
2433              
2434 0 0       0 $self->{DEBUG}->Log1("SearchRequest: received(",$iq->GetXML(),")")
2435             if defined($iq);
2436              
2437             #--------------------------------------------------------------------------
2438             # Check if there was an error.
2439             #--------------------------------------------------------------------------
2440 0 0       0 return unless defined($iq);
2441 0 0       0 if ($iq->GetType() eq "error")
2442             {
2443 0         0 $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError());
2444 0         0 $self->{DEBUG}->Log1("SearchRequest: error(",$self->GetErrorCode(),")");
2445 0         0 return;
2446             }
2447              
2448 0         0 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 0         0 $query = $iq->GetQuery();
2454 0         0 $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 0         0 &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 0         0 &ExtractOobs(\%search,$query->GetX("jabber:x:oob"));
2467              
2468 0         0 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 0     0 0 0 my $self = shift;
2482 0         0 my %args;
2483 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2484              
2485             #--------------------------------------------------------------------------
2486             # Create a Net::Jabber::IQ object to send to the server
2487             #--------------------------------------------------------------------------
2488 0         0 my $iq = $self->_iq();
2489 0 0       0 $iq->SetIQ(to=>delete($args{to})) if exists($args{to});
2490 0         0 $iq->SetIQ(type=>"set");
2491 0         0 my $iqSearch = $iq->NewQuery("jabber:iq:search");
2492 0         0 $iqSearch->SetSearch(%args);
2493              
2494             #--------------------------------------------------------------------------
2495             # Send the IQ.
2496             #--------------------------------------------------------------------------
2497 0         0 $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 0     0 0 0 my $self = shift;
2511 0         0 my $to = shift;
2512 0         0 my %args;
2513 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2514              
2515             #--------------------------------------------------------------------------
2516             # Create a Net::Jabber::IQ object to send to the server
2517             #--------------------------------------------------------------------------
2518 0         0 my $iq = $self->_iq();
2519 0 0 0     0 $iq->SetIQ(to=>$to) if (defined($to) && ($to ne ""));
2520 0         0 $iq->SetIQ(type=>"set");
2521 0         0 my $iqSearch = $iq->NewQuery("jabber:iq:search");
2522 0         0 my $xForm = $iqSearch->NewX("jabber:x:data");
2523 0         0 foreach my $var (keys(%args))
2524             {
2525 0 0       0 next if ($args{$var} eq "");
2526 0         0 $xForm->AddField(var=>$var,
2527             value=>$args{$var}
2528             );
2529             }
2530              
2531             #--------------------------------------------------------------------------
2532             # Send the IQ.
2533             #--------------------------------------------------------------------------
2534 0         0 $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 0     0 0 0 my $self = shift;
2547 0         0 my %args;
2548 0         0 $args{mode} = "passthru";
2549 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2550              
2551 0 0       0 $args{waitforid} = 0 unless exists($args{waitforid});
2552 0         0 my $waitforid = delete($args{waitforid});
2553 0 0       0 $args{mode} = "block" if $waitforid;
2554              
2555 0 0       0 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
2556              
2557 0         0 my $iq = $self->_iq();
2558 0 0       0 $iq->SetIQ(to=>delete($args{to})) if exists($args{to});
2559 0         0 $iq->SetIQ(type=>'get',%args);
2560 0         0 my $time = $iq->NewQuery("jabber:iq:time");
2561              
2562 0 0       0 if ($args{mode} eq "passthru")
2563             {
2564 0         0 my $id = $self->UniqueID();
2565 0         0 $iq->SetIQ(id=>$id);
2566 0         0 $self->Send($iq);
2567 0         0 return $id;
2568             }
2569            
2570 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
2571              
2572 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
2573              
2574 0 0       0 return unless defined($iq);
2575              
2576 0         0 my $query = $iq->GetQuery();
2577              
2578 0 0       0 return unless defined($query);
2579              
2580 0         0 my %result;
2581 0         0 $result{utc} = $query->GetUTC();
2582 0         0 $result{display} = $query->GetDisplay();
2583 0         0 $result{tz} = $query->GetTZ();
2584 0         0 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 0     0 0 0 my $self = shift;
2596 0         0 my %args;
2597 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2598              
2599 0         0 my $iq = $self->_iq();
2600 0         0 $iq->SetIQ(to=>delete($args{to}),
2601             type=>'result');
2602 0         0 my $time = $iq->NewQuery("jabber:iq:time");
2603 0         0 $time->SetTime(%args);
2604              
2605 0         0 $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 0     0 0 0 my $self = shift;
2619 0         0 my %args;
2620 0         0 $args{mode} = "passthru";
2621 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2622              
2623 0 0       0 $args{waitforid} = 0 unless exists($args{waitforid});
2624 0         0 my $waitforid = delete($args{waitforid});
2625 0 0       0 $args{mode} = "block" if $waitforid;
2626            
2627 0 0       0 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
2628              
2629 0         0 my $iq = $self->_iq();
2630 0 0       0 $iq->SetIQ(to=>delete($args{to})) if exists($args{to});
2631 0         0 $iq->SetIQ(type=>'get',%args);
2632 0         0 my $version = $iq->NewQuery("jabber:iq:version");
2633              
2634 0 0       0 if ($args{mode} eq "passthru")
2635             {
2636 0         0 my $id = $self->UniqueID();
2637 0         0 $iq->SetIQ(id=>$id);
2638 0         0 $self->Send($iq);
2639 0         0 return $id;
2640             }
2641            
2642 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
2643              
2644 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
2645              
2646 0 0       0 return unless defined($iq);
2647              
2648 0         0 my $query = $iq->GetQuery();
2649              
2650 0 0       0 return unless defined($query);
2651              
2652 0         0 my %result;
2653 0         0 $result{name} = $query->GetName();
2654 0         0 $result{ver} = $query->GetVer();
2655 0         0 $result{os} = $query->GetOS();
2656 0         0 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 0     0 0 0 my $self = shift;
2668 0         0 my %args;
2669 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2670              
2671 0         0 my $iq = $self->_iq();
2672 0         0 $iq->SetIQ(to=>delete($args{to}),
2673             type=>'result');
2674 0         0 my $version = $iq->NewQuery("jabber:iq:version");
2675 0         0 $version->SetVersion(%args);
2676              
2677 0         0 $self->Send($iq);
2678             }
2679              
2680              
2681             ###############################################################################
2682             #
2683             # MUCJoin - join a MUC room
2684             #
2685             ###############################################################################
2686             sub MUCJoin
2687             {
2688 1     1 0 4475 my $self = shift;
2689 1         2 my %args;
2690 1         7 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  4         19  
2691              
2692 1         14 my $presence = $self->_presence();
2693 1         234 $presence->SetTo($args{room}.'@'.$args{server}.'/'.$args{nick});
2694 1         729 my $x = $presence->NewChild("http://jabber.org/protocol/muc");
2695              
2696 1 50 33     22 if (exists($args{password}) && ($args{password} ne ""))
2697             {
2698 0         0 $x->SetMUC(password=>$args{password});
2699             }
2700            
2701 1 50       13 return $presence->GetXML() if exists($args{'__netjabber__:test'});
2702 0           $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 0     0 0   my ($target,@xForms) = @_;
2724              
2725 0           my $tempVar = "1";
2726 0           foreach my $xForm (@xForms) {
2727 0           $target->{instructions} = $xForm->GetInstructions();
2728 0           my $order = 0;
2729 0           foreach my $field ($xForm->GetFields())
2730             {
2731 0 0         $target->{form}->[$order]->{type} = $field->GetType()
2732             if $field->DefinedType();
2733 0 0         $target->{form}->[$order]->{label} = $field->GetLabel()
2734             if $field->DefinedLabel();
2735 0 0         $target->{form}->[$order]->{desc} = $field->GetDesc()
2736             if $field->DefinedDesc();
2737 0 0         $target->{form}->[$order]->{var} = $field->GetVar()
2738             if $field->DefinedVar();
2739 0 0         $target->{form}->[$order]->{var} = "__netjabber__:tempvar:".$tempVar++
2740             if !$field->DefinedVar();
2741 0 0         if ($field->DefinedValue())
2742             {
2743 0 0         if ($field->GetType() eq "list-multi")
2744             {
2745 0           $target->{form}->[$order]->{value} = [ $field->GetValue() ];
2746             }
2747             else
2748             {
2749 0           $target->{form}->[$order]->{value} = ($field->GetValue())[0];
2750             }
2751             }
2752 0           my $count = 0;
2753 0           foreach my $option ($field->GetOptions())
2754             {
2755 0           $target->{form}->[$order]->{options}->[$count]->{value} =
2756             $option->GetValue();
2757 0           $target->{form}->[$order]->{options}->[$count]->{label} =
2758             $option->GetLabel();
2759 0           $count++;
2760             }
2761 0           $order++;
2762             }
2763 0           foreach my $reported ($xForm->GetReported())
2764             {
2765 0           my $order = 0;
2766 0           foreach my $field ($reported->GetFields())
2767             {
2768 0           $target->{reported}->[$order]->{label} = $field->GetLabel();
2769 0           $target->{reported}->[$order]->{var} = $field->GetVar();
2770 0           $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 0     0 0   my ($target,@xOobs) = @_;
2786              
2787 0           foreach my $xOob (@xOobs)
2788             {
2789 0           $target->{oob}->{url} = $xOob->GetURL();
2790 0           $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 0     0 0   my $self = shift;
2812              
2813 0           $self->SUPER::callbackInit();
2814              
2815             $self->SetIQCallBacks("jabber:iq:last"=>
2816             {
2817 0     0     get=>sub{ $self->callbackGetIQLast(@_) },
2818 0     0     result=>sub{ $self->callbackResultIQLast(@_) }
2819             },
2820             "jabber:iq:rpc"=>
2821             {
2822 0     0     set=>sub{ $self->callbackSetIQRPC(@_) },
2823             },
2824             "jabber:iq:time"=>
2825             {
2826 0     0     get=>sub{ $self->callbackGetIQTime(@_) },
2827 0     0     result=>sub{ $self->callbackResultIQTime(@_) }
2828             },
2829             "jabber:iq:version"=>
2830             {
2831 0     0     get=>sub{ $self->callbackGetIQVersion(@_) },
2832 0     0     result=>sub{ $self->callbackResultIQVersion(@_) }
2833             },
2834 0           );
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 0     0 0   my $self = shift;
2847 0           my $sid = shift;
2848 0           my $iq = shift;
2849              
2850 0           my $query = $iq->GetQuery();
2851              
2852 0           my $reply = $iq->Reply(type=>"result");
2853 0           my $replyQuery = $reply->GetQuery();
2854              
2855 0 0         if (!$query->DefinedMethodCall())
2856             {
2857 0           my $methodResponse = $replyQuery->AddMethodResponse();
2858 0           my $struct = $methodResponse->AddFault()->AddValue()->AddStruct();
2859 0           $struct->AddMember(name=>"faultCode")->AddValue(int=>400);
2860 0           $struct->AddMember(name=>"faultString")->AddValue(string=>"Missing methodCall.");
2861 0           $self->Send($reply,1);
2862 0           return;
2863             }
2864              
2865 0 0         if (!$query->GetMethodCall()->DefinedMethodName())
2866             {
2867 0           my $methodResponse = $replyQuery->AddMethodResponse();
2868 0           my $struct = $methodResponse->AddFault()->AddValue()->AddStruct();
2869 0           $struct->AddMember(name=>"faultCode")->AddValue(int=>400);
2870 0           $struct->AddMember(name=>"faultString")->AddValue(string=>"Missing methodName.");
2871 0           $self->Send($reply,1);
2872 0           return;
2873             }
2874              
2875 0           my $methodName = $query->GetMethodCall()->GetMethodName();
2876              
2877 0 0         if (!exists($self->{RPCCB}->{$methodName}))
2878             {
2879 0           my $methodResponse = $replyQuery->AddMethodResponse();
2880 0           my $struct = $methodResponse->AddFault()->AddValue()->AddStruct();
2881 0           $struct->AddMember(name=>"faultCode")->AddValue(int=>404);
2882 0           $struct->AddMember(name=>"faultString")->AddValue(string=>"methodName $methodName not defined.");
2883 0           $self->Send($reply,1);
2884 0           return;
2885             }
2886              
2887 0           my @params = $self->RPCParse($iq);
2888              
2889 0           my @return = &{$self->{RPCCB}->{$methodName}}($iq,$params[1]);
  0            
2890              
2891 0 0         if ($return[0] ne "ok") {
2892 0           my $methodResponse = $replyQuery->AddMethodResponse();
2893 0           my $struct = $methodResponse->AddFault()->AddValue()->AddStruct();
2894 0           $struct->AddMember(name=>"faultCode")->AddValue(int=>$return[1]->{faultCode});
2895 0           $struct->AddMember(name=>"faultString")->AddValue(string=>$return[1]->{faultString});
2896 0           $self->Send($reply,1);
2897 0           return;
2898             }
2899 0           $reply->RemoveQuery();
2900 0           $reply->AddQuery($self->RPCEncode(type=>"methodResponse",
2901             params=>$return[1]));
2902              
2903 0           $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 0     0 0   my $self = shift;
2915 0           my $sid = shift;
2916 0           my $iq = shift;
2917              
2918 0           my $query = $iq->GetQuery();
2919              
2920 0           my $reply = $iq->Reply(type=>"result");
2921 0           my $replyQuery = $reply->GetQuery();
2922 0           $replyQuery->SetTime();
2923              
2924 0           $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 0     0 0   my $self = shift;
2937 0           my $sid = shift;
2938 0           my $iq = shift;
2939              
2940 0           my $fromJID = $iq->GetFrom("jid");
2941 0           my $query = $iq->GetQuery();
2942              
2943 0           my $body = "UTC: ".$query->GetUTC()."\n";
2944 0           $body .= "Time: ".$query->GetDisplay()."\n";
2945 0           $body .= "Timezone: ".$query->GetTZ()."\n";
2946            
2947 0           my $message = $self->_message();
2948 0           $message->SetMessage(to=>$iq->GetTo(),
2949             from=>$iq->GetFrom(),
2950             subject=>"CTCP: Time",
2951             body=>$body);
2952              
2953              
2954 0           $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 0     0 0   my $self = shift;
2967 0           my $sid = shift;
2968 0           my $iq = shift;
2969              
2970 0           my $query = $iq->GetQuery();
2971              
2972 0           my $reply = $iq->Reply(type=>"result");
2973 0           my $replyQuery = $reply->GetQuery();
2974 0           $replyQuery->SetVersion(name=>$self->{INFO}->{name},
2975             ver=>$self->{INFO}->{version},
2976             os=>"");
2977              
2978 0           $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 0     0 0   my $self = shift;
2991 0           my $sid = shift;
2992 0           my $iq = shift;
2993              
2994 0           my $query = $iq->GetQuery();
2995              
2996 0           my $body = "Program: ".$query->GetName()."\n";
2997 0           $body .= "Version: ".$query->GetVer()."\n";
2998 0           $body .= "OS: ".$query->GetOS()."\n";
2999              
3000 0           my $message = $self->_message();
3001 0           $message->SetMessage(to=>$iq->GetTo(),
3002             from=>$iq->GetFrom(),
3003             subject=>"CTCP: Version",
3004             body=>$body);
3005              
3006 0           $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 0     0 0   my $self = shift;
3018 0           my $sid = shift;
3019 0           my $iq = shift;
3020              
3021 0           my $query = $iq->GetQuery();
3022 0           my $reply = $iq->Reply(type=>"result");
3023 0           my $replyQuery = $reply->GetQuery();
3024 0           $replyQuery->SetLast(seconds=>$self->LastActivity());
3025              
3026 0           $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 0     0 0   my $self = shift;
3039 0           my $sid = shift;
3040 0           my $iq = shift;
3041              
3042 0           my $fromJID = $iq->GetFrom("jid");
3043 0           my $query = $iq->GetQuery();
3044 0           my $seconds = $query->GetSeconds();
3045              
3046 0           my $lastTime = &Net::Jabber::GetTimeStamp("local",(time - $seconds),"long");
3047              
3048 0           my $elapsedTime = &Net::Jabber::GetHumanTime($seconds);
3049              
3050 0           my $body;
3051 0 0         if ($fromJID->GetUserID() eq "")
    0          
3052             {
3053 0           $body = "Start Time: $lastTime\n";
3054 0           $body .= "Up time: $elapsedTime\n";
3055 0 0         $body .= "Message: ".$query->GetMessage()."\n"
3056             if ($query->DefinedMessage());
3057             }
3058             elsif ($fromJID->GetResource() eq "")
3059             {
3060 0           $body = "Logout Time: $lastTime\n";
3061 0           $body .= "Elapsed time: $elapsedTime\n";
3062 0 0         $body .= "Message: ".$query->GetMessage()."\n"
3063             if ($query->DefinedMessage());
3064             }
3065             else
3066             {
3067 0           $body = "Last activity: $lastTime\n";
3068 0           $body .= "Elapsed time: $elapsedTime\n";
3069 0 0         $body .= "Message: ".$query->GetMessage()."\n"
3070             if ($query->DefinedMessage());
3071             }
3072            
3073 0           my $message = $self->_message();
3074 0           $message->SetMessage(from=>$iq->GetFrom(),
3075             subject=>"Last Activity",
3076             body=>$body);
3077              
3078 0           $self->CallBack($sid,$message);
3079             }
3080              
3081              
3082             1;