source: perl/lib/Net/Jabber/Protocol.pm @ cb54527

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