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