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

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