File Coverage

blib/lib/Net/XMPP/Protocol.pm
Criterion Covered Total %
statement 88 950 9.2
branch 3 304 0.9
condition 0 69 0.0
subroutine 24 133 18.0
pod 47 104 45.1
total 162 1560 10.3


line stmt bran cond sub pod time code
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              
22             package Net::XMPP::Protocol;
23              
24             =head1 NAME
25              
26             Net::XMPP::Protocol - XMPP Protocol Module
27              
28             =head1 SYNOPSIS
29              
30             Net::XMPP::Protocol is a module that provides a developer easy
31             access to the XMPP Instant Messaging protocol. It provides high
32             level functions to the Net::XMPP Client object. These functions are
33             inherited by that modules.
34              
35             =head1 DESCRIPTION
36              
37             Protocol.pm seeks to provide enough high level APIs and automation of
38             the low level APIs that writing a XMPP Client in Perl is trivial. For
39             those that wish to work with the low level you can do that too, but
40             those functions are covered in the documentation for each module.
41              
42             Net::XMPP::Protocol provides functions to login, send and receive
43             messages, set personal information, create a new user account, manage
44             the roster, and disconnect. You can use all or none of the functions,
45             there is no requirement.
46              
47             For more information on how the details for how L is written
48             please see the help for Net::XMPP itself.
49              
50             For more information on writing a Client see L.
51              
52             =head2 Modes
53              
54             Several of the functions take a mode argument that let you specify how
55             the function should behave:
56              
57             =over 4
58              
59             =item block
60              
61             send the packet with an ID, and then block until an answer
62             comes back. You can optionally specify a timeout so that
63             you do not block forever.
64              
65             =item nonblock
66              
67             send the packet with an ID, but then return that id and
68             control to the master program. Net::XMPP is still
69             tracking this packet, so you must use the CheckID function
70             to tell when it comes in. (This might not be very
71             useful...)
72              
73             =item passthru
74              
75             send the packet with an ID, but do NOT register it with
76             Net::XMPP, then return the ID. This is useful when
77             combined with the XPath function because you can register
78             a 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("XML");
130              
131             $Con->Send($object,1);
132             $Con->Send("XML",1);
133              
134             $Con->Disconnect();
135              
136             =head2 ID Functions
137              
138             $id = $Con->SendWithID($sendObj);
139             $id = $Con->SendWithID("XML");
140             $receiveObj = $Con->SendAndReceiveWithID($sendObj);
141             $receiveObj = $Con->SendAndReceiveWithID($sendObj,
142             10);
143             $receiveObj = $Con->SendAndReceiveWithID("XML");
144             $receiveObj = $Con->SendAndReceiveWithID("XML",
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              
286             returns a string that will hopefully contain some
287             useful information about why a function returned
288             an undef to you.
289              
290             =item SetErrorCode
291              
292             SetErrorCode(string)
293              
294             set a useful error message before you return
295             an 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              
307             sets the callback functions for
308             the top level tags listed. The
309             available tags to look for are
310             , , and
311             . If a packet is received
312             with an ID which is found in the
313             registered ID list (see RegisterID
314             below) then it is not sent to
315             these functions, instead it
316             is inserted into a LIST and can
317             be retrieved by some functions
318             we will mention later.
319              
320             send and receive are used to
321             log what XML is sent and received.
322             update is used as way to update
323             your program while waiting for
324             a packet with an ID to be
325             returned (useful for GUI apps).
326              
327             A major change that came with
328             the last release is that the
329             session id is passed to the
330             callback as the first argument.
331             This was done to facilitate
332             the Server module.
333              
334             The next argument depends on
335             which callback you are talking
336             about. message, presence, and iq
337             all get passed in Net::XMPP
338             objects that match those types.
339             send and receive get passed in
340             strings. update gets passed
341             nothing, not even the session id.
342              
343             If you set the function to undef,
344             then the callback is removed from
345             the list.
346              
347             =item SetPresenceCallBacks
348              
349             SetPresenceCallBacks(type=>function etc...)
350              
351             sets the callback functions for
352             the specified presence type.
353             The function takes types as the
354             main key, and lets you specify
355             a function for each type of
356             packet you can get.
357              
358             "available"
359             "unavailable"
360             "subscribe"
361             "unsubscribe"
362             "subscribed"
363             "unsubscribed"
364             "probe"
365             "error"
366              
367             When it gets a
368             packet it checks the type=''
369             for a defined callback. If
370             there is one then it calls the
371             function with two arguments:
372              
373             the session ID, and the
374             Net::XMPP::Presence object.
375              
376             If you set the function to
377             undef, then the callback is
378             removed from the list.
379              
380             NOTE: If you use this, which is a cleaner method,
381             then you must *NOT* specify a callback for
382             presence 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              
403             sets the callback functions for
404             the specified message type. The
405             function takes types as the
406             main key, and lets you specify
407             a function for each type of
408             packet you can get.
409              
410             "normal"
411             "chat"
412             "groupchat"
413             "headline"
414             "error"
415              
416             When it gets a packet
417             it checks the type='' for a
418             defined callback. If there is
419             one then it calls the function
420             with two arguments:
421              
422             the session ID, and the
423             Net::XMPP::Message object.
424              
425             If you set the function to
426             undef, then the callback is
427             removed from the list.
428              
429             NOTE: If you use this, which is a cleaner method,
430             then you must *NOT* specify a callback for
431             message 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              
443             sets the callback functions for
444             the specified namespace. The
445             function takes namespaces as the
446             main key, and lets you specify a
447             function for each type of packet
448             you can get.
449              
450             "get"
451             "set"
452             "result"
453              
454             When it gets an packet it
455             checks the type='' and the
456             xmlns='' for a defined callback.
457             If there is one then it calls
458             the function with two arguments:
459             the session ID, and the
460             Net::XMPP::xxxx object.
461              
462             If you set the function to undef,
463             then the callback is removed from
464             the list.
465              
466             NOTE: If you use this, which is a cleaner method,
467             then you must *NOT* specify a callback for
468             iq in the SetCallBacks function.
469              
470             =item SetXPathCallBacks
471              
472              
473             SetXPathCallBacks(xpath=>function, etc...)
474              
475             registers a callback function
476             for each xpath specified. If
477             Net::XMPP matches the xpath,
478             then it calls the function with
479             two arguments:
480              
481             the session ID, and the
482             Net::XMPP::Message object.
483              
484             Xpaths are rooted at each
485             packet:
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              
496             unregisters a callback
497             function for each xpath
498             specified.
499              
500             =item SetDirectXPathCallBacks
501              
502             SetDirectXPathCallBacks(xpath=>function, etc...)
503              
504             registers a callback function
505             for each xpath specified. If
506             Net::XMPP matches the xpath,
507             then it calls the function with
508             two arguments:
509              
510             the session ID, and the
511             XML::Stream::Node object.
512              
513             Xpaths are rooted at each
514             packet:
515              
516             /anything
517             /anotherthing/foo/[1]
518             ...
519              
520             The big difference between this
521             and regular XPathCallBacks is
522             the fact that this passes in
523             the XML directly and not a
524             Net::XMPP based object.
525              
526             =item RemoveDirectXPathCallBacks
527              
528             RemoveDirectXPathCallBacks(xpath=>function, etc...)
529              
530             unregisters a callback
531             function for each xpath
532             specified.
533              
534             =item Process
535              
536             Process(integer)
537             takes the timeout period as an argument. If no
538             timeout is listed then the function blocks until
539             a packet is received. Otherwise it waits that
540             number of seconds and then exits so your program
541             can continue doing useful things. NOTE: This is
542             important for GUIs. You need to leave time to
543             process GUI commands even if you are waiting for
544             packets. The following are the possible return
545             values, 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              
551             IMPORTANT: You need to check the output of every
552             Process. If you get an undef then the connection
553             died and you should behave accordingly.
554              
555             =item Send
556              
557             Send(object, ignoreActivity)
558             Send(string, ignoreActivity)
559              
560             takes either a Net::XMPP::xxxxx object or
561             an XML string as an argument and sends it to
562             the server. If you set ignoreActivty to 1,
563             then the XML::Stream module will not record
564             this 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              
577             takes either a Net::XMPP::xxxxx object or an
578             XML string as an argument, adds the next
579             available ID number and sends that packet to
580             the server. Returns the ID number assigned.
581              
582             =item SendAndReceiveWithID
583              
584             SendAndReceiveWithID(object, timeout)
585             SendAndReceiveWithID(string, timeout)
586              
587             uses SendWithID and WaitForID to
588             provide a complete way to send and
589             receive packets with IDs. Can take
590             either a Net::XMPP::xxxxx object
591             or an XML string. Returns the
592             proper Net::XMPP::xxxxx object
593             based on the type of packet
594             received. The timeout is passed
595             on to WaitForID, see that function
596             for how the timeout works.
597              
598             =item ReceivedID
599              
600             ReceivedID(integer)
601              
602             returns 1 if a packet has been received with
603             specified ID, 0 otherwise.
604              
605             =item GetID
606              
607             GetID(integer)
608              
609             returns the proper Net::XMPP::xxxxx object based
610             on the type of packet received with the specified
611             ID. If the ID has been received the GetID returns 0.
612              
613             =item WaitForID
614              
615             WaitForID(integer, timeout)
616              
617             blocks until a packet with the ID is received.
618             Returns the proper Net::XMPP::xxxxx object
619             based on the type of packet received. If the
620             timeout limit is reached then if the packet
621             does come in, it will be discarded.
622              
623              
624             NOTE: Only officially support ids, so sending a , or
625             with an id is a risk. The server will ignore the
626             id tag and pass it through, so both clients must support the
627             id 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              
641             This function is very complex.
642             It is a little too complex to
643             discuss within the confines of
644             this small paragraph. Please
645             refer to the man page for
646             Net::XMPP::Namespaces for the
647             full documentation on this
648             subject.
649              
650             =back
651              
652             =head2 Message Functions
653              
654             =over 4
655              
656             =item MessageSend
657              
658             MessageSend(hash)
659              
660             takes the hash and passes it to SetMessage in
661             Net::XMPP::Message (refer there for valid
662             settings). Then it sends the message to the
663             server.
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              
676             No arguments will send an empty
677             Presence to the server to tell it
678             that you are available. If you
679             provide a hash, then it will pass
680             that hash to the SetPresence()
681             function as defined in the
682             Net::XMPP::Presence module.
683             Optionally, you can specify a
684             signature and a jabber:x:signed
685             will be placed in the .
686              
687             =back
688              
689             =head2 Subscription Functions
690              
691             =over 4
692              
693             =item Subscription
694              
695             Subscription(hash)
696              
697             taks the hash and passes it to SetPresence in
698             Net::XMPP::Presence (refer there for valid
699             settings). Then it sends the subscription to
700             server.
701              
702             The 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              
719             Tell the object to initialize the callbacks to
720             automatically populate the Presence DB.
721              
722             =item PresenceDBParse
723              
724             PresenceDBParse(Net::XMPP::Presence)
725              
726             for every presence that you
727             receive pass the Presence
728             object to the DB so that
729             it can track the resources
730             and priorities for you.
731             Returns either the presence
732             passed in, if it not able
733             to parsed for the DB, or the
734             current presence as found by
735             the PresenceDBQuery
736             function.
737              
738             =item PresenceDBDelete
739              
740             PresenceDBDelete(string|Net::XMPP::JID)
741              
742             delete thes JID entry from the DB.
743              
744             =item PresenceDBClear
745              
746             PresenceDBClear()
747              
748             delete all entries in the database.
749              
750             =item PresenceDBQuery
751              
752             PresenceDBQuery(string|Net::XMPP::JID)
753              
754             returns the NX::Presence
755             that was last received for
756             the highest priority of
757             this JID. You can pass
758             it a string or a NX::JID
759             object.
760              
761             =item PresenceDBResources
762              
763             PresenceDBResources(string|Net::XMPP::JID)
764              
765             returns an array of
766             resources in order
767             from highest priority
768             to 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              
784             takes all of the information and
785             builds a L packet.
786             It then sends that packet to the
787             server with an ID and waits for that
788             ID to return. Then it looks in
789             resulting packet and determines if
790             authentication was successful for not.
791             The array returned from AuthSend looks
792             like this:
793              
794             [ type , message ]
795              
796             If type is "ok" then authentication
797             was successful, otherwise message
798             contains a little more detail about the
799             error.
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              
813             send an request to the specified
814             server/transport, if not specified it
815             sends to the current active server.
816             The function returns a hash that
817             contains the required fields. Here
818             is 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              
831             In $hash{form}, the fields that are
832             present are the required fields the
833             server needs.
834              
835             =item RegisterSend
836              
837             RegisterSend(hash)
838              
839             takes the contents of the hash and passes it
840             to the SetRegister function in the module
841             Net::XMPP::Query jabber:iq:register namespace.
842             This function returns an array that looks like
843             this:
844              
845             [ type , message ]
846              
847             If type is "ok" then registration was
848             successful, otherwise message contains a
849             little 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              
862             returns a L object. This will automatically
863             intercept all of the roster and presence packets sent from
864             the server and give you an accurate Roster. For more
865             information please read the man page for Net::XMPP::Roster.
866              
867             =item RosterParse
868              
869             RosterParse(IQ object)
870              
871             returns a hash that contains the roster
872             parsed 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              
893             sends an empty Net::XMPP::IQ::Roster tag to the
894             server so the server will send the Roster to the
895             client. Returns the above hash from RosterParse.
896              
897             =item RosterRequest
898              
899             RosterRequest()
900              
901             sends an empty Net::XMPP::IQ::Roster tag to the
902             server so the server will send the Roster to the
903             client.
904              
905             =item RosterAdd
906              
907             RosterAdd(hash)
908              
909             sends a packet asking that the jid be
910             added to the roster. The hash format
911             is defined in the SetItem function
912             in the Net::XMPP::Query jabber:iq:roster
913             namespace.
914              
915             =item RosterRemove
916              
917             RosterRemove(hash)
918              
919             sends a packet asking that the jid be
920             removed from the roster. The hash
921             format is defined in the SetItem function
922             in the Net::XMPP::Query jabber:iq:roster
923             namespace.
924              
925             =back
926              
927             =head2 Roster DB Functions
928              
929             =over 4
930              
931             =item RosterDB
932              
933             RosterDB()
934              
935             Tell the object to initialize the callbacks to
936             automatically populate the Roster DB. If you do this,
937             then make sure that you call RosterRequest() instead of
938             RosterGet() so that the callbacks can catch it and
939             parse it.
940              
941             =item RosterDBParse
942              
943             RosterDBParse(IQ object)
944              
945             If you want to manually control the
946             database, then you can pass in all iq
947             packets with jabber:iq:roster queries to
948             this function.
949              
950             =item RosterDBAdd
951              
952             RosterDBAdd(jid,hash)
953              
954             Add a new JID into the roster DB. The JID
955             is either a string, or a Net::XMPP::JID
956             object. The hash must be the same format as
957             the has returned by RosterParse above, and
958             is the actual hash, not a reference.
959              
960             =item RosterDBRemove
961              
962             RosterDBRemove(jid)
963              
964             Remove a JID from the roster DB. The JID is
965             either a string, or a Net::XMPP::JID object.
966              
967             =item RosterDBClear
968              
969             Remove all JIDs from the roster DB.
970              
971             =item RosterDBExists
972              
973             RosterDBExists(jid)
974              
975             return 1 if the JID exists in the roster DB,
976             undef otherwise. The JID is either a string,
977             or a Net::XMPP::JID object.
978              
979             =item RosterDBJIDs
980              
981             RosterDBJIDs()
982              
983             returns a list of Net::XMPP::JID objects that
984             represents all of the JIDs in the DB.
985              
986             =item RosterDBGroups
987              
988             returns the complete list of roster groups in the
989             roster.
990              
991             =item RosterDBGroupExists
992              
993             RosterDBGroupExists(group)
994              
995             return 1 if the group is a group in the
996             roster DB, undef otherwise.
997              
998             =item RosterDBGroupJIDs
999              
1000             RosterDBGroupJIDs(group)
1001              
1002             returns a list of Net::XMPP::JID objects
1003             that represents all of the JIDs in the
1004             specified roster group.
1005              
1006             =item RosterDBNonGroupJIDs
1007              
1008             returns a list of Net::XMPP::JID objects
1009             that represents all of the JIDs not in a
1010             roster group.
1011              
1012             =item RosterDBQuery
1013              
1014             RosterDBQuery(jid)
1015              
1016             returns a hash containing the data from the
1017             roster DB for the specified JID. The JID is
1018             either a string, or a Net::XMPP::JID object.
1019             The hash format the same as in RosterParse
1020             above.
1021              
1022             =item RosterDBQuery
1023              
1024             RosterDBQuery(jid,key)
1025              
1026             returns the entry from the above hash for
1027             the given key. The available keys are:
1028             name, ask, subsrcription and groups
1029             The JID is either a string, or a
1030             L object.
1031              
1032             =back
1033              
1034             =head1 AUTHOR
1035              
1036             Originally authored by Ryan Eatmon.
1037              
1038             Previously maintained by Eric Hacker.
1039              
1040             Currently maintained by Darian Anthony Patrick.
1041              
1042             =head1 COPYRIGHT
1043              
1044             This module is free software, you can redistribute it and/or modify it
1045             under the LGPL 2.1.
1046              
1047             =cut
1048              
1049             require 5.003;
1050 15     15   61 use strict;
  15         19  
  15         447  
1051 15     15   54 use warnings;
  15         20  
  15         306  
1052              
1053 15     15   50 use Carp;
  15         15  
  15         699  
1054 15     15   7919 use Digest::SHA;
  15         42266  
  15         725  
1055 15     15   93 use MIME::Base64;
  15         22  
  15         712  
1056 15     15   71 use Authen::SASL;
  15         21  
  15         121  
1057              
1058 15     15   280 use XML::Stream;
  15         17  
  15         109  
1059              
1060 15     15   281 use Net::XMPP::IQ;
  15         24  
  15         223  
1061 15     15   51 use Net::XMPP::Message;
  15         19  
  15         215  
1062 15     15   52 use Net::XMPP::Presence;
  15         21  
  15         229  
1063 15     15   51 use Net::XMPP::JID;
  15         19  
  15         204  
1064 15     15   7210 use Net::XMPP::Roster;
  15         30  
  15         424  
1065 15     15   5990 use Net::XMPP::PrivacyLists;
  15         76  
  15         441  
1066              
1067 15     15   65 use vars qw( %XMLNS %NEWOBJECT $SASL_CALLBACK $TLS_CALLBACK );
  15         21  
  15         126476  
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              
1091 0     0   0 sub _message { shift; my $o; eval "\$o = $NEWOBJECT{'message'}->new(\@_);"; return $o; }
  0         0  
  0         0  
  0         0  
1092 0     0   0 sub _presence { shift; my $o; eval "\$o = $NEWOBJECT{'presence'}->new(\@_);"; return $o; }
  0         0  
  0         0  
  0         0  
1093 0     0   0 sub _iq { shift; my $o; eval "\$o = $NEWOBJECT{'iq'}->new(\@_);"; return $o; }
  0         0  
  0         0  
  0         0  
1094 0     0   0 sub _jid { shift; my $o; eval "\$o = $NEWOBJECT{'jid'}->new(\@_);"; return $o; }
  0         0  
  0         0  
  0         0  
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             ###############################################################################
1110             sub GetErrorCode
1111             {
1112 0     0 1 0 my $self = shift;
1113 0 0 0     0 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             ###############################################################################
1126             sub SetErrorCode
1127             {
1128 0     0 1 0 my $self = shift;
1129 0         0 my ($errorcode) = @_;
1130 0         0 $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             ###############################################################################
1146             sub CallBack
1147             {
1148 0     0 0 0 my $self = shift;
1149 0         0 my $sid = shift;
1150 0         0 my ($object) = @_;
1151              
1152 0         0 my $tag;
1153             my $id;
1154 0         0 my $tree;
1155              
1156 0 0       0 if (ref($object) !~ /^Net::XMPP/)
1157             {
1158 0 0 0     0 if ($self->{DEBUG}->GetLevel() >= 1 || exists($self->{CB}->{receive}))
1159             {
1160 0         0 my $xml = $object->GetXML();
1161 0         0 $self->{DEBUG}->Log1("CallBack: sid($sid) received($xml)");
1162 0 0       0 &{$self->{CB}->{receive}}($sid,$xml) if exists($self->{CB}->{receive});
  0         0  
1163             }
1164              
1165 0         0 $tag = $object->get_tag();
1166 0         0 $id = "";
1167 0 0       0 $id = $object->get_attrib("id")
1168             if defined($object->get_attrib("id"));
1169 0         0 $tree = $object;
1170             }
1171             else
1172             {
1173 0         0 $tag = $object->GetTag();
1174 0         0 $id = $object->GetID();
1175 0         0 $tree = $object->GetTree();
1176             }
1177              
1178 0         0 $self->{DEBUG}->Log1("CallBack: tag($tag)");
1179 0 0       0 $self->{DEBUG}->Log1("CallBack: id($id)") if ($id ne "");
1180              
1181 0         0 my $pass = 1;
1182 0 0 0     0 $pass = 0
      0        
      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 0 0       0 if ($pass)
1190             {
1191 0         0 $self->{DEBUG}->Log1("CallBack: we either want it or were waiting for it.");
1192              
1193 0 0       0 if (exists($self->{CB}->{DirectXPath}))
1194             {
1195 0         0 $self->{DEBUG}->Log1("CallBack: check directxpath");
1196              
1197 0         0 my $direct_pass = 0;
1198              
1199 0         0 foreach my $xpath (keys(%{$self->{CB}->{DirectXPath}}))
  0         0  
1200             {
1201 0         0 $self->{DEBUG}->Log1("CallBack: check directxpath($xpath)");
1202 0 0       0 if ($object->XPathCheck($xpath))
1203             {
1204 0         0 foreach my $func (keys(%{$self->{CB}->{DirectXPath}->{$xpath}}))
  0         0  
1205             {
1206 0         0 $self->{DEBUG}->Log1("CallBack: goto directxpath($xpath) function($func)");
1207 0         0 &{$self->{CB}->{DirectXPath}->{$xpath}->{$func}}($sid,$object);
  0         0  
1208 0         0 $direct_pass = 1;
1209             }
1210             }
1211             }
1212              
1213 0 0       0 return if $direct_pass;
1214             }
1215              
1216 0         0 my $NXObject;
1217 0 0       0 if (ref($object) !~ /^Net::XMPP/)
1218             {
1219 0         0 $NXObject = $self->BuildObject($tag,$object);
1220             }
1221             else
1222             {
1223 0         0 $NXObject = $object;
1224             }
1225              
1226 0 0       0 if ($NXObject == -1)
1227             {
1228 0         0 $self->{DEBUG}->Log1("CallBack: DANGER!! DANGER!! We didn't build a packet! We're all gonna die!!");
1229             }
1230             else
1231             {
1232 0 0       0 if ($self->CheckID($tag,$id))
1233             {
1234 0         0 $self->{DEBUG}->Log1("CallBack: found registry entry: tag($tag) id($id)");
1235 0         0 $self->DeregisterID($tag,$id);
1236 0 0       0 if ($self->TimedOutID($id))
1237             {
1238 0         0 $self->{DEBUG}->Log1("CallBack: dropping packet due to timeout");
1239 0         0 $self->CleanID($id);
1240             }
1241             else
1242             {
1243 0         0 $self->{DEBUG}->Log1("CallBack: they still want it... we still got it...");
1244 0         0 $self->GotID($id,$NXObject);
1245             }
1246             }
1247             else
1248             {
1249 0         0 $self->{DEBUG}->Log1("CallBack: no registry entry");
1250              
1251 0 0       0 if (exists($self->{CB}->{XPath}))
1252             {
1253 0         0 $self->{DEBUG}->Log1("CallBack: check xpath");
1254              
1255 0         0 foreach my $xpath (keys(%{$self->{CB}->{XPath}}))
  0         0  
1256             {
1257 0 0       0 if ($NXObject->GetTree()->XPathCheck($xpath))
1258             {
1259 0         0 foreach my $func (keys(%{$self->{CB}->{XPath}->{$xpath}}))
  0         0  
1260             {
1261 0         0 $self->{DEBUG}->Log1("CallBack: goto xpath($xpath) function($func)");
1262 0         0 &{$self->{CB}->{XPath}->{$xpath}->{$func}}($sid,$NXObject);
  0         0  
1263             }
1264             }
1265             }
1266             }
1267              
1268 0 0       0 if (exists($self->{CB}->{$tag}))
1269             {
1270 0         0 $self->{DEBUG}->Log1("CallBack: goto user function($self->{CB}->{$tag})");
1271 0         0 &{$self->{CB}->{$tag}}($sid,$NXObject);
  0         0  
1272             }
1273             else
1274             {
1275 0         0 $self->{DEBUG}->Log1("CallBack: no defined function. Dropping packet.");
1276             }
1277             }
1278             }
1279             }
1280             else
1281             {
1282 0         0 $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             ###############################################################################
1292             sub BuildObject
1293             {
1294 0     0 0 0 my $self = shift;
1295 0         0 my ($tag,$tree) = @_;
1296              
1297 0         0 my $obj = -1;
1298              
1299 0 0       0 if (exists($NEWOBJECT{$tag}))
1300             {
1301 0         0 $self->{DEBUG}->Log1("BuildObject: tag($tag) package($NEWOBJECT{$tag})");
1302 0         0 eval "\$obj = $NEWOBJECT{$tag}->new(\$tree);";
1303             }
1304              
1305 0         0 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             ###############################################################################
1317             sub SetCallBacks
1318             {
1319 11     11 1 98 my $self = shift;
1320 11         53 while($#_ >= 0)
1321             {
1322 33         158 my $func = pop(@_);
1323 33         57 my $tag = pop(@_);
1324 33         241 $self->{DEBUG}->Log1("SetCallBacks: tag($tag) func($func)");
1325 33 50       71 if (defined($func))
1326             {
1327 33         119 $self->{CB}->{$tag} = $func;
1328             }
1329             else
1330             {
1331 0         0 delete($self->{CB}->{$tag});
1332             }
1333 33 50       146 $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             ###############################################################################
1343             sub SetIQCallBacks
1344             {
1345 0     0 1 0 my $self = shift;
1346              
1347 0         0 while($#_ >= 0)
1348             {
1349 0         0 my $hash = pop(@_);
1350 0         0 my $namespace = pop(@_);
1351              
1352 0         0 foreach my $type (keys(%{$hash}))
  0         0  
1353             {
1354 0         0 $self->{DEBUG}->Log1("SetIQCallBacks: type($type) func($hash->{$type}) ".
1355             "namespace($namespace)");
1356 0 0       0 if (defined($hash->{$type}))
1357             {
1358 0         0 $self->{CB}->{IQns}->{$namespace}->{$type} = $hash->{$type};
1359             }
1360             else
1361             {
1362 0         0 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             ###############################################################################
1374             sub SetPresenceCallBacks
1375             {
1376 11     11 1 25 my $self = shift;
1377 11         94 my (%types) = @_;
1378              
1379 11         51 foreach my $type (keys(%types))
1380             {
1381 44         255 $self->{DEBUG}->Log1("SetPresenceCallBacks: type($type) func($types{$type})");
1382              
1383 44 50       88 if (defined($types{$type}))
1384             {
1385 44         153 $self->{CB}->{Pres}->{$type} = $types{$type};
1386             }
1387             else
1388             {
1389 0         0 delete($self->{CB}->{Pres}->{$type});
1390             }
1391             }
1392             }
1393              
1394              
1395             ###############################################################################
1396             #
1397             # SetMessageCallBacks - define callbacks for the different message packets.
1398             #
1399             ###############################################################################
1400             sub SetMessageCallBacks
1401             {
1402 0     0 1 0 my $self = shift;
1403 0         0 my (%types) = @_;
1404              
1405 0         0 foreach my $type (keys(%types))
1406             {
1407 0         0 $self->{DEBUG}->Log1("SetMessageCallBacks: type($type) func($types{$type})");
1408              
1409 0 0       0 if (defined($types{$type}))
1410             {
1411 0         0 $self->{CB}->{Mess}->{$type} = $types{$type};
1412             }
1413             else
1414             {
1415 0         0 delete($self->{CB}->{Mess}->{$type});
1416             }
1417             }
1418             }
1419              
1420              
1421             ###############################################################################
1422             #
1423             # SetXPathCallBacks - define callbacks for packets based on XPath.
1424             #
1425             ###############################################################################
1426             sub SetXPathCallBacks
1427             {
1428 2     2 1 3 my $self = shift;
1429 2         4 my (%xpaths) = @_;
1430              
1431 2         4 foreach my $xpath (keys(%xpaths))
1432             {
1433 2         12 $self->{DEBUG}->Log1("SetXPathCallBacks: xpath($xpath) func($xpaths{$xpath})");
1434 2         11 $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             ###############################################################################
1444             sub RemoveXPathCallBacks
1445             {
1446 0     0 1 0 my $self = shift;
1447 0         0 my (%xpaths) = @_;
1448              
1449 0         0 foreach my $xpath (keys(%xpaths))
1450             {
1451 0         0 $self->{DEBUG}->Log1("RemoveXPathCallBacks: xpath($xpath) func($xpaths{$xpath})");
1452 0         0 delete($self->{CB}->{XPath}->{$xpath}->{$xpaths{$xpath}});
1453 0         0 delete($self->{CB}->{XPath}->{$xpath})
1454 0 0       0 if (scalar(keys(%{$self->{CB}->{XPath}->{$xpath}})) == 0);
1455 0         0 delete($self->{CB}->{XPath})
1456 0 0       0 if (scalar(keys(%{$self->{CB}->{XPath}})) == 0);
1457             }
1458             }
1459              
1460              
1461             ###############################################################################
1462             #
1463             # SetDirectXPathCallBacks - define callbacks for packets based on XPath.
1464             #
1465             ###############################################################################
1466             sub SetDirectXPathCallBacks
1467             {
1468 22     22 1 39 my $self = shift;
1469 22         70 my (%xpaths) = @_;
1470              
1471 22         66 foreach my $xpath (keys(%xpaths))
1472             {
1473 22         243 $self->{DEBUG}->Log1("SetDirectXPathCallBacks: xpath($xpath) func($xpaths{$xpath})");
1474 22         178 $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             ###############################################################################
1484             sub RemoveDirectXPathCallBacks
1485             {
1486 0     0 1 0 my $self = shift;
1487 0         0 my (%xpaths) = @_;
1488              
1489 0         0 foreach my $xpath (keys(%xpaths))
1490             {
1491 0         0 $self->{DEBUG}->Log1("RemoveDirectXPathCallBacks: xpath($xpath) func($xpaths{$xpath})");
1492 0         0 delete($self->{CB}->{DirectXPath}->{$xpath}->{$xpaths{$xpath}});
1493 0         0 delete($self->{CB}->{DirectXPath}->{$xpath})
1494 0 0       0 if (scalar(keys(%{$self->{CB}->{DirectXPath}->{$xpath}})) == 0);
1495 0         0 delete($self->{CB}->{DirectXPath})
1496 0 0       0 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             ###############################################################################
1507             sub Send
1508             {
1509 0     0 1 0 my $self = shift;
1510 0         0 my $object = shift;
1511 0         0 my $ignoreActivity = shift;
1512 0 0       0 $ignoreActivity = 0 unless defined($ignoreActivity);
1513              
1514 0 0       0 if (ref($object) eq "")
1515             {
1516 0         0 $self->SendXML($object,$ignoreActivity);
1517             }
1518             else
1519             {
1520 0         0 $self->SendXML($object->GetXML(),$ignoreActivity);
1521             }
1522             }
1523              
1524              
1525             ###############################################################################
1526             #
1527             # SendXML - Sends the XML packet to the server
1528             #
1529             ###############################################################################
1530             sub SendXML
1531             {
1532 0     0 0 0 my $self = shift;
1533 0         0 my $xml = shift;
1534 0         0 my $ignoreActivity = shift;
1535 0 0       0 $ignoreActivity = 0 unless defined($ignoreActivity);
1536              
1537 0         0 $self->{DEBUG}->Log1("SendXML: sent($xml)");
1538 0 0       0 &{$self->{CB}->{send}}($self->GetStreamID(),$xml) if exists($self->{CB}->{send});
  0         0  
1539 0         0 $self->{STREAM}->IgnoreActivity($self->GetStreamID(),$ignoreActivity);
1540 0         0 $self->{STREAM}->Send($self->GetStreamID(),$xml);
1541 0         0 $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             ###############################################################################
1552             sub SendWithID
1553             {
1554 0     0 1 0 my $self = shift;
1555 0         0 my ($object) = @_;
1556              
1557             #--------------------------------------------------------------------------
1558             # Take the current XML stream and insert an id attrib at the top level.
1559             #--------------------------------------------------------------------------
1560 0         0 my $id = $self->UniqueID();
1561              
1562 0         0 $self->{DEBUG}->Log1("SendWithID: id($id)");
1563              
1564 0         0 my $xml;
1565 0 0       0 if (ref($object) eq "")
1566             {
1567 0         0 $self->{DEBUG}->Log1("SendWithID: in($object)");
1568 0         0 $xml = $object;
1569 0         0 $xml =~ s/^(\<[^\>]+)(\>)/$1 id\=\'$id\'$2/;
1570 0         0 my ($tag) = ($xml =~ /^\<(\S+)\s/);
1571 0         0 $self->RegisterID($tag,$id);
1572             }
1573             else
1574             {
1575 0         0 $self->{DEBUG}->Log1("SendWithID: in(",$object->GetXML(),")");
1576 0         0 $object->SetID($id);
1577 0         0 $xml = $object->GetXML();
1578 0         0 $self->RegisterID($object->GetTag(),$id);
1579             }
1580 0         0 $self->{DEBUG}->Log1("SendWithID: out($xml)");
1581              
1582             #--------------------------------------------------------------------------
1583             # Send the new XML string.
1584             #--------------------------------------------------------------------------
1585 0         0 $self->SendXML($xml);
1586              
1587             #--------------------------------------------------------------------------
1588             # Return the ID number we just assigned.
1589             #--------------------------------------------------------------------------
1590 0         0 return $id;
1591             }
1592              
1593              
1594             ###############################################################################
1595             #
1596             # UniqueID - Increment and return a new unique ID.
1597             #
1598             ###############################################################################
1599             sub UniqueID
1600             {
1601 0     0 0 0 my $self = shift;
1602              
1603 0         0 my $id_num = $self->{RCVDB}->{currentID};
1604              
1605 0         0 $self->{RCVDB}->{currentID}++;
1606              
1607 0         0 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             ###############################################################################
1619             sub SendAndReceiveWithID
1620             {
1621 0     0 1 0 my $self = shift;
1622 0         0 my ($object,$timeout) = @_;
1623 0 0       0 &{$self->{CB}->{startwait}}() if exists($self->{CB}->{startwait});
  0         0  
1624 0         0 $self->{DEBUG}->Log1("SendAndReceiveWithID: object($object)");
1625 0         0 my $id = $self->SendWithID($object);
1626 0         0 $self->{DEBUG}->Log1("SendAndReceiveWithID: sent with id($id)");
1627 0         0 my $packet = $self->WaitForID($id,$timeout);
1628 0 0       0 &{$self->{CB}->{endwait}}() if exists($self->{CB}->{endwait});
  0         0  
1629 0         0 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             ###############################################################################
1639             sub ReceivedID
1640             {
1641 0     0 1 0 my $self = shift;
1642 0         0 my ($id) = @_;
1643              
1644 0         0 $self->{DEBUG}->Log1("ReceivedID: id($id)");
1645 0 0       0 return 1 if exists($self->{RCVDB}->{$id});
1646 0         0 $self->{DEBUG}->Log1("ReceivedID: nope...");
1647 0         0 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             ###############################################################################
1657             sub GetID
1658             {
1659 0     0 1 0 my $self = shift;
1660 0         0 my ($id) = @_;
1661              
1662 0         0 $self->{DEBUG}->Log1("GetID: id($id)");
1663 0 0       0 return $self->{RCVDB}->{$id} if $self->ReceivedID($id);
1664 0         0 $self->{DEBUG}->Log1("GetID: haven't gotten that id yet...");
1665 0         0 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             ###############################################################################
1674             sub CleanID
1675             {
1676 0     0 0 0 my $self = shift;
1677 0         0 my ($id) = @_;
1678              
1679 0         0 $self->{DEBUG}->Log1("CleanID: id($id)");
1680 0         0 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             ###############################################################################
1690             sub WaitForID
1691             {
1692 0     0 1 0 my $self = shift;
1693 0         0 my ($id,$timeout) = @_;
1694 0 0       0 $timeout = "300" unless defined($timeout);
1695              
1696 0         0 $self->{DEBUG}->Log1("WaitForID: id($id)");
1697 0         0 my $endTime = time + $timeout;
1698 0   0     0 while(!$self->ReceivedID($id) && ($endTime >= time))
1699             {
1700 0         0 $self->{DEBUG}->Log1("WaitForID: haven't gotten it yet... let's wait for more packets");
1701 0 0       0 return unless (defined($self->Process(1)));
1702 0 0       0 &{$self->{CB}->{update}}() if exists($self->{CB}->{update});
  0         0  
1703             }
1704 0 0       0 if (!$self->ReceivedID($id))
1705             {
1706 0         0 $self->TimeoutID($id);
1707 0         0 $self->{DEBUG}->Log1("WaitForID: timed out...");
1708 0         0 return;
1709             }
1710             else
1711             {
1712 0         0 $self->{DEBUG}->Log1("WaitForID: we got it!");
1713 0         0 my $packet = $self->GetID($id);
1714 0         0 $self->CleanID($id);
1715 0         0 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             ###############################################################################
1726             sub GotID
1727             {
1728 0     0 0 0 my $self = shift;
1729 0         0 my ($id,$object) = @_;
1730              
1731 0         0 $self->{DEBUG}->Log1("GotID: id($id) xml(",$object->GetXML(),")");
1732 0         0 $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             ###############################################################################
1742             sub CheckID
1743             {
1744 0     0 0 0 my $self = shift;
1745 0         0 my ($tag,$id) = @_;
1746 0 0       0 $id = "" unless defined($id);
1747              
1748 0         0 $self->{DEBUG}->Log1("CheckID: tag($tag) id($id)");
1749 0 0       0 return 0 if ($id eq "");
1750 0         0 $self->{DEBUG}->Log1("CheckID: we have that here somewhere...");
1751 0         0 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             ###############################################################################
1761             sub TimeoutID
1762             {
1763 0     0 0 0 my $self = shift;
1764 0         0 my ($id) = @_;
1765              
1766 0         0 $self->{DEBUG}->Log1("TimeoutID: id($id)");
1767 0         0 $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             ###############################################################################
1777             sub TimedOutID
1778             {
1779 0     0 0 0 my $self = shift;
1780 0         0 my ($id) = @_;
1781              
1782 0   0     0 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             ###############################################################################
1792             sub RegisterID
1793             {
1794 0     0 0 0 my $self = shift;
1795 0         0 my ($tag,$id) = @_;
1796              
1797 0         0 $self->{DEBUG}->Log1("RegisterID: tag($tag) id($id)");
1798 0         0 $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             ###############################################################################
1808             sub DeregisterID
1809             {
1810 0     0 0 0 my $self = shift;
1811 0         0 my ($tag,$id) = @_;
1812              
1813 0         0 $self->{DEBUG}->Log1("DeregisterID: tag($tag) id($id)");
1814 0         0 delete($self->{IDRegistry}->{$tag}->{$id});
1815             }
1816              
1817              
1818             ###############################################################################
1819             #
1820             # AddNamespace - Add a custom namespace into the mix.
1821             #
1822             ###############################################################################
1823             sub AddNamespace
1824             {
1825 0     0 1 0 my $self = shift;
1826 0         0 &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             ###############################################################################
1836             sub MessageSend
1837             {
1838 0     0 1 0 my $self = shift;
1839              
1840 0         0 my $mess = $self->_message();
1841 0         0 $mess->SetMessage(@_);
1842 0         0 $self->Send($mess);
1843             }
1844              
1845              
1846             ##############################################################################
1847             #
1848             # PresenceDB - initialize the module to use the presence database
1849             #
1850             ##############################################################################
1851             sub PresenceDB
1852             {
1853 0     0 1 0 my $self = shift;
1854              
1855 0     0   0 $self->SetXPathCallBacks('/presence'=>sub{ shift; $self->PresenceDBParse(@_) });
  0         0  
  0         0  
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             ###############################################################################
1866             sub PresenceDBParse
1867             {
1868 0     0 1 0 my $self = shift;
1869 0         0 my ($presence) = @_;
1870              
1871 0         0 $self->{DEBUG}->Log4("PresenceDBParse: pres(",$presence->GetXML(),")");
1872              
1873 0         0 my $type = $presence->GetType();
1874 0 0       0 $type = "" unless defined($type);
1875 0 0 0     0 return $presence unless (($type eq "") ||
      0        
1876             ($type eq "available") ||
1877             ($type eq "unavailable"));
1878              
1879 0         0 my $fromJID = $presence->GetFrom("jid");
1880 0         0 my $fromID = $fromJID->GetJID();
1881 0 0       0 $fromID = "" unless defined($fromID);
1882 0         0 my $resource = $fromJID->GetResource();
1883 0 0       0 $resource = " " unless ($resource ne "");
1884 0         0 my $priority = $presence->GetPriority();
1885 0 0       0 $priority = 0 unless defined($priority);
1886              
1887 0         0 $self->{DEBUG}->Log1("PresenceDBParse: fromJID(",$fromJID->GetJID("full"),") resource($resource) priority($priority) type($type)");
1888 0         0 $self->{DEBUG}->Log2("PresenceDBParse: xml(",$presence->GetXML(),")");
1889              
1890 0 0       0 if (exists($self->{PRESENCEDB}->{$fromID}))
1891             {
1892 0         0 my $oldPriority = $self->{PRESENCEDB}->{$fromID}->{resources}->{$resource};
1893 0 0       0 $oldPriority = "" unless defined($oldPriority);
1894              
1895 0         0 my $loc = 0;
1896 0         0 foreach my $index (0..$#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}})
  0         0  
1897             {
1898 0 0       0 $loc = $index
1899             if ($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}->[$index]->{resource} eq $resource);
1900             }
1901 0         0 splice(@{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}},$loc,1);
  0         0  
1902 0         0 delete($self->{PRESENCEDB}->{$fromID}->{resources}->{$resource});
1903 0         0 delete($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority})
1904             if (exists($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}) &&
1905 0 0 0     0 ($#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}} == -1));
1906 0         0 delete($self->{PRESENCEDB}->{$fromID})
1907 0 0       0 if (scalar(keys(%{$self->{PRESENCEDB}->{$fromID}})) == 0);
1908              
1909 0         0 $self->{DEBUG}->Log1("PresenceDBParse: remove ",$fromJID->GetJID("full")," from the DB");
1910             }
1911              
1912 0 0 0     0 if (($type eq "") || ($type eq "available"))
1913             {
1914 0         0 my $loc = -1;
1915 0         0 foreach my $index (0..$#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}}) {
  0         0  
1916 0 0       0 $loc = $index
1917             if ($self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$index]->{resource} eq $resource);
1918             }
1919 0 0       0 $loc = $#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}}+1
  0         0  
1920             if ($loc == -1);
1921 0         0 $self->{PRESENCEDB}->{$fromID}->{resources}->{$resource} = $priority;
1922 0         0 $self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$loc]->{presence} =
1923             $presence;
1924 0         0 $self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$loc]->{resource} =
1925             $resource;
1926              
1927 0         0 $self->{DEBUG}->Log1("PresenceDBParse: add ",$fromJID->GetJID("full")," to the DB");
1928             }
1929              
1930 0         0 my $currentPresence = $self->PresenceDBQuery($fromJID);
1931 0 0       0 return (defined($currentPresence) ? $currentPresence : $presence);
1932             }
1933              
1934              
1935             ###############################################################################
1936             #
1937             # PresenceDBDelete - delete the JID from the DB completely.
1938             #
1939             ###############################################################################
1940             sub PresenceDBDelete
1941             {
1942 0     0 1 0 my $self = shift;
1943 0         0 my ($jid) = @_;
1944              
1945 0         0 my $indexJID = $jid;
1946 0 0 0     0 $indexJID = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
1947              
1948 0 0       0 return if !exists($self->{PRESENCEDB}->{$indexJID});
1949 0         0 delete($self->{PRESENCEDB}->{$indexJID});
1950 0         0 $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             ###############################################################################
1959             sub PresenceDBClear
1960             {
1961 0     0 1 0 my $self = shift;
1962              
1963 0         0 $self->{DEBUG}->Log1("PresenceDBClear: clearing the database");
1964 0         0 foreach my $indexJID (keys(%{$self->{PRESENCEDB}}))
  0         0  
1965             {
1966 0         0 $self->{DEBUG}->Log3("PresenceDBClear: deleting ",$indexJID," from the DB");
1967 0         0 delete($self->{PRESENCEDB}->{$indexJID});
1968             }
1969 0         0 $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             ###############################################################################
1979             sub PresenceDBQuery
1980             {
1981 0     0 1 0 my $self = shift;
1982 0         0 my ($jid) = @_;
1983              
1984 0         0 my $indexJID = $jid;
1985 0 0 0     0 $indexJID = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
1986              
1987 0 0       0 return if !exists($self->{PRESENCEDB}->{$indexJID});
1988 0 0       0 return if (scalar(keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}})) == 0);
  0         0  
1989              
1990 0         0 my $highPriority =
1991 0         0 (sort {$b cmp $a} keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}}))[0];
  0         0  
1992              
1993 0         0 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             ###############################################################################
2003             sub PresenceDBResources
2004             {
2005 0     0 1 0 my $self = shift;
2006 0         0 my ($jid) = @_;
2007              
2008 0         0 my $indexJID = $jid;
2009 0 0 0     0 $indexJID = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
2010              
2011 0         0 my @resources;
2012              
2013 0 0       0 return if !exists($self->{PRESENCEDB}->{$indexJID});
2014              
2015 0         0 foreach my $priority (sort {$b cmp $a} keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}}))
  0         0  
  0         0  
2016             {
2017 0         0 foreach my $index (0..$#{$self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}})
  0         0  
2018             {
2019 0 0       0 next if ($self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}->[$index]->{resource} eq " ");
2020 0         0 push(@resources,$self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}->[$index]->{resource});
2021             }
2022             }
2023 0         0 return @resources;
2024             }
2025              
2026              
2027             ###############################################################################
2028             #
2029             # PresenceSend - Sends a presence tag to announce your availability
2030             #
2031             ###############################################################################
2032             sub PresenceSend
2033             {
2034 0     0 1 0 my $self = shift;
2035 0         0 my %args;
2036 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2037              
2038 0 0       0 $args{ignoreactivity} = 0 unless exists($args{ignoreactivity});
2039 0         0 my $ignoreActivity = delete($args{ignoreactivity});
2040              
2041 0         0 my $presence = $self->_presence();
2042              
2043 0         0 $presence->SetPresence(%args);
2044 0         0 $self->Send($presence,$ignoreActivity);
2045 0         0 return $presence;
2046             }
2047              
2048              
2049             ###############################################################################
2050             #
2051             # PresenceProbe - Sends a presence probe to the server
2052             #
2053             ###############################################################################
2054             sub PresenceProbe
2055             {
2056 0     0 0 0 my $self = shift;
2057 0         0 my %args;
2058 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2059 0         0 delete($args{type});
2060              
2061 0         0 my $presence = $self->_presence();
2062 0         0 $presence->SetPresence(type=>"probe",
2063             %args);
2064 0         0 $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             ###############################################################################
2074             sub Subscription
2075             {
2076 0     0 1 0 my $self = shift;
2077              
2078 0         0 my $presence = $self->_presence();
2079 0         0 $presence->SetPresence(@_);
2080 0         0 $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             ###############################################################################
2091             sub AuthSend
2092             {
2093 0     0 1 0 my $self = shift;
2094 0         0 my %args;
2095 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2096              
2097 0 0       0 carp("AuthSend requires a username arguement")
2098             unless exists($args{username});
2099 0 0       0 carp("AuthSend requires a password arguement")
2100             unless exists($args{password});
2101              
2102 0 0       0 if($self->{STREAM}->GetStreamFeature($self->GetStreamID(),"xmpp-sasl"))
2103             {
2104 0         0 return $self->AuthSASL(%args);
2105             }
2106              
2107 0         0 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             ###############################################################################
2117             sub AuthIQAuth
2118             {
2119 0     0 0 0 my $self = shift;
2120 0         0 my %args;
2121 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2122              
2123 0         0 $self->{DEBUG}->Log1("AuthIQAuth: old school auth");
2124              
2125 0 0       0 carp("AuthIQAuth requires a resource arguement")
2126             unless exists($args{resource});
2127              
2128 0         0 my $authType = "digest";
2129 0         0 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 0         0 my $iqAuth = $self->_iq();
2137 0         0 $iqAuth->SetIQ(type=>"get");
2138 0         0 my $iqAuthQuery = $iqAuth->NewChild("jabber:iq:auth");
2139 0         0 $iqAuthQuery->SetUsername($args{username});
2140 0         0 $iqAuth = $self->SendAndReceiveWithID($iqAuth);
2141              
2142 0 0       0 return unless defined($iqAuth);
2143 0 0       0 return ( $iqAuth->GetErrorCode() , $iqAuth->GetError() )
2144             if ($iqAuth->GetType() eq "error");
2145              
2146 0 0       0 if ($iqAuth->GetType() eq "error")
2147             {
2148 0         0 $authType = "digest";
2149             }
2150             else
2151             {
2152 0         0 $iqAuthQuery = $iqAuth->GetChild();
2153 0 0       0 $authType = "plain" if $iqAuthQuery->DefinedPassword();
2154 0 0       0 $authType = "digest" if $iqAuthQuery->DefinedDigest();
2155 0 0 0     0 $authType = "zerok" if ($iqAuthQuery->DefinedSequence() &&
2156             $iqAuthQuery->DefinedToken());
2157 0 0       0 $token = $iqAuthQuery->GetToken() if ($authType eq "zerok");
2158 0 0       0 $sequence = $iqAuthQuery->GetSequence() if ($authType eq "zerok");
2159             }
2160              
2161 0         0 $self->{DEBUG}->Log1("AuthIQAuth: authType($authType)");
2162              
2163 0         0 delete($args{digest});
2164 0         0 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 0 0       0 if ($authType eq "zerok")
2177             {
2178 0         0 my $hashA = Digest::SHA::sha1_hex(delete($args{password}));
2179 0         0 $args{hash} = Digest::SHA::sha1_hex($hashA.$token);
2180              
2181 0         0 for (1..$sequence)
2182             {
2183 0         0 $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 0 0       0 if ($authType eq "digest")
2196             {
2197 0         0 my $password = delete($args{password});
2198 0         0 $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 0         0 my $iqLogin = $self->_iq();
2205 0         0 $iqLogin->SetIQ(type=>"set");
2206 0         0 my $iqLoginQuery = $iqLogin->NewChild("jabber:iq:auth");
2207 0         0 $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 0         0 $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 0 0       0 return unless defined($iqLogin);
2220 0 0       0 return ( $iqLogin->GetErrorCode() , $iqLogin->GetError() )
2221             if ($iqLogin->GetType() eq "error");
2222              
2223 0         0 $self->{DEBUG}->Log1("AuthIQAuth: we authed!");
2224              
2225 0         0 return ("ok","");
2226             }
2227              
2228              
2229             ###############################################################################
2230             #
2231             # AuthSASL - Try and auth using SASL, the XMPP preferred way of authenticating.
2232             #
2233             ###############################################################################
2234             sub AuthSASL
2235             {
2236 0     0 0 0 my $self = shift;
2237 0         0 my %args;
2238 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2239              
2240 0         0 $self->{DEBUG}->Log1("AuthSASL: shiney new auth");
2241              
2242 0 0       0 carp("AuthSASL requires a username arguement")
2243             unless exists($args{username});
2244 0 0       0 carp("AuthSASL requires a password arguement")
2245             unless exists($args{password});
2246              
2247 0 0       0 $args{resource} = "" unless exists($args{resource});
2248              
2249             #-------------------------------------------------------------------------
2250             # Create the SASLClient on our end
2251             #-------------------------------------------------------------------------
2252 0         0 my $sid = $self->{SESSION}->{id};
2253 0         0 my $status =
2254             $self->{STREAM}->SASLClient($sid,
2255             $args{username},
2256             $args{password}
2257             );
2258              
2259 0 0       0 $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 0         0 my $endTime = time + $args{timeout};
2265 0   0     0 while(!$self->{STREAM}->SASLClientDone($sid) && ($endTime >= time))
2266             {
2267 0         0 $self->{DEBUG}->Log1("AuthSASL: haven't authed yet... let's wait.");
2268 0 0       0 return unless (defined($self->Process(1)));
2269 0 0       0 &{$self->{CB}->{update}}() if exists($self->{CB}->{update});
  0         0  
2270             }
2271              
2272             #-------------------------------------------------------------------------
2273             # The loop finished... but was it done?
2274             #-------------------------------------------------------------------------
2275 0 0       0 if (!$self->{STREAM}->SASLClientDone($sid))
2276             {
2277 0         0 $self->{DEBUG}->Log1("AuthSASL: timed out...");
2278 0         0 return( "system","SASL timed out authenticating");
2279             }
2280              
2281             #-------------------------------------------------------------------------
2282             # Ok, it was done... but did we auth?
2283             #-------------------------------------------------------------------------
2284 0 0       0 if (!$self->{STREAM}->SASLClientAuthed($sid))
2285             {
2286 0         0 $self->{DEBUG}->Log1("AuthSASL: Authentication failed.");
2287 0         0 return ( "error", $self->{STREAM}->SASLClientError($sid));
2288             }
2289              
2290             #-------------------------------------------------------------------------
2291             # Phew... Restart the per XMPP
2292             #-------------------------------------------------------------------------
2293 0         0 $self->{DEBUG}->Log1("AuthSASL: We authed!");
2294 0         0 $self->{SESSION} = $self->{STREAM}->OpenStream($sid);
2295 0         0 $sid = $self->{SESSION}->{id};
2296              
2297 0         0 $self->{DEBUG}->Log1("AuthSASL: We got a new session. sid($sid)");
2298              
2299             #-------------------------------------------------------------------------
2300             # Look in the new set of s and see if xmpp-bind was
2301             # offered.
2302             #-------------------------------------------------------------------------
2303 0         0 my $bind = $self->{STREAM}->GetStreamFeature($sid,"xmpp-bind");
2304 0 0       0 if ($bind)
2305             {
2306 0         0 $self->{DEBUG}->Log1("AuthSASL: Binding to resource");
2307 0         0 $self->BindResource($args{resource});
2308             }
2309              
2310             #-------------------------------------------------------------------------
2311             # Look in the new set of s and see if xmpp-session was
2312             # offered.
2313             #-------------------------------------------------------------------------
2314 0         0 my $session = $self->{STREAM}->GetStreamFeature($sid,"xmpp-session");
2315 0 0       0 if ($session)
2316             {
2317 0         0 $self->{DEBUG}->Log1("AuthSASL: Starting session");
2318 0         0 $self->StartSession();
2319             }
2320              
2321 0         0 return ("ok","");
2322             }
2323              
2324              
2325             ##############################################################################
2326             #
2327             # BindResource - bind to a resource
2328             #
2329             ##############################################################################
2330             sub BindResource
2331             {
2332 0     0 0 0 my $self = shift;
2333 0         0 my $resource = shift;
2334              
2335 0         0 $self->{DEBUG}->Log2("BindResource: Binding to resource");
2336 0         0 my $iq = $self->_iq();
2337              
2338 0         0 $iq->SetIQ(type=>"set");
2339 0         0 my $bind = $iq->NewChild(&ConstXMLNS("xmpp-bind"));
2340              
2341 0 0 0     0 if (defined($resource) && ($resource ne ""))
2342             {
2343 0         0 $self->{DEBUG}->Log2("BindResource: resource($resource)");
2344 0         0 $bind->SetBind(resource=>$resource);
2345             }
2346              
2347 0         0 my $result = $self->SendAndReceiveWithID($iq);
2348             }
2349              
2350              
2351             ##############################################################################
2352             #
2353             # StartSession - Initialize a session
2354             #
2355             ##############################################################################
2356             sub StartSession
2357             {
2358 0     0 0 0 my $self = shift;
2359              
2360 0         0 my $iq = $self->_iq();
2361              
2362 0         0 $iq->SetIQ(type=>"set");
2363 0         0 my $session = $iq->NewChild(&ConstXMLNS("xmpp-session"));
2364              
2365 0         0 my $result = $self->SendAndReceiveWithID($iq);
2366             }
2367              
2368              
2369             ##############################################################################
2370             #
2371             # PrivacyLists - Initialize a Net::XMPP::PrivacyLists object and return it.
2372             #
2373             ##############################################################################
2374             sub PrivacyLists
2375             {
2376 0     0 0 0 my $self = shift;
2377              
2378 0         0 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             ##############################################################################
2389             sub PrivacyListsGet
2390             {
2391 0     0 0 0 my $self = shift;
2392 0         0 my %args;
2393 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2394              
2395 0         0 my $iq = $self->_iq();
2396 0         0 $iq->SetIQ(type=>"get");
2397 0         0 my $query = $iq->NewChild("jabber:iq:privacy");
2398              
2399 0 0       0 if (exists($args{list}))
2400             {
2401 0         0 $query->AddList(name=>$args{list});
2402             }
2403              
2404 0         0 $iq = $self->SendAndReceiveWithID($iq);
2405 0 0       0 return unless defined($iq);
2406              
2407 0         0 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             ##############################################################################
2418             sub PrivacyListsRequest
2419             {
2420 0     0 0 0 my $self = shift;
2421 0         0 my %args;
2422 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2423              
2424 0         0 my $iq = $self->_iq();
2425 0         0 $iq->SetIQ(type=>"get");
2426 0         0 my $query = $iq->NewChild("jabber:iq:privacy");
2427              
2428 0 0       0 if (exists($args{list}))
2429             {
2430 0         0 $query->AddList(name=>$args{list});
2431             }
2432              
2433 0         0 $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             ##############################################################################
2444             sub PrivacyListsSet
2445             {
2446 0     0 0 0 my $self = shift;
2447 0         0 my %args;
2448 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2449              
2450 0         0 my $iq = $self->_iq();
2451 0         0 $iq->SetIQ(type=>"set");
2452 0         0 my $query = $iq->NewChild("jabber:iq:privacy");
2453              
2454             #XXX error check that there is a list
2455 0         0 my $list = $query->AddList(name=>$args{list});
2456              
2457 0         0 foreach my $item (@{$args{items}})
  0         0  
2458             {
2459 0         0 $list->AddItem(%{$item});
  0         0  
2460             }
2461              
2462 0         0 $iq = $self->SendAndReceiveWithID($iq);
2463 0 0       0 return unless defined($iq);
2464              
2465 0 0       0 return if $iq->DefinedError();
2466              
2467 0         0 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             ###############################################################################
2480             sub RegisterRequest
2481             {
2482 0     0 1 0 my $self = shift;
2483 0         0 my %args;
2484 0         0 $args{mode} = "block";
2485 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2486              
2487 0 0       0 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 0         0 my $iq = $self->_iq();
2493 0 0       0 $iq->SetIQ(to=>delete($args{to})) if exists($args{to});
2494 0         0 $iq->SetIQ(type=>"get");
2495 0         0 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 0 0       0 if ($args{mode} eq "passthru")
2502             {
2503 0         0 my $id = $self->UniqueID();
2504 0         0 $iq->SetIQ(id=>$id);
2505 0         0 $self->Send($iq);
2506 0         0 return $id;
2507             }
2508              
2509 0 0       0 return $self->SendWithID($iq) if ($args{mode} eq "nonblock");
2510              
2511 0         0 $iq = $self->SendAndReceiveWithID($iq,$timeout);
2512              
2513             #--------------------------------------------------------------------------
2514             # Check if there was an error.
2515             #--------------------------------------------------------------------------
2516 0 0       0 return unless defined($iq);
2517 0 0       0 if ($iq->GetType() eq "error")
2518             {
2519 0         0 $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError());
2520 0         0 return;
2521             }
2522              
2523 0         0 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 0         0 $query = $iq->GetChild();
2529 0         0 $register{fields} = { $query->GetRegister() };
2530              
2531 0         0 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             ###############################################################################
2542             sub RegisterSend
2543             {
2544 0     0 1 0 my $self = shift;
2545 0         0 my %args;
2546 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2547              
2548             #--------------------------------------------------------------------------
2549             # Create a Net::XMPP::IQ object to send to the server
2550             #--------------------------------------------------------------------------
2551 0         0 my $iq = $self->_iq();
2552 0 0       0 $iq->SetIQ(to=>delete($args{to})) if exists($args{to});
2553 0         0 $iq->SetIQ(type=>"set");
2554 0         0 my $iqRegister = $iq->NewChild("jabber:iq:register");
2555 0         0 $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 0         0 $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 0 0       0 return unless defined($iq);
2568 0 0       0 return ( $iq->GetErrorCode() , $iq->GetError() )
2569             if ($iq->GetType() eq "error");
2570 0         0 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             ##############################################################################
2580             sub RosterAdd
2581             {
2582 0     0 1 0 my $self = shift;
2583 0         0 my %args;
2584 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2585              
2586 0         0 my $iq = $self->_iq();
2587 0         0 $iq->SetIQ(type=>"set");
2588 0         0 my $roster = $iq->NewChild("jabber:iq:roster");
2589 0         0 my $item = $roster->AddItem();
2590 0         0 $item->SetItem(%args);
2591              
2592 0         0 $self->{DEBUG}->Log1("RosterAdd: xml(",$iq->GetXML(),")");
2593 0         0 $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             ##############################################################################
2603             sub RosterRemove
2604             {
2605 0     0 1 0 my $self = shift;
2606 0         0 my %args;
2607 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
2608 0         0 delete($args{subscription});
2609              
2610 0         0 my $iq = $self->_iq();
2611 0         0 $iq->SetIQ(type=>"set");
2612 0         0 my $roster = $iq->NewChild("jabber:iq:roster");
2613 0         0 my $item = $roster->AddItem();
2614 0         0 $item->SetItem(%args,
2615             subscription=>"remove");
2616 0         0 $self->Send($iq);
2617             }
2618              
2619              
2620             ##############################################################################
2621             #
2622             # RosterParse - Returns a hash of roster items.
2623             #
2624             ##############################################################################
2625             sub RosterParse
2626             {
2627 0     0 1 0 my $self = shift;
2628 0         0 my($iq) = @_;
2629              
2630 0         0 my %roster;
2631 0         0 my $query = $iq->GetChild("jabber:iq:roster");
2632              
2633 0 0       0 if (defined($query)) #$query->GetXMLNS() eq "jabber:iq:roster")
2634             {
2635 0         0 my @items = $query->GetItems();
2636              
2637 0         0 foreach my $item (@items)
2638             {
2639 0         0 my $jid = $item->GetJID();
2640 0         0 $roster{$jid}->{name} = $item->GetName();
2641 0         0 $roster{$jid}->{subscription} = $item->GetSubscription();
2642 0         0 $roster{$jid}->{ask} = $item->GetAsk();
2643 0         0 $roster{$jid}->{groups} = [ $item->GetGroup() ];
2644             }
2645             }
2646              
2647 0         0 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             ##############################################################################
2657             sub RosterGet
2658             {
2659 0     0 1 0 my $self = shift;
2660              
2661 0         0 my $iq = $self->_iq();
2662 0         0 $iq->SetIQ(type=>"get");
2663 0         0 my $query = $iq->NewChild("jabber:iq:roster");
2664              
2665 0         0 $iq = $self->SendAndReceiveWithID($iq);
2666              
2667 0 0       0 return unless defined($iq);
2668              
2669 0         0 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             ##############################################################################
2680             sub RosterRequest
2681             {
2682 0     0 1 0 my $self = shift;
2683              
2684 0         0 my $iq = $self->_iq();
2685 0         0 $iq->SetIQ(type=>"get");
2686 0         0 my $query = $iq->NewChild("jabber:iq:roster");
2687              
2688 0         0 $self->Send($iq);
2689             }
2690              
2691              
2692             ##############################################################################
2693             #
2694             # Roster - Initialize a Net::XMPP::Roster object and return it.
2695             #
2696             ##############################################################################
2697             sub Roster
2698             {
2699 0     0 1 0 my $self = shift;
2700              
2701 0         0 return Net::XMPP::Roster->new(connection=>$self);
2702             }
2703              
2704              
2705             ##############################################################################
2706             #
2707             # RosterDB - initialize the module to use the roster database
2708             #
2709             ##############################################################################
2710             sub RosterDB
2711             {
2712 0     0 1 0 my $self = shift;
2713              
2714 0     0   0 $self->SetXPathCallBacks('/iq[@type="result" or @type="set"]/query[@xmlns="jabber:iq:roster"]'=>sub{ shift; $self->RosterDBParse(@_) });
  0         0  
  0         0  
2715             }
2716              
2717              
2718             ##############################################################################
2719             #
2720             # RosterDBAdd - adds the entry to the Roster DB.
2721             #
2722             ##############################################################################
2723             sub RosterDBAdd
2724             {
2725 0     0 1 0 my $self = shift;
2726 0         0 my ($jid,%item) = @_;
2727              
2728 0         0 $self->{ROSTERDB}->{JIDS}->{$jid} = \%item;
2729              
2730 0         0 foreach my $group (@{$item{groups}})
  0         0  
2731             {
2732 0         0 $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             ###############################################################################
2742             sub RosterDBClear
2743             {
2744 0     0 1 0 my $self = shift;
2745              
2746 0         0 $self->{DEBUG}->Log1("RosterDBClear: clearing the database");
2747 0         0 foreach my $jid ($self->RosterDBJIDs())
2748             {
2749 0         0 $self->{DEBUG}->Log3("RosterDBClear: deleting ",$jid->GetJID()," from the DB");
2750 0         0 $self->RosterDBRemove($jid);
2751             }
2752 0         0 $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             ##############################################################################
2761             sub RosterDBExists
2762             {
2763 0     0 1 0 my $self = shift;
2764 0         0 my ($jid) = @_;
2765              
2766 0 0 0     0 if (ref $jid && $jid->isa('Net::XMPP::JID'))
2767             {
2768 0         0 $jid = $jid->GetJID();
2769             }
2770              
2771 0 0       0 return unless exists($self->{ROSTERDB});
2772 0 0       0 return unless exists($self->{ROSTERDB}->{JIDS});
2773 0 0       0 return unless exists($self->{ROSTERDB}->{JIDS}->{$jid});
2774 0         0 return 1;
2775             }
2776              
2777              
2778             ##############################################################################
2779             #
2780             # RosterDBGroupExists - allows you to query if the group exists in the Roster
2781             # DB.
2782             #
2783             ##############################################################################
2784             sub RosterDBGroupExists
2785             {
2786 0     0 1 0 my $self = shift;
2787 0         0 my ($group) = @_;
2788              
2789 0 0       0 return unless exists($self->{ROSTERDB});
2790 0 0       0 return unless exists($self->{ROSTERDB}->{GROUPS});
2791 0 0       0 return unless exists($self->{ROSTERDB}->{GROUPS}->{$group});
2792 0         0 return 1;
2793             }
2794              
2795              
2796             ##############################################################################
2797             #
2798             # RosterDBGroupJIDs - returns a list of the current groups in your roster.
2799             #
2800             ##############################################################################
2801             sub RosterDBGroupJIDs
2802             {
2803 0     0 1 0 my $self = shift;
2804 0         0 my $group = shift;
2805              
2806 0 0       0 return unless $self->RosterDBGroupExists($group);
2807 0         0 my @jids;
2808 0         0 foreach my $jid (keys(%{$self->{ROSTERDB}->{GROUPS}->{$group}}))
  0         0  
2809             {
2810 0         0 push(@jids,$self->_jid($jid));
2811             }
2812 0         0 return @jids;
2813             }
2814              
2815              
2816             ##############################################################################
2817             #
2818             # RosterDBGroups - returns a list of the current groups in your roster.
2819             #
2820             ##############################################################################
2821             sub RosterDBGroups
2822             {
2823 0     0 1 0 my $self = shift;
2824              
2825 0 0       0 return () unless exists($self->{ROSTERDB}->{GROUPS});
2826 0 0       0 return () if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}})) == 0);
  0         0  
2827 0         0 return keys(%{$self->{ROSTERDB}->{GROUPS}});
  0         0  
2828             }
2829              
2830              
2831             ##############################################################################
2832             #
2833             # RosterDBJIDs - returns a list of all of the JIDs in your roster.
2834             #
2835             ##############################################################################
2836             sub RosterDBJIDs
2837             {
2838 0     0 1 0 my $self = shift;
2839 0         0 my $group = shift;
2840              
2841 0         0 my @jids;
2842              
2843 0 0       0 return () unless exists($self->{ROSTERDB});
2844 0 0       0 return () unless exists($self->{ROSTERDB}->{JIDS});
2845 0         0 foreach my $jid (keys(%{$self->{ROSTERDB}->{JIDS}}))
  0         0  
2846             {
2847 0         0 push(@jids,$self->_jid($jid));
2848             }
2849 0         0 return @jids;
2850             }
2851              
2852              
2853             ##############################################################################
2854             #
2855             # RosterDBNonGroupJIDs - returns a list of the JIDs not in a group.
2856             #
2857             ##############################################################################
2858             sub RosterDBNonGroupJIDs
2859             {
2860 0     0 1 0 my $self = shift;
2861 0         0 my $group = shift;
2862              
2863 0         0 my @jids;
2864              
2865 0 0       0 return () unless exists($self->{ROSTERDB});
2866 0 0       0 return () unless exists($self->{ROSTERDB}->{JIDS});
2867 0         0 foreach my $jid (keys(%{$self->{ROSTERDB}->{JIDS}}))
  0         0  
2868             {
2869 0         0 next if (exists($self->{ROSTERDB}->{JIDS}->{$jid}->{groups}) &&
2870 0 0 0     0 ($#{$self->{ROSTERDB}->{JIDS}->{$jid}->{groups}} > -1));
2871              
2872 0         0 push(@jids,$self->_jid($jid));
2873             }
2874 0         0 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             ##############################################################################
2884             sub RosterDBParse
2885             {
2886 0     0 1 0 my $self = shift;
2887 0         0 my ($iq) = @_;
2888              
2889             #print "RosterDBParse: iq(",$iq->GetXML(),")\n";
2890              
2891 0         0 my $type = $iq->GetType();
2892 0 0 0     0 return unless (($type eq "set") || ($type eq "result"));
2893              
2894 0         0 my %newroster = $self->RosterParse($iq);
2895              
2896 0         0 $self->RosterDBProcessParsed(%newroster);
2897             }
2898              
2899              
2900             ##############################################################################
2901             #
2902             # RosterDBProcessParsed - takes a parsed roster and puts it into the Roster DB.
2903             #
2904             ##############################################################################
2905             sub RosterDBProcessParsed
2906             {
2907 0     0 0 0 my $self = shift;
2908 0         0 my (%roster) = @_;
2909              
2910 0         0 foreach my $jid (keys(%roster))
2911             {
2912 0         0 $self->RosterDBRemove($jid);
2913              
2914 0 0       0 if ($roster{$jid}->{subscription} ne "remove")
2915             {
2916 0         0 $self->RosterDBAdd($jid, %{$roster{$jid}} );
  0         0  
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             ##############################################################################
2928             sub RosterDBQuery
2929             {
2930 0     0 1 0 my $self = shift;
2931 0         0 my $jid = shift;
2932 0         0 my $key = shift;
2933              
2934 0 0 0     0 if (ref $jid && $jid->isa('Net::XMPP::JID'))
2935             {
2936 0         0 $jid = $jid->GetJID();
2937             }
2938              
2939 0 0       0 return unless $self->RosterDBExists($jid);
2940 0 0       0 if (defined($key))
2941             {
2942 0 0       0 return unless exists($self->{ROSTERDB}->{JIDS}->{$jid}->{$key});
2943 0         0 return $self->{ROSTERDB}->{JIDS}->{$jid}->{$key};
2944             }
2945 0         0 return %{$self->{ROSTERDB}->{JIDS}->{$jid}};
  0         0  
2946             }
2947              
2948              
2949             ##############################################################################
2950             #
2951             # RosterDBRemove - removes the JID from the Roster DB.
2952             #
2953             ##############################################################################
2954             sub RosterDBRemove
2955             {
2956 0     0 1 0 my $self = shift;
2957 0         0 my ($jid) = @_;
2958              
2959 0 0       0 if ($self->RosterDBExists($jid))
2960             {
2961 0 0       0 if (defined($self->RosterDBQuery($jid,"groups")))
2962             {
2963 0         0 foreach my $group (@{$self->RosterDBQuery($jid,"groups")})
  0         0  
2964             {
2965 0         0 delete($self->{ROSTERDB}->{GROUPS}->{$group}->{$jid});
2966 0         0 delete($self->{ROSTERDB}->{GROUPS}->{$group})
2967 0 0       0 if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}->{$group}})) == 0);
2968 0         0 delete($self->{ROSTERDB}->{GROUPS})
2969 0 0       0 if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}})) == 0);
2970             }
2971             }
2972              
2973 0         0 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             ##############################################################################
2993             sub TLSInit
2994             {
2995 11     11 0 23 my $self = shift;
2996              
2997 11     0   64 $TLS_CALLBACK = sub{ $self->ProcessTLSStanza( @_ ) };
  0         0  
2998 11         79 $self->SetDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-tls").'"]'=>$TLS_CALLBACK);
2999             }
3000              
3001              
3002             ##############################################################################
3003             #
3004             # ProcessTLSStanza - process a TLS based packet.
3005             #
3006             ##############################################################################
3007             sub ProcessTLSStanza
3008             {
3009 0     0 0 0 my $self = shift;
3010 0         0 my $sid = shift;
3011 0         0 my $node = shift;
3012              
3013 0         0 my $tag = &XML::Stream::XPath($node,"name()");
3014              
3015 0 0       0 if ($tag eq "failure")
3016             {
3017 0         0 $self->TLSClientFailure($node);
3018             }
3019              
3020 0 0       0 if ($tag eq "proceed")
3021             {
3022 0         0 $self->TLSClientProceed($node);
3023             }
3024             }
3025              
3026              
3027             ##############################################################################
3028             #
3029             # TLSStart - client function to have the socket start TLS.
3030             #
3031             ##############################################################################
3032             sub TLSStart
3033             {
3034 0     0 0 0 my $self = shift;
3035 0         0 my $timeout = shift;
3036 0 0       0 $timeout = 120 unless defined($timeout);
3037 0 0       0 $timeout = 120 if ($timeout eq "");
3038              
3039 0         0 $self->TLSSendStartTLS();
3040              
3041 0         0 my $endTime = time + $timeout;
3042 0   0     0 while(!$self->TLSClientDone() && ($endTime >= time))
3043             {
3044 0         0 $self->Process();
3045             }
3046              
3047 0 0       0 if (!$self->TLSClientSecure())
3048             {
3049 0         0 return;
3050             }
3051              
3052 0         0 $self->RestartStream($timeout);
3053             }
3054              
3055              
3056             ##############################################################################
3057             #
3058             # TLSClientProceed - handle a packet.
3059             #
3060             ##############################################################################
3061             sub TLSClientProceed
3062             {
3063 0     0 0 0 my $self = shift;
3064 0         0 my $node = shift;
3065              
3066 0         0 my ($status,$message) = $self->{STREAM}->StartTLS($self->GetStreamID());
3067              
3068 0 0       0 if ($status)
3069             {
3070 0         0 $self->{TLS}->{done} = 1;
3071 0         0 $self->{TLS}->{secure} = 1;
3072             }
3073             else
3074             {
3075 0         0 $self->{TLS}->{done} = 1;
3076 0         0 $self->{TLS}->{error} = $message;
3077             }
3078              
3079 0         0 $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             ##############################################################################
3088             sub TLSClientSecure
3089             {
3090 0     0 0 0 my $self = shift;
3091              
3092 0         0 return $self->{TLS}->{secure};
3093             }
3094              
3095              
3096             ##############################################################################
3097             #
3098             # TLSClientDone - return 1 if the TLS process is done
3099             #
3100             ##############################################################################
3101             sub TLSClientDone
3102             {
3103 0     0 0 0 my $self = shift;
3104              
3105 0         0 return $self->{TLS}->{done};
3106             }
3107              
3108              
3109             ##############################################################################
3110             #
3111             # TLSClientError - return the TLS error if any
3112             #
3113             ##############################################################################
3114             sub TLSClientError
3115             {
3116 0     0 0 0 my $self = shift;
3117              
3118 0         0 return $self->{TLS}->{error};
3119             }
3120              
3121              
3122             ##############################################################################
3123             #
3124             # TLSClientFailure - handle a
3125             #
3126             ##############################################################################
3127             sub TLSClientFailure
3128             {
3129 0     0 0 0 my $self = shift;
3130 0         0 my $node = shift;
3131              
3132 0         0 my $type = &XML::Stream::XPath($node,"*/name()");
3133              
3134 0         0 $self->{TLS}->{error} = $type;
3135 0         0 $self->{TLS}->{done} = 1;
3136             }
3137              
3138              
3139             ##############################################################################
3140             #
3141             # TLSSendFailure - Send a in the TLS namespace
3142             #
3143             ##############################################################################
3144             sub TLSSendFailure
3145             {
3146 0     0 0 0 my $self = shift;
3147 0         0 my $type = shift;
3148              
3149 0         0 $self->Send("<${type}/>");
3150             }
3151              
3152              
3153             ##############################################################################
3154             #
3155             # TLSSendStartTLS - send a in the TLS namespace.
3156             #
3157             ##############################################################################
3158             sub TLSSendStartTLS
3159             {
3160 0     0 0 0 my $self = shift;
3161              
3162 0         0 $self->Send("");
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             ##############################################################################
3181             sub SASLInit
3182             {
3183 11     11 0 21 my $self = shift;
3184              
3185 11     0   55 $SASL_CALLBACK = sub{ $self->ProcessSASLStanza( @_ ) };
  0         0  
3186 11         194 $self->SetDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-sasl").'"]'=> $SASL_CALLBACK);
3187             }
3188              
3189              
3190             ##############################################################################
3191             #
3192             # ProcessSASLStanza - process a SASL based packet.
3193             #
3194             ##############################################################################
3195             sub ProcessSASLStanza
3196             {
3197 0     0 0 0 my $self = shift;
3198 0         0 my $sid = shift;
3199 0         0 my $node = shift;
3200              
3201 0         0 my $tag = &XML::Stream::XPath($node,"name()");
3202              
3203 0 0       0 if ($tag eq "challenge")
3204             {
3205 0         0 $self->SASLAnswerChallenge($node);
3206             }
3207              
3208 0 0       0 if ($tag eq "failure")
3209             {
3210 0         0 $self->SASLClientFailure($node);
3211             }
3212              
3213 0 0       0 if ($tag eq "success")
3214             {
3215 0         0 $self->SASLClientSuccess($node);
3216             }
3217             }
3218              
3219              
3220             ##############################################################################
3221             #
3222             # SASLAnswerChallenge - when we get a we need to do the grunt
3223             # work to return a .
3224             #
3225             ##############################################################################
3226             sub SASLAnswerChallenge
3227             {
3228 0     0 0 0 my $self = shift;
3229 0         0 my $node = shift;
3230              
3231 0         0 my $challenge64 = &XML::Stream::XPath($node,"text()");
3232 0         0 my $challenge = MIME::Base64::decode_base64($challenge64);
3233              
3234 0         0 my $response = $self->SASLGetClient()->client_step($challenge);
3235              
3236 0         0 my $response64 = MIME::Base64::encode_base64($response,"");
3237 0         0 $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             ###############################################################################
3247             sub SASLClient
3248             {
3249 0     0 0 0 my $self = shift;
3250 0         0 my $username = shift;
3251 0         0 my $password = shift;
3252              
3253 0         0 my $mechanisms = $self->GetStreamFeature("xmpp-sasl");
3254              
3255 0 0       0 return unless defined($mechanisms);
3256              
3257 0         0 my $sasl = Authen::SASL->new(mechanism=>join(" ",@{$mechanisms}),
  0         0  
3258             callback=>{ user => $username,
3259             pass => $password
3260             }
3261             );
3262              
3263 0         0 $self->{SASL}->{client} = $sasl->client_new();
3264 0         0 $self->{SASL}->{username} = $username;
3265 0         0 $self->{SASL}->{password} = $password;
3266 0         0 $self->{SASL}->{authed} = 0;
3267 0         0 $self->{SASL}->{done} = 0;
3268              
3269 0         0 $self->SASLSendAuth();
3270             }
3271              
3272              
3273             ##############################################################################
3274             #
3275             # SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise
3276             #
3277             ##############################################################################
3278             sub SASLClientAuthed
3279             {
3280 0     0 0 0 my $self = shift;
3281              
3282 0         0 return $self->{SASL}->{authed};
3283             }
3284              
3285              
3286             ##############################################################################
3287             #
3288             # SASLClientDone - return 1 if the SASL process is finished
3289             #
3290             ##############################################################################
3291             sub SASLClientDone
3292             {
3293 0     0 0 0 my $self = shift;
3294              
3295 0         0 return $self->{SASL}->{done};
3296             }
3297              
3298              
3299             ##############################################################################
3300             #
3301             # SASLClientError - return the error if any
3302             #
3303             ##############################################################################
3304             sub SASLClientError
3305             {
3306 0     0 0 0 my $self = shift;
3307              
3308 0         0 return $self->{SASL}->{error};
3309             }
3310              
3311              
3312             ##############################################################################
3313             #
3314             # SASLClientFailure - handle a received
3315             #
3316             ##############################################################################
3317             sub SASLClientFailure
3318             {
3319 0     0 0 0 my $self = shift;
3320 0         0 my $node = shift;
3321              
3322 0         0 my $type = &XML::Stream::XPath($node,"*/name()");
3323              
3324 0         0 $self->{SASL}->{error} = $type;
3325 0         0 $self->{SASL}->{done} = 1;
3326             }
3327              
3328              
3329             ##############################################################################
3330             #
3331             # SASLClientSuccess - handle a received
3332             #
3333             ##############################################################################
3334             sub SASLClientSuccess
3335             {
3336 0     0 0 0 my $self = shift;
3337 0         0 my $node = shift;
3338              
3339 0         0 $self->{SASL}->{authed} = 1;
3340 0         0 $self->{SASL}->{done} = 1;
3341              
3342 0         0 $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             ###############################################################################
3351             sub SASLGetClient
3352             {
3353 0     0 0 0 my $self = shift;
3354              
3355 0         0 return $self->{SASL}->{client};
3356             }
3357              
3358              
3359             ##############################################################################
3360             #
3361             # SASLSendAuth - send an in the SASL namespace
3362             #
3363             ##############################################################################
3364             sub SASLSendAuth
3365             {
3366 0     0 0 0 my $self = shift;
3367              
3368 0         0 $self->Send("");
3369             }
3370              
3371              
3372             ##############################################################################
3373             #
3374             # SASLSendChallenge - Send a in the SASL namespace
3375             #
3376             ##############################################################################
3377             sub SASLSendChallenge
3378             {
3379 0     0 0 0 my $self = shift;
3380 0         0 my $challenge = shift;
3381              
3382 0         0 $self->Send("${challenge}");
3383             }
3384              
3385              
3386             ##############################################################################
3387             #
3388             # SASLSendFailure - Send a tag in the SASL namespace
3389             #
3390             ##############################################################################
3391             sub SASLSendFailure
3392             {
3393 0     0 0 0 my $self = shift;
3394 0         0 my $type = shift;
3395              
3396 0         0 $self->Send("<${type}/>");
3397             }
3398              
3399              
3400             ##############################################################################
3401             #
3402             # SASLSendResponse - Send a tag in the SASL namespace
3403             #
3404             ##############################################################################
3405             sub SASLSendResponse
3406             {
3407 0     0 0 0 my $self = shift;
3408 0         0 my $response = shift;
3409              
3410 0         0 $self->Send("${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             ##############################################################################
3430             sub xmppCallbackInit
3431             {
3432 11     11 0 24 my $self = shift;
3433              
3434 11         458 $self->{DEBUG}->Log1("xmppCallbackInit: start");
3435              
3436 11         22 my $weak = $self;
3437 11         3292 weaken $weak;
3438 0     0   0 $self->SetCallBacks(iq=>sub{ $weak->callbackIQ(@_) },
3439 0     0   0 presence=>sub{ $weak->callbackPresence(@_) },
3440 0     0   0 message=>sub{ $weak->callbackMessage(@_) },
3441 11         224 );
3442              
3443 0     0   0 $self->SetPresenceCallBacks(subscribe=>sub{ $weak->callbackPresenceSubscribe(@_) },
3444 0     0   0 unsubscribe=>sub{ $weak->callbackPresenceUnsubscribe(@_) },
3445 0     0   0 subscribed=>sub{ $weak->callbackPresenceSubscribed(@_) },
3446 0     0   0 unsubscribed=>sub{ $weak->callbackPresenceUnsubscribed(@_) },
3447 11         196 );
3448              
3449 11         86 $self->TLSInit();
3450 11         58 $self->SASLInit();
3451              
3452 11         67 $self->{DEBUG}->Log1("xmppCallbackInit: stop");
3453             }
3454              
3455              
3456             ##############################################################################
3457             #
3458             # callbackMessage - default callback for packets.
3459             #
3460             ##############################################################################
3461             sub callbackMessage
3462             {
3463 0     0 0 0 my $self = shift;
3464 0         0 my $sid = shift;
3465 0         0 my $message = shift;
3466              
3467 0         0 my $type = "normal";
3468 0 0       0 $type = $message->GetType() if $message->DefinedType();
3469              
3470 0         0 $self->{DEBUG}->Log1("callbackMessage: type($type) sid($sid) ");
3471              
3472 0 0       0 if (exists($self->{CB}->{Mess}->{$type})
3473             #&& (ref($self->{CB}->{Mess}->{$type}) =~ /CODE/)
3474             )
3475             {
3476 0         0 &{$self->{CB}->{Mess}->{$type}}($sid,$message);
  0         0  
3477             }
3478             else
3479             {
3480 0         0 $self->{DEBUG}->Log1("callbackMessage: type($type) not code (ref($self->{CB}->{Mess}->{$type})) ");
3481             }
3482             }
3483              
3484              
3485             ##############################################################################
3486             #
3487             # callbackPresence - default callback for packets.
3488             #
3489             ##############################################################################
3490             sub callbackPresence
3491             {
3492 0     0 0 0 my $self = shift;
3493 0         0 my $sid = shift;
3494 0         0 my $presence = shift;
3495              
3496 0         0 my $type = "available";
3497 0 0       0 $type = $presence->GetType() if $presence->DefinedType();
3498              
3499 0         0 $self->{DEBUG}->Log1("callbackPresence: type($type) sid($sid) ");
3500              
3501 0 0       0 if (exists($self->{CB}->{Pres}->{$type})
3502             # && (ref($self->{CB}->{Pres}->{$type}) =~ /CODE/)
3503             )
3504             {
3505 0         0 &{$self->{CB}->{Pres}->{$type}}($sid,$presence);
  0         0  
3506             }
3507             }
3508              
3509              
3510             ##############################################################################
3511             #
3512             # callbackIQ - default callback for packets.
3513             #
3514             ##############################################################################
3515             sub callbackIQ
3516             {
3517 0     0 0 0 my $self = shift;
3518 0         0 my $sid = shift;
3519 0         0 my $iq = shift;
3520              
3521 0         0 $self->{DEBUG}->Log1("callbackIQ: sid($sid) iq($iq)");
3522              
3523 0 0       0 return unless $iq->DefinedChild();
3524 0         0 my $query = $iq->GetChild();
3525 0 0       0 return unless defined($query);
3526              
3527 0         0 my $type = $iq->GetType();
3528 0         0 my $ns = $query->GetXMLNS();
3529              
3530 0         0 $self->{DEBUG}->Log1("callbackIQ: type($type) ns($ns)");
3531              
3532 0 0 0     0 if (exists($self->{CB}->{IQns}->{$ns})
    0          
3533             && (ref($self->{CB}->{IQns}->{$ns}) eq 'HASH' )
3534             )
3535             {
3536 0         0 $self->{DEBUG}->Log1("callbackIQ: goto user function( $self->{CB}->{IQns}->{$ns} )");
3537 0         0 &{$self->{CB}->{IQns}->{$ns}}($sid,$iq);
  0         0  
3538              
3539             }
3540             elsif (exists($self->{CB}->{IQns}->{$ns}->{$type})
3541             # && (ref($self->{CB}->{IQns}->{$ns}->{$type}) =~ /CODE/)
3542             )
3543             {
3544 0         0 $self->{DEBUG}->Log1("callbackIQ: goto user function( $self->{CB}->{IQns}->{$ns}->{$type} )");
3545 0         0 &{$self->{CB}->{IQns}->{$ns}->{$type}}($sid,$iq);
  0         0  
3546             }
3547             }
3548              
3549              
3550             ##############################################################################
3551             #
3552             # callbackPresenceSubscribe - default callback for subscribe packets.
3553             #
3554             ##############################################################################
3555             sub callbackPresenceSubscribe
3556             {
3557 0     0 0 0 my $self = shift;
3558 0         0 my $sid = shift;
3559 0         0 my $presence = shift;
3560              
3561 0         0 my $reply = $presence->Reply(type=>"subscribed");
3562 0         0 $self->Send($reply,1);
3563 0         0 $reply->SetType("subscribe");
3564 0         0 $self->Send($reply,1);
3565             }
3566              
3567              
3568             ##############################################################################
3569             #
3570             # callbackPresenceUnsubscribe - default callback for unsubscribe packets.
3571             #
3572             ##############################################################################
3573             sub callbackPresenceUnsubscribe
3574             {
3575 0     0 0 0 my $self = shift;
3576 0         0 my $sid = shift;
3577 0         0 my $presence = shift;
3578              
3579 0         0 my $reply = $presence->Reply(type=>"unsubscribed");
3580 0         0 $self->Send($reply,1);
3581             }
3582              
3583              
3584             ##############################################################################
3585             #
3586             # callbackPresenceSubscribed - default callback for subscribed packets.
3587             #
3588             ##############################################################################
3589             sub callbackPresenceSubscribed
3590             {
3591 0     0 0 0 my $self = shift;
3592 0         0 my $sid = shift;
3593 0         0 my $presence = shift;
3594              
3595 0         0 my $reply = $presence->Reply(type=>"subscribed");
3596 0         0 $self->Send($reply,1);
3597             }
3598              
3599              
3600             ##############################################################################
3601             #
3602             # callbackPresenceUnsubscribed - default callback for unsubscribed packets.
3603             #
3604             ##############################################################################
3605             sub callbackPresenceUnsubscribed
3606             {
3607 0     0 0 0 my $self = shift;
3608 0         0 my $sid = shift;
3609 0         0 my $presence = shift;
3610              
3611 0         0 my $reply = $presence->Reply(type=>"unsubscribed");
3612 0         0 $self->Send($reply,1);
3613             }
3614              
3615              
3616              
3617             ##############################################################################
3618             #+----------------------------------------------------------------------------
3619             #|
3620             #| Stream functions
3621             #|
3622             #+----------------------------------------------------------------------------
3623             ##############################################################################
3624             sub GetStreamID
3625             {
3626 10     10 0 16 my $self = shift;
3627              
3628 10         56 return $self->{SESSION}->{id};
3629             }
3630              
3631              
3632             sub GetStreamFeature
3633             {
3634 10     10 0 17 my $self = shift;
3635 10         17 my $feature = shift;
3636              
3637 10         47 return $self->{STREAM}->GetStreamFeature($self->GetStreamID(),$feature);
3638             }
3639              
3640              
3641             sub RestartStream
3642             {
3643 0     0 0 0 my $self = shift;
3644 0         0 my $timeout = shift;
3645              
3646 0         0 $self->{SESSION} =
3647             $self->{STREAM}->OpenStream($self->GetStreamID(),$timeout);
3648 0         0 return $self->GetStreamID();
3649             }
3650              
3651              
3652             ##############################################################################
3653             #
3654             # ConstXMLNS - Return the namespace from the constant string.
3655             #
3656             ##############################################################################
3657             sub ConstXMLNS
3658             {
3659 22     22 0 1874 my $const = shift;
3660              
3661 22         248 return $XMLNS{$const};
3662             }
3663              
3664              
3665             1;