Context Navigation

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

Visit:

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9

Last change on this file since bfc127b was 7f33c18, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 18 years ago
Net::XMPP::Protocol - Make resource binding note the full jid on connect. BarnOwl::Module::Jabber::ConnectionManager - Allow for connections to be renamed. BarnOwl::Module::Jabber - Rename the connection after connect to match the jid received. This makes Net::XMPP recognize that the server may in fact connect a user under a different resource than the one the user specified. In particular, it works around the crap GoogleTalk appends to the supplied resource.
Property mode set to `100644`
File size: 109.1 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: