source: perl/modules/Jabber/lib/Net/XMPP/Protocol.pm @ 54d9b42

release-1.10release-1.9
Last change on this file since 54d9b42 was a8c55b5, checked in by David Benjamin <davidben@mit.edu>, 12 years ago
Use Digest::SHA in Jabber module instead of Digest::SHA1 The cool kids spell it without the 1 these days. More precisely, Digest::SHA1 no longer exists in precise. Also it's in perl itself these days. (We can just install Digest::SHA into the locker for the sysnames that need it.)
  • Property mode set to 100644
File size: 109.1 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 );
[cb54527]76    $Con = Net::XMPP::Client->new();                  # From
[0ff8d110]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    {
[a8c55b5]1851        my $hashA = Digest::SHA::sha1_hex($password);
1852        $args{hash} = Digest::SHA::sha1_hex($hashA.$token);
[0ff8d110]1853
1854        for (1..$sequence)
1855        {
[a8c55b5]1856            $args{hash} = Digest::SHA::sha1_hex($args{hash});
[0ff8d110]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    {
[a8c55b5]1870        $args{digest} = Digest::SHA::sha1_hex($self->GetStreamID().$password);
[0ff8d110]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");
[7f33c18]1980        my $jid = $self->BindResource($args{resource});
1981        $self->{SESSION}->{FULLJID} = $jid;
[0ff8d110]1982    }
1983
1984    #-------------------------------------------------------------------------
1985    # Look in the new set of <stream:feature/>s and see if xmpp-session was
1986    # offered.
1987    #-------------------------------------------------------------------------
1988    my $session = $self->{STREAM}->GetStreamFeature($sid,"xmpp-session");
1989    if ($session)
1990    {
1991        $self->{DEBUG}->Log1("AuthSASL: Starting session");
1992        $self->StartSession();
1993    }
1994
1995    return ("ok","");
1996}
1997
1998
1999##############################################################################
2000#
2001# BindResource - bind to a resource
2002#
2003##############################################################################
2004sub BindResource
2005{
2006    my $self = shift;
2007    my $resource = shift;
2008
2009    $self->{DEBUG}->Log2("BindResource: Binding to resource");
2010    my $iq = $self->_iq();
2011
2012    $iq->SetIQ(type=>"set");
2013    my $bind = $iq->NewChild(&ConstXMLNS("xmpp-bind"));
2014   
2015    if (defined($resource) && ($resource ne ""))
2016    {
2017        $self->{DEBUG}->Log2("BindResource: resource($resource)");
2018        $bind->SetBind(resource=>$resource);
2019    }
2020
2021    my $result = $self->SendAndReceiveWithID($iq);
[7f33c18]2022    return $result->GetChild(&ConstXMLNS("xmpp-bind"))->GetJID();;
[0ff8d110]2023}
2024
2025
2026##############################################################################
2027#
2028# StartSession - Initialize a session
2029#
2030##############################################################################
2031sub StartSession
2032{
2033    my $self = shift;
2034
2035    my $iq = $self->_iq();
2036
2037    $iq->SetIQ(type=>"set");
2038    my $session = $iq->NewChild(&ConstXMLNS("xmpp-session"));
2039   
2040    my $result = $self->SendAndReceiveWithID($iq);
2041}
2042
2043
2044##############################################################################
2045#
2046# PrivacyLists - Initialize a Net::XMPP::PrivacyLists object and return it.
2047#
2048##############################################################################
2049sub PrivacyLists
2050{
2051    my $self = shift;
2052
[cb54527]2053    return Net::XMPP::PrivacyLists->new(connection=>$self);
[0ff8d110]2054}
2055
2056
2057##############################################################################
2058#
2059# PrivacyListsGet - Sends an empty IQ to the server to request that the user's
2060#                   Privacy Lists be sent to them.  Returns the iq packet
2061#                   of the result.
2062#
2063##############################################################################
2064sub PrivacyListsGet
2065{
2066    my $self = shift;
2067    my %args;
2068    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2069
2070    my $iq = $self->_iq();
2071    $iq->SetIQ(type=>"get");
2072    my $query = $iq->NewChild("jabber:iq:privacy");
2073
2074    if (exists($args{list}))
2075    {
2076        $query->AddList(name=>$args{list});
2077    }
2078
2079    $iq = $self->SendAndReceiveWithID($iq);
2080    return unless defined($iq);
2081
2082    return $iq;
2083}
2084
2085
2086##############################################################################
2087#
2088# PrivacyListsRequest - Sends an empty IQ to the server to request that the
2089#                       user's privacy lists be sent to them, and return to
2090#                       let the user's program handle parsing the return packet.
2091#
2092##############################################################################
2093sub PrivacyListsRequest
2094{
2095    my $self = shift;
2096    my %args;
2097    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2098   
2099    my $iq = $self->_iq();
2100    $iq->SetIQ(type=>"get");
2101    my $query = $iq->NewChild("jabber:iq:privacy");
2102
2103    if (exists($args{list}))
2104    {
2105        $query->AddList(name=>$args{list});
2106    }
2107
2108    $self->Send($iq);
2109}
2110
2111
2112##############################################################################
2113#
2114# PrivacyListsSet - Sends an empty IQ to the server to request that the
2115#                       user's privacy lists be sent to them, and return to
2116#                       let the user's program handle parsing the return packet.
2117#
2118##############################################################################
2119sub PrivacyListsSet
2120{
2121    my $self = shift;
2122    my %args;
2123    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2124   
2125    my $iq = $self->_iq();
2126    $iq->SetIQ(type=>"set");
2127    my $query = $iq->NewChild("jabber:iq:privacy");
2128
2129    #XXX error check that there is a list
2130    my $list = $query->AddList(name=>$args{list});
2131
2132    foreach my $item (@{$args{items}})
2133    {
2134        $list->AddItem(%{$item});
2135    }
2136
2137    $iq = $self->SendAndReceiveWithID($iq);
2138    return unless defined($iq);
2139
2140    return if $iq->DefinedError();
2141
2142    return 1;
2143}
2144
2145
2146###############################################################################
2147#
2148# RegisterRequest - This is a self contained function to send an iq tag
2149#                   an id that requests the target address to send back
2150#                   the required fields.  It waits for a reply what the
2151#                   same id to come back and tell the caller what the
2152#                   fields are.
2153#
2154###############################################################################
2155sub RegisterRequest
2156{
2157    my $self = shift;
2158    my %args;
2159    $args{mode} = "block";
2160    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2161
2162    my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef;
2163
2164    #--------------------------------------------------------------------------
2165    # Create a Net::XMPP::IQ object to send to the server
2166    #--------------------------------------------------------------------------
2167    my $iq = $self->_iq();
2168    $iq->SetIQ(to=>delete($args{to})) if exists($args{to});
2169    $iq->SetIQ(type=>"get");
2170    my $query = $iq->NewChild("jabber:iq:register");
2171
2172    #--------------------------------------------------------------------------
2173    # Send the IQ with the next available ID and wait for a reply with that
2174    # id to be received.  Then grab the IQ reply.
2175    #--------------------------------------------------------------------------
2176    if ($args{mode} eq "passthru")
2177    {
2178        my $id = $self->UniqueID();
2179        $iq->SetIQ(id=>$id);
2180        $self->Send($iq);
2181        return $id;
2182    }
2183   
2184    return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
2185
2186    $iq = $self->SendAndReceiveWithID($iq,$timeout);
2187
2188    #--------------------------------------------------------------------------
2189    # Check if there was an error.
2190    #--------------------------------------------------------------------------
2191    return unless defined($iq);
2192    if ($iq->GetType() eq "error")
2193    {
2194        $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError());
2195        return;
2196    }
2197
2198    my %register;
2199    #--------------------------------------------------------------------------
2200    # From the reply IQ determine what fields are required and send a hash
2201    # back with the fields and any values that are already defined (like key)
2202    #--------------------------------------------------------------------------
2203    $query = $iq->GetChild();
2204    $register{fields} = { $query->GetRegister() };
2205
2206    return %register;
2207}
2208
2209
2210###############################################################################
2211#
2212# RegisterSend - This is a self contained function to send a registration
2213#                iq tag with an id.  Then wait for a reply what the same
2214#                id to come back and tell the caller what the result was.
2215#
2216###############################################################################
2217sub RegisterSend
2218{
2219    my $self = shift;
2220    my %args;
2221    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2222
2223    #--------------------------------------------------------------------------
2224    # Create a Net::XMPP::IQ object to send to the server
2225    #--------------------------------------------------------------------------
2226    my $iq = $self->_iq();
2227    $iq->SetIQ(to=>delete($args{to})) if exists($args{to});
2228    $iq->SetIQ(type=>"set");
2229    my $iqRegister = $iq->NewChild("jabber:iq:register");
2230    $iqRegister->SetRegister(%args);
2231
2232    #--------------------------------------------------------------------------
2233    # Send the IQ with the next available ID and wait for a reply with that
2234    # id to be received.  Then grab the IQ reply.
2235    #--------------------------------------------------------------------------
2236    $iq = $self->SendAndReceiveWithID($iq);
2237
2238    #--------------------------------------------------------------------------
2239    # From the reply IQ determine if we were successful or not.  If yes then
2240    # return "".  If no then return error string from the reply.
2241    #--------------------------------------------------------------------------
2242    return unless defined($iq);
2243    return ( $iq->GetErrorCode() , $iq->GetError() )
2244        if ($iq->GetType() eq "error");
2245    return ("ok","");
2246}
2247
2248
2249##############################################################################
2250#
2251# RosterAdd - Takes the Jabber ID of the user to add to their Roster and
2252#             sends the IQ packet to the server.
2253#
2254##############################################################################
2255sub RosterAdd
2256{
2257    my $self = shift;
2258    my %args;
2259    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2260
2261    my $iq = $self->_iq();
2262    $iq->SetIQ(type=>"set");
2263    my $roster = $iq->NewChild("jabber:iq:roster");
2264    my $item = $roster->AddItem();
2265    $item->SetItem(%args);
2266
2267    $self->{DEBUG}->Log1("RosterAdd: xml(",$iq->GetXML(),")");
2268    $self->Send($iq);
2269}
2270
2271
2272##############################################################################
2273#
2274# RosterAdd - Takes the Jabber ID of the user to remove from their Roster
2275#             and sends the IQ packet to the server.
2276#
2277##############################################################################
2278sub RosterRemove
2279{
2280    my $self = shift;
2281    my %args;
2282    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
2283    delete($args{subscription});
2284
2285    my $iq = $self->_iq();
2286    $iq->SetIQ(type=>"set");
2287    my $roster = $iq->NewChild("jabber:iq:roster");
2288    my $item = $roster->AddItem();
2289    $item->SetItem(%args,
2290                   subscription=>"remove");
2291    $self->Send($iq);
2292}
2293
2294
2295##############################################################################
2296#
2297# RosterParse - Returns a hash of roster items.
2298#
2299##############################################################################
2300sub RosterParse
2301{
2302    my $self = shift;
2303    my($iq) = @_;
2304
2305    my %roster;
2306    my $query = $iq->GetChild("jabber:iq:roster");
2307
2308    if (defined($query)) #$query->GetXMLNS() eq "jabber:iq:roster")
2309    {
2310        my @items = $query->GetItems();
2311
2312        foreach my $item (@items)
2313        {
2314            my $jid = $item->GetJID();
2315            $roster{$jid}->{name} = $item->GetName();
2316            $roster{$jid}->{subscription} = $item->GetSubscription();
2317            $roster{$jid}->{ask} = $item->GetAsk();
2318            $roster{$jid}->{groups} = [ $item->GetGroup() ];
2319        }
2320    }
2321
2322    return %roster;
2323}
2324
2325
2326##############################################################################
2327#
2328# RosterGet - Sends an empty IQ to the server to request that the user's
2329#             Roster be sent to them.  Returns a hash of roster items.
2330#
2331##############################################################################
2332sub RosterGet
2333{
2334    my $self = shift;
2335
2336    my $iq = $self->_iq();
2337    $iq->SetIQ(type=>"get");
2338    my $query = $iq->NewChild("jabber:iq:roster");
2339
2340    $iq = $self->SendAndReceiveWithID($iq);
2341
2342    return unless defined($iq);
2343
2344    return $self->RosterParse($iq);
2345}
2346
2347
2348##############################################################################
2349#
2350# RosterRequest - Sends an empty IQ to the server to request that the user's
2351#                 Roster be sent to them, and return to let the user's program
2352#                 handle parsing the return packet.
2353#
2354##############################################################################
2355sub RosterRequest
2356{
2357    my $self = shift;
2358
2359    my $iq = $self->_iq();
2360    $iq->SetIQ(type=>"get");
2361    my $query = $iq->NewChild("jabber:iq:roster");
2362
2363    $self->Send($iq);
2364}
2365
2366
2367##############################################################################
2368#
2369# Roster - Initialize a Net::XMPP::Roster object and return it.
2370#
2371##############################################################################
2372sub Roster
2373{
2374    my $self = shift;
2375
[cb54527]2376    return Net::XMPP::Roster->new(connection=>$self);
[0ff8d110]2377}
2378
2379
2380##############################################################################
2381#
2382# RosterDB - initialize the module to use the roster database
2383#
2384##############################################################################
2385sub RosterDB
2386{
2387    my $self = shift;
2388
2389    $self->SetXPathCallBacks('/iq[@type="result" or @type="set"]/query[@xmlns="jabber:iq:roster"]'=>sub{ shift; $self->RosterDBParse(@_) });
2390}
2391
2392
2393##############################################################################
2394#
2395# RosterDBAdd - adds the entry to the Roster DB.
2396#
2397##############################################################################
2398sub RosterDBAdd
2399{
2400    my $self = shift;
2401    my ($jid,%item) = @_;
2402
2403    $self->{ROSTERDB}->{JIDS}->{$jid} = \%item;
2404
2405    foreach my $group (@{$item{groups}})
2406    {
2407        $self->{ROSTERDB}->{GROUPS}->{$group}->{$jid} = 1;
2408    }
2409}
2410
2411
2412###############################################################################
2413#
2414# RosterDBClear - delete all of the JIDs from the DB completely.
2415#
2416###############################################################################
2417sub RosterDBClear
2418{
2419    my $self = shift;
2420
2421    $self->{DEBUG}->Log1("RosterDBClear: clearing the database");
2422    foreach my $jid ($self->RosterDBJIDs())
2423    {
2424        $self->{DEBUG}->Log3("RosterDBClear: deleting ",$jid->GetJID()," from the DB");
2425        $self->RosterDBRemove($jid);
2426    }
2427    $self->{DEBUG}->Log3("RosterDBClear: database is empty");
2428}
2429
2430
2431##############################################################################
2432#
2433# RosterDBExists - allows you to query if the JID exists in the Roster DB.
2434#
2435##############################################################################
2436sub RosterDBExists
2437{
2438    my $self = shift;
2439    my ($jid) = @_;
2440
2441    if ($jid->isa("Net::XMPP::JID"))
2442    {
2443        $jid = $jid->GetJID();
2444    }
2445   
2446    return unless exists($self->{ROSTERDB});
2447    return unless exists($self->{ROSTERDB}->{JIDS});
2448    return unless exists($self->{ROSTERDB}->{JIDS}->{$jid});
2449    return 1;
2450}
2451
2452
2453##############################################################################
2454#
2455# RosterDBGroupExists - allows you to query if the group exists in the Roster
2456#                       DB.
2457#
2458##############################################################################
2459sub RosterDBGroupExists
2460{
2461    my $self = shift;
2462    my ($group) = @_;
2463
2464    return unless exists($self->{ROSTERDB});
2465    return unless exists($self->{ROSTERDB}->{GROUPS});
2466    return unless exists($self->{ROSTERDB}->{GROUPS}->{$group});
2467    return 1;
2468}
2469
2470
2471##############################################################################
2472#
2473# RosterDBGroupJIDs - returns a list of the current groups in your roster.
2474#
2475##############################################################################
2476sub RosterDBGroupJIDs
2477{
2478    my $self = shift;
2479    my $group = shift;
2480
2481    return unless $self->RosterDBGroupExists($group);
2482    my @jids;
2483    foreach my $jid (keys(%{$self->{ROSTERDB}->{GROUPS}->{$group}}))
2484    {
2485        push(@jids,$self->_jid($jid));
2486    }
2487    return @jids;
2488}
2489
2490
2491##############################################################################
2492#
2493# RosterDBGroups - returns a list of the current groups in your roster.
2494#
2495##############################################################################
2496sub RosterDBGroups
2497{
2498    my $self = shift;
2499
2500    return () unless exists($self->{ROSTERDB}->{GROUPS});
2501    return () if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}})) == 0);
2502    return keys(%{$self->{ROSTERDB}->{GROUPS}});
2503}
2504
2505
2506##############################################################################
2507#
2508# RosterDBJIDs - returns a list of all of the JIDs in your roster.
2509#
2510##############################################################################
2511sub RosterDBJIDs
2512{
2513    my $self = shift;
2514    my $group = shift;
2515
2516    my @jids;
2517
2518    return () unless exists($self->{ROSTERDB});
2519    return () unless exists($self->{ROSTERDB}->{JIDS});
2520    foreach my $jid (keys(%{$self->{ROSTERDB}->{JIDS}}))
2521    {
2522        push(@jids,$self->_jid($jid));
2523    }
2524    return @jids;
2525}
2526
2527
2528##############################################################################
2529#
2530# RosterDBNonGroupJIDs - returns a list of the JIDs not in a group.
2531#
2532##############################################################################
2533sub RosterDBNonGroupJIDs
2534{
2535    my $self = shift;
2536    my $group = shift;
2537
2538    my @jids;
2539
2540    return () unless exists($self->{ROSTERDB});
2541    return () unless exists($self->{ROSTERDB}->{JIDS});
2542    foreach my $jid (keys(%{$self->{ROSTERDB}->{JIDS}}))
2543    {
2544        next if (exists($self->{ROSTERDB}->{JIDS}->{$jid}->{groups}) &&
2545                 ($#{$self->{ROSTERDB}->{JIDS}->{$jid}->{groups}} > -1));
2546
2547        push(@jids,$self->_jid($jid));
2548    }
2549    return @jids;
2550}
2551
2552
2553##############################################################################
2554#
2555# RosterDBParse - takes an iq packet that containsa roster, parses it, and puts
2556#                 the roster into the Roster DB.
2557#
2558##############################################################################
2559sub RosterDBParse
2560{
2561    my $self = shift;
2562    my ($iq) = @_;
2563
2564    #print "RosterDBParse: iq(",$iq->GetXML(),")\n";
2565
2566    my $type = $iq->GetType();
2567    return unless (($type eq "set") || ($type eq "result"));
2568
2569    my %newroster = $self->RosterParse($iq);
2570
2571    $self->RosterDBProcessParsed(%newroster);
2572}
2573
2574
2575##############################################################################
2576#
2577# RosterDBProcessParsed - takes a parsed roster and puts it into the Roster DB.
2578#
2579##############################################################################
2580sub RosterDBProcessParsed
2581{
2582    my $self = shift;
2583    my (%roster) = @_;
2584
2585    foreach my $jid (keys(%roster))
2586    {
2587        $self->RosterDBRemove($jid);
2588
2589        if ($roster{$jid}->{subscription} ne "remove")
2590        {
2591            $self->RosterDBAdd($jid, %{$roster{$jid}} );
2592        }
2593    }
2594}
2595
2596
2597##############################################################################
2598#
2599# RosterDBQuery - allows you to get one of the pieces of info from the
2600#                 Roster DB.
2601#
2602##############################################################################
2603sub RosterDBQuery
2604{
2605    my $self = shift;
2606    my $jid = shift;
2607    my $key = shift;
2608
2609    if ($jid->isa("Net::XMPP::JID"))
2610    {
2611        $jid = $jid->GetJID();
2612    }
2613   
2614    return unless $self->RosterDBExists($jid);
2615    if (defined($key))
2616    {
2617        return unless exists($self->{ROSTERDB}->{JIDS}->{$jid}->{$key});
2618        return $self->{ROSTERDB}->{JIDS}->{$jid}->{$key};
2619    }
2620    return %{$self->{ROSTERDB}->{JIDS}->{$jid}};
2621}                       
2622
2623
2624##############################################################################
2625#
2626# RosterDBRemove - removes the JID from the Roster DB.
2627#
2628##############################################################################
2629sub RosterDBRemove
2630{
2631    my $self = shift;
2632    my ($jid) = @_;
2633
2634    if ($self->RosterDBExists($jid))
2635    {
2636        if (defined($self->RosterDBQuery($jid,"groups")))
2637        {
2638            foreach my $group (@{$self->RosterDBQuery($jid,"groups")})
2639            {
2640                delete($self->{ROSTERDB}->{GROUPS}->{$group}->{$jid});
2641                delete($self->{ROSTERDB}->{GROUPS}->{$group})
2642                    if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}->{$group}})) == 0);
2643                delete($self->{ROSTERDB}->{GROUPS})
2644                    if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}})) == 0);
2645            }
2646        }
2647   
2648        delete($self->{ROSTERDB}->{JIDS}->{$jid});
2649    }
2650}
2651
2652
2653
2654
2655##############################################################################
2656#+----------------------------------------------------------------------------
2657#|
2658#| TLS Functions
2659#|
2660#+----------------------------------------------------------------------------
2661##############################################################################
2662
2663##############################################################################
2664#
2665# TLSInit - Initialize the connection for TLS.
2666#
2667##############################################################################
2668sub TLSInit
2669{
2670    my $self = shift;
2671
2672    $TLS_CALLBACK = sub{ $self->ProcessTLSStanza( @_ ) };
2673    $self->SetDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-tls").'"]'=>$TLS_CALLBACK);
2674}
2675
2676
2677##############################################################################
2678#
2679# ProcessTLSStanza - process a TLS based packet.
2680#
2681##############################################################################
2682sub ProcessTLSStanza
2683{
2684    my $self = shift;
2685    my $sid = shift;
2686    my $node = shift;
2687
2688    my $tag = &XML::Stream::XPath($node,"name()");
2689
2690    if ($tag eq "failure")
2691    {
2692        $self->TLSClientFailure($node);
2693    }
2694   
2695    if ($tag eq "proceed")
2696    {
2697        $self->TLSClientProceed($node);
2698    }
2699}
2700
2701
2702##############################################################################
2703#
2704# TLSStart - client function to have the socket start TLS.
2705#
2706##############################################################################
2707sub TLSStart
2708{
2709    my $self = shift;
2710    my $timeout = shift;
2711    $timeout = 120 unless defined($timeout);
2712    $timeout = 120 if ($timeout eq "");
2713   
2714    $self->TLSSendStartTLS();
2715
2716    my $endTime = time + $timeout;
2717    while(!$self->TLSClientDone() && ($endTime >= time))
2718    {
2719        $self->Process();
2720    }
2721
2722    if (!$self->TLSClientSecure())
2723    {
2724        return;
2725    }
2726
2727    $self->RestartStream($timeout);
2728}
2729
2730
2731##############################################################################
2732#
2733# TLSClientProceed - handle a <proceed/> packet.
2734#
2735##############################################################################
2736sub TLSClientProceed
2737{
2738    my $self = shift;
2739    my $node = shift;
2740
2741    my ($status,$message) = $self->{STREAM}->StartTLS($self->GetStreamID());
2742
2743    if ($status)
2744    {
2745        $self->{TLS}->{done} = 1;
2746        $self->{TLS}->{secure} = 1;
2747    }
2748    else
2749    {
2750        $self->{TLS}->{done} = 1;
2751        $self->{TLS}->{error} = $message;
2752    }
2753   
2754    $self->RemoveDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-tls").'"]'=>$TLS_CALLBACK);
2755}
2756
2757
2758##############################################################################
2759#
2760# TLSClientSecure - return 1 if the socket is secure, 0 otherwise.
2761#
2762##############################################################################
2763sub TLSClientSecure
2764{
2765    my $self = shift;
2766   
2767    return $self->{TLS}->{secure};
2768}
2769
2770
2771##############################################################################
2772#
2773# TLSClientDone - return 1 if the TLS process is done
2774#
2775##############################################################################
2776sub TLSClientDone
2777{
2778    my $self = shift;
2779   
2780    return $self->{TLS}->{done};
2781}
2782
2783
2784##############################################################################
2785#
2786# TLSClientError - return the TLS error if any
2787#
2788##############################################################################
2789sub TLSClientError
2790{
2791    my $self = shift;
2792   
2793    return $self->{TLS}->{error};
2794}
2795
2796
2797##############################################################################
2798#
2799# TLSClientFailure - handle a <failure/>
2800#
2801##############################################################################
2802sub TLSClientFailure
2803{
2804    my $self = shift;
2805    my $node = shift;
2806   
2807    my $type = &XML::Stream::XPath($node,"*/name()");
2808
2809    $self->{TLS}->{error} = $type;
2810    $self->{TLS}->{done} = 1;
2811}
2812
2813
2814##############################################################################
2815#
2816# TLSSendFailure - Send a <failure/> in the TLS namespace
2817#
2818##############################################################################
2819sub TLSSendFailure
2820{
2821    my $self = shift;
2822    my $type = shift;
2823   
2824    $self->Send("<failure xmlns='".&ConstXMLNS('xmpp-tls')."'><${type}/></failure>");
2825}
2826
2827
2828##############################################################################
2829#
2830# TLSSendStartTLS - send a <starttls/> in the TLS namespace.
2831#
2832##############################################################################
2833sub TLSSendStartTLS
2834{
2835    my $self = shift;
2836
2837    $self->Send("<starttls xmlns='".&ConstXMLNS('xmpp-tls')."'/>");
2838}
2839
2840
2841
2842
2843##############################################################################
2844#+----------------------------------------------------------------------------
2845#|
2846#| SASL Functions
2847#|
2848#+----------------------------------------------------------------------------
2849##############################################################################
2850
2851##############################################################################
2852#
2853# SASLInit - Initialize the connection for SASL.
2854#
2855##############################################################################
2856sub SASLInit
2857{
2858    my $self = shift;
2859
2860    $SASL_CALLBACK = sub{ $self->ProcessSASLStanza( @_ ) };
2861    $self->SetDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-sasl").'"]'=> $SASL_CALLBACK);
2862}
2863
2864
2865##############################################################################
2866#
2867# ProcessSASLStanza - process a SASL based packet.
2868#
2869##############################################################################
2870sub ProcessSASLStanza
2871{
2872    my $self = shift;
2873    my $sid = shift;
2874    my $node = shift;
2875
2876    my $tag = &XML::Stream::XPath($node,"name()");
2877
2878    if ($tag eq "challenge")
2879    {
2880        $self->SASLAnswerChallenge($node);
2881    }
2882   
2883    if ($tag eq "failure")
2884    {
2885        $self->SASLClientFailure($node);
2886    }
2887   
2888    if ($tag eq "success")
2889    {
2890        $self->SASLClientSuccess($node);
2891    }
2892}
2893
2894
2895##############################################################################
2896#
2897# SASLAnswerChallenge - when we get a <challenge/> we need to do the grunt
2898#                       work to return a <response/>.
2899#
2900##############################################################################
2901sub SASLAnswerChallenge
2902{
2903    my $self = shift;
2904    my $node = shift;
2905
2906    my $challenge64 = &XML::Stream::XPath($node,"text()");
2907    my $challenge = MIME::Base64::decode_base64($challenge64);
2908   
2909    my $response = $self->SASLGetClient()->client_step($challenge);
2910
2911    my $response64 = MIME::Base64::encode_base64($response,"");
2912    $self->SASLSendResponse($response64);
2913}
2914
2915
2916###############################################################################
2917#
2918# SASLClient - This is a helper function to perform all of the required steps
2919#              for doing SASL with the server.
2920#
2921###############################################################################
2922sub SASLClient
2923{
2924    my $self = shift;
2925    my $username = shift;
2926    my $password = shift;
2927
2928    my $mechanisms = $self->GetStreamFeature("xmpp-sasl");
2929
2930    return unless defined($mechanisms);
2931   
2932    my $sasl = new Authen::SASL(mechanism=>join(" ",@{$mechanisms}),
2933                                callback=>{ user => $username,
2934                                            pass => $password
2935                                          }
2936                               );
2937
2938    $self->{SASL}->{client} = $sasl->client_new();
2939    $self->{SASL}->{username} = $username;
2940    $self->{SASL}->{password} = $password;
2941    $self->{SASL}->{authed} = 0;
2942    $self->{SASL}->{done} = 0;
2943
2944    $self->SASLSendAuth();
2945}
2946
2947
2948##############################################################################
2949#
2950# SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise
2951#
2952##############################################################################
2953sub SASLClientAuthed
2954{
2955    my $self = shift;
2956   
2957    return $self->{SASL}->{authed};
2958}
2959
2960
2961##############################################################################
2962#
2963# SASLClientDone - return 1 if the SASL process is finished
2964#
2965##############################################################################
2966sub SASLClientDone
2967{
2968    my $self = shift;
2969   
2970    return $self->{SASL}->{done};
2971}
2972
2973
2974##############################################################################
2975#
2976# SASLClientError - return the error if any
2977#
2978##############################################################################
2979sub SASLClientError
2980{
2981    my $self = shift;
2982   
2983    return $self->{SASL}->{error};
2984}
2985
2986
2987##############################################################################
2988#
2989# SASLClientFailure - handle a received <failure/>
2990#
2991##############################################################################
2992sub SASLClientFailure
2993{
2994    my $self = shift;
2995    my $node = shift;
2996   
2997    my $type = &XML::Stream::XPath($node,"*/name()");
2998
2999    $self->{SASL}->{error} = $type;
3000    $self->{SASL}->{done} = 1;
3001}
3002
3003
3004##############################################################################
3005#
3006# SASLClientSuccess - handle a received <success/>
3007#
3008##############################################################################
3009sub SASLClientSuccess
3010{
3011    my $self = shift;
3012    my $node = shift;
3013   
3014    $self->{SASL}->{authed} = 1;
3015    $self->{SASL}->{done} = 1;
3016
3017    $self->RemoveDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-sasl").'"]'=>$SASL_CALLBACK);
3018}
3019
3020
3021###############################################################################
3022#
3023# SASLGetClient - This is a helper function to return the SASL client object.
3024#
3025###############################################################################
3026sub SASLGetClient
3027{
3028    my $self = shift;
3029   
3030    return $self->{SASL}->{client};
3031}
3032
3033
3034##############################################################################
3035#
3036# SASLSendAuth - send an <auth/> in the SASL namespace
3037#
3038##############################################################################
3039sub SASLSendAuth
3040{
3041    my $self = shift;
3042
3043    $self->Send("<auth xmlns='".&ConstXMLNS('xmpp-sasl')."' mechanism='".$self->SASLGetClient()->mechanism()."'/>");
3044}
3045
3046
3047##############################################################################
3048#
3049# SASLSendChallenge - Send a <challenge/> in the SASL namespace
3050#
3051##############################################################################
3052sub SASLSendChallenge
3053{
3054    my $self = shift;
3055    my $challenge = shift;
3056
3057    $self->Send("<challenge xmlns='".&ConstXMLNS('xmpp-sasl')."'>${challenge}</challenge>");
3058}
3059
3060
3061##############################################################################
3062#
3063# SASLSendFailure - Send a <failure/> tag in the SASL namespace
3064#
3065##############################################################################
3066sub SASLSendFailure
3067{
3068    my $self = shift;
3069    my $type = shift;
3070   
3071    $self->Send("<failure xmlns='".&ConstXMLNS('xmpp-sasl')."'><${type}/></failure>");
3072}
3073
3074
3075##############################################################################
3076#
3077# SASLSendResponse - Send a <response/> tag in the SASL namespace
3078#
3079##############################################################################
3080sub SASLSendResponse
3081{
3082    my $self = shift;
3083    my $response = shift;
3084
3085    $self->Send("<response xmlns='".&ConstXMLNS('xmpp-sasl')."'>${response}</response>");
3086}
3087
3088
3089
3090
3091##############################################################################
3092#+----------------------------------------------------------------------------
3093#|
3094#| Default CallBacks
3095#|
3096#+----------------------------------------------------------------------------
3097##############################################################################
3098
3099
3100##############################################################################
3101#
3102# callbackInit - initialize the default callbacks
3103#
3104##############################################################################
3105sub callbackInit
3106{
3107    my $self = shift;
3108
3109    $self->SetCallBacks(iq=>sub{ $self->callbackIQ(@_) },
3110                        presence=>sub{ $self->callbackPresence(@_) },
3111                        message=>sub{ $self->callbackMessage(@_) },
3112                        );
3113
3114    $self->SetPresenceCallBacks(subscribe=>sub{ $self->callbackPresenceSubscribe(@_) },
3115                                unsubscribe=>sub{ $self->callbackPresenceUnsubscribe(@_) },
3116                                subscribed=>sub{ $self->callbackPresenceSubscribed(@_) },
3117                                unsubscribed=>sub{ $self->callbackPresenceUnsubscribed(@_) },
3118                               );
3119
3120    $self->TLSInit();
3121    $self->SASLInit();
3122}
3123
3124
3125##############################################################################
3126#
3127# callbackMessage - default callback for <message/> packets.
3128#
3129##############################################################################
3130sub callbackMessage
3131{
3132    my $self = shift;
3133    my $sid = shift;
3134    my $message = shift;
3135
3136    my $type = "normal";
3137    $type = $message->GetType() if $message->DefinedType();
3138
3139    if (exists($self->{CB}->{Mess}->{$type}) &&
3140        (ref($self->{CB}->{Mess}->{$type}) eq "CODE"))
3141    {
3142        &{$self->{CB}->{Mess}->{$type}}($sid,$message);
3143    }
3144}
3145
3146
3147##############################################################################
3148#
3149# callbackPresence - default callback for <presence/> packets.
3150#
3151##############################################################################
3152sub callbackPresence
3153{
3154    my $self = shift;
3155    my $sid = shift;
3156    my $presence = shift;
3157
3158    my $type = "available";
3159    $type = $presence->GetType() if $presence->DefinedType();
3160
3161    if (exists($self->{CB}->{Pres}->{$type}) &&
3162        (ref($self->{CB}->{Pres}->{$type}) eq "CODE"))
3163    {
3164        &{$self->{CB}->{Pres}->{$type}}($sid,$presence);
3165    }
3166}
3167
3168
3169##############################################################################
3170#
3171# callbackIQ - default callback for <iq/> packets.
3172#
3173##############################################################################
3174sub callbackIQ
3175{
3176    my $self = shift;
3177    my $sid = shift;
3178    my $iq = shift;
3179
3180    return unless $iq->DefinedChild();
3181    my $query = $iq->GetChild();
3182    return unless defined($query);
3183
3184    my $type = $iq->GetType();
3185    my $ns = $query->GetXMLNS();
3186
3187    if (exists($self->{CB}->{IQns}->{$ns}) &&
3188        (ref($self->{CB}->{IQns}->{$ns}) eq "CODE"))
3189    {
3190        &{$self->{CB}->{IQns}->{$ns}}($sid,$iq);
3191
3192    }
3193    elsif (exists($self->{CB}->{IQns}->{$ns}->{$type}) &&
3194           (ref($self->{CB}->{IQns}->{$ns}->{$type}) eq "CODE"))
3195    {
3196        &{$self->{CB}->{IQns}->{$ns}->{$type}}($sid,$iq);
3197    }
3198}
3199
3200
3201##############################################################################
3202#
3203# callbackPresenceSubscribe - default callback for subscribe packets.
3204#
3205##############################################################################
3206sub callbackPresenceSubscribe
3207{
3208    my $self = shift;
3209    my $sid = shift;
3210    my $presence = shift;
3211
3212    my $reply = $presence->Reply(type=>"subscribed");
3213    $self->Send($reply,1);
3214    $reply->SetType("subscribe");
3215    $self->Send($reply,1);
3216}
3217
3218
3219##############################################################################
3220#
3221# callbackPresenceUnsubscribe - default callback for unsubscribe packets.
3222#
3223##############################################################################
3224sub callbackPresenceUnsubscribe
3225{
3226    my $self = shift;
3227    my $sid = shift;
3228    my $presence = shift;
3229
3230    my $reply = $presence->Reply(type=>"unsubscribed");
3231    $self->Send($reply,1);
3232}
3233
3234   
3235##############################################################################
3236#
3237# callbackPresenceSubscribed - default callback for subscribed packets.
3238#
3239##############################################################################
3240sub callbackPresenceSubscribed
3241{
3242    my $self = shift;
3243    my $sid = shift;
3244    my $presence = shift;
3245
3246    my $reply = $presence->Reply(type=>"subscribed");
3247    $self->Send($reply,1);
3248}
3249
3250
3251##############################################################################
3252#
3253# callbackPresenceUnsubscribed - default callback for unsubscribed packets.
3254#
3255##############################################################################
3256sub callbackPresenceUnsubscribed
3257{
3258    my $self = shift;
3259    my $sid = shift;
3260    my $presence = shift;
3261
3262    my $reply = $presence->Reply(type=>"unsubscribed");
3263    $self->Send($reply,1);
3264}
3265
3266
3267
3268##############################################################################
3269#+----------------------------------------------------------------------------
3270#|
3271#| Stream functions
3272#|
3273#+----------------------------------------------------------------------------
3274##############################################################################
3275sub GetStreamID
3276{
3277    my $self = shift;
3278
3279    return $self->{SESSION}->{id};
3280}
3281
3282
3283sub GetStreamFeature
3284{
3285    my $self = shift;
3286    my $feature = shift;
3287
3288    return $self->{STREAM}->GetStreamFeature($self->GetStreamID(),$feature);
3289}
3290
3291
3292sub RestartStream
3293{
3294    my $self = shift;
3295    my $timeout = shift;
3296
3297    $self->{SESSION} =
3298        $self->{STREAM}->OpenStream($self->GetStreamID(),$timeout);
3299    return $self->GetStreamID();
3300}
3301
3302
3303##############################################################################
3304#
3305# ConstXMLNS - Return the namespace from the constant string.
3306#
3307##############################################################################
3308sub ConstXMLNS
3309{
3310    my $const = shift;
3311   
3312    return $XMLNS{$const};
3313}
3314
3315
33161;
Note: See TracBrowser for help on using the repository browser.