source: perl/lib/Net/XMPP/Protocol.pm @ d524c83

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since d524c83 was 3405394, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 18 years ago
Protocol.pm: allow IQ Auth to take a password callback like SASL's.
  • Property mode set to 100644
File size: 109.0 KB
RevLine 
[0ff8d110]1##############################################################################
2#
3#  This library is free software; you can redistribute it and/or
4#  modify it under the terms of the GNU Library General Public
5#  License as published by the Free Software Foundation; either
6#  version 2 of the License, or (at your option) any later version.
7#
8#  This library is distributed in the hope that it will be useful,
9#  but WITHOUT ANY WARRANTY; without even the implied warranty of
10#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11#  Library General Public License for more details.
12#
13#  You should have received a copy of the GNU Library General Public
14#  License along with this library; if not, write to the
15#  Free Software Foundation, Inc., 59 Temple Place - Suite 330,
16#  Boston, MA  02111-1307, USA.
17#
18#  Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
19#
20##############################################################################
21
22package Net::XMPP::Protocol;
23
24=head1 NAME
25
26Net::XMPP::Protocol - XMPP Protocol Module
27
28=head1 SYNOPSIS
29
30  Net::XMPP::Protocol is a module that provides a developer easy
31  access to the XMPP Instant Messaging protocol.  It provides high
32  level functions to the Net::XMPP Client object.  These functions are
33  inherited by that modules.
34
35=head1 DESCRIPTION
36
37  Protocol.pm seeks to provide enough high level APIs and automation of
38  the low level APIs that writing a XMPP Client in Perl is trivial.  For
39  those that wish to work with the low level you can do that too, but
40  those functions are covered in the documentation for each module.
41
42  Net::XMPP::Protocol provides functions to login, send and receive
43  messages, set personal information, create a new user account, manage
44  the roster, and disconnect.  You can use all or none of the functions,
45  there is no requirement.
46
47  For more information on how the details for how Net::XMPP is written
48  please see the help for Net::XMPP itself.
49
50  For more information on writing a Client see Net::XMPP::Client.
51
52=head2 Modes
53
54  Several of the functions take a mode argument that let you specify how
55  the function should behave:
56
57    block - send the packet with an ID, and then block until an answer
58            comes back.  You can optionally specify a timeout so that
59            you do not block forever.
60           
61    nonblock - send the packet with an ID, but then return that id and
62               control to the master program.  Net::XMPP is still
63               tracking this packet, so you must use the CheckID function
64               to tell when it comes in.  (This might not be very
65               useful...)
66
67    passthru - send the packet with an ID, but do NOT register it with
68               Net::XMPP, then return the ID.  This is useful when
69               combined with the XPath function because you can register
70               a one shot function tied to the id you get back.
71               
72
73=head2 Basic Functions
74
75    use Net::XMPP qw( Client );
76    $Con = new Net::XMPP::Client();                  # From
77    $status = $Con->Connect(hostname=>"jabber.org"); # Net::XMPP::Client
78
79    $Con->SetCallBacks(send=>\&sendCallBack,
80                       receive=>\&receiveCallBack,
81                       message=>\&messageCallBack,
82                       iq=>\&handleTheIQTag);
83
84    $Con->SetMessageCallBacks(normal=>\&messageNormalCB,
85                              chat=>\&messageChatCB);
86
87    $Con->SetPresenceCallBacks(available=>\&presenceAvailableCB,
88                               unavailable=>\&presenceUnavailableCB);
89
90    $Con->SetIQCallBacks("custom-namespace"=>
91                                             {
92                                                 get=>\&iqCustomGetCB,
93                                                 set=>\&iqCustomSetCB,
94                                                 result=>\&iqCustomResultCB,
95                                             },
96                                             etc...
97                                            );
98
99    $Con->SetXPathCallBacks("/message[@type='chat']"=>&messageChatCB,
100                            "/message[@type='chat']"=>&otherMessageChatCB,
101                            ...
102                           );
103
104    $Con->RemoveXPathCallBacks("/message[@type='chat']"=>&otherMessageChatCB);
105
106    $error = $Con->GetErrorCode();
107    $Con->SetErrorCode("Timeout limit reached");
108
109    $status = $Con->Process();
110    $status = $Con->Process(5);
111
112    $Con->Send($object);
113    $Con->Send("<tag>XML</tag>");
114
115    $Con->Send($object,1);
116    $Con->Send("<tag>XML</tag>",1);
117
118    $Con->Disconnect();
119
120=head2 ID Functions
121
122    $id         = $Con->SendWithID($sendObj);
123    $id         = $Con->SendWithID("<tag>XML</tag>");
124    $receiveObj = $Con->SendAndReceiveWithID($sendObj);
125    $receiveObj = $Con->SendAndReceiveWithID($sendObj,
126                                             10);
127    $receiveObj = $Con->SendAndReceiveWithID("<tag>XML</tag>");
128    $receiveObj = $Con->SendAndReceiveWithID("<tag>XML</tag>",
129                                             5);
130    $yesno      = $Con->ReceivedID($id);
131    $receiveObj = $Con->GetID($id);
132    $receiveObj = $Con->WaitForID($id);
133    $receiveObj = $Con->WaitForID($id,
134                                  20);
135
136=head2 Namespace Functions
137
138    $Con->AddNamespace(ns=>"foo:bar",
139                       tag=>"myfoo",
140                       xpath=>{Foo=>{ path=> "foo/text()" },
141                               Bar=>{ path=> "bar/text()" },
142                               FooBar=>{ type=> "master" },
143                              }
144                      );
145
146=head2 Message Functions
147
148    $Con->MessageSend(to=>"bob@jabber.org",
149                      subject=>"Lunch",
150                      body=>"Let's go grab some...\n",
151                      thread=>"ABC123",
152                      priority=>10);
153
154=head2 Presence Functions
155
156    $Con->PresenceSend();
157    $Con->PresenceSend(type=>"unavailable");
158    $Con->PresenceSend(show=>"away");
159    $Con->PresenceSend(signature=>...signature...);
160
161=head2 Subscription Functions
162
163    $Con->Subscription(type=>"subscribe",
164                       to=>"bob@jabber.org");
165
166    $Con->Subscription(type=>"unsubscribe",
167                       to=>"bob@jabber.org");
168
169    $Con->Subscription(type=>"subscribed",
170                       to=>"bob@jabber.org");
171
172    $Con->Subscription(type=>"unsubscribed",
173                       to=>"bob@jabber.org");
174
175=head2 Presence DB Functions
176
177    $Con->PresenceDB();
178
179    $Con->PresenceDBParse(Net::XMPP::Presence);
180
181    $Con->PresenceDBDelete("bob\@jabber.org");
182    $Con->PresenceDBDelete(Net::XMPP::JID);
183
184    $Con->PresenceDBClear();
185
186    $presence  = $Con->PresenceDBQuery("bob\@jabber.org");
187    $presence  = $Con->PresenceDBQuery(Net::XMPP::JID);
188
189    @resources = $Con->PresenceDBResources("bob\@jabber.org");
190    @resources = $Con->PresenceDBResources(Net::XMPP::JID);
191
192=head2 IQ  Functions
193
194=head2 Auth Functions
195
196    @result = $Con->AuthSend();
197    @result = $Con->AuthSend(username=>"bob",
198                             password=>"bobrulez",
199                             resource=>"Bob");
200
201=head2 Register Functions
202
203    %hash   = $Con->RegisterRequest();
204    %hash   = $Con->RegisterRequest(to=>"transport.jabber.org");
205    %hash   = $Con->RegisterRequest(to=>"transport.jabber.org",
206                                    timeout=>10);
207
208    @result = $Con->RegisterSend(to=>"somewhere",
209                                 username=>"newuser",
210                                 resource=>"New User",
211                                 password=>"imanewbie",
212                                 email=>"newguy@new.com",
213                                 key=>"some key");
214
215=head2 Roster Functions
216
217    $Roster = $Con->Roster();
218
219    %roster = $Con->RosterParse($iq);
220    %roster = $Con->RosterGet();
221    $Con->RosterRequest();
222    $Con->RosterAdd(jid=>"bob\@jabber.org",
223                    name=>"Bob");
224    $Con->RosterRemove(jid=>"bob@jabber.org");
225
226=head2 Roster DB Functions
227
228    $Con->RosterDB();
229
230    $Con->RosterDBParse(Net::XMPP::IQ);
231
232    $Con->RosterDBAdd("bob\@jabber.org",
233                      name=>"Bob",
234                      groups=>["foo"]
235                     );
236   
237    $Con->RosterDBRemove("bob\@jabber.org");
238    $Con->RosterDBRemove(Net::XMPP::JID);
239
240    $Con->RosterDBClear();
241
242    if ($Con->RosterDBExists("bob\@jabber.org")) { ...
243    if ($Con->RosterDBExists(Net::XMPP::JID)) { ...
244
245    @jids = $Con->RosterDBJIDs();
246   
247    if ($Con->RosterDBGroupExists("foo")) { ...
248
249    @groups = $Con->RosterDBGroups();
250   
251    @jids = $Con->RosterDBGroupJIDs("foo");
252   
253    @jids = $Con->RosterDBNonGroupJIDs();
254   
255    %hash = $Con->RosterDBQuery("bob\@jabber.org");
256    %hash = $Con->RosterDBQuery(Net::XMPP::JID);
257
258    $value = $Con->RosterDBQuery("bob\@jabber.org","name");
259    $value = $Con->RosterDBQuery(Net::XMPP::JID,"groups");
260
261
262=head1 METHODS
263
264=head2 Basic Functions
265
266    GetErrorCode() - returns a string that will hopefully contain some
267                     useful information about why a function returned
268                     an undef to you.
269
270    SetErrorCode(string) - set a useful error message before you return
271                           an undef to the caller.
272
273    SetCallBacks(message=>function,  - sets the callback functions for
274                 presence=>function,   the top level tags listed.  The
275                 iq=>function,         available tags to look for are
276                 send=>function,       <message/>, <presence/>, and
277                 receive=>function,    <iq/>.  If a packet is received
278                 update=>function)     with an ID which is found in the
279                                       registerd ID list (see RegisterID
280                                       below) then it is not sent to
281                                       these functions, instead it
282                                       is inserted into a LIST and can
283                                       be retrieved by some functions
284                                       we will mention later.
285
286                                       send and receive are used to
287                                       log what XML is sent and received.
288                                       update is used as way to update
289                                       your program while waiting for
290                                       a packet with an ID to be
291                                       returned (useful for GUI apps).
292
293                                       A major change that came with
294                                       the last release is that the
295                                       session id is passed to the
296                                       callback as the first argument.
297                                       This was done to facilitate
298                                       the Server module.
299
300                                       The next argument depends on
301                                       which callback you are talking
302                                       about.  message, presence, and iq
303                                       all get passed in Net::XMPP
304                                       objects that match those types.
305                                       send and receive get passed in
306                                       strings.  update gets passed
307                                       nothing, not even the session id.
308
309                                       If you set the function to undef,
310                                       then the callback is removed from
311                                       the list.
312
313    SetPresenceCallBacks(type=>function - sets the callback functions for
314                         etc...)          the specified presence type.
315                                          The function takes types as the
316                                          main key, and lets you specify
317                                          a function for each type of
318                                          packet you can get.
319                                            "available"
320                                            "unavailable"
321                                            "subscribe"
322                                            "unsubscribe"
323                                            "subscribed"
324                                            "unsubscribed"
325                                            "probe"
326                                            "error"
327                                          When it gets a <presence/>
328                                          packet it checks the type=''
329                                          for a defined callback.  If
330                                          there is one then it calls the
331                                          function with two arguments:
332                                            the session ID, and the
333                                            Net::XMPP::Presence object.
334
335                                          If you set the function to
336                                          undef, then the callback is
337                                          removed from the list.
338
339                        NOTE: If you use this, which is a cleaner method,
340                              then you must *NOT* specify a callback for
341                              presence in the SetCallBacks function.
342 
343                                          Net::XMPP defines a few default
344                                          callbacks for various types:
345 
346                                          "subscribe" -
347                                            replies with subscribed
348                                         
349                                          "unsubscribe" -
350                                            replies with unsubscribed
351                                         
352                                          "subscribed" -
353                                            replies with subscribed
354                                         
355                                          "unsubscribed" -
356                                            replies with unsubscribed
357                                         
358
359    SetMessageCallBacks(type=>function, - sets the callback functions for
360                        etc...)           the specified message type. The
361                                          function takes types as the
362                                          main key, and lets you specify
363                                          a function for each type of
364                                          packet you can get.
365                                           "normal"
366                                           "chat"
367                                           "groupchat"
368                                           "headline"
369                                           "error"
370                                         When it gets a <message/> packet
371                                         it checks the type='' for a
372                                         defined callback. If there is
373                                         one then it calls the function
374                                         with two arguments:
375                                           the session ID, and the
376                                           Net::XMPP::Message object.
377
378                                         If you set the function to
379                                         undef, then the callback is
380                                         removed from the list.
381
382                       NOTE: If you use this, which is a cleaner method,
383                             then you must *NOT* specify a callback for
384                             message in the SetCallBacks function.
385
386
387    SetIQCallBacks(namespace=>{      - sets the callback functions for
388                     get=>function,    the specified namespace. The
389                     set=>function,    function takes namespaces as the
390                     result=>function  main key, and lets you specify a
391                   },                  function for each type of packet
392                   etc...)             you can get.
393                                         "get"
394                                         "set"
395                                         "result"
396                                       When it gets an <iq/> packet it
397                                       checks the type='' and the
398                                       xmlns='' for a defined callback.
399                                       If there is one then it calls
400                                       the function with two arguments:
401                                       the session ID, and the
402                                       Net::XMPP::xxxx object.
403
404                                       If you set the function to undef,
405                                       then the callback is removed from
406                                       the list.
407
408                       NOTE: If you use this, which is a cleaner method,
409                             then you must *NOT* specify a callback for
410                             iq in the SetCallBacks function.
411
412    SetXPathCallBacks(xpath=>function, - registers a callback function
413                        etc...)          for each xpath specified.  If
414                                         Net::XMPP matches the xpath,
415                                         then it calls the function with
416                                         two arguments:
417                                           the session ID, and the
418                                           Net::XMPP::Message object.
419
420                                         Xpaths are rooted at each
421                                         packet:
422                                           /message[@type="chat"]
423                                           /iq/*[xmlns="jabber:iq:roster"][1]
424                                           ...
425
426    RemoveXPathCallBacks(xpath=>function, - unregisters a callback
427                        etc...)             function for each xpath
428                                            specified.
429
430    Process(integer) - takes the timeout period as an argument.  If no
431                       timeout is listed then the function blocks until
432                       a packet is received.  Otherwise it waits that
433                       number of seconds and then exits so your program
434                       can continue doing useful things.  NOTE: This is
435                       important for GUIs.  You need to leave time to
436                       process GUI commands even if you are waiting for
437                       packets.  The following are the possible return
438                       values, and what they mean:
439
440                           1   - Status ok, data received.
441                           0   - Status ok, no data received.
442                         undef - Status not ok, stop processing.
443                       
444                       IMPORTANT: You need to check the output of every
445                       Process.  If you get an undef then the connection
446                       died and you should behave accordingly.
447
448    Send(object,         - takes either a Net::XMPP::xxxxx object or
449         ignoreActivity)   an XML string as an argument and sends it to
450    Send(string,           the server.  If you set ignoreActivty to 1,
451         ignoreActivity)   then the XML::Stream module will not record
452                           this packet as couting towards user activity.
453=head2 ID Functions
454
455    SendWithID(object) - takes either a Net::XMPP::xxxxx object or an
456    SendWithID(string)   XML string as an argument, adds the next
457                         available ID number and sends that packet to
458                         the server.  Returns the ID number assigned.
459
460    SendAndReceiveWithID(object,  - uses SendWithID and WaitForID to
461                         timeout)   provide a complete way to send and
462    SendAndReceiveWithID(string,    receive packets with IDs.  Can take
463                         timeout)   either a Net::XMPP::xxxxx object
464                                    or an XML string.  Returns the
465                                    proper Net::XMPP::xxxxx object
466                                    based on the type of packet
467                                    received.  The timeout is passed
468                                    on to WaitForID, see that function
469                                    for how the timeout works.
470
471    ReceivedID(integer) - returns 1 if a packet has been received with
472                          specified ID, 0 otherwise.
473
474    GetID(integer) - returns the proper Net::XMPP::xxxxx object based
475                     on the type of packet received with the specified
476                     ID.  If the ID has been received the GetID returns
477                     0.
478
479    WaitForID(integer, - blocks until a packet with the ID is received.
480              timeout)   Returns the proper Net::XMPP::xxxxx object
481                         based on the type of packet received.  If the
482                         timeout limit is reached then if the packet
483                         does come in, it will be discarded.
484
485
486    NOTE:  Only <iq/> officially support ids, so sending a <message/>, or
487           <presence/> with an id is a risk.  The server will ignore the
488           id tag and pass it through, so both clients must support the
489           id tag for these functions to be useful.
490
491=head2 Namespace Functions
492
493    AddNamespace(ns=>string,  - This function is very complex.
494                 tag=>string,   It is a little too complex to
495                 xpath=>hash)   discuss within the confines of
496                                this small paragraph.  Please
497                                refer to the man page for
498                                Net::XMPP::Namespaces for the
499                                full documentation on this
500                                subject.
501
502=head2 Message Functions
503
504    MessageSend(hash) - takes the hash and passes it to SetMessage in
505                        Net::XMPP::Message (refer there for valid
506                        settings).  Then it sends the message to the
507                        server.
508
509=head2 Presence Functions
510
511    PresenceSend()                  - no arguments will send an empty
512    PresenceSend(hash,                Presence to the server to tell it
513                 signature=>string)   that you are available.  If you
514                                      provide a hash, then it will pass
515                                      that hash to the SetPresence()
516                                      function as defined in the
517                                      Net::XMPP::Presence module.
518                                      Optionally, you can specify a
519                                      signature and a jabber:x:signed
520                                      will be placed in the <presence/>.
521
522=head2 Subscription Functions
523
524    Subscription(hash) - taks the hash and passes it to SetPresence in
525                         Net::XMPP::Presence (refer there for valid
526                         settings).  Then it sends the subscription to
527                         server.
528
529                         The valid types of subscription are:
530
531                           subscribe    - subscribe to JID's presence
532                           unsubscribe  - unsubscribe from JID's presence
533                           subscribed   - response to a subscribe
534                           unsubscribed - response to an unsubscribe
535
536=head2 Presence DB Functions
537
538    PresenceDB() - Tell the object to initialize the callbacks to
539                   automatically populate the Presence DB.
540
541    PresenceDBParse(Net::XMPP::Presence) - for every presence that you
542                                             receive pass the Presence
543                                             object to the DB so that
544                                             it can track the resources
545                                             and priorities for you.
546                                             Returns either the presence
547                                             passed in, if it not able
548                                             to parsed for the DB, or the
549                                             current presence as found by
550                                             the PresenceDBQuery
551                                             function.
552
553    PresenceDBDelete(string|Net::XMPP::JID) - delete thes JID entry
554                                                from the DB.
555
556    PresenceDBClear() - delete all entries in the database.
557
558    PresenceDBQuery(string|Net::XMPP::JID) - returns the NJ::Presence
559                                               that was last received for
560                                               the highest priority of
561                                               this JID.  You can pass
562                                               it a string or a NJ::JID
563                                               object.
564
565    PresenceDBResources(string|Net::XMPP::JID) - returns an array of
566                                                   resources in order
567                                                   from highest priority
568                                                   to lowest.
569
570=head2 IQ Functions
571
572=head2 Auth Functions
573
574    AuthSend(username=>string, - takes all of the information and
575             password=>string,   builds a Net::XMPP::IQ::Auth packet.
576             resource=>string)   It then sends that packet to the
577                                 server with an ID and waits for that
578                                 ID to return.  Then it looks in
579                                 resulting packet and determines if
580                                 authentication was successful for not.
581                                 The array returned from AuthSend looks
582                                 like this:
583                                   [ type , message ]
584                                 If type is "ok" then authentication
585                                 was successful, otherwise message
586                                 contains a little more detail about the
587                                 error.
588
589=head2 IQ::Register Functions
590
591    RegisterRequest(to=>string,  - send an <iq/> request to the specified
592                    timeout=>int)  server/transport, if not specified it
593    RegisterRequest()              sends to the current active server.
594                                   The function returns a hash that
595                                   contains the required fields.   Here
596                                   is an example of the hash:
597
598                                   $hash{fields}    - The raw fields from
599                                                      the iq:register.
600                                                      To be used if there
601                                                      is no x:data in the
602                                                      packet.
603                                   $hash{instructions} - How to fill out
604                                                         the form.
605                                   $hash{form}   - The new dynamic forms.
606
607                                   In $hash{form}, the fields that are
608                                   present are the required fields the
609                                   server needs.
610
611    RegisterSend(hash) - takes the contents of the hash and passes it
612                         to the SetRegister function in the module
613                         Net::XMPP::Query jabber:iq:register namespace.
614                         This function returns an array that looks like
615                         this:
616
617                            [ type , message ]
618
619                         If type is "ok" then registration was
620                         successful, otherwise message contains a
621                         little more detail about the error.
622
623=head2 Roster Functions
624
625    Roster() - returns a Net::XMPP::Roster object.  This will automatically
626               intercept all of the roster and presence packets sent from
627               the server and give you an accurate Roster.  For more
628               information please read the man page for Net::XMPP::Roster.
629
630    RosterParse(IQ object) - returns a hash that contains the roster
631                             parsed into the following data structure:
632
633                  $roster{'bob@jabber.org'}->{name}
634                                      - Name you stored in the roster
635
636                  $roster{'bob@jabber.org'}->{subscription}
637                                      - Subscription status
638                                        (to, from, both, none)
639
640                  $roster{'bob@jabber.org'}->{ask}
641                                      - The ask status from this user
642                                        (subscribe, unsubscribe)
643
644                  $roster{'bob@jabber.org'}->{groups}
645                                      - Array of groups that
646                                        bob@jabber.org is in
647
648    RosterGet() - sends an empty Net::XMPP::IQ::Roster tag to the
649                  server so the server will send the Roster to the
650                  client.  Returns the above hash from RosterParse.
651
652    RosterRequest() - sends an empty Net::XMPP::IQ::Roster tag to the
653                      server so the server will send the Roster to the
654                      client.
655
656    RosterAdd(hash) - sends a packet asking that the jid be
657                      added to the roster.  The hash format
658                      is defined in the SetItem function
659                      in the Net::XMPP::Query jabber:iq:roster
660                      namespace.
661
662    RosterRemove(hash) - sends a packet asking that the jid be
663                         removed from the roster.  The hash
664                         format is defined in the SetItem function
665                         in the Net::XMPP::Query jabber:iq:roster
666                         namespace.
667
668=head2 Roster DB Functions
669
670    RosterDB() - Tell the object to initialize the callbacks to
671                 automatically populate the Roster DB.  If you do this,
672                 then make sure that you call RosterRequest() instead of
673                 RosterGet() so that the callbacks can catch it and
674                 parse it.
675
676    RosterDBParse(IQ object) - If you want to manually control the
677                               database, then you can pass in all iq
678                               packets with jabber:iq:roster queries to
679                               this function.
680
681    RosterDBAdd(jid,hash) - Add a new JID into the roster DB.  The JID
682                            is either a string, or a Net::XMPP::JID
683                            object.  The hash must be the same format as
684                            the has returned by RosterParse above, and
685                            is the actual hash, not a reference.
686   
687    RosterDBRemove(jid) - Remove a JID from the roster DB. The JID is
688                          either a string, or a Net::XMPP::JID object.
689
690    RosterDBClear() - Remove all JIDs from the roster DB.
691
692    RosterDBExists(jid) - return 1 if the JID exists in the roster DB,
693                          undef otherwise.  The JID is either a string,
694                          or a Net::XMPP::JID object.
695
696    RosterDBJIDs() - returns a list of Net::XMPP::JID objects that
697                     represents all of the JIDs in the DB.
698   
699    RosterDBGroups() - returns the complete list of roster groups in the
700                       roster.
701   
702    RosterDBGroupExists(group) - return 1 if the group is a group in the
703                                 roster DB, undef otherwise.
704
705    RosterDBGroupJIDs(group) - returns a list of Net::XMPP::JID objects
706                               that represents all of the JIDs in the
707                               specified roster group.
708   
709    RosterDBNonGroupJIDs() - returns a list of Net::XMPP::JID objects
710                             that represents all of the JIDs not in a
711                             roster group.
712
713    RosterDBQuery(jid) - returns a hash containing the data from the
714                         roster DB for the specified JID.  The JID is
715                         either a string, or a Net::XMPP::JID object.
716                         The hash format the same as in RosterParse
717                         above.
718
719    RosterDBQuery(jid,key) - returns the entry from the above hash for
720                             the given key.  The available keys are:
721                               name, ask, subsrcription and groups
722                             The JID is either a string, or a
723                             Net::XMPP::JID object.
724
725
726=head1 AUTHOR
727
728Ryan Eatmon
729
730=head1 COPYRIGHT
731
732This module is free software; you can redistribute it and/or modify
733it under the same terms as Perl itself.
734
735=cut
736
737use Net::XMPP::Roster;
738use Net::XMPP::PrivacyLists;
739use strict;
740use Carp;
741use vars qw( %XMLNS %NEWOBJECT $SASL_CALLBACK $TLS_CALLBACK );
742
743##############################################################################
744# Define the namespaces in an easy/constant manner.
745#-----------------------------------------------------------------------------
746# 1.0
747#-----------------------------------------------------------------------------
748$XMLNS{'xmppstreams'}   = "urn:ietf:params:xml:ns:xmpp-streams";
749$XMLNS{'xmpp-bind'}     = "urn:ietf:params:xml:ns:xmpp-bind";
750$XMLNS{'xmpp-sasl'}     = "urn:ietf:params:xml:ns:xmpp-sasl";
751$XMLNS{'xmpp-session'}  = "urn:ietf:params:xml:ns:xmpp-session";
752$XMLNS{'xmpp-tls'}      = "urn:ietf:params:xml:ns:xmpp-tls";
753##############################################################################
754
755##############################################################################
756# BuildObject takes a root tag and builds the correct object.  NEWOBJECT is
757# the table that maps tag to package.  Override these, or provide new ones.
758#-----------------------------------------------------------------------------
759$NEWOBJECT{'iq'}       = "Net::XMPP::IQ";
760$NEWOBJECT{'message'}  = "Net::XMPP::Message";
761$NEWOBJECT{'presence'} = "Net::XMPP::Presence";
762$NEWOBJECT{'jid'}      = "Net::XMPP::JID";
763##############################################################################
764
765sub _message  { shift; my $o; eval "\$o = new $NEWOBJECT{'message'}(\@_);"; return $o;  }
766sub _presence { shift; my $o; eval "\$o = new $NEWOBJECT{'presence'}(\@_);"; return $o; }
767sub _iq       { shift; my $o; eval "\$o = new $NEWOBJECT{'iq'}(\@_);"; return $o;       }
768sub _jid      { shift; my $o; eval "\$o = new $NEWOBJECT{'jid'}(\@_);"; return $o;      }
769
770###############################################################################
771#+-----------------------------------------------------------------------------
772#|
773#| Base API
774#|
775#+-----------------------------------------------------------------------------
776###############################################################################
777
778###############################################################################
779#
780# GetErrorCode - if you are returned an undef, you can call this function
781#                and hopefully learn more information about the problem.
782#
783###############################################################################
784sub GetErrorCode
785{
786    my $self = shift;
787    return ((exists($self->{ERRORCODE}) && ($self->{ERRORCODE} ne "")) ?
788            $self->{ERRORCODE} :
789            $!
790           );
791}
792
793
794###############################################################################
795#
796# SetErrorCode - sets the error code so that the caller can find out more
797#                information about the problem
798#
799###############################################################################
800sub SetErrorCode
801{
802    my $self = shift;
803    my ($errorcode) = @_;
804    $self->{ERRORCODE} = $errorcode;
805}
806
807
808###############################################################################
809#
810# CallBack - Central callback function.  If a packet comes back with an ID
811#            and the tag and ID have been registered then the packet is not
812#            returned as normal, instead it is inserted in the LIST and
813#            stored until the user wants to fetch it.  If the tag and ID
814#            are not registered the function checks if a callback exists
815#            for this tag, if it does then that callback is called,
816#            otherwise the function drops the packet since it does not know
817#            how to handle it.
818#
819###############################################################################
820sub CallBack
821{
822    my $self = shift;
823    my $sid = shift;
824    my ($object) = @_;
825
826    my $tag;
827    my $id;
828    my $tree;
829   
830    if (ref($object) !~ /^Net::XMPP/)
831    {
832        if ($self->{DEBUG}->GetLevel() >= 1 || exists($self->{CB}->{receive}))
833        {
834            my $xml = $object->GetXML();
835            $self->{DEBUG}->Log1("CallBack: sid($sid) received($xml)");
836            &{$self->{CB}->{receive}}($sid,$xml) if exists($self->{CB}->{receive});
837        }
838
839        $tag = $object->get_tag();
840        $id = "";
841        $id = $object->get_attrib("id")
842            if defined($object->get_attrib("id"));
843        $tree = $object;
844    }
845    else
846    {
847        $tag = $object->GetTag();
848        $id = $object->GetID();
849        $tree = $object->GetTree();
850    }
851
852    $self->{DEBUG}->Log1("CallBack: tag($tag)");
853    $self->{DEBUG}->Log1("CallBack: id($id)") if ($id ne "");
854
855    my $pass = 1;
856    $pass = 0
857        if (!exists($self->{CB}->{$tag}) &&
858            !exists($self->{CB}->{XPath}) &&
859            !exists($self->{CB}->{DirectXPath}) &&
860            !$self->CheckID($tag,$id)
861           );
862
863    if ($pass)
864    {
865        $self->{DEBUG}->Log1("CallBack: we either want it or were waiting for it.");
866
867        if (exists($self->{CB}->{DirectXPath}))
868        {
869            $self->{DEBUG}->Log1("CallBack: check directxpath");
870
871            my $direct_pass = 0;
872
873            foreach my $xpath (keys(%{$self->{CB}->{DirectXPath}}))
874            {
875                $self->{DEBUG}->Log1("CallBack: check directxpath($xpath)");
876                if ($object->XPathCheck($xpath))
877                {
878                    foreach my $func (keys(%{$self->{CB}->{DirectXPath}->{$xpath}}))
879                    {
880                        $self->{DEBUG}->Log1("CallBack: goto directxpath($xpath) function($func)");
881                        &{$self->{CB}->{DirectXPath}->{$xpath}->{$func}}($sid,$object);
882                        $direct_pass = 1;
883                    }
884                }
885            }
886           
887            return if $direct_pass;
888        }
889
890        my $NJObject;
891        if (ref($object) !~ /^Net::XMPP/)
892        {
893            $NJObject = $self->BuildObject($tag,$object);
894        }
895        else
896        {
897            $NJObject = $object;
898        }
899
900        if ($NJObject == -1)
901        {
902            $self->{DEBUG}->Log1("CallBack: DANGER!! DANGER!! We didn't build a packet!  We're all gonna die!!");
903        }
904        else
905        {
906            if ($self->CheckID($tag,$id))
907            {
908                $self->{DEBUG}->Log1("CallBack: found registry entry: tag($tag) id($id)");
909                $self->DeregisterID($tag,$id);
910                if ($self->TimedOutID($id))
911                {
912                    $self->{DEBUG}->Log1("CallBack: dropping packet due to timeout");
913                    $self->CleanID($id);
914                }
915                else
916                {
917                    $self->{DEBUG}->Log1("CallBack: they still want it... we still got it...");
918                    $self->GotID($id,$NJObject);
919                }
920            }
921            else
922            {
923                $self->{DEBUG}->Log1("CallBack: no registry entry");
924
925                if (exists($self->{CB}->{XPath}))
926                {
927                    $self->{DEBUG}->Log1("CallBack: check xpath");
928
929                    foreach my $xpath (keys(%{$self->{CB}->{XPath}}))
930                    {
931                        if ($NJObject->GetTree()->XPathCheck($xpath))
932                        {
933                            foreach my $func (keys(%{$self->{CB}->{XPath}->{$xpath}}))
934                            {
935                                $self->{DEBUG}->Log1("CallBack: goto xpath($xpath) function($func)");
936                                &{$self->{CB}->{XPath}->{$xpath}->{$func}}($sid,$NJObject);
937                            }
938                        }
939                    }
940                }
941
942                if (exists($self->{CB}->{$tag}))
943                {
944                    $self->{DEBUG}->Log1("CallBack: goto user function($self->{CB}->{$tag})");
945                    &{$self->{CB}->{$tag}}($sid,$NJObject);
946                }
947                else
948                {
949                    $self->{DEBUG}->Log1("CallBack: no defined function.  Dropping packet.");
950                }
951            }
952        }
953    }
954    else
955    {
956        $self->{DEBUG}->Log1("CallBack: a packet that no one wants... how sad. =(");
957    }
958}
959
960
961###############################################################################
962#
963# BuildObject - turn the packet into an object.
964#
965###############################################################################
966sub BuildObject
967{
968    my $self = shift;
969    my ($tag,$tree) = @_;
970
971    my $obj = -1;
972
973    if (exists($NEWOBJECT{$tag}))
974    {
975        $self->{DEBUG}->Log1("BuildObject: tag($tag) package($NEWOBJECT{$tag})");
976        eval "\$obj = new $NEWOBJECT{$tag}(\$tree);";
977    }
978
979    return $obj;
980}
981
982
983###############################################################################
984#
985# SetCallBacks - Takes a hash with top level tags to look for as the keys
986#                and pointers to functions as the values.  The functions
987#                are called and passed the XML::Parser::Tree objects
988#                generated by XML::Stream.
989#
990###############################################################################
991sub SetCallBacks
992{
993    my $self = shift;
994    while($#_ >= 0)
995    {
996        my $func = pop(@_);
997        my $tag = pop(@_);
998        $self->{DEBUG}->Log1("SetCallBacks: tag($tag) func($func)");
999        if (defined($func))
1000        {
1001            $self->{CB}->{$tag} = $func;
1002        }
1003        else
1004        {
1005            delete($self->{CB}->{$tag});
1006        }
1007        $self->{STREAM}->SetCallBacks(update=>$func) if ($tag eq "update");
1008    }
1009}
1010
1011
1012###############################################################################
1013#
1014# SetIQCallBacks - define callbacks for the namespaces inside an iq.
1015#
1016###############################################################################
1017sub SetIQCallBacks
1018{
1019    my $self = shift;
1020
1021    while($#_ >= 0)
1022    {
1023        my $hash = pop(@_);
1024        my $namespace = pop(@_);
1025
1026        foreach my $type (keys(%{$hash}))
1027        {
1028            if (defined($hash->{$type}))
1029            {
1030                $self->{CB}->{IQns}->{$namespace}->{$type} = $hash->{$type};
1031            }
1032            else
1033            {
1034                delete($self->{CB}->{IQns}->{$namespace}->{$type});
1035            }
1036        }
1037    }
1038}
1039
1040
1041###############################################################################
1042#
1043# SetPresenceCallBacks - define callbacks for the different presence packets.
1044#
1045###############################################################################
1046sub SetPresenceCallBacks
1047{
1048    my $self = shift;
1049    my (%types) = @_;
1050
1051    foreach my $type (keys(%types))
1052    {
1053        if (defined($types{$type}))
1054        {
1055            $self->{CB}->{Pres}->{$type} = $types{$type};
1056        }
1057        else
1058        {
1059            delete($self->{CB}->{Pres}->{$type});
1060        }
1061    }
1062}
1063
1064
1065###############################################################################
1066#
1067# SetMessageCallBacks - define callbacks for the different message packets.
1068#
1069###############################################################################
1070sub SetMessageCallBacks
1071{
1072    my $self = shift;
1073    my (%types) = @_;
1074
1075    foreach my $type (keys(%types))
1076    {
1077        if (defined($types{$type}))
1078        {
1079            $self->{CB}->{Mess}->{$type} = $types{$type};
1080        }
1081        else
1082        {
1083            delete($self->{CB}->{Mess}->{$type});
1084        }
1085    }
1086}
1087
1088
1089###############################################################################
1090#
1091# SetXPathCallBacks - define callbacks for packets based on XPath.
1092#
1093###############################################################################
1094sub SetXPathCallBacks
1095{ 
1096    my $self = shift;
1097    my (%xpaths) = @_;
1098
1099    foreach my $xpath (keys(%xpaths))
1100    {
1101        $self->{DEBUG}->Log1("SetXPathCallBacks: xpath($xpath) func($xpaths{$xpath})");
1102        $self->{CB}->{XPath}->{$xpath}->{$xpaths{$xpath}} = $xpaths{$xpath};
1103    }
1104}
1105
1106
1107###############################################################################
1108#
1109# RemoveXPathCallBacks - remove callbacks for packets based on XPath.
1110#
1111###############################################################################
1112sub RemoveXPathCallBacks
1113{
1114    my $self = shift;
1115    my (%xpaths) = @_;
1116
1117    foreach my $xpath (keys(%xpaths))
1118    {
1119        $self->{DEBUG}->Log1("RemoveXPathCallBacks: xpath($xpath) func($xpaths{$xpath})");
1120        delete($self->{CB}->{XPath}->{$xpath}->{$xpaths{$xpath}});
1121        delete($self->{CB}->{XPath}->{$xpath})
1122            if (scalar(keys(%{$self->{CB}->{XPath}->{$xpath}})) == 0);
1123        delete($self->{CB}->{XPath})
1124            if (scalar(keys(%{$self->{CB}->{XPath}})) == 0);
1125    }
1126}
1127
1128
1129###############################################################################
1130#
1131# SetDirectXPathCallBacks - define callbacks for packets based on XPath.
1132#
1133###############################################################################
1134sub SetDirectXPathCallBacks
1135{ 
1136    my $self = shift;
1137    my (%xpaths) = @_;
1138
1139    foreach my $xpath (keys(%xpaths))
1140    {
1141        $self->{DEBUG}->Log1("SetDirectXPathCallBacks: xpath($xpath) func($xpaths{$xpath})");
1142        $self->{CB}->{DirectXPath}->{$xpath}->{$xpaths{$xpath}} = $xpaths{$xpath};
1143    }
1144}
1145
1146
1147###############################################################################
1148#
1149# RemoveDirectXPathCallBacks - remove callbacks for packets based on XPath.
1150#
1151###############################################################################
1152sub RemoveDirectXPathCallBacks
1153{
1154    my $self = shift;
1155    my (%xpaths) = @_;
1156
1157    foreach my $xpath (keys(%xpaths))
1158    {
1159        $self->{DEBUG}->Log1("RemoveDirectXPathCallBacks: xpath($xpath) func($xpaths{$xpath})");
1160        delete($self->{CB}->{DirectXPath}->{$xpath}->{$xpaths{$xpath}});
1161        delete($self->{CB}->{DirectXPath}->{$xpath})
1162            if (scalar(keys(%{$self->{CB}->{DirectXPath}->{$xpath}})) == 0);
1163        delete($self->{CB}->{DirectXPath})
1164            if (scalar(keys(%{$self->{CB}->{DirectXPath}})) == 0);
1165    }
1166}
1167
1168
1169###############################################################################
1170#
1171# Send - Takes either XML or a Net::XMPP::xxxx object and sends that
1172#        packet to the server.
1173#
1174###############################################################################
1175sub Send
1176{
1177    my $self = shift;
1178    my $object = shift;
1179    my $ignoreActivity = shift;
1180    $ignoreActivity = 0 unless defined($ignoreActivity);
1181
1182    if (ref($object) eq "")
1183    {
1184        $self->SendXML($object,$ignoreActivity);
1185    }
1186    else
1187    {
1188        $self->SendXML($object->GetXML(),$ignoreActivity);
1189    }
1190}
1191
1192
1193###############################################################################
1194#
1195# SendXML - Sends the XML packet to the server
1196#
1197###############################################################################
1198sub SendXML
1199{
1200    my $self = shift;
1201    my $xml = shift;
1202    my $ignoreActivity = shift;
1203    $ignoreActivity = 0 unless defined($ignoreActivity);
1204
1205    $self->{DEBUG}->Log1("SendXML: sent($xml)");
1206    &{$self->{CB}->{send}}($self->GetStreamID(),$xml) if exists($self->{CB}->{send});
1207    $self->{STREAM}->IgnoreActivity($self->GetStreamID(),$ignoreActivity);
1208    $self->{STREAM}->Send($self->GetStreamID(),$xml);
1209    $self->{STREAM}->IgnoreActivity($self->GetStreamID(),0);
1210}
1211
1212
1213###############################################################################
1214#
1215# SendWithID - Take either XML or a Net::XMPP::xxxx object and send it
1216#              with the next available ID number.  Then return that ID so
1217#              the client can track it.
1218#
1219###############################################################################
1220sub SendWithID
1221{
1222    my $self = shift;
1223    my ($object) = @_;
1224
1225    #--------------------------------------------------------------------------
1226    # Take the current XML stream and insert an id attrib at the top level.
1227    #--------------------------------------------------------------------------
1228    my $id = $self->UniqueID();
1229
1230    $self->{DEBUG}->Log1("SendWithID: id($id)");
1231
1232    my $xml;
1233    if (ref($object) eq "")
1234    {
1235        $self->{DEBUG}->Log1("SendWithID: in($object)");
1236        $xml = $object;
1237        $xml =~ s/^(\<[^\>]+)(\>)/$1 id\=\'$id\'$2/;
1238        my ($tag) = ($xml =~ /^\<(\S+)\s/);
1239        $self->RegisterID($tag,$id);
1240    }
1241    else
1242    {
1243        $self->{DEBUG}->Log1("SendWithID: in(",$object->GetXML(),")");
1244        $object->SetID($id);
1245        $xml = $object->GetXML();
1246        $self->RegisterID($object->GetTag(),$id);
1247    }
1248    $self->{DEBUG}->Log1("SendWithID: out($xml)");
1249
1250    #--------------------------------------------------------------------------
1251    # Send the new XML string.
1252    #--------------------------------------------------------------------------
1253    $self->SendXML($xml);
1254
1255    #--------------------------------------------------------------------------
1256    # Return the ID number we just assigned.
1257    #--------------------------------------------------------------------------
1258    return $id;
1259}
1260
1261
1262###############################################################################
1263#
1264# UniqueID - Increment and return a new unique ID.
1265#
1266###############################################################################
1267sub UniqueID
1268{
1269    my $self = shift;
1270
1271    my $id_num = $self->{RCVDB}->{currentID};
1272
1273    $self->{RCVDB}->{currentID}++;
1274
1275    return "netjabber-$id_num";
1276}
1277
1278
1279###############################################################################
1280#
1281# SendAndReceiveWithID - Take either XML or a Net::XMPP::xxxxx object and
1282#                        send it with the next ID.  Then wait for that ID
1283#                        to come back and return the response in a
1284#                        Net::XMPP::xxxx object.
1285#
1286###############################################################################
1287sub SendAndReceiveWithID
1288{
1289    my $self = shift;
1290    my ($object,$timeout) = @_;
1291    &{$self->{CB}->{startwait}}() if exists($self->{CB}->{startwait});
1292    $self->{DEBUG}->Log1("SendAndReceiveWithID: object($object)");
1293    my $id = $self->SendWithID($object);
1294    $self->{DEBUG}->Log1("SendAndReceiveWithID: sent with id($id)");
1295    my $packet = $self->WaitForID($id,$timeout);
1296    &{$self->{CB}->{endwait}}() if exists($self->{CB}->{endwait});
1297    return $packet;
1298}
1299
1300
1301###############################################################################
1302#
1303# ReceivedID - returns 1 if a packet with the ID has been received, or 0
1304#              if it has not.
1305#
1306###############################################################################
1307sub ReceivedID
1308{
1309    my $self = shift;
1310    my ($id) = @_;
1311
1312    $self->{DEBUG}->Log1("ReceivedID: id($id)");
1313    return 1 if exists($self->{RCVDB}->{$id});
1314    $self->{DEBUG}->Log1("ReceivedID: nope...");
1315    return 0;
1316}
1317
1318
1319###############################################################################
1320#
1321# GetID - Return the Net::XMPP::xxxxx object that is stored in the LIST
1322#         that matches the ID if that ID exists.  Otherwise return 0.
1323#
1324###############################################################################
1325sub GetID
1326{
1327    my $self = shift;
1328    my ($id) = @_;
1329
1330    $self->{DEBUG}->Log1("GetID: id($id)");
1331    return $self->{RCVDB}->{$id} if $self->ReceivedID($id);
1332    $self->{DEBUG}->Log1("GetID: haven't gotten that id yet...");
1333    return 0;
1334}
1335
1336
1337###############################################################################
1338#
1339# CleanID - Delete the list entry for this id since we don't want a leak.
1340#
1341###############################################################################
1342sub CleanID
1343{
1344    my $self = shift;
1345    my ($id) = @_;
1346
1347    $self->{DEBUG}->Log1("CleanID: id($id)");
1348    delete($self->{RCVDB}->{$id});
1349}
1350
1351
1352###############################################################################
1353#
1354# WaitForID - Keep looping and calling Process(1) to poll every second
1355#             until the response from the server occurs.
1356#
1357###############################################################################
1358sub WaitForID
1359{
1360    my $self = shift;
1361    my ($id,$timeout) = @_;
1362    $timeout = "300" unless defined($timeout);
1363
1364    $self->{DEBUG}->Log1("WaitForID: id($id)");
1365    my $endTime = time + $timeout;
1366    while(!$self->ReceivedID($id) && ($endTime >= time))
1367    {
1368        $self->{DEBUG}->Log1("WaitForID: haven't gotten it yet... let's wait for more packets");
1369        return unless (defined($self->Process(1)));
1370        &{$self->{CB}->{update}}() if exists($self->{CB}->{update});
1371    }
1372    if (!$self->ReceivedID($id))
1373    {
1374        $self->TimeoutID($id);
1375        $self->{DEBUG}->Log1("WaitForID: timed out...");
1376        return;
1377    }
1378    else
1379    {
1380        $self->{DEBUG}->Log1("WaitForID: we got it!");
1381        my $packet = $self->GetID($id);
1382        $self->CleanID($id);
1383        return $packet;
1384    }
1385}
1386
1387
1388###############################################################################
1389#
1390# GotID - Callback to store the Net::XMPP::xxxxx object in the LIST at
1391#         the ID index.  This is a private helper function.
1392#
1393###############################################################################
1394sub GotID
1395{
1396    my $self = shift;
1397    my ($id,$object) = @_;
1398
1399    $self->{DEBUG}->Log1("GotID: id($id) xml(",$object->GetXML(),")");
1400    $self->{RCVDB}->{$id} = $object;
1401}
1402
1403
1404###############################################################################
1405#
1406# CheckID - Checks the ID registry if this tag and ID have been registered.
1407#           0 = no, 1 = yes
1408#
1409###############################################################################
1410sub CheckID
1411{
1412    my $self = shift;
1413    my ($tag,$id) = @_;
1414    $id = "" unless defined($id);
1415
1416    $self->{DEBUG}->Log1("CheckID: tag($tag) id($id)");
1417    return 0 if ($id eq "");
1418    $self->{DEBUG}->Log1("CheckID: we have that here somewhere...");
1419    return exists($self->{IDRegistry}->{$tag}->{$id});
1420}
1421
1422
1423###############################################################################
1424#
1425# TimeoutID - Timeout the tag and ID in the registry so that the CallBack
1426#             can know what to put in the ID list and what to pass on.
1427#
1428###############################################################################
1429sub TimeoutID
1430{
1431    my $self = shift;
1432    my ($id) = @_;
1433
1434    $self->{DEBUG}->Log1("TimeoutID: id($id)");
1435    $self->{RCVDB}->{$id} = 0;
1436}
1437
1438
1439###############################################################################
1440#
1441# TimedOutID - Timeout the tag and ID in the registry so that the CallBack
1442#             can know what to put in the ID list and what to pass on.
1443#
1444###############################################################################
1445sub TimedOutID
1446{
1447    my $self = shift;
1448    my ($id) = @_;
1449
1450    return (exists($self->{RCVDB}->{$id}) && ($self->{RCVDB}->{$id} == 0));
1451}
1452
1453
1454###############################################################################
1455#
1456# RegisterID - Register the tag and ID in the registry so that the CallBack
1457#              can know what to put in the ID list and what to pass on.
1458#
1459###############################################################################
1460sub RegisterID
1461{
1462    my $self = shift;
1463    my ($tag,$id) = @_;
1464
1465    $self->{DEBUG}->Log1("RegisterID: tag($tag) id($id)");
1466    $self->{IDRegistry}->{$tag}->{$id} = 1;
1467}
1468
1469
1470###############################################################################
1471#
1472# DeregisterID - Delete the tag and ID in the registry so that the CallBack
1473#                can knows that it has been received.
1474#
1475###############################################################################
1476sub DeregisterID
1477{
1478    my $self = shift;
1479    my ($tag,$id) = @_;
1480
1481    $self->{DEBUG}->Log1("DeregisterID: tag($tag) id($id)");
1482    delete($self->{IDRegistry}->{$tag}->{$id});
1483}
1484
1485
1486###############################################################################
1487#
1488# AddNamespace - Add a custom namespace into the mix.
1489#
1490###############################################################################
1491sub AddNamespace
1492{
1493    my $self = shift;
1494    &Net::XMPP::Namespaces::add_ns(@_);
1495}
1496
1497
1498###############################################################################
1499#
1500# MessageSend - Takes the same hash that Net::XMPP::Message->SetMessage
1501#               takes and sends the message to the server.
1502#
1503###############################################################################
1504sub MessageSend
1505{
1506    my $self = shift;
1507
1508    my $mess = $self->_message();
1509    $mess->SetMessage(@_);
1510    $self->Send($mess);
1511}
1512
1513
1514##############################################################################
1515#
1516# PresenceDB - initialize the module to use the presence database
1517#
1518##############################################################################
1519sub PresenceDB
1520{
1521    my $self = shift;
1522
1523    $self->SetXPathCallBacks('/presence'=>sub{ shift; $self->PresenceDBParse(@_) });
1524}
1525
1526
1527###############################################################################
1528#
1529# PresenceDBParse - adds the presence information to the Presence DB so
1530#                   you can keep track of the current state of the JID and
1531#                   all of it's resources.
1532#
1533###############################################################################
1534sub PresenceDBParse
1535{
1536    my $self = shift;
1537    my ($presence) = @_;
1538
1539    $self->{DEBUG}->Log4("PresenceDBParse: pres(",$presence->GetXML(),")");
1540   
1541    my $type = $presence->GetType();
1542    $type = "" unless defined($type);
1543    return $presence unless (($type eq "") ||
1544                 ($type eq "available") ||
1545                 ($type eq "unavailable"));
1546
1547    my $fromJID = $presence->GetFrom("jid");
1548    my $fromID = $fromJID->GetJID();
1549    $fromID = "" unless defined($fromID);
1550    my $resource = $fromJID->GetResource();
1551    $resource = " " unless ($resource ne "");
1552    my $priority = $presence->GetPriority();
1553    $priority = 0 unless defined($priority);
1554
1555    $self->{DEBUG}->Log1("PresenceDBParse: fromJID(",$fromJID->GetJID("full"),") resource($resource) priority($priority) type($type)");
1556    $self->{DEBUG}->Log2("PresenceDBParse: xml(",$presence->GetXML(),")");
1557
1558    if (exists($self->{PRESENCEDB}->{$fromID}))
1559    {
1560        my $oldPriority = $self->{PRESENCEDB}->{$fromID}->{resources}->{$resource};
1561        $oldPriority = "" unless defined($oldPriority);
1562
1563        my $loc = 0;
1564        foreach my $index (0..$#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}})
1565        {
1566            $loc = $index
1567               if ($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}->[$index]->{resource} eq $resource);
1568        }
1569        splice(@{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}},$loc,1);
1570        delete($self->{PRESENCEDB}->{$fromID}->{resources}->{$resource});
1571        delete($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority})
1572            if (exists($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}) &&
1573        ($#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}} == -1));
1574        delete($self->{PRESENCEDB}->{$fromID})
1575            if (scalar(keys(%{$self->{PRESENCEDB}->{$fromID}})) == 0);
1576
1577        $self->{DEBUG}->Log1("PresenceDBParse: remove ",$fromJID->GetJID("full")," from the DB");
1578    }
1579
1580    if (($type eq "") || ($type eq "available"))
1581    {
1582        my $loc = -1;
1583        foreach my $index (0..$#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}}) {
1584            $loc = $index
1585                if ($self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$index]->{resource} eq $resource);
1586        }
1587        $loc = $#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}}+1
1588            if ($loc == -1);
1589        $self->{PRESENCEDB}->{$fromID}->{resources}->{$resource} = $priority;
1590        $self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$loc]->{presence} =
1591            $presence;
1592        $self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$loc]->{resource} =
1593            $resource;
1594
1595        $self->{DEBUG}->Log1("PresenceDBParse: add ",$fromJID->GetJID("full")," to the DB");
1596    }
1597
1598    my $currentPresence = $self->PresenceDBQuery($fromJID);
1599    return (defined($currentPresence) ? $currentPresence : $presence);
1600}
1601
1602
1603###############################################################################
1604#
1605# PresenceDBDelete - delete the JID from the DB completely.
1606#
1607###############################################################################
1608sub PresenceDBDelete
1609{
1610    my $self = shift;
1611    my ($jid) = @_;
1612
1613    my $indexJID = $jid;
1614    $indexJID = $jid->GetJID() if $jid->isa("Net::XMPP::JID");
1615
1616    return if !exists($self->{PRESENCEDB}->{$indexJID});
1617    delete($self->{PRESENCEDB}->{$indexJID});
1618    $self->{DEBUG}->Log1("PresenceDBDelete: delete ",$indexJID," from the DB");
1619}
1620
1621
1622###############################################################################
1623#
1624# PresenceDBClear - delete all of the JIDs from the DB completely.
1625#
1626###############################################################################
1627sub PresenceDBClear
1628{
1629    my $self = shift;
1630
1631    $self->{DEBUG}->Log1("PresenceDBClear: clearing the database");
1632    foreach my $indexJID (keys(%{$self->{PRESENCEDB}}))
1633    {
1634        $self->{DEBUG}->Log3("PresenceDBClear: deleting ",$indexJID," from the DB");
1635        delete($self->{PRESENCEDB}->{$indexJID});
1636    }
1637    $self->{DEBUG}->Log3("PresenceDBClear: database is empty");
1638}
1639
1640
1641###############################################################################
1642#
1643# PresenceDBQuery - retrieve the last Net::XMPP::Presence received with
1644#                  the highest priority.
1645#
1646###############################################################################
1647sub PresenceDBQuery
1648{
1649    my $self = shift;
1650    my ($jid) = @_;
1651
1652    my $indexJID = $jid;
1653    $indexJID = $jid->GetJID() if $jid->isa("Net::XMPP::JID");
1654
1655    return if !exists($self->{PRESENCEDB}->{$indexJID});
1656    return if (scalar(keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}})) == 0);
1657
1658    my $highPriority =
1659        (sort {$b cmp $a} keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}}))[0];
1660
1661    return $self->{PRESENCEDB}->{$indexJID}->{priorities}->{$highPriority}->[0]->{presence};
1662}
1663
1664
1665###############################################################################
1666#
1667# PresenceDBResources - returns a list of the resources from highest
1668#                       priority to lowest.
1669#
1670###############################################################################
1671sub PresenceDBResources
1672{
1673    my $self = shift;
1674    my ($jid) = @_;
1675
1676    my $indexJID = $jid;
1677    $indexJID = $jid->GetJID() if $jid->isa("Net::XMPP::JID");
1678
1679    my @resources;
1680
1681    return if !exists($self->{PRESENCEDB}->{$indexJID});
1682
1683    foreach my $priority (sort {$b cmp $a} keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}}))
1684    {
1685        foreach my $index (0..$#{$self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}})
1686        {
1687            next if ($self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}->[$index]->{resource} eq " ");
1688            push(@resources,$self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}->[$index]->{resource});
1689        }
1690    }
1691    return @resources;
1692}
1693
1694
1695###############################################################################
1696#
1697# PresenceSend - Sends a presence tag to announce your availability
1698#
1699###############################################################################
1700sub PresenceSend
1701{
1702    my $self = shift;
1703    my %args;
1704    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
1705
1706    $args{ignoreactivity} = 0 unless exists($args{ignoreactivity});
1707    my $ignoreActivity = delete($args{ignoreactivity});
1708
1709    my $presence = $self->_presence();
1710
1711    $presence->SetPresence(%args);
1712    $self->Send($presence,$ignoreActivity);
1713    return $presence;
1714}
1715
1716
1717###############################################################################
1718#
1719# PresenceProbe - Sends a presence probe to the server
1720#
1721###############################################################################
1722sub PresenceProbe
1723{
1724    my $self = shift;
1725    my %args;
1726    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
1727    delete($args{type});
1728
1729    my $presence = $self->_presence();
1730    $presence->SetPresence(type=>"probe",
1731                           %args);
1732    $self->Send($presence);
1733}
1734
1735
1736###############################################################################
1737#
1738# Subscription - Sends a presence tag to perform the subscription on the
1739#                specified JID.
1740#
1741###############################################################################
1742sub Subscription
1743{
1744    my $self = shift;
1745
1746    my $presence = $self->_presence();
1747    $presence->SetPresence(@_);
1748    $self->Send($presence);
1749}
1750
1751
1752###############################################################################
1753#
1754# AuthSend - This is a self contained function to send a login iq tag with
1755#            an id.  Then wait for a reply what the same id to come back
1756#            and tell the caller what the result was.
1757#
1758###############################################################################
1759sub AuthSend
1760{
1761    my $self = shift;
1762    my %args;
1763    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
1764
1765    carp("AuthSend requires a username arguement")
1766        unless exists($args{username});
1767    carp("AuthSend requires a password arguement")
1768        unless exists($args{password});
1769
1770    if($self->{STREAM}->GetStreamFeature($self->GetStreamID(),"xmpp-sasl"))
1771    {
1772        return $self->AuthSASL(%args);
1773    }
1774
1775    return $self->AuthIQAuth(%args);
1776}
1777
1778
1779###############################################################################
1780#
1781# AuthIQAuth - Try and auth using jabber:iq:auth, the old Jabber way of
1782#              authenticating.
1783#
1784###############################################################################
1785sub AuthIQAuth
1786{
1787    my $self = shift;
1788    my %args;
1789    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
1790
1791    $self->{DEBUG}->Log1("AuthIQAuth: old school auth");
1792
1793    carp("AuthIQAuth requires a resource arguement")
1794        unless exists($args{resource});
1795
1796    my $authType = "digest";
1797    my $token;
1798    my $sequence;
1799
1800    #--------------------------------------------------------------------------
1801    # First let's ask the sever what all is available in terms of auth types.
1802    # If we get an error, then all we can do is digest or plain.
1803    #--------------------------------------------------------------------------
1804    my $iqAuth = $self->_iq();
1805    $iqAuth->SetIQ(type=>"get");
1806    my $iqAuthQuery = $iqAuth->NewChild("jabber:iq:auth");
1807    $iqAuthQuery->SetUsername($args{username});
1808    $iqAuth = $self->SendAndReceiveWithID($iqAuth);
1809
1810    return unless defined($iqAuth);
1811    return ( $iqAuth->GetErrorCode() , $iqAuth->GetError() )
1812        if ($iqAuth->GetType() eq "error");
1813
1814    if ($iqAuth->GetType() eq "error")
1815    {
1816        $authType = "digest";
1817    }
1818    else
1819    {
1820        $iqAuthQuery = $iqAuth->GetChild();
1821        $authType = "plain" if $iqAuthQuery->DefinedPassword();
1822        $authType = "digest" if $iqAuthQuery->DefinedDigest();
1823        $authType = "zerok" if ($iqAuthQuery->DefinedSequence() &&
1824                    $iqAuthQuery->DefinedToken());
1825        $token = $iqAuthQuery->GetToken() if ($authType eq "zerok");
1826        $sequence = $iqAuthQuery->GetSequence() if ($authType eq "zerok");
1827    }
1828
1829    $self->{DEBUG}->Log1("AuthIQAuth: authType($authType)");
1830
1831    delete($args{digest});
1832    delete($args{type});
[3405394]1833    my $password = delete $args{password};
1834    if (ref($password) eq 'CODE')
1835    {
1836        $password = $password->();
1837    }
[0ff8d110]1838
1839    #--------------------------------------------------------------------------
1840    # 0k authenticaion (http://core.jabber.org/0k.html)
1841    #
1842    # Tell the server that we want to connect this way, the server sends back
1843    # a token and a sequence number.  We take that token + the password and
1844    # SHA1 it.  Then we SHA1 it sequence number more times and send that hash.
1845    # The server SHA1s that hash one more time and compares it to the hash it
1846    # stored last time.  IF they match, we are in and it stores the hash we sent
1847    # for the next time and decreases the sequence number, else, no go.
1848    #--------------------------------------------------------------------------
1849    if ($authType eq "zerok")
1850    {
[3405394]1851        my $hashA = Digest::SHA1::sha1_hex($password);
[0ff8d110]1852        $args{hash} = Digest::SHA1::sha1_hex($hashA.$token);
1853
1854        for (1..$sequence)
1855        {
1856            $args{hash} = Digest::SHA1::sha1_hex($args{hash});
1857        }
1858    }
1859
1860    #--------------------------------------------------------------------------
1861    # If we have access to the SHA-1 digest algorithm then let's use it.
1862    # Remove the password from the hash, create the digest, and put the
1863    # digest in the hash instead.
1864    #
1865    # Note: Concat the Session ID and the password and then digest that
1866    # string to get the server to accept the digest.
1867    #--------------------------------------------------------------------------
1868    if ($authType eq "digest")
1869    {
1870        $args{digest} = Digest::SHA1::sha1_hex($self->GetStreamID().$password);
1871    }
1872
1873    #--------------------------------------------------------------------------
1874    # Create a Net::XMPP::IQ object to send to the server
1875    #--------------------------------------------------------------------------
1876    my $iqLogin = $self->_iq();
1877    $iqLogin->SetIQ(type=>"set");
1878    my $iqLoginQuery = $iqLogin->NewChild("jabber:iq:auth");
1879    $iqLoginQuery->SetAuth(%args);
1880
1881    #--------------------------------------------------------------------------
1882    # Send the IQ with the next available ID and wait for a reply with that
1883    # id to be received.  Then grab the IQ reply.
1884    #--------------------------------------------------------------------------
1885    $iqLogin = $self->SendAndReceiveWithID($iqLogin);
1886
1887    #--------------------------------------------------------------------------
1888    # From the reply IQ determine if we were successful or not.  If yes then
1889    # return "".  If no then return error string from the reply.
1890    #--------------------------------------------------------------------------
[3405394]1891    $password =~ tr/\0-\377/x/;
[0ff8d110]1892    return unless defined($iqLogin);
1893    return ( $iqLogin->GetErrorCode() , $iqLogin->GetError() )
1894        if ($iqLogin->GetType() eq "error");
1895
1896    $self->{DEBUG}->Log1("AuthIQAuth: we authed!");
1897
1898    return ("ok","");
1899}
1900
1901
1902###############################################################################
1903#
1904# AuthSASL - Try and auth using SASL, the XMPP preferred way of authenticating.
1905#
1906###############################################################################
1907sub AuthSASL
1908{
1909    my $self = shift;
1910    my %args;
1911    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
1912
1913    $self->{DEBUG}->Log1("AuthSASL: shiney new auth");
1914
1915    carp("AuthSASL requires a username arguement")
1916        unless exists($args{username});
1917    carp("AuthSASL requires a password arguement")
1918        unless exists($args{password});
1919
1920    $args{resource} = "" unless exists($args{resource});
1921
1922    #-------------------------------------------------------------------------
1923    # Create the SASLClient on our end
1924    #-------------------------------------------------------------------------
1925    my $sid = $self->{SESSION}->{id};
1926    my $status =
1927        $self->{STREAM}->SASLClient($sid,
1928                                    $args{username},
1929                                    $args{password}
1930                                   );
1931
1932    $args{timeout} = "120" unless exists($args{timeout});
1933
1934    #-------------------------------------------------------------------------
1935    # While we haven't timed out, keep waiting for the SASLClient to finish
1936    #-------------------------------------------------------------------------
1937    my $endTime = time + $args{timeout};
1938    while(!$self->{STREAM}->SASLClientDone($sid) && ($endTime >= time))
1939    {
1940        $self->{DEBUG}->Log1("AuthSASL: haven't authed yet... let's wait.");
1941        return unless (defined($self->Process(1)));
1942        &{$self->{CB}->{update}}() if exists($self->{CB}->{update});
1943    }
1944   
1945    #-------------------------------------------------------------------------
1946    # The loop finished... but was it done?
1947    #-------------------------------------------------------------------------
1948    if (!$self->{STREAM}->SASLClientDone($sid))
1949    {
1950        $self->{DEBUG}->Log1("AuthSASL: timed out...");
1951        return( "system","SASL timed out authenticating");
1952    }
1953   
1954    #-------------------------------------------------------------------------
1955    # Ok, it was done... but did we auth?
1956    #-------------------------------------------------------------------------
1957    if (!$self->{STREAM}->SASLClientAuthed($sid))
1958    {
1959        $self->{DEBUG}->Log1("AuthSASL: Authentication failed.");
1960        return ( "error", $self->{STREAM}->SASLClientError($sid));
1961    }
1962   
1963    #-------------------------------------------------------------------------
1964    # Phew... Restart the <stream:stream> per XMPP
1965    #-------------------------------------------------------------------------
1966    $self->{DEBUG}->Log1("AuthSASL: We authed!");
1967    $self->{SESSION} = $self->{STREAM}->OpenStream($sid);
1968    $sid = $self->{SESSION}->{id};
1969   
1970    $self->{DEBUG}->Log1("AuthSASL: We got a new session. sid($sid)");
1971
1972    #-------------------------------------------------------------------------
1973    # Look in the new set of <stream:feature/>s and see if xmpp-bind was
1974    # offered.
1975    #-------------------------------------------------------------------------
1976    my $bind = $self->{STREAM}->GetStreamFeature($sid,"xmpp-bind");
1977    if ($bind)
1978    {
1979        $self->{DEBUG}->Log1("AuthSASL: Binding to resource");
1980        $self->BindResource($args{resource});
1981    }
1982
1983    #-------------------------------------------------------------------------
1984    # Look in the new set of <stream:feature/>s and see if xmpp-session was
1985    # offered.
1986    #-------------------------------------------------------------------------
1987    my $session = $self->{STREAM}->GetStreamFeature($sid,"xmpp-session");
1988    if ($session)
1989    {
1990        $self->{DEBUG}->Log1("AuthSASL: Starting session");
1991        $self->StartSession();
1992    }
1993
1994    return ("ok","");
1995}
1996
1997
1998##############################################################################
1999#
2000# BindResource - bind to a resource
2001#
2002##############################################################################
2003sub BindResource
2004{
2005    my $self = shift;
2006    my $resource = shift;
2007
2008    $self->{DEBUG}->Log2("BindResource: Binding to resource");
2009    my $iq = $self->_iq();
2010
2011    $iq->SetIQ(type=>"set");
2012    my $bind = $iq->NewChild(&ConstXMLNS("xmpp-bind"));
2013   
2014    if (defined($resource) && ($resource ne ""))
2015    {
2016        $self->{DEBUG}->Log2("BindResource: resource($resource)");
2017        $bind->SetBind(resource=>$resource);
2018    }
2019
2020    my $result = $self->SendAndReceiveWithID($iq);
2021}
2022
2023
2024##############################################################################
2025#
2026# StartSession - Initialize a session
2027#
2028##############################################################################
2029sub StartSession
2030{
2031    my $self = shift;
2032
2033    my $iq = $self->_iq();
2034
2035    $iq->SetIQ(type=>"set");
2036    my $session = $iq->NewChild(&ConstXMLNS("xmpp-session"));
2037   
2038    my $result = $self->SendAndReceiveWithID($iq);
2039}
2040
2041
2042##############################################################################
2043#
2044# PrivacyLists - Initialize a Net::XMPP::PrivacyLists object and return it.
2045#
2046##############################################################################
2047sub PrivacyLists
2048{
2049    my $self = shift;
2050
2051    return new Net::XMPP::PrivacyLists(connection=>$self);
2052}
2053
2054
2055##############################################################################
2056#
2057# PrivacyListsGet - Sends an empty IQ to the server to request that the user's
2058#                   Privacy Lists be sent to them.  Returns the iq packet
2059#                   of the result.
2060#
2061##############################################################################
2062sub PrivacyListsGet
2063{
2064    my $self = shift;
2065    my %args;
2066    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2067
2068    my $iq = $self->_iq();
2069    $iq->SetIQ(type=>"get");
2070    my $query = $iq->NewChild("jabber:iq:privacy");
2071
2072    if (exists($args{list}))
2073    {
2074        $query->AddList(name=>$args{list});
2075    }
2076
2077    $iq = $self->SendAndReceiveWithID($iq);
2078    return unless defined($iq);
2079
2080    return $iq;
2081}
2082
2083
2084##############################################################################
2085#
2086# PrivacyListsRequest - Sends an empty IQ to the server to request that the
2087#                       user's privacy lists be sent to them, and return to
2088#                       let the user's program handle parsing the return packet.
2089#
2090##############################################################################
2091sub PrivacyListsRequest
2092{
2093    my $self = shift;
2094    my %args;
2095    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2096   
2097    my $iq = $self->_iq();
2098    $iq->SetIQ(type=>"get");
2099    my $query = $iq->NewChild("jabber:iq:privacy");
2100
2101    if (exists($args{list}))
2102    {
2103        $query->AddList(name=>$args{list});
2104    }
2105
2106    $self->Send($iq);
2107}
2108
2109
2110##############################################################################
2111#
2112# PrivacyListsSet - Sends an empty IQ to the server to request that the
2113#                       user's privacy lists be sent to them, and return to
2114#                       let the user's program handle parsing the return packet.
2115#
2116##############################################################################
2117sub PrivacyListsSet
2118{
2119    my $self = shift;
2120    my %args;
2121    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2122   
2123    my $iq = $self->_iq();
2124    $iq->SetIQ(type=>"set");
2125    my $query = $iq->NewChild("jabber:iq:privacy");
2126
2127    #XXX error check that there is a list
2128    my $list = $query->AddList(name=>$args{list});
2129
2130    foreach my $item (@{$args{items}})
2131    {
2132        $list->AddItem(%{$item});
2133    }
2134
2135    $iq = $self->SendAndReceiveWithID($iq);
2136    return unless defined($iq);
2137
2138    return if $iq->DefinedError();
2139
2140    return 1;
2141}
2142
2143
2144###############################################################################
2145#
2146# RegisterRequest - This is a self contained function to send an iq tag
2147#                   an id that requests the target address to send back
2148#                   the required fields.  It waits for a reply what the
2149#                   same id to come back and tell the caller what the
2150#                   fields are.
2151#
2152###############################################################################
2153sub RegisterRequest
2154{
2155    my $self = shift;
2156    my %args;
2157    $args{mode} = "block";
2158    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2159
2160    my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
2161
2162    #--------------------------------------------------------------------------
2163    # Create a Net::XMPP::IQ object to send to the server
2164    #--------------------------------------------------------------------------
2165    my $iq = $self->_iq();
2166    $iq->SetIQ(to=>delete($args{to})) if exists($args{to});
2167    $iq->SetIQ(type=>"get");
2168    my $query = $iq->NewChild("jabber:iq:register");
2169
2170    #--------------------------------------------------------------------------
2171    # Send the IQ with the next available ID and wait for a reply with that
2172    # id to be received.  Then grab the IQ reply.
2173    #--------------------------------------------------------------------------
2174    if ($args{mode} eq "passthru")
2175    {
2176        my $id = $self->UniqueID();
2177        $iq->SetIQ(id=>$id);
2178        $self->Send($iq);
2179        return $id;
2180    }
2181   
2182    return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
2183
2184    $iq = $self->SendAndReceiveWithID($iq,$timeout);
2185
2186    #--------------------------------------------------------------------------
2187    # Check if there was an error.
2188    #--------------------------------------------------------------------------
2189    return unless defined($iq);
2190    if ($iq->GetType() eq "error")
2191    {
2192        $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError());
2193        return;
2194    }
2195
2196    my %register;
2197    #--------------------------------------------------------------------------
2198    # From the reply IQ determine what fields are required and send a hash
2199    # back with the fields and any values that are already defined (like key)
2200    #--------------------------------------------------------------------------
2201    $query = $iq->GetChild();
2202    $register{fields} = { $query->GetRegister() };
2203
2204    return %register;
2205}
2206
2207
2208###############################################################################
2209#
2210# RegisterSend - This is a self contained function to send a registration
2211#                iq tag with an id.  Then wait for a reply what the same
2212#                id to come back and tell the caller what the result was.
2213#
2214###############################################################################
2215sub RegisterSend
2216{
2217    my $self = shift;
2218    my %args;
2219    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2220
2221    #--------------------------------------------------------------------------
2222    # Create a Net::XMPP::IQ object to send to the server
2223    #--------------------------------------------------------------------------
2224    my $iq = $self->_iq();
2225    $iq->SetIQ(to=>delete($args{to})) if exists($args{to});
2226    $iq->SetIQ(type=>"set");
2227    my $iqRegister = $iq->NewChild("jabber:iq:register");
2228    $iqRegister->SetRegister(%args);
2229
2230    #--------------------------------------------------------------------------
2231    # Send the IQ with the next available ID and wait for a reply with that
2232    # id to be received.  Then grab the IQ reply.
2233    #--------------------------------------------------------------------------
2234    $iq = $self->SendAndReceiveWithID($iq);
2235
2236    #--------------------------------------------------------------------------
2237    # From the reply IQ determine if we were successful or not.  If yes then
2238    # return "".  If no then return error string from the reply.
2239    #--------------------------------------------------------------------------
2240    return unless defined($iq);
2241    return ( $iq->GetErrorCode() , $iq->GetError() )
2242        if ($iq->GetType() eq "error");
2243    return ("ok","");
2244}
2245
2246
2247##############################################################################
2248#
2249# RosterAdd - Takes the Jabber ID of the user to add to their Roster and
2250#             sends the IQ packet to the server.
2251#
2252##############################################################################
2253sub RosterAdd
2254{
2255    my $self = shift;
2256    my %args;
2257    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2258
2259    my $iq = $self->_iq();
2260    $iq->SetIQ(type=>"set");
2261    my $roster = $iq->NewChild("jabber:iq:roster");
2262    my $item = $roster->AddItem();
2263    $item->SetItem(%args);
2264
2265    $self->{DEBUG}->Log1("RosterAdd: xml(",$iq->GetXML(),")");
2266    $self->Send($iq);
2267}
2268
2269
2270##############################################################################
2271#
2272# RosterAdd - Takes the Jabber ID of the user to remove from their Roster
2273#             and sends the IQ packet to the server.
2274#
2275##############################################################################
2276sub RosterRemove
2277{
2278    my $self = shift;
2279    my %args;
2280    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2281    delete($args{subscription});
2282
2283    my $iq = $self->_iq();
2284    $iq->SetIQ(type=>"set");
2285    my $roster = $iq->NewChild("jabber:iq:roster");
2286    my $item = $roster->AddItem();
2287    $item->SetItem(%args,
2288                   subscription=>"remove");
2289    $self->Send($iq);
2290}
2291
2292
2293##############################################################################
2294#
2295# RosterParse - Returns a hash of roster items.
2296#
2297##############################################################################
2298sub RosterParse
2299{
2300    my $self = shift;
2301    my($iq) = @_;
2302
2303    my %roster;
2304    my $query = $iq->GetChild("jabber:iq:roster");
2305
2306    if (defined($query)) #$query->GetXMLNS() eq "jabber:iq:roster")
2307    {
2308        my @items = $query->GetItems();
2309
2310        foreach my $item (@items)
2311        {
2312            my $jid = $item->GetJID();
2313            $roster{$jid}->{name} = $item->GetName();
2314            $roster{$jid}->{subscription} = $item->GetSubscription();
2315            $roster{$jid}->{ask} = $item->GetAsk();
2316            $roster{$jid}->{groups} = [ $item->GetGroup() ];
2317        }
2318    }
2319
2320    return %roster;
2321}
2322
2323
2324##############################################################################
2325#
2326# RosterGet - Sends an empty IQ to the server to request that the user's
2327#             Roster be sent to them.  Returns a hash of roster items.
2328#
2329##############################################################################
2330sub RosterGet
2331{
2332    my $self = shift;
2333
2334    my $iq = $self->_iq();
2335    $iq->SetIQ(type=>"get");
2336    my $query = $iq->NewChild("jabber:iq:roster");
2337
2338    $iq = $self->SendAndReceiveWithID($iq);
2339
2340    return unless defined($iq);
2341
2342    return $self->RosterParse($iq);
2343}
2344
2345
2346##############################################################################
2347#
2348# RosterRequest - Sends an empty IQ to the server to request that the user's
2349#                 Roster be sent to them, and return to let the user's program
2350#                 handle parsing the return packet.
2351#
2352##############################################################################
2353sub RosterRequest
2354{
2355    my $self = shift;
2356
2357    my $iq = $self->_iq();
2358    $iq->SetIQ(type=>"get");
2359    my $query = $iq->NewChild("jabber:iq:roster");
2360
2361    $self->Send($iq);
2362}
2363
2364
2365##############################################################################
2366#
2367# Roster - Initialize a Net::XMPP::Roster object and return it.
2368#
2369##############################################################################
2370sub Roster
2371{
2372    my $self = shift;
2373
2374    return new Net::XMPP::Roster(connection=>$self);
2375}
2376
2377
2378##############################################################################
2379#
2380# RosterDB - initialize the module to use the roster database
2381#
2382##############################################################################
2383sub RosterDB
2384{
2385    my $self = shift;
2386
2387    $self->SetXPathCallBacks('/iq[@type="result" or @type="set"]/query[@xmlns="jabber:iq:roster"]'=>sub{ shift; $self->RosterDBParse(@_) });
2388}
2389
2390
2391##############################################################################
2392#
2393# RosterDBAdd - adds the entry to the Roster DB.
2394#
2395##############################################################################
2396sub RosterDBAdd
2397{
2398    my $self = shift;
2399    my ($jid,%item) = @_;
2400
2401    $self->{ROSTERDB}->{JIDS}->{$jid} = \%item;
2402
2403    foreach my $group (@{$item{groups}})
2404    {
2405        $self->{ROSTERDB}->{GROUPS}->{$group}->{$jid} = 1;
2406    }
2407}
2408
2409
2410###############################################################################
2411#
2412# RosterDBClear - delete all of the JIDs from the DB completely.
2413#
2414###############################################################################
2415sub RosterDBClear
2416{
2417    my $self = shift;
2418
2419    $self->{DEBUG}->Log1("RosterDBClear: clearing the database");
2420    foreach my $jid ($self->RosterDBJIDs())
2421    {
2422        $self->{DEBUG}->Log3("RosterDBClear: deleting ",$jid->GetJID()," from the DB");
2423        $self->RosterDBRemove($jid);
2424    }
2425    $self->{DEBUG}->Log3("RosterDBClear: database is empty");
2426}
2427
2428
2429##############################################################################
2430#
2431# RosterDBExists - allows you to query if the JID exists in the Roster DB.
2432#
2433##############################################################################
2434sub RosterDBExists
2435{
2436    my $self = shift;
2437    my ($jid) = @_;
2438
2439    if ($jid->isa("Net::XMPP::JID"))
2440    {
2441        $jid = $jid->GetJID();
2442    }
2443   
2444    return unless exists($self->{ROSTERDB});
2445    return unless exists($self->{ROSTERDB}->{JIDS});
2446    return unless exists($self->{ROSTERDB}->{JIDS}->{$jid});
2447    return 1;
2448}
2449
2450
2451##############################################################################
2452#
2453# RosterDBGroupExists - allows you to query if the group exists in the Roster
2454#                       DB.
2455#
2456##############################################################################
2457sub RosterDBGroupExists
2458{
2459    my $self = shift;
2460    my ($group) = @_;
2461
2462    return unless exists($self->{ROSTERDB});
2463    return unless exists($self->{ROSTERDB}->{GROUPS});
2464    return unless exists($self->{ROSTERDB}->{GROUPS}->{$group});
2465    return 1;
2466}
2467
2468
2469##############################################################################
2470#
2471# RosterDBGroupJIDs - returns a list of the current groups in your roster.
2472#
2473##############################################################################
2474sub RosterDBGroupJIDs
2475{
2476    my $self = shift;
2477    my $group = shift;
2478
2479    return unless $self->RosterDBGroupExists($group);
2480    my @jids;
2481    foreach my $jid (keys(%{$self->{ROSTERDB}->{GROUPS}->{$group}}))
2482    {
2483        push(@jids,$self->_jid($jid));
2484    }
2485    return @jids;
2486}
2487
2488
2489##############################################################################
2490#
2491# RosterDBGroups - returns a list of the current groups in your roster.
2492#
2493##############################################################################
2494sub RosterDBGroups
2495{
2496    my $self = shift;
2497
2498    return () unless exists($self->{ROSTERDB}->{GROUPS});
2499    return () if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}})) == 0);
2500    return keys(%{$self->{ROSTERDB}->{GROUPS}});
2501}
2502
2503
2504##############################################################################
2505#
2506# RosterDBJIDs - returns a list of all of the JIDs in your roster.
2507#
2508##############################################################################
2509sub RosterDBJIDs
2510{
2511    my $self = shift;
2512    my $group = shift;
2513
2514    my @jids;
2515
2516    return () unless exists($self->{ROSTERDB});
2517    return () unless exists($self->{ROSTERDB}->{JIDS});
2518    foreach my $jid (keys(%{$self->{ROSTERDB}->{JIDS}}))
2519    {
2520        push(@jids,$self->_jid($jid));
2521    }
2522    return @jids;
2523}
2524
2525
2526##############################################################################
2527#
2528# RosterDBNonGroupJIDs - returns a list of the JIDs not in a group.
2529#
2530##############################################################################
2531sub RosterDBNonGroupJIDs
2532{
2533    my $self = shift;
2534    my $group = shift;
2535
2536    my @jids;
2537
2538    return () unless exists($self->{ROSTERDB});
2539    return () unless exists($self->{ROSTERDB}->{JIDS});
2540    foreach my $jid (keys(%{$self->{ROSTERDB}->{JIDS}}))
2541    {
2542        next if (exists($self->{ROSTERDB}->{JIDS}->{$jid}->{groups}) &&
2543                 ($#{$self->{ROSTERDB}->{JIDS}->{$jid}->{groups}} > -1));
2544
2545        push(@jids,$self->_jid($jid));
2546    }
2547    return @jids;
2548}
2549
2550
2551##############################################################################
2552#
2553# RosterDBParse - takes an iq packet that containsa roster, parses it, and puts
2554#                 the roster into the Roster DB.
2555#
2556##############################################################################
2557sub RosterDBParse
2558{
2559    my $self = shift;
2560    my ($iq) = @_;
2561
2562    #print "RosterDBParse: iq(",$iq->GetXML(),")\n";
2563
2564    my $type = $iq->GetType();
2565    return unless (($type eq "set") || ($type eq "result"));
2566
2567    my %newroster = $self->RosterParse($iq);
2568
2569    $self->RosterDBProcessParsed(%newroster);
2570}
2571
2572
2573##############################################################################
2574#
2575# RosterDBProcessParsed - takes a parsed roster and puts it into the Roster DB.
2576#
2577##############################################################################
2578sub RosterDBProcessParsed
2579{
2580    my $self = shift;
2581    my (%roster) = @_;
2582
2583    foreach my $jid (keys(%roster))
2584    {
2585        $self->RosterDBRemove($jid);
2586
2587        if ($roster{$jid}->{subscription} ne "remove")
2588        {
2589            $self->RosterDBAdd($jid, %{$roster{$jid}} );
2590        }
2591    }
2592}
2593
2594
2595##############################################################################
2596#
2597# RosterDBQuery - allows you to get one of the pieces of info from the
2598#                 Roster DB.
2599#
2600##############################################################################
2601sub RosterDBQuery
2602{
2603    my $self = shift;
2604    my $jid = shift;
2605    my $key = shift;
2606
2607    if ($jid->isa("Net::XMPP::JID"))
2608    {
2609        $jid = $jid->GetJID();
2610    }
2611   
2612    return unless $self->RosterDBExists($jid);
2613    if (defined($key))
2614    {
2615        return unless exists($self->{ROSTERDB}->{JIDS}->{$jid}->{$key});
2616        return $self->{ROSTERDB}->{JIDS}->{$jid}->{$key};
2617    }
2618    return %{$self->{ROSTERDB}->{JIDS}->{$jid}};
2619}                       
2620
2621
2622##############################################################################
2623#
2624# RosterDBRemove - removes the JID from the Roster DB.
2625#
2626##############################################################################
2627sub RosterDBRemove
2628{
2629    my $self = shift;
2630    my ($jid) = @_;
2631
2632    if ($self->RosterDBExists($jid))
2633    {
2634        if (defined($self->RosterDBQuery($jid,"groups")))
2635        {
2636            foreach my $group (@{$self->RosterDBQuery($jid,"groups")})
2637            {
2638                delete($self->{ROSTERDB}->{GROUPS}->{$group}->{$jid});
2639                delete($self->{ROSTERDB}->{GROUPS}->{$group})
2640                    if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}->{$group}})) == 0);
2641                delete($self->{ROSTERDB}->{GROUPS})
2642                    if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}})) == 0);
2643            }
2644        }
2645   
2646        delete($self->{ROSTERDB}->{JIDS}->{$jid});
2647    }
2648}
2649
2650
2651
2652
2653##############################################################################
2654#+----------------------------------------------------------------------------
2655#|
2656#| TLS Functions
2657#|
2658#+----------------------------------------------------------------------------
2659##############################################################################
2660
2661##############################################################################
2662#
2663# TLSInit - Initialize the connection for TLS.
2664#
2665##############################################################################
2666sub TLSInit
2667{
2668    my $self = shift;
2669
2670    $TLS_CALLBACK = sub{ $self->ProcessTLSStanza( @_ ) };
2671    $self->SetDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-tls").'"]'=>$TLS_CALLBACK);
2672}
2673
2674
2675##############################################################################
2676#
2677# ProcessTLSStanza - process a TLS based packet.
2678#
2679##############################################################################
2680sub ProcessTLSStanza
2681{
2682    my $self = shift;
2683    my $sid = shift;
2684    my $node = shift;
2685
2686    my $tag = &XML::Stream::XPath($node,"name()");
2687
2688    if ($tag eq "failure")
2689    {
2690        $self->TLSClientFailure($node);
2691    }
2692   
2693    if ($tag eq "proceed")
2694    {
2695        $self->TLSClientProceed($node);
2696    }
2697}
2698
2699
2700##############################################################################
2701#
2702# TLSStart - client function to have the socket start TLS.
2703#
2704##############################################################################
2705sub TLSStart
2706{
2707    my $self = shift;
2708    my $timeout = shift;
2709    $timeout = 120 unless defined($timeout);
2710    $timeout = 120 if ($timeout eq "");
2711   
2712    $self->TLSSendStartTLS();
2713
2714    my $endTime = time + $timeout;
2715    while(!$self->TLSClientDone() && ($endTime >= time))
2716    {
2717        $self->Process();
2718    }
2719
2720    if (!$self->TLSClientSecure())
2721    {
2722        return;
2723    }
2724
2725    $self->RestartStream($timeout);
2726}
2727
2728
2729##############################################################################
2730#
2731# TLSClientProceed - handle a <proceed/> packet.
2732#
2733##############################################################################
2734sub TLSClientProceed
2735{
2736    my $self = shift;
2737    my $node = shift;
2738
2739    my ($status,$message) = $self->{STREAM}->StartTLS($self->GetStreamID());
2740
2741    if ($status)
2742    {
2743        $self->{TLS}->{done} = 1;
2744        $self->{TLS}->{secure} = 1;
2745    }
2746    else
2747    {
2748        $self->{TLS}->{done} = 1;
2749        $self->{TLS}->{error} = $message;
2750    }
2751   
2752    $self->RemoveDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-tls").'"]'=>$TLS_CALLBACK);
2753}
2754
2755
2756##############################################################################
2757#
2758# TLSClientSecure - return 1 if the socket is secure, 0 otherwise.
2759#
2760##############################################################################
2761sub TLSClientSecure
2762{
2763    my $self = shift;
2764   
2765    return $self->{TLS}->{secure};
2766}
2767
2768
2769##############################################################################
2770#
2771# TLSClientDone - return 1 if the TLS process is done
2772#
2773##############################################################################
2774sub TLSClientDone
2775{
2776    my $self = shift;
2777   
2778    return $self->{TLS}->{done};
2779}
2780
2781
2782##############################################################################
2783#
2784# TLSClientError - return the TLS error if any
2785#
2786##############################################################################
2787sub TLSClientError
2788{
2789    my $self = shift;
2790   
2791    return $self->{TLS}->{error};
2792}
2793
2794
2795##############################################################################
2796#
2797# TLSClientFailure - handle a <failure/>
2798#
2799##############################################################################
2800sub TLSClientFailure
2801{
2802    my $self = shift;
2803    my $node = shift;
2804   
2805    my $type = &XML::Stream::XPath($node,"*/name()");
2806
2807    $self->{TLS}->{error} = $type;
2808    $self->{TLS}->{done} = 1;
2809}
2810
2811
2812##############################################################################
2813#
2814# TLSSendFailure - Send a <failure/> in the TLS namespace
2815#
2816##############################################################################
2817sub TLSSendFailure
2818{
2819    my $self = shift;
2820    my $type = shift;
2821   
2822    $self->Send("<failure xmlns='".&ConstXMLNS('xmpp-tls')."'><${type}/></failure>");
2823}
2824
2825
2826##############################################################################
2827#
2828# TLSSendStartTLS - send a <starttls/> in the TLS namespace.
2829#
2830##############################################################################
2831sub TLSSendStartTLS
2832{
2833    my $self = shift;
2834
2835    $self->Send("<starttls xmlns='".&ConstXMLNS('xmpp-tls')."'/>");
2836}
2837
2838
2839
2840
2841##############################################################################
2842#+----------------------------------------------------------------------------
2843#|
2844#| SASL Functions
2845#|
2846#+----------------------------------------------------------------------------
2847##############################################################################
2848
2849##############################################################################
2850#
2851# SASLInit - Initialize the connection for SASL.
2852#
2853##############################################################################
2854sub SASLInit
2855{
2856    my $self = shift;
2857
2858    $SASL_CALLBACK = sub{ $self->ProcessSASLStanza( @_ ) };
2859    $self->SetDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-sasl").'"]'=> $SASL_CALLBACK);
2860}
2861
2862
2863##############################################################################
2864#
2865# ProcessSASLStanza - process a SASL based packet.
2866#
2867##############################################################################
2868sub ProcessSASLStanza
2869{
2870    my $self = shift;
2871    my $sid = shift;
2872    my $node = shift;
2873
2874    my $tag = &XML::Stream::XPath($node,"name()");
2875
2876    if ($tag eq "challenge")
2877    {
2878        $self->SASLAnswerChallenge($node);
2879    }
2880   
2881    if ($tag eq "failure")
2882    {
2883        $self->SASLClientFailure($node);
2884    }
2885   
2886    if ($tag eq "success")
2887    {
2888        $self->SASLClientSuccess($node);
2889    }
2890}
2891
2892
2893##############################################################################
2894#
2895# SASLAnswerChallenge - when we get a <challenge/> we need to do the grunt
2896#                       work to return a <response/>.
2897#
2898##############################################################################
2899sub SASLAnswerChallenge
2900{
2901    my $self = shift;
2902    my $node = shift;
2903
2904    my $challenge64 = &XML::Stream::XPath($node,"text()");
2905    my $challenge = MIME::Base64::decode_base64($challenge64);
2906   
2907    my $response = $self->SASLGetClient()->client_step($challenge);
2908
2909    my $response64 = MIME::Base64::encode_base64($response,"");
2910    $self->SASLSendResponse($response64);
2911}
2912
2913
2914###############################################################################
2915#
2916# SASLClient - This is a helper function to perform all of the required steps
2917#              for doing SASL with the server.
2918#
2919###############################################################################
2920sub SASLClient
2921{
2922    my $self = shift;
2923    my $username = shift;
2924    my $password = shift;
2925
2926    my $mechanisms = $self->GetStreamFeature("xmpp-sasl");
2927
2928    return unless defined($mechanisms);
2929   
2930    my $sasl = new Authen::SASL(mechanism=>join(" ",@{$mechanisms}),
2931                                callback=>{ user => $username,
2932                                            pass => $password
2933                                          }
2934                               );
2935
2936    $self->{SASL}->{client} = $sasl->client_new();
2937    $self->{SASL}->{username} = $username;
2938    $self->{SASL}->{password} = $password;
2939    $self->{SASL}->{authed} = 0;
2940    $self->{SASL}->{done} = 0;
2941
2942    $self->SASLSendAuth();
2943}
2944
2945
2946##############################################################################
2947#
2948# SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise
2949#
2950##############################################################################
2951sub SASLClientAuthed
2952{
2953    my $self = shift;
2954   
2955    return $self->{SASL}->{authed};
2956}
2957
2958
2959##############################################################################
2960#
2961# SASLClientDone - return 1 if the SASL process is finished
2962#
2963##############################################################################
2964sub SASLClientDone
2965{
2966    my $self = shift;
2967   
2968    return $self->{SASL}->{done};
2969}
2970
2971
2972##############################################################################
2973#
2974# SASLClientError - return the error if any
2975#
2976##############################################################################
2977sub SASLClientError
2978{
2979    my $self = shift;
2980   
2981    return $self->{SASL}->{error};
2982}
2983
2984
2985##############################################################################
2986#
2987# SASLClientFailure - handle a received <failure/>
2988#
2989##############################################################################
2990sub SASLClientFailure
2991{
2992    my $self = shift;
2993    my $node = shift;
2994   
2995    my $type = &XML::Stream::XPath($node,"*/name()");
2996
2997    $self->{SASL}->{error} = $type;
2998    $self->{SASL}->{done} = 1;
2999}
3000
3001
3002##############################################################################
3003#
3004# SASLClientSuccess - handle a received <success/>
3005#
3006##############################################################################
3007sub SASLClientSuccess
3008{
3009    my $self = shift;
3010    my $node = shift;
3011   
3012    $self->{SASL}->{authed} = 1;
3013    $self->{SASL}->{done} = 1;
3014
3015    $self->RemoveDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-sasl").'"]'=>$SASL_CALLBACK);
3016}
3017
3018
3019###############################################################################
3020#
3021# SASLGetClient - This is a helper function to return the SASL client object.
3022#
3023###############################################################################
3024sub SASLGetClient
3025{
3026    my $self = shift;
3027   
3028    return $self->{SASL}->{client};
3029}
3030
3031
3032##############################################################################
3033#
3034# SASLSendAuth - send an <auth/> in the SASL namespace
3035#
3036##############################################################################
3037sub SASLSendAuth
3038{
3039    my $self = shift;
3040
3041    $self->Send("<auth xmlns='".&ConstXMLNS('xmpp-sasl')."' mechanism='".$self->SASLGetClient()->mechanism()."'/>");
3042}
3043
3044
3045##############################################################################
3046#
3047# SASLSendChallenge - Send a <challenge/> in the SASL namespace
3048#
3049##############################################################################
3050sub SASLSendChallenge
3051{
3052    my $self = shift;
3053    my $challenge = shift;
3054
3055    $self->Send("<challenge xmlns='".&ConstXMLNS('xmpp-sasl')."'>${challenge}</challenge>");
3056}
3057
3058
3059##############################################################################
3060#
3061# SASLSendFailure - Send a <failure/> tag in the SASL namespace
3062#
3063##############################################################################
3064sub SASLSendFailure
3065{
3066    my $self = shift;
3067    my $type = shift;
3068   
3069    $self->Send("<failure xmlns='".&ConstXMLNS('xmpp-sasl')."'><${type}/></failure>");
3070}
3071
3072
3073##############################################################################
3074#
3075# SASLSendResponse - Send a <response/> tag in the SASL namespace
3076#
3077##############################################################################
3078sub SASLSendResponse
3079{
3080    my $self = shift;
3081    my $response = shift;
3082
3083    $self->Send("<response xmlns='".&ConstXMLNS('xmpp-sasl')."'>${response}</response>");
3084}
3085
3086
3087
3088
3089##############################################################################
3090#+----------------------------------------------------------------------------
3091#|
3092#| Default CallBacks
3093#|
3094#+----------------------------------------------------------------------------
3095##############################################################################
3096
3097
3098##############################################################################
3099#
3100# callbackInit - initialize the default callbacks
3101#
3102##############################################################################
3103sub callbackInit
3104{
3105    my $self = shift;
3106
3107    $self->SetCallBacks(iq=>sub{ $self->callbackIQ(@_) },
3108                        presence=>sub{ $self->callbackPresence(@_) },
3109                        message=>sub{ $self->callbackMessage(@_) },
3110                        );
3111
3112    $self->SetPresenceCallBacks(subscribe=>sub{ $self->callbackPresenceSubscribe(@_) },
3113                                unsubscribe=>sub{ $self->callbackPresenceUnsubscribe(@_) },
3114                                subscribed=>sub{ $self->callbackPresenceSubscribed(@_) },
3115                                unsubscribed=>sub{ $self->callbackPresenceUnsubscribed(@_) },
3116                               );
3117
3118    $self->TLSInit();
3119    $self->SASLInit();
3120}
3121
3122
3123##############################################################################
3124#
3125# callbackMessage - default callback for <message/> packets.
3126#
3127##############################################################################
3128sub callbackMessage
3129{
3130    my $self = shift;
3131    my $sid = shift;
3132    my $message = shift;
3133
3134    my $type = "normal";
3135    $type = $message->GetType() if $message->DefinedType();
3136
3137    if (exists($self->{CB}->{Mess}->{$type}) &&
3138        (ref($self->{CB}->{Mess}->{$type}) eq "CODE"))
3139    {
3140        &{$self->{CB}->{Mess}->{$type}}($sid,$message);
3141    }
3142}
3143
3144
3145##############################################################################
3146#
3147# callbackPresence - default callback for <presence/> packets.
3148#
3149##############################################################################
3150sub callbackPresence
3151{
3152    my $self = shift;
3153    my $sid = shift;
3154    my $presence = shift;
3155
3156    my $type = "available";
3157    $type = $presence->GetType() if $presence->DefinedType();
3158
3159    if (exists($self->{CB}->{Pres}->{$type}) &&
3160        (ref($self->{CB}->{Pres}->{$type}) eq "CODE"))
3161    {
3162        &{$self->{CB}->{Pres}->{$type}}($sid,$presence);
3163    }
3164}
3165
3166
3167##############################################################################
3168#
3169# callbackIQ - default callback for <iq/> packets.
3170#
3171##############################################################################
3172sub callbackIQ
3173{
3174    my $self = shift;
3175    my $sid = shift;
3176    my $iq = shift;
3177
3178    return unless $iq->DefinedChild();
3179    my $query = $iq->GetChild();
3180    return unless defined($query);
3181
3182    my $type = $iq->GetType();
3183    my $ns = $query->GetXMLNS();
3184
3185    if (exists($self->{CB}->{IQns}->{$ns}) &&
3186        (ref($self->{CB}->{IQns}->{$ns}) eq "CODE"))
3187    {
3188        &{$self->{CB}->{IQns}->{$ns}}($sid,$iq);
3189
3190    }
3191    elsif (exists($self->{CB}->{IQns}->{$ns}->{$type}) &&
3192           (ref($self->{CB}->{IQns}->{$ns}->{$type}) eq "CODE"))
3193    {
3194        &{$self->{CB}->{IQns}->{$ns}->{$type}}($sid,$iq);
3195    }
3196}
3197
3198
3199##############################################################################
3200#
3201# callbackPresenceSubscribe - default callback for subscribe packets.
3202#
3203##############################################################################
3204sub callbackPresenceSubscribe
3205{
3206    my $self = shift;
3207    my $sid = shift;
3208    my $presence = shift;
3209
3210    my $reply = $presence->Reply(type=>"subscribed");
3211    $self->Send($reply,1);
3212    $reply->SetType("subscribe");
3213    $self->Send($reply,1);
3214}
3215
3216
3217##############################################################################
3218#
3219# callbackPresenceUnsubscribe - default callback for unsubscribe packets.
3220#
3221##############################################################################
3222sub callbackPresenceUnsubscribe
3223{
3224    my $self = shift;
3225    my $sid = shift;
3226    my $presence = shift;
3227
3228    my $reply = $presence->Reply(type=>"unsubscribed");
3229    $self->Send($reply,1);
3230}
3231
3232   
3233##############################################################################
3234#
3235# callbackPresenceSubscribed - default callback for subscribed packets.
3236#
3237##############################################################################
3238sub callbackPresenceSubscribed
3239{
3240    my $self = shift;
3241    my $sid = shift;
3242    my $presence = shift;
3243
3244    my $reply = $presence->Reply(type=>"subscribed");
3245    $self->Send($reply,1);
3246}
3247
3248
3249##############################################################################
3250#
3251# callbackPresenceUnsubscribed - default callback for unsubscribed packets.
3252#
3253##############################################################################
3254sub callbackPresenceUnsubscribed
3255{
3256    my $self = shift;
3257    my $sid = shift;
3258    my $presence = shift;
3259
3260    my $reply = $presence->Reply(type=>"unsubscribed");
3261    $self->Send($reply,1);
3262}
3263
3264
3265
3266##############################################################################
3267#+----------------------------------------------------------------------------
3268#|
3269#| Stream functions
3270#|
3271#+----------------------------------------------------------------------------
3272##############################################################################
3273sub GetStreamID
3274{
3275    my $self = shift;
3276
3277    return $self->{SESSION}->{id};
3278}
3279
3280
3281sub GetStreamFeature
3282{
3283    my $self = shift;
3284    my $feature = shift;
3285
3286    return $self->{STREAM}->GetStreamFeature($self->GetStreamID(),$feature);
3287}
3288
3289
3290sub RestartStream
3291{
3292    my $self = shift;
3293    my $timeout = shift;
3294
3295    $self->{SESSION} =
3296        $self->{STREAM}->OpenStream($self->GetStreamID(),$timeout);
3297    return $self->GetStreamID();
3298}
3299
3300
3301##############################################################################
3302#
3303# ConstXMLNS - Return the namespace from the constant string.
3304#
3305##############################################################################
3306sub ConstXMLNS
3307{
3308    my $const = shift;
3309   
3310    return $XMLNS{$const};
3311}
3312
3313
33141;
Note: See TracBrowser for help on using the repository browser.