Context Navigation

source: perl/modules/Jabber/lib/XML/Stream.pm @ e0ffe77

Visit:

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

Last change on this file since e0ffe77 was 8574801, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 16 years ago
Patches to jabber libraries for better UTF-8 handling.
Property mode set to `100644`
File size: 114.2 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	# Jabber
19	# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
20	#
21	##############################################################################
22
23	package XML::Stream;
24
25	=head1 NAME
26
27	XML::Stream - Creates and XML Stream connection and parses return data
28
29	=head1 SYNOPSIS
30
31	XML::Stream is an attempt at solidifying the use of XML via streaming.
32
33	=head1 DESCRIPTION
34
35	This module provides the user with methods to connect to a remote
36	server, send a stream of XML to the server, and receive/parse an XML
37	stream from the server. It is primarily based work for the Etherx XML
38	router developed by the Jabber Development Team. For more information
39	about this project visit http://etherx.jabber.org/stream/.
40
41	XML::Stream gives the user the ability to define a central callback
42	that will be used to handle the tags received from the server. These
43	tags are passed in the format defined at instantiation time.
44	the closing tag of an object is seen, the tree is finished and passed
45	to the call back function. What the user does with it from there is up
46	to them.
47
48	For a detailed description of how this module works, and about the data
49	structure that it returns, please view the source of Stream.pm and
50	look at the detailed description at the end of the file.
51
52
53	NOTE: The parser that XML::Stream::Parser provides, as are most Perl
54	parsers, is synchronous. If you are in the middle of parsing a
55	packet and call a user defined callback, the Parser is blocked until
56	your callback finishes. This means you cannot be operating on a
57	packet, send out another packet and wait for a response to that packet.
58	It will never get to you. Threading might solve this, but as we all
59	know threading in Perl is not quite up to par yet. This issue will be
60	revisted in the future.
61
62
63
64	=head1 METHODS
65
66	new(debug=>string, - creates the XML::Stream object. debug
67	debugfh=>FileHandle, should be set to the path for the debug log
68	debuglevel=>0\|1\|N, to be written. If set to "stdout" then the
69	debugtime=>0\|1, debug will go there. Also, you can specify
70	style=>string) a filehandle that already exists byt using
71	debugfh. debuglevel determines the amount
72	of debug to generate. 0 is the least, 1 is
73	a little more, N is the limit you want.
74	debugtime determines wether a timestamp
75	should be preappended to the entry. style
76	defines the way the data structure is
77	returned. The two available styles are:
78
79	tree - XML::Parser Tree format
80	node - XML::Stream::Node format
81
82	For more information see the respective man
83	pages.
84
85	Connect(hostname=>string, - opens a tcp connection to the
86	port=>integer, specified server and sends the proper
87	to=>string, opening XML Stream tag. hostname,
88	from=>string, port, and namespace are required.
89	myhostname=>string, namespaces allows you to use
90	namespace=>string, XML::Stream::Namespace objects.
91	namespaces=>array, to is needed if you want the stream
92	connectiontype=>string, to attribute to be something other
93	ssl=>0\|1, than the hostname you are connecting
94	srv=>string) to. from is needed if you want the
95	stream from attribute to be something
96	other than the hostname you are
97	connecting from. myhostname should
98	not be needed but if the module
99	cannot determine your hostname
100	properly (check the debug log), set
101	this to the correct value, or if you
102	want the other side of the stream to
103	think that you are someone else. The
104	type determines the kind of
105	connection that is made:
106	"tcpip" - TCP/IP (default)
107	"stdinout" - STDIN/STDOUT
108	"http" - HTTP
109	HTTP recognizes proxies if the ENV
110	variables http_proxy or https_proxy
111	are set. ssl specifies if an SLL
112	socket should be used for encrypted
113	communications. This function
114	returns the same hash from GetRoot()
115	below. Make sure you get the SID
116	(Session ID) since you have to use it
117	to call most other functions in here.
118
119	If srv is specified AND Net::DNS is
120	installed and can be loaded, then
121	an SRV query is sent to srv.hostname
122	and the results processed to replace
123	the hostname and port. If the lookup
124	fails, or Net::DNS cannot be loaded,
125	then hostname and port are left alone
126	as the defaults.
127
128
129	OpenFile(string) - opens a filehandle to the argument specified, and
130	pretends that it is a stream. It will ignore the
131	outer tag, and not check if it was a
132	<stream:stream/>. This is useful for writing a
133	program that has to parse any XML file that is
134	basically made up of small packets (like RDF).
135
136	Disconnect(sid) - sends the proper closing XML tag and closes the
137	specified socket down.
138
139	Process(integer) - waits for data to be available on the socket. If
140	a timeout is specified then the Process function
141	waits that period of time before returning nothing.
142	If a timeout period is not specified then the
143	function blocks until data is received. The
144	function returns a hash with session ids as the key,
145	and status values or data as the hash values.
146
147	SetCallBacks(node=>function, - sets the callback that should be
148	update=>function) called in various situations. node
149	is used to handle the data structures
150	that are built for each top level tag.
151	Update is used for when Process is
152	blocking waiting for data, but you
153	want your original code to be updated.
154
155	GetRoot(sid) - returns the attributes that the stream:stream tag sent
156	by the other end listed in a hash for the specified
157	session.
158
159	GetSock(sid) - returns a pointer to the IO::Socket object for the
160	specified session.
161
162	Send(sid, - sends the string over the specified connection as is.
163	string) This does no checking if valid XML was sent or not.
164	Best behavior when sending information.
165
166	GetErrorCode(sid) - returns a string for the specified session that
167	will hopefully contain some useful information
168	about why Process or Connect returned an undef
169	to you.
170
171	XPath(node,path) - returns an array of results that match the xpath.
172	node can be any of the three types (Tree, Node).
173
174	=head1 VARIABLES
175
176	$NONBLOCKING - tells the Parser to enter into a nonblocking state. This
177	might cause some funky behavior since you can get nested
178	callbacks while things are waiting. 1=on, 0=off(default).
179
180	=head1 EXAMPLES
181
182	##########################
183	# simple example
184
185	use XML::Stream qw( Tree );
186
187	$stream = new XML::Stream;
188
189	my $status = $stream->Connect(hostname => "jabber.org",
190	port => 5222,
191	namespace => "jabber:client");
192
193	if (!defined($status)) {
194	print "ERROR: Could not connect to server\n";
195	print " (",$stream->GetErrorCode(),")\n";
196	exit(0);
197	}
198
199	while($node = $stream->Process()) {
200	# do something with $node
201	}
202
203	$stream->Disconnect();
204
205
206	###########################
207	# example using a handler
208
209	use XML::Stream qw( Tree );
210
211	$stream = new XML::Stream;
212	$stream->SetCallBacks(node=>\&noder);
213	$stream->Connect(hostname => "jabber.org",
214	port => 5222,
215	namespace => "jabber:client",
216	timeout => undef) \|\| die $!;
217
218	# Blocks here forever, noder is called for incoming
219	# packets when they arrive.
220	while(defined($stream->Process())) { }
221
222	print "ERROR: Stream died (",$stream->GetErrorCode(),")\n";
223
224	sub noder
225	{
226	my $sid = shift;
227	my $node = shift;
228	# do something with $node
229	}
230
231	=head1 AUTHOR
232
233	Tweaked, tuned, and brightness changes by Ryan Eatmon, reatmon@ti.com
234	in May of 2000.
235	Colorized, and Dolby Surround sound added by Thomas Charron,
236	tcharron@jabber.org
237	By Jeremie in October of 1999 for http://etherx.jabber.org/streams/
238
239	=head1 COPYRIGHT
240
241	This module is free software; you can redistribute it and/or modify
242	it under the same terms as Perl itself.
243
244	=cut
245
246	use 5.006_001;
247	use strict;
248	use Sys::Hostname;
249	use IO::Socket;
250	use IO::Select;
251	use FileHandle;
252	use Carp;
253	use POSIX;
254	use Authen::SASL;
255	use MIME::Base64;
256	use utf8;
257	use Encode;
258
259	$SIG{PIPE} = "IGNORE";
260
261	use vars qw($VERSION $PAC $SSL $NONBLOCKING %HANDLERS $NETDNS %XMLNS );
262
263	##############################################################################
264	# Define the namespaces in an easy/constant manner.
265	#-----------------------------------------------------------------------------
266	# 0.9
267	#-----------------------------------------------------------------------------
268	$XMLNS{'stream'} = "http://etherx.jabber.org/streams";
269
270	#-----------------------------------------------------------------------------
271	# 1.0
272	#-----------------------------------------------------------------------------
273	$XMLNS{'xmppstreams'} = "urn:ietf:params:xml:ns:xmpp-streams";
274	$XMLNS{'xmpp-bind'} = "urn:ietf:params:xml:ns:xmpp-bind";
275	$XMLNS{'xmpp-sasl'} = "urn:ietf:params:xml:ns:xmpp-sasl";
276	$XMLNS{'xmpp-session'} = "urn:ietf:params:xml:ns:xmpp-session";
277	$XMLNS{'xmpp-tls'} = "urn:ietf:params:xml:ns:xmpp-tls";
278	##############################################################################
279
280
281	if (eval "require Net::DNS;" )
282	{
283	require Net::DNS;
284	import Net::DNS;
285	$NETDNS = 1;
286	}
287	else
288	{
289	$NETDNS = 0;
290	}
291
292
293	$VERSION = "1.22";
294	$NONBLOCKING = 0;
295
296	use XML::Stream::Namespace;
297	use XML::Stream::Parser;
298	use XML::Stream::XPath;
299
300	##############################################################################
301	#
302	# Setup the exportable objects
303	#
304	##############################################################################
305	require Exporter;
306	my @ISA = qw(Exporter);
307	my @EXPORT_OK = qw(Tree Node);
308
309	sub import
310	{
311	my $class = shift;
312
313	foreach my $module (@_)
314	{
315	eval "use XML::Stream::$module;";
316	die($@) if ($@);
317
318	my $lc = lc($module);
319
320	eval("\$HANDLERS{\$lc}->{startElement} = \\&XML::Stream::${module}::_handle_element;");
321	eval("\$HANDLERS{\$lc}->{endElement} = \\&XML::Stream::${module}::_handle_close;");
322	eval("\$HANDLERS{\$lc}->{characters} = \\&XML::Stream::${module}::_handle_cdata;");
323	}
324	}
325
326
327	sub new
328	{
329	my $proto = shift;
330	my $self = { };
331
332	bless($self,$proto);
333
334	my %args;
335	while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
336
337	$self->{DATASTYLE} = "tree";
338	$self->{DATASTYLE} = delete($args{style}) if exists($args{style});
339
340	if ((($self->{DATASTYLE} eq "tree") && !defined($XML::Stream::Tree::LOADED)) \|\|
341	(($self->{DATASTYLE} eq "node") && !defined($XML::Stream::Node::LOADED))
342	)
343	{
344	croak("The style that you have chosen was not defined when you \"use\"d the module.\n");
345	}
346
347	$self->{DEBUGARGS} = \%args;
348
349	$self->{DEBUGTIME} = 0;
350	$self->{DEBUGTIME} = $args{debugtime} if exists($args{debugtime});
351
352	$self->{DEBUGLEVEL} = 0;
353	$self->{DEBUGLEVEL} = $args{debuglevel} if exists($args{debuglevel});
354
355	$self->{DEBUGFILE} = "";
356
357	if (exists($args{debugfh}) && ($args{debugfh} ne ""))
358	{
359	$self->{DEBUGFILE} = $args{debugfh};
360	$self->{DEBUG} = 1;
361	}
362	if ((exists($args{debugfh}) && ($args{debugfh} eq "")) \|\|
363	(exists($args{debug}) && ($args{debug} ne "")))
364	{
365	$self->{DEBUG} = 1;
366	if (lc($args{debug}) eq "stdout")
367	{
368	$self->{DEBUGFILE} = new FileHandle(">&STDERR");
369	$self->{DEBUGFILE}->autoflush(1);
370	}
371	else
372	{
373	if (-e $args{debug})
374	{
375	if (-w $args{debug})
376	{
377	$self->{DEBUGFILE} = new FileHandle(">$args{debug}");
378	$self->{DEBUGFILE}->autoflush(1);
379	}
380	else
381	{
382	print "WARNING: debug file ($args{debug}) is not writable by you\n";
383	print " No debug information being saved.\n";
384	$self->{DEBUG} = 0;
385	}
386	}
387	else
388	{
389	$self->{DEBUGFILE} = new FileHandle(">$args{debug}");
390	if (defined($self->{DEBUGFILE}))
391	{
392	$self->{DEBUGFILE}->autoflush(1);
393	}
394	else
395	{
396	print "WARNING: debug file ($args{debug}) does not exist \n";
397	print " and is not writable by you.\n";
398	print " No debug information being saved.\n";
399	$self->{DEBUG} = 0;
400	}
401	}
402	}
403	}
404
405	my $hostname = hostname();
406	my $address = gethostbyname($hostname) \|\|
407	die("Cannot resolve $hostname: $!");
408	my $fullname = gethostbyaddr($address,AF_INET) \|\| $hostname;
409
410	$self->debug(1,"new: hostname = ($fullname)");
411
412	#---------------------------------------------------------------------------
413	# Setup the defaults that the module will work with.
414	#---------------------------------------------------------------------------
415	$self->{SIDS}->{default}->{hostname} = "";
416	$self->{SIDS}->{default}->{port} = "";
417	$self->{SIDS}->{default}->{sock} = 0;
418	$self->{SIDS}->{default}->{ssl} = (exists($args{ssl}) ? $args{ssl} : 0);
419	$self->{SIDS}->{default}->{namespace} = "";
420	$self->{SIDS}->{default}->{myhostname} = $fullname;
421	$self->{SIDS}->{default}->{derivedhostname} = $fullname;
422	$self->{SIDS}->{default}->{id} = "";
423
424	#---------------------------------------------------------------------------
425	# We are only going to use one callback, let the user call other callbacks
426	# on his own.
427	#---------------------------------------------------------------------------
428	$self->SetCallBacks(node=>sub { $self->_node(@_) });
429
430	$self->{IDCOUNT} = 0;
431
432	return $self;
433	}
434
435
436
437
438	##############################################################################
439	#+----------------------------------------------------------------------------
440	#\|
441	#\| Incoming Connection Functions
442	#\|
443	#+----------------------------------------------------------------------------
444	##############################################################################
445
446	##############################################################################
447	#
448	# Listen - starts the stream by listening on a port for someone to connect,
449	# and send the opening stream tag, and then sending a response based
450	# on if the received header was correct for this stream. Server
451	# name, port, and namespace are required otherwise we don't know
452	# where to listen and what namespace to accept.
453	#
454	##############################################################################
455	sub Listen
456	{
457	my $self = shift;
458	my %args;
459	while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
460
461	my $serverid = "server$args{port}";
462
463	return if exists($self->{SIDS}->{$serverid});
464
465	push(@{$self->{SIDS}->{server}},$serverid);
466
467	foreach my $key (keys(%{$self->{SIDS}->{default}}))
468	{
469	$self->{SIDS}->{$serverid}->{$key} = $self->{SIDS}->{default}->{$key};
470	}
471
472	foreach my $key (keys(%args))
473	{
474	$self->{SIDS}->{$serverid}->{$key} = $args{$key};
475	}
476
477	$self->debug(1,"Listen: start");
478
479	if ($self->{SIDS}->{$serverid}->{namespace} eq "")
480	{
481	$self->SetErrorCode($serverid,"Namespace not specified");
482	return;
483	}
484
485	#---------------------------------------------------------------------------
486	# Check some things that we have to know in order get the connection up
487	# and running. Server hostname, port number, namespace, etc...
488	#---------------------------------------------------------------------------
489	if ($self->{SIDS}->{$serverid}->{hostname} eq "")
490	{
491	$self->SetErrorCode("$serverid","Server hostname not specified");
492	return;
493	}
494	if ($self->{SIDS}->{$serverid}->{port} eq "")
495	{
496	$self->SetErrorCode("$serverid","Server port not specified");
497	return;
498	}
499	if ($self->{SIDS}->{$serverid}->{myhostname} eq "")
500	{
501	$self->{SIDS}->{$serverid}->{myhostname} = $self->{SIDS}->{$serverid}->{derivedhostname};
502	}
503
504	#-------------------------------------------------------------------------
505	# Open the connection to the listed server and port. If that fails then
506	# abort ourselves and let the user check $! on his own.
507	#-------------------------------------------------------------------------
508
509	while($self->{SIDS}->{$serverid}->{sock} == 0)
510	{
511	$self->{SIDS}->{$serverid}->{sock} =
512	new IO::Socket::INET(LocalHost=>$self->{SIDS}->{$serverid}->{hostname},
513	LocalPort=>$self->{SIDS}->{$serverid}->{port},
514	Reuse=>1,
515	Listen=>10,
516	Proto=>'tcp');
517	select(undef,undef,undef,.1);
518	}
519	$self->{SIDS}->{$serverid}->{status} = 1;
520	$self->nonblock($self->{SIDS}->{$serverid}->{sock});
521	$self->{SIDS}->{$serverid}->{sock}->autoflush(1);
522
523	$self->{SELECT} =
524	new IO::Select($self->{SIDS}->{$serverid}->{sock});
525	$self->{SIDS}->{$serverid}->{select} =
526	new IO::Select($self->{SIDS}->{$serverid}->{sock});
527
528	$self->{SOCKETS}->{$self->{SIDS}->{$serverid}->{sock}} = "$serverid";
529
530	return $serverid;
531	}
532
533
534	##############################################################################
535	#
536	# ConnectionAccept - accept an incoming connection.
537	#
538	##############################################################################
539	sub ConnectionAccept
540	{
541	my $self = shift;
542	my $serverid = shift;
543
544	my $sid = $self->NewSID();
545
546	$self->debug(1,"ConnectionAccept: sid($sid)");
547
548	$self->{SIDS}->{$sid}->{sock} = $self->{SIDS}->{$serverid}->{sock}->accept();
549
550	$self->nonblock($self->{SIDS}->{$sid}->{sock});
551	$self->{SIDS}->{$sid}->{sock}->autoflush(1);
552
553	$self->debug(3,"ConnectionAccept: sid($sid) client($self->{SIDS}->{$sid}->{sock}) server($self->{SIDS}->{$serverid}->{sock})");
554
555	$self->{SELECT}->add($self->{SIDS}->{$sid}->{sock});
556
557	#-------------------------------------------------------------------------
558	# Create the XML::Stream::Parser and register our callbacks
559	#-------------------------------------------------------------------------
560	$self->{SIDS}->{$sid}->{parser} =
561	new XML::Stream::Parser(%{$self->{DEBUGARGS}},
562	nonblocking=>$NONBLOCKING,
563	sid=>$sid,
564	style=>$self->{DATASTYLE},
565	Handlers=>{
566	startElement=>sub{ $self->_handle_root(@_) },
567	endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
568	characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
569	}
570	);
571
572	$self->{SIDS}->{$sid}->{select} =
573	new IO::Select($self->{SIDS}->{$sid}->{sock});
574	$self->{SIDS}->{$sid}->{connectiontype} = "tcpip";
575	$self->{SOCKETS}->{$self->{SIDS}->{$sid}->{sock}} = $sid;
576
577	$self->InitConnection($sid,$serverid);
578
579	#---------------------------------------------------------------------------
580	# Grab the init time so that we can check if we get data in the timeout
581	# period or not.
582	#---------------------------------------------------------------------------
583	$self->{SIDS}->{$sid}->{activitytimeout} = time;
584
585	return $sid;
586	}
587
588
589	##############################################################################
590	#
591	# Respond - If this is a listening socket then we need to respond to the
592	# opening <stream:stream/>.
593	#
594	##############################################################################
595	sub Respond
596	{
597	my $self = shift;
598	my $sid = shift;
599	my $serverid = $self->{SIDS}->{$sid}->{serverid};
600
601	my $root = $self->GetRoot($sid);
602
603	if ($root->{xmlns} ne $self->{SIDS}->{$serverid}->{namespace})
604	{
605	my $error = $self->StreamError($sid,"invalid-namespace","Invalid namespace specified");
606	$self->Send($sid,$error);
607
608	$self->{SIDS}->{$sid}->{sock}->flush();
609	select(undef,undef,undef,1);
610	$self->Disconnect($sid);
611	}
612
613	#---------------------------------------------------------------------------
614	# Next, we build the opening handshake.
615	#---------------------------------------------------------------------------
616	my %stream_args;
617
618	$stream_args{from} =
619	(exists($self->{SIDS}->{$serverid}->{from}) ?
620	$self->{SIDS}->{$serverid}->{from} :
621	$self->{SIDS}->{$serverid}->{hostname}
622	);
623
624	$stream_args{to} = $self->GetRoot($sid)->{from};
625	$stream_args{id} = $sid;
626	$stream_args{namespaces} = $self->{SIDS}->{$serverid}->{namespaces};
627
628	my $stream =
629	$self->StreamHeader(
630	xmlns=>$self->{SIDS}->{$serverid}->{namespace},
631	xmllang=>"en",
632	%stream_args
633	);
634
635	#---------------------------------------------------------------------------
636	# Then we send the opening handshake.
637	#---------------------------------------------------------------------------
638	$self->Send($sid,$stream);
639	delete($self->{SIDS}->{$sid}->{activitytimeout});
640	}
641
642
643
644
645	##############################################################################
646	#+----------------------------------------------------------------------------
647	#\|
648	#\| Outgoing Connection Functions
649	#\|
650	#+----------------------------------------------------------------------------
651	##############################################################################
652
653	##############################################################################
654	#
655	# Connect - starts the stream by connecting to the server, sending the opening
656	# stream tag, and then waiting for a response and verifying that it
657	# is correct for this stream. Server name, port, and namespace are
658	# required otherwise we don't know where to send the stream to...
659	#
660	##############################################################################
661	sub Connect
662	{
663	my $self = shift;
664
665	foreach my $key (keys(%{$self->{SIDS}->{default}}))
666	{
667	$self->{SIDS}->{newconnection}->{$key} = $self->{SIDS}->{default}->{$key};
668	}
669	while($#_ >= 0) { $self->{SIDS}->{newconnection}->{ lc pop(@_) } = pop(@_); }
670
671	my $timeout = exists($self->{SIDS}->{newconnection}->{timeout}) ?
672	delete($self->{SIDS}->{newconnection}->{timeout}) :
673	"";
674
675	$self->debug(4,"Connect: timeout($timeout)");
676
677
678	if (exists($self->{SIDS}->{newconnection}->{srv}))
679	{
680	$self->debug(1,"Connect: srv requested");
681	if ($NETDNS)
682	{
683	my $res = Net::DNS::Resolver->new();
684	my $query = $res->query($self->{SIDS}->{newconnection}->{srv}.".".$self->{SIDS}->{newconnection}->{hostname},"SRV");
685
686	if ($query)
687	{
688	$self->{SIDS}->{newconnection}->{hostname} = ($query->answer)[0]->target();
689	$self->{SIDS}->{newconnection}->{port} = ($query->answer)[0]->port();
690	$self->debug(1,"Connect: srv host: $self->{SIDS}->{newconnection}->{hostname}");
691	$self->debug(1,"Connect: srv post: $self->{SIDS}->{newconnection}->{port}");
692	}
693	else
694	{
695	$self->debug(1,"Connect: srv query failed");
696	}
697	}
698	else
699	{
700	$self->debug(1,"Connect: srv query failed");
701	}
702	delete($self->{SIDS}->{newconnection}->{srv});
703	}
704
705	$self->{SIDS}->{newconnection}->{connectiontype} = "tcpip"
706	unless exists($self->{SIDS}->{newconnection}->{connectiontype});
707
708	$self->debug(1,"Connect: type($self->{SIDS}->{newconnection}->{connectiontype})");
709
710	if ($self->{SIDS}->{newconnection}->{namespace} eq "")
711	{
712	$self->SetErrorCode("newconnection","Namespace not specified");
713	return;
714	}
715
716	#---------------------------------------------------------------------------
717	# TCP/IP
718	#---------------------------------------------------------------------------
719	if ($self->{SIDS}->{newconnection}->{connectiontype} eq "tcpip")
720	{
721	#-----------------------------------------------------------------------
722	# Check some things that we have to know in order get the connection up
723	# and running. Server hostname, port number, namespace, etc...
724	#-----------------------------------------------------------------------
725	if ($self->{SIDS}->{newconnection}->{hostname} eq "")
726	{
727	$self->SetErrorCode("newconnection","Server hostname not specified");
728	return;
729	}
730	if ($self->{SIDS}->{newconnection}->{port} eq "")
731	{
732	$self->SetErrorCode("newconnection","Server port not specified");
733	return;
734	}
735	if ($self->{SIDS}->{newconnection}->{myhostname} eq "")
736	{
737	$self->{SIDS}->{newconnection}->{myhostname} = $self->{SIDS}->{newconnection}->{derivedhostname};
738	}
739
740	#-----------------------------------------------------------------------
741	# Open the connection to the listed server and port. If that fails then
742	# abort ourselves and let the user check $! on his own.
743	#-----------------------------------------------------------------------
744	$self->{SIDS}->{newconnection}->{sock} =
745	new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{hostname},
746	PeerPort=>$self->{SIDS}->{newconnection}->{port},
747	Proto=>"tcp",
748	(($timeout ne "") ? ( Timeout=>$timeout ) : ()),
749	);
750	return unless $self->{SIDS}->{newconnection}->{sock};
751
752	if ($self->{SIDS}->{newconnection}->{ssl} == 1)
753	{
754	$self->debug(1,"Connect: Convert normal socket to SSL");
755	$self->debug(1,"Connect: sock($self->{SIDS}->{newconnection}->{sock})");
756	$self->LoadSSL();
757	$self->{SIDS}->{newconnection}->{sock} =
758	IO::Socket::SSL::socketToSSL($self->{SIDS}->{newconnection}->{sock},
759	{SSL_verify_mode=>0x00});
760	$self->debug(1,"Connect: ssl_sock($self->{SIDS}->{newconnection}->{sock})");
761	$self->debug(1,"Connect: SSL: We are secure") if ($self->{SIDS}->{newconnection}->{sock});
762	}
763	return unless $self->{SIDS}->{newconnection}->{sock};
764	}
765
766	#---------------------------------------------------------------------------
767	# STDIN/OUT
768	#---------------------------------------------------------------------------
769	if ($self->{SIDS}->{newconnection}->{connectiontype} eq "stdinout")
770	{
771	$self->{SIDS}->{newconnection}->{sock} =
772	new FileHandle(">&STDOUT");
773	}
774
775	#---------------------------------------------------------------------------
776	# HTTP
777	#---------------------------------------------------------------------------
778	if ($self->{SIDS}->{newconnection}->{connectiontype} eq "http")
779	{
780	#-----------------------------------------------------------------------
781	# Check some things that we have to know in order get the connection up
782	# and running. Server hostname, port number, namespace, etc...
783	#-----------------------------------------------------------------------
784	if ($self->{SIDS}->{newconnection}->{hostname} eq "")
785	{
786	$self->SetErrorCode("newconnection","Server hostname not specified");
787	return;
788	}
789	if ($self->{SIDS}->{newconnection}->{port} eq "")
790	{
791	$self->SetErrorCode("newconnection","Server port not specified");
792	return;
793	}
794	if ($self->{SIDS}->{newconnection}->{myhostname} eq "")
795	{
796	$self->{SIDS}->{newconnection}->{myhostname} = $self->{SIDS}->{newconnection}->{derivedhostname};
797	}
798
799	if (!defined($PAC))
800	{
801	eval("use HTTP::ProxyAutoConfig;");
802	if ($@)
803	{
804	$PAC = 0;
805	}
806	else
807	{
808	require HTTP::ProxyAutoConfig;
809	$PAC = new HTTP::ProxyAutoConfig();
810	}
811	}
812
813	if ($PAC eq "0") {
814	if (exists($ENV{"http_proxy"}))
815	{
816	my($host,$port) = ($ENV{"http_proxy"} =~ /^(\S+)\:(\d+)$/);
817	$self->{SIDS}->{newconnection}->{httpproxyhostname} = $host;
818	$self->{SIDS}->{newconnection}->{httpproxyport} = $port;
819	$self->{SIDS}->{newconnection}->{httpproxyhostname} =~ s/^http\:\/\///;
820	}
821	if (exists($ENV{"https_proxy"}))
822	{
823	my($host,$port) = ($ENV{"https_proxy"} =~ /^(\S+)\:(\d+)$/);
824	$self->{SIDS}->{newconnection}->{httpsproxyhostname} = $host;
825	$self->{SIDS}->{newconnection}->{httpsproxyport} = $port;
826	$self->{SIDS}->{newconnection}->{httpsproxyhostname} =~ s/^https?\:\/\///;
827	}
828	}
829	else
830	{
831	my $proxy = $PAC->FindProxy("http://".$self->{SIDS}->{newconnection}->{hostname});
832	if ($proxy ne "DIRECT")
833	{
834	($self->{SIDS}->{newconnection}->{httpproxyhostname},$self->{SIDS}->{newconnection}->{httpproxyport}) = ($proxy =~ /^PROXY ([^:]+):(\d+)$/);
835	}
836
837	$proxy = $PAC->FindProxy("https://".$self->{SIDS}->{newconnection}->{hostname});
838
839	if ($proxy ne "DIRECT")
840	{
841	($self->{SIDS}->{newconnection}->{httpsproxyhostname},$self->{SIDS}->{newconnection}->{httpsproxyport}) = ($proxy =~ /^PROXY ([^:]+):(\d+)$/);
842	}
843	}
844
845	$self->debug(1,"Connect: http_proxy($self->{SIDS}->{newconnection}->{httpproxyhostname}:$self->{SIDS}->{newconnection}->{httpproxyport})")
846	if (exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
847	defined($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
848	exists($self->{SIDS}->{newconnection}->{httpproxyport}) &&
849	defined($self->{SIDS}->{newconnection}->{httpproxyport}));
850	$self->debug(1,"Connect: https_proxy($self->{SIDS}->{newconnection}->{httpsproxyhostname}:$self->{SIDS}->{newconnection}->{httpsproxyport})")
851	if (exists($self->{SIDS}->{newconnection}->{httpsproxyhostname}) &&
852	defined($self->{SIDS}->{newconnection}->{httpsproxyhostname}) &&
853	exists($self->{SIDS}->{newconnection}->{httpsproxyport}) &&
854	defined($self->{SIDS}->{newconnection}->{httpsproxyport}));
855
856	#-----------------------------------------------------------------------
857	# Open the connection to the listed server and port. If that fails then
858	# abort ourselves and let the user check $! on his own.
859	#-----------------------------------------------------------------------
860	my $connect = "CONNECT $self->{SIDS}->{newconnection}->{hostname}:$self->{SIDS}->{newconnection}->{port} HTTP/1.1\r\nHost: $self->{SIDS}->{newconnection}->{hostname}\r\n\r\n";
861	my $put = "PUT http://$self->{SIDS}->{newconnection}->{hostname}:$self->{SIDS}->{newconnection}->{port} HTTP/1.1\r\nHost: $self->{SIDS}->{newconnection}->{hostname}\r\nProxy-Connection: Keep-Alive\r\n\r\n";
862
863	my $connected = 0;
864	#-----------------------------------------------------------------------
865	# Combo #0 - The user didn't specify a proxy
866	#-----------------------------------------------------------------------
867	if (!exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
868	!exists($self->{SIDS}->{newconnection}->{httpsproxyhostname}))
869	{
870
871	$self->debug(1,"Connect: Combo #0: User did not specify a proxy... connecting DIRECT");
872
873	$self->debug(1,"Connect: Combo #0: Create normal socket");
874	$self->{SIDS}->{newconnection}->{sock} =
875	new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{hostname},
876	PeerPort=>$self->{SIDS}->{newconnection}->{port},
877	Proto=>"tcp",
878	(($timeout ne "") ? ( Timeout=>$timeout ) : ()),
879	);
880	$connected = defined($self->{SIDS}->{newconnection}->{sock});
881	$self->debug(1,"Connect: Combo #0: connected($connected)");
882	# if ($connected)
883	# {
884	# $self->{SIDS}->{newconnection}->{sock}->syswrite($put,length($put),0);
885	# my $buff;
886	# $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ);
887	# my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/);
888	# $self->debug(1,"Connect: Combo #1: buff($buff)");
889	# $connected = 0 if ($code !~ /2\d\d/);
890	# }
891	# $self->debug(1,"Connect: Combo #0: connected($connected)");
892	}
893
894	#-----------------------------------------------------------------------
895	# Combo #1 - PUT through http_proxy
896	#-----------------------------------------------------------------------
897	if (!$connected &&
898	exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
899	($self->{SIDS}->{newconnection}->{ssl} == 0))
900	{
901
902	$self->debug(1,"Connect: Combo #1: PUT through http_proxy");
903	$self->{SIDS}->{newconnection}->{sock} =
904	new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpproxyhostname},
905	PeerPort=>$self->{SIDS}->{newconnection}->{httpproxyport},
906	Proto=>"tcp",
907	(($timeout ne "") ? ( Timeout=>$timeout ) : ()),
908	);
909	$connected = defined($self->{SIDS}->{newconnection}->{sock});
910	$self->debug(1,"Connect: Combo #1: connected($connected)");
911	if ($connected)
912	{
913	$self->debug(1,"Connect: Combo #1: send($put)");
914	$self->{SIDS}->{newconnection}->{sock}->syswrite($put,length($put),0);
915	my $buff;
916	$self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ);
917	my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/);
918	$self->debug(1,"Connect: Combo #1: buff($buff)");
919	$connected = 0 if ($code !~ /2\d\d/);
920	}
921	$self->debug(1,"Connect: Combo #1: connected($connected)");
922	}
923	#-----------------------------------------------------------------------
924	# Combo #2 - CONNECT through http_proxy
925	#-----------------------------------------------------------------------
926	if (!$connected &&
927	exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
928	($self->{SIDS}->{newconnection}->{ssl} == 0))
929	{
930
931	$self->debug(1,"Connect: Combo #2: CONNECT through http_proxy");
932	$self->{SIDS}->{newconnection}->{sock} =
933	new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpproxyhostname},
934	PeerPort=>$self->{SIDS}->{newconnection}->{httpproxyport},
935	Proto=>"tcp",
936	(($timeout ne "") ? ( Timeout=>$timeout ) : ()),
937	);
938	$connected = defined($self->{SIDS}->{newconnection}->{sock});
939	$self->debug(1,"Connect: Combo #2: connected($connected)");
940	if ($connected)
941	{
942	$self->{SIDS}->{newconnection}->{sock}->syswrite($connect,length($connect),0);
943	my $buff;
944	$self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ);
945	my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/);
946	$self->debug(1,"Connect: Combo #2: buff($buff)");
947	$connected = 0 if ($code !~ /2\d\d/);
948	}
949	$self->debug(1,"Connect: Combo #2: connected($connected)");
950	}
951
952	#-----------------------------------------------------------------------
953	# Combo #3 - CONNECT through https_proxy
954	#-----------------------------------------------------------------------
955	if (!$connected &&
956	exists($self->{SIDS}->{newconnection}->{httpsproxyhostname}))
957	{
958	$self->debug(1,"Connect: Combo #3: CONNECT through https_proxy");
959	$self->{SIDS}->{newconnection}->{sock} =
960	new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpsproxyhostname},
961	PeerPort=>$self->{SIDS}->{newconnection}->{httpsproxyport},
962	Proto=>"tcp");
963	$connected = defined($self->{SIDS}->{newconnection}->{sock});
964	$self->debug(1,"Connect: Combo #3: connected($connected)");
965	if ($connected)
966	{
967	$self->{SIDS}->{newconnection}->{sock}->syswrite($connect,length($connect),0);
968	my $buff;
969	$self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ);
970	my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/);
971	$self->debug(1,"Connect: Combo #3: buff($buff)");
972	$connected = 0 if ($code !~ /2\d\d/);
973	}
974	$self->debug(1,"Connect: Combo #3: connected($connected)");
975	}
976
977	#-----------------------------------------------------------------------
978	# We have failed
979	#-----------------------------------------------------------------------
980	if (!$connected)
981	{
982	$self->debug(1,"Connect: No connection... I have failed... I.. must... end it all...");
983	$self->SetErrorCode("newconnection","Unable to open a connection to destination. Please check your http_proxy and/or https_proxy environment variables.");
984	return;
985	}
986
987	return unless $self->{SIDS}->{newconnection}->{sock};
988
989	$self->debug(1,"Connect: We are connected");
990
991	if (($self->{SIDS}->{newconnection}->{ssl} == 1) &&
992	(ref($self->{SIDS}->{newconnection}->{sock}) eq "IO::Socket::INET"))
993	{
994	$self->debug(1,"Connect: Convert normal socket to SSL");
995	$self->debug(1,"Connect: sock($self->{SIDS}->{newconnection}->{sock})");
996	$self->LoadSSL();
997	$self->{SIDS}->{newconnection}->{sock} =
998	IO::Socket::SSL::socketToSSL($self->{SIDS}->{newconnection}->{sock},
999	{SSL_verify_mode=>0x00});
1000	$self->debug(1,"Connect: ssl_sock($self->{SIDS}->{newconnection}->{sock})");
1001	$self->debug(1,"Connect: SSL: We are secure") if ($self->{SIDS}->{newconnection}->{sock});
1002	}
1003	return unless $self->{SIDS}->{newconnection}->{sock};
1004	}
1005
1006	$self->debug(1,"Connect: Got a connection");
1007
1008	$self->{SIDS}->{newconnection}->{sock}->autoflush(1);
1009
1010	return $self->OpenStream("newconnection",$timeout);
1011	}
1012
1013
1014	##############################################################################
1015	#
1016	# OpenStream - Send the opening stream and save the root element info.
1017	#
1018	##############################################################################
1019	sub OpenStream
1020	{
1021	my $self = shift;
1022	my $currsid = shift;
1023	my $timeout = shift;
1024	$timeout = "" unless defined($timeout);
1025
1026	$self->InitConnection($currsid,$currsid);
1027
1028	#---------------------------------------------------------------------------
1029	# Next, we build the opening handshake.
1030	#---------------------------------------------------------------------------
1031	my %stream_args;
1032
1033	if (($self->{SIDS}->{$currsid}->{connectiontype} eq "tcpip") \|\|
1034	($self->{SIDS}->{$currsid}->{connectiontype} eq "http"))
1035	{
1036	$stream_args{to}= $self->{SIDS}->{$currsid}->{hostname}
1037	unless exists($self->{SIDS}->{$currsid}->{to});
1038
1039	$stream_args{to} = $self->{SIDS}->{$currsid}->{to}
1040	if exists($self->{SIDS}->{$currsid}->{to});
1041
1042	$stream_args{from} = $self->{SIDS}->{$currsid}->{myhostname}
1043	if (!exists($self->{SIDS}->{$currsid}->{from}) &&
1044	($self->{SIDS}->{$currsid}->{myhostname} ne "")
1045	);
1046
1047	$stream_args{from} = $self->{SIDS}->{$currsid}->{from}
1048	if exists($self->{SIDS}->{$currsid}->{from});
1049
1050	$stream_args{id} = $self->{SIDS}->{$currsid}->{id}
1051	if (exists($self->{SIDS}->{$currsid}->{id}) &&
1052	($self->{SIDS}->{$currsid}->{id} ne "")
1053	);
1054
1055	$stream_args{namespaces} = $self->{SIDS}->{$currsid}->{namespaces};
1056	}
1057
1058	my $stream =
1059	$self->StreamHeader(
1060	xmlns=>$self->{SIDS}->{$currsid}->{namespace},
1061	xmllang=>"en",
1062	%stream_args
1063	);
1064
1065	#---------------------------------------------------------------------------
1066	# Create the XML::Stream::Parser and register our callbacks
1067	#---------------------------------------------------------------------------
1068	$self->{SIDS}->{$currsid}->{parser} =
1069	new XML::Stream::Parser(%{$self->{DEBUGARGS}},
1070	nonblocking=>$NONBLOCKING,
1071	sid=>$currsid,
1072	style=>$self->{DATASTYLE},
1073	Handlers=>{
1074	startElement=>sub{ $self->_handle_root(@_) },
1075	endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
1076	characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
1077	}
1078	);
1079
1080	$self->{SIDS}->{$currsid}->{select} =
1081	new IO::Select($self->{SIDS}->{$currsid}->{sock});
1082
1083	if (($self->{SIDS}->{$currsid}->{connectiontype} eq "tcpip") \|\|
1084	($self->{SIDS}->{$currsid}->{connectiontype} eq "http"))
1085	{
1086	$self->{SELECT} = new IO::Select($self->{SIDS}->{$currsid}->{sock});
1087	$self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = "newconnection";
1088	}
1089
1090	if ($self->{SIDS}->{$currsid}->{connectiontype} eq "stdinout")
1091	{
1092	$self->{SELECT} = new IO::Select(*STDIN);
1093	$self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $currsid;
1094	$self->{SOCKETS}->{*STDIN} = $currsid;
1095	$self->{SIDS}->{$currsid}->{select}->add(*STDIN);
1096	}
1097
1098	$self->{SIDS}->{$currsid}->{status} = 0;
1099
1100	#---------------------------------------------------------------------------
1101	# Then we send the opening handshake.
1102	#---------------------------------------------------------------------------
1103	$self->Send($currsid,$stream) \|\| return;
1104
1105	#---------------------------------------------------------------------------
1106	# Before going on let's make sure that the server responded with a valid
1107	# root tag and that the stream is open.
1108	#---------------------------------------------------------------------------
1109	my $buff = "";
1110	my $timeEnd = ($timeout eq "") ? "" : time + $timeout;
1111	while($self->{SIDS}->{$currsid}->{status} == 0)
1112	{
1113	my $now = time;
1114	my $wait = (($timeEnd eq "") \|\| ($timeEnd - $now > 10)) ? 10 :
1115	$timeEnd - $now;
1116
1117	$self->debug(5,"Connect: can_read(",join(",",$self->{SIDS}->{$currsid}->{select}->can_read(0)),")");
1118	if ($self->{SIDS}->{$currsid}->{select}->can_read($wait))
1119	{
1120	$self->{SIDS}->{$currsid}->{status} = -1
1121	unless defined($buff = $self->Read($currsid));
1122	return unless($self->{SIDS}->{$currsid}->{status} == 0);
1123	return unless($self->ParseStream($currsid,$buff) == 1);
1124	}
1125	else
1126	{
1127	if ($timeout ne "")
1128	{
1129	if (time >= $timeEnd)
1130	{
1131	$self->SetErrorCode($currsid,"Timeout limit reached");
1132	return;
1133	}
1134	}
1135	}
1136
1137	return if($self->{SIDS}->{$currsid}->{select}->has_exception(0));
1138	}
1139	return if($self->{SIDS}->{$currsid}->{status} != 1);
1140
1141	$self->debug(3,"Connect: status($self->{SIDS}->{$currsid}->{status})");
1142
1143	my $sid = $self->GetRoot($currsid)->{id};
1144	$\| = 1;
1145	foreach my $key (keys(%{$self->{SIDS}->{$currsid}}))
1146	{
1147	$self->{SIDS}->{$sid}->{$key} = $self->{SIDS}->{$currsid}->{$key};
1148	}
1149	$self->{SIDS}->{$sid}->{parser}->setSID($sid);
1150
1151	if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") \|\|
1152	($self->{SIDS}->{$sid}->{connectiontype} eq "http"))
1153	{
1154	$self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $sid;
1155	}
1156
1157	if ($self->{SIDS}->{$sid}->{connectiontype} eq "stdinout")
1158	{
1159	$self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $sid;
1160	$self->{SOCKETS}->{*STDIN} = $sid;
1161	}
1162
1163	# 08.04.05(Fri) slipstream@yandex.ru for compapility with ejabberd since it reuses stream id
1164	delete($self->{SIDS}->{$currsid}) unless ($currsid eq $sid);
1165
1166	if (exists($self->GetRoot($sid)->{version}) &&
1167	($self->GetRoot($sid)->{version} ne ""))
1168	{
1169	while(!$self->ReceivedStreamFeatures($sid))
1170	{
1171	$self->Process(1);
1172	}
1173	}
1174
1175	return $self->GetRoot($sid);
1176	}
1177
1178
1179	##############################################################################
1180	#
1181	# OpenFile - starts the stream by opening a file and setting it up so that
1182	# Process reads from the filehandle to get the incoming stream.
1183	#
1184	##############################################################################
1185	sub OpenFile
1186	{
1187	my $self = shift;
1188	my $file = shift;
1189
1190	$self->debug(1,"OpenFile: file($file)");
1191
1192	$self->{SIDS}->{newconnection}->{connectiontype} = "file";
1193
1194	$self->{SIDS}->{newconnection}->{sock} = new FileHandle($file);
1195	$self->{SIDS}->{newconnection}->{sock}->autoflush(1);
1196
1197	$self->RegisterPrefix("newconnection",&ConstXMLNS("stream"),"stream");
1198
1199	#---------------------------------------------------------------------------
1200	# Create the XML::Stream::Parser and register our callbacks
1201	#---------------------------------------------------------------------------
1202	$self->{SIDS}->{newconnection}->{parser} =
1203	new XML::Stream::Parser(%{$self->{DEBUGARGS}},
1204	nonblocking=>$NONBLOCKING,
1205	sid=>"newconnection",
1206	style=>$self->{DATASTYLE},
1207	Handlers=>{
1208	startElement=>sub{ $self->_handle_root(@_) },
1209	endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
1210	characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
1211	}
1212	);
1213
1214	$self->{SIDS}->{newconnection}->{select} =
1215	new IO::Select($self->{SIDS}->{newconnection}->{sock});
1216
1217	$self->{SELECT} = new IO::Select($self->{SIDS}->{newconnection}->{sock});
1218
1219	$self->{SIDS}->{newconnection}->{status} = 0;
1220
1221	my $buff = "";
1222	while($self->{SIDS}->{newconnection}->{status} == 0)
1223	{
1224	$self->debug(5,"OpenFile: can_read(",join(",",$self->{SIDS}->{newconnection}->{select}->can_read(0)),")");
1225	if ($self->{SIDS}->{newconnection}->{select}->can_read(0))
1226	{
1227	$self->{SIDS}->{newconnection}->{status} = -1
1228	unless defined($buff = $self->Read("newconnection"));
1229	return unless($self->{SIDS}->{newconnection}->{status} == 0);
1230	return unless($self->ParseStream("newconnection",$buff) == 1);
1231	}
1232
1233	return if($self->{SIDS}->{newconnection}->{select}->has_exception(0) &&
1234	$self->{SIDS}->{newconnection}->{sock}->error());
1235	}
1236	return if($self->{SIDS}->{newconnection}->{status} != 1);
1237
1238
1239	my $sid = $self->NewSID();
1240	foreach my $key (keys(%{$self->{SIDS}->{newconnection}}))
1241	{
1242	$self->{SIDS}->{$sid}->{$key} = $self->{SIDS}->{newconnection}->{$key};
1243	}
1244	$self->{SIDS}->{$sid}->{parser}->setSID($sid);
1245
1246	$self->{SOCKETS}->{$self->{SIDS}->{newconnection}->{sock}} = $sid;
1247
1248	delete($self->{SIDS}->{newconnection});
1249
1250	return $sid;
1251	}
1252
1253
1254
1255
1256	##############################################################################
1257	#+----------------------------------------------------------------------------
1258	#\|
1259	#\| Common Functions
1260	#\|
1261	#+----------------------------------------------------------------------------
1262	##############################################################################
1263
1264	##############################################################################
1265	#
1266	# Disconnect - sends the closing XML tag and shuts down the socket.
1267	#
1268	##############################################################################
1269	sub Disconnect
1270	{
1271	my $self = shift;
1272	my $sid = shift;
1273
1274	$self->Send($sid,"</stream:stream>");
1275	close($self->{SIDS}->{$sid}->{sock})
1276	if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") \|\|
1277	($self->{SIDS}->{$sid}->{connectiontype} eq "http"));
1278	delete($self->{SOCKETS}->{$self->{SIDS}->{$sid}->{sock}});
1279	foreach my $key (keys(%{$self->{SIDS}->{$sid}}))
1280	{
1281	delete($self->{SIDS}->{$sid}->{$key});
1282	}
1283	delete($self->{SIDS}->{$sid});
1284	}
1285
1286
1287	##############################################################################
1288	#
1289	# InitConnection - Initialize the connection data structure
1290	#
1291	##############################################################################
1292	sub InitConnection
1293	{
1294	my $self = shift;
1295	my $sid = shift;
1296	my $serverid = shift;
1297
1298	#---------------------------------------------------------------------------
1299	# Set the default STATUS so that we can keep track of it throughout the
1300	# session.
1301	# 1 = no errors
1302	# 0 = no data has been received yet
1303	# -1 = error from handlers
1304	# -2 = error but keep the connection alive so that we can send some info.
1305	#---------------------------------------------------------------------------
1306	$self->{SIDS}->{$sid}->{status} = 0;
1307
1308	#---------------------------------------------------------------------------
1309	# A storage place for when we don't have a callback registered and we need
1310	# to stockpile the nodes we receive until Process is called and we return
1311	# them.
1312	#---------------------------------------------------------------------------
1313	$self->{SIDS}->{$sid}->{nodes} = ();
1314
1315	#---------------------------------------------------------------------------
1316	# If there is an error on the stream, then we need a place to indicate that.
1317	#---------------------------------------------------------------------------
1318	$self->{SIDS}->{$sid}->{streamerror} = {};
1319
1320	#---------------------------------------------------------------------------
1321	# Grab the init time so that we can keep the connection alive by sending " "
1322	#---------------------------------------------------------------------------
1323	$self->{SIDS}->{$sid}->{keepalive} = time;
1324
1325	#---------------------------------------------------------------------------
1326	# Keep track of the "server" we are connected to so we can check stuff
1327	# later.
1328	#---------------------------------------------------------------------------
1329	$self->{SIDS}->{$sid}->{serverid} = $serverid;
1330
1331	#---------------------------------------------------------------------------
1332	# Mark the stream:features as MIA.
1333	#---------------------------------------------------------------------------
1334	$self->{SIDS}->{$sid}->{streamfeatures}->{received} = 0;
1335
1336	#---------------------------------------------------------------------------
1337	# First acitivty is the connection... duh. =)
1338	#---------------------------------------------------------------------------
1339	$self->MarkActivity($sid);
1340	}
1341
1342
1343	##############################################################################
1344	#
1345	# ParseStream - takes the incoming stream and makes sure that only full
1346	# XML tags gets passed to the parser. If a full tag has not
1347	# read yet, then the Stream saves the incomplete part and
1348	# sends the rest to the parser.
1349	#
1350	##############################################################################
1351	sub ParseStream
1352	{
1353	my $self = shift;
1354	my $sid = shift;
1355	my $stream = shift;
1356
1357	$stream = "" unless defined($stream);
1358
1359	$self->debug(3,"ParseStream: sid($sid) stream($stream)");
1360
1361	$self->{SIDS}->{$sid}->{parser}->parse($stream);
1362
1363	if (exists($self->{SIDS}->{$sid}->{streamerror}->{type}))
1364	{
1365	$self->debug(3,"ParseStream: ERROR($self->{SIDS}->{$sid}->{streamerror}->{type})");
1366	$self->SetErrorCode($sid,$self->{SIDS}->{$sid}->{streamerror});
1367	return 0;
1368	}
1369
1370	return 1;
1371	}
1372
1373
1374	##############################################################################
1375	#
1376	# Process - checks for data on the socket and returns a status code depending
1377	# on if there was data or not. If a timeout is not defined in the
1378	# call then the timeout defined in Connect() is used. If a timeout
1379	# of 0 is used then the call blocks until it gets some data,
1380	# otherwise it returns after the timeout period.
1381	#
1382	##############################################################################
1383	sub Process
1384	{
1385	my $self = shift;
1386	my $timeout = shift;
1387	$timeout = "" unless defined($timeout);
1388
1389	$self->debug(4,"Process: timeout($timeout)");
1390	#---------------------------------------------------------------------------
1391	# We need to keep track of what's going on in the function and tell the
1392	# outside world about it so let's return something useful. We track this
1393	# information based on sid:
1394	# -1 connection closed and error
1395	# 0 connection open but no data received.
1396	# 1 connection open and data received.
1397	# array connection open and the data that has been collected
1398	# over time (No CallBack specified)
1399	#---------------------------------------------------------------------------
1400	my %status;
1401	foreach my $sid (keys(%{$self->{SIDS}}))
1402	{
1403	next if ($sid eq "default");
1404	$self->debug(5,"Process: initialize sid($sid) status to 0");
1405	$status{$sid} = 0;
1406	}
1407
1408	#---------------------------------------------------------------------------
1409	# Either block until there is data and we have parsed it all, or wait a
1410	# certain period of time and then return control to the user.
1411	#---------------------------------------------------------------------------
1412	my $block = 1;
1413	my $timeEnd = ($timeout eq "") ? "" : time + $timeout;
1414	while($block == 1)
1415	{
1416	$self->debug(4,"Process: let's wait for data");
1417
1418	my $now = time;
1419	my $wait = (($timeEnd eq "") \|\| ($timeEnd - $now > 10)) ? 10 :
1420	$timeEnd - $now;
1421
1422	foreach my $connection ($self->{SELECT}->can_read($wait))
1423	{
1424	$self->debug(4,"Process: connection($connection)");
1425	$self->debug(4,"Process: sid($self->{SOCKETS}->{$connection})");
1426	$self->debug(4,"Process: connection_status($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status})");
1427
1428	next unless (($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status} == 1) \|\|
1429	exists($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{activitytimeout}));
1430
1431	my $processit = 1;
1432	if (exists($self->{SIDS}->{server}))
1433	{
1434	foreach my $serverid (@{$self->{SIDS}->{server}})
1435	{
1436	if (exists($self->{SIDS}->{$serverid}->{sock}) &&
1437	($connection == $self->{SIDS}->{$serverid}->{sock}))
1438	{
1439	my $sid = $self->ConnectionAccept($serverid);
1440	$status{$sid} = 0;
1441	$processit = 0;
1442	last;
1443	}
1444	}
1445	}
1446	if ($processit == 1)
1447	{
1448	my $sid = $self->{SOCKETS}->{$connection};
1449	$self->debug(4,"Process: there's something to read");
1450	$self->debug(4,"Process: connection($connection) sid($sid)");
1451	my $buff;
1452	$self->debug(4,"Process: read");
1453	$status{$sid} = 1;
1454	$self->{SIDS}->{$sid}->{status} = -1
1455	if (!defined($buff = $self->Read($sid)));
1456	$buff = "" unless defined($buff);
1457	$self->debug(4,"Process: connection_status($self->{SIDS}->{$sid}->{status})");
1458	$status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1);
1459	$self->debug(4,"Process: parse($buff)");
1460	$status{$sid} = -1 unless($self->ParseStream($sid,$buff) == 1);
1461	}
1462	$block = 0;
1463	}
1464
1465	if ($timeout ne "")
1466	{
1467	if (time >= $timeEnd)
1468	{
1469	$self->debug(4,"Process: Everyone out of the pool! Time to stop blocking.");
1470	$block = 0;
1471	}
1472	}
1473
1474	$self->debug(4,"Process: timeout($timeout)");
1475
1476	if (exists($self->{CB}->{update}))
1477	{
1478	$self->debug(4,"Process: Calling user defined update function");
1479	&{$self->{CB}->{update}}();
1480	}
1481
1482	$block = 1 if $self->{SELECT}->can_read(0);
1483
1484	#---------------------------------------------------------------------
1485	# Check for connections that need to be kept alive
1486	#---------------------------------------------------------------------
1487	$self->debug(4,"Process: check for keepalives");
1488	foreach my $sid (keys(%{$self->{SIDS}}))
1489	{
1490	next if ($sid eq "default");
1491	next if ($sid =~ /^server/);
1492	next if ($status{$sid} == -1);
1493	if ((time - $self->{SIDS}->{$sid}->{keepalive}) > 10)
1494	{
1495	$self->IgnoreActivity($sid,1);
1496	$self->{SIDS}->{$sid}->{status} = -1
1497	if !defined($self->Send($sid," "));
1498	$status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1);
1499	if ($status{$sid} == -1)
1500	{
1501	$self->debug(2,"Process: Keep-Alive failed. What the hell happened?!?!");
1502	$self->debug(2,"Process: connection_status($self->{SIDS}->{$sid}->{status})");
1503	}
1504	$self->IgnoreActivity($sid,0);
1505	}
1506	}
1507	#---------------------------------------------------------------------
1508	# Check for connections that have timed out.
1509	#---------------------------------------------------------------------
1510	$self->debug(4,"Process: check for timeouts");
1511	foreach my $sid (keys(%{$self->{SIDS}}))
1512	{
1513	next if ($sid eq "default");
1514	next if ($sid =~ /^server/);
1515
1516	if (exists($self->{SIDS}->{$sid}->{activitytimeout}))
1517	{
1518	$self->debug(4,"Process: sid($sid) time(",time,") timeout($self->{SIDS}->{$sid}->{activitytimeout})");
1519	}
1520	else
1521	{
1522	$self->debug(4,"Process: sid($sid) time(",time,") timeout(undef)");
1523	}
1524
1525	$self->Respond($sid)
1526	if (exists($self->{SIDS}->{$sid}->{activitytimeout}) &&
1527	defined($self->GetRoot($sid)));
1528	$self->Disconnect($sid)
1529	if (exists($self->{SIDS}->{$sid}->{activitytimeout}) &&
1530	((time - $self->{SIDS}->{$sid}->{activitytimeout}) > 10) &&
1531	($self->{SIDS}->{$sid}->{status} != 1));
1532	}
1533
1534
1535	#---------------------------------------------------------------------
1536	# If any of the connections have status == -1 then return so that the
1537	# user can handle it.
1538	#---------------------------------------------------------------------
1539	foreach my $sid (keys(%status))
1540	{
1541	if ($status{$sid} == -1)
1542	{
1543	$self->debug(4,"Process: sid($sid) is broken... let's tell someone and watch it hit the fan... =)");
1544	$block = 0;
1545	}
1546	}
1547
1548	$self->debug(2,"Process: block($block)");
1549	}
1550
1551	#---------------------------------------------------------------------------
1552	# If the Select has an error then shut this party down.
1553	#---------------------------------------------------------------------------
1554	foreach my $connection ($self->{SELECT}->has_exception(0))
1555	{
1556	$self->debug(4,"Process: has_exception sid($self->{SOCKETS}->{$connection})");
1557	$status{$self->{SOCKETS}->{$connection}} = -1;
1558	}
1559
1560	#---------------------------------------------------------------------------
1561	# If there are data structures that have not been collected return
1562	# those, otherwise return the status which indicates if nodes were read or
1563	# not.
1564	#---------------------------------------------------------------------------
1565	foreach my $sid (keys(%status))
1566	{
1567	$status{$sid} = $self->{SIDS}->{$sid}->{nodes}
1568	if (($status{$sid} == 1) &&
1569	($#{$self->{SIDS}->{$sid}->{nodes}} > -1));
1570	}
1571
1572	return %status;
1573	}
1574
1575
1576	##############################################################################
1577	#
1578	# Read - Takes the data from the server and returns a string
1579	#
1580	##############################################################################
1581	sub Read
1582	{
1583	my $self = shift;
1584	my $sid = shift;
1585	my $buff;
1586	my $status = 1;
1587
1588	$self->debug(3,"Read: sid($sid)");
1589	$self->debug(3,"Read: connectionType($self->{SIDS}->{$sid}->{connectiontype})");
1590	$self->debug(3,"Read: socket($self->{SIDS}->{$sid}->{sock})");
1591
1592	return if ($self->{SIDS}->{$sid}->{status} == -1);
1593
1594	if (!defined($self->{SIDS}->{$sid}->{sock}))
1595	{
1596	$self->{SIDS}->{$sid}->{status} = -1;
1597	$self->SetErrorCode($sid,"Socket does not defined.");
1598	return;
1599	}
1600
1601	$self->{SIDS}->{$sid}->{sock}->flush();
1602
1603	$status = $self->{SIDS}->{$sid}->{sock}->sysread($buff,4*POSIX::BUFSIZ)
1604	if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") \|\|
1605	($self->{SIDS}->{$sid}->{connectiontype} eq "http") \|\|
1606	($self->{SIDS}->{$sid}->{connectiontype} eq "file"));
1607	$status = sysread(STDIN,$buff,1024)
1608	if ($self->{SIDS}->{$sid}->{connectiontype} eq "stdinout");
1609
1610	$buff =~ s/^HTTP[\S\s]+\n\n// if ($self->{SIDS}->{$sid}->{connectiontype} eq "http");
1611	$self->debug(1,"Read: buff($buff)");
1612	$self->debug(3,"Read: status($status)") if defined($status);
1613	$self->debug(3,"Read: status(undef)") unless defined($status);
1614	$self->{SIDS}->{$sid}->{keepalive} = time
1615	unless (($buff eq "") \|\| !defined($status) \|\| ($status == 0));
1616	if (defined($status) && ($status != 0))
1617	{
1618	$buff = Encode::decode_utf8($buff);
1619	return $buff;
1620	}
1621	#return $buff unless (!defined($status) \|\| ($status == 0));
1622	$self->debug(1,"Read: ERROR");
1623	return;
1624	}
1625
1626
1627	##############################################################################
1628	#
1629	# Send - Takes the data string and sends it to the server
1630	#
1631	##############################################################################
1632	sub Send
1633	{
1634	my $self = shift;
1635	my $sid = shift;
1636	$self->debug(1,"Send: (@_)");
1637	$self->debug(3,"Send: sid($sid)");
1638	$self->debug(3,"Send: status($self->{SIDS}->{$sid}->{status})");
1639
1640	$self->{SIDS}->{$sid}->{keepalive} = time;
1641
1642	return if ($self->{SIDS}->{$sid}->{status} == -1);
1643
1644	if (!defined($self->{SIDS}->{$sid}->{sock}))
1645	{
1646	$self->debug(3,"Send: socket not defined");
1647	$self->{SIDS}->{$sid}->{status} = -1;
1648	$self->SetErrorCode($sid,"Socket not defined.");
1649	return;
1650	}
1651	else
1652	{
1653	$self->debug(3,"Send: socket($self->{SIDS}->{$sid}->{sock})");
1654	}
1655
1656	$self->{SIDS}->{$sid}->{sock}->flush();
1657
1658	if ($self->{SIDS}->{$sid}->{select}->can_write(0))
1659	{
1660	$self->debug(3,"Send: can_write");
1661
1662	my $sendstring = join("",@_);
1663
1664	Encode::_utf8_on($sendstring);
1665	Encode::_utf8_off($sendstring) unless (Encode::is_utf8($sendstring, 1));
1666
1667	$self->{SENDSTRING} = Encode::encode_utf8($sendstring);
1668
1669	$self->{SENDWRITTEN} = 0;
1670	$self->{SENDOFFSET} = 0;
1671	$self->{SENDLENGTH} = length($self->{SENDSTRING});
1672	while ($self->{SENDLENGTH})
1673	{
1674	$self->{SENDWRITTEN} = $self->{SIDS}->{$sid}->{sock}->syswrite($self->{SENDSTRING},$self->{SENDLENGTH},$self->{SENDOFFSET});
1675
1676	if (!defined($self->{SENDWRITTEN}))
1677	{
1678	$self->debug(4,"Send: SENDWRITTEN(undef)");
1679	$self->debug(4,"Send: Ok... what happened? Did we lose the connection?");
1680	$self->{SIDS}->{$sid}->{status} = -1;
1681	$self->SetErrorCode($sid,"Socket died for an unknown reason.");
1682	return;
1683	}
1684
1685	$self->debug(4,"Send: SENDWRITTEN($self->{SENDWRITTEN})");
1686
1687	$self->{SENDLENGTH} -= $self->{SENDWRITTEN};
1688	$self->{SENDOFFSET} += $self->{SENDWRITTEN};
1689	}
1690	}
1691	else
1692	{
1693	$self->debug(3,"Send: can't write...");
1694	}
1695
1696	return if($self->{SIDS}->{$sid}->{select}->has_exception(0));
1697
1698	$self->debug(3,"Send: no exceptions");
1699
1700	$self->{SIDS}->{$sid}->{keepalive} = time;
1701
1702	$self->MarkActivity($sid);
1703
1704	return 1;
1705	}
1706
1707
1708
1709
1710	##############################################################################
1711	#+----------------------------------------------------------------------------
1712	#\|
1713	#\| Feature Functions
1714	#\|
1715	#+----------------------------------------------------------------------------
1716	##############################################################################
1717
1718	##############################################################################
1719	#
1720	# ProcessStreamFeatures - process the <stream:featutres/> block.
1721	#
1722	##############################################################################
1723	sub ProcessStreamFeatures
1724	{
1725	my $self = shift;
1726	my $sid = shift;
1727	my $node = shift;
1728
1729	$self->{SIDS}->{$sid}->{streamfeatures}->{received} = 1;
1730
1731	#-------------------------------------------------------------------------
1732	# SASL - 1.0
1733	#-------------------------------------------------------------------------
1734	my @sasl = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-sasl').'"]');
1735	if ($#sasl > -1)
1736	{
1737	if (&XPath($sasl[0],"name()") eq "mechanisms")
1738	{
1739	my @mechanisms = &XPath($sasl[0],"mechanism/text()");
1740	$self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-sasl'} = \@mechanisms;
1741	}
1742	}
1743
1744	#-------------------------------------------------------------------------
1745	# XMPP-TLS - 1.0
1746	#-------------------------------------------------------------------------
1747	my @tls = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-tls').'"]');
1748	if ($#tls > -1)
1749	{
1750	if (&XPath($tls[0],"name()") eq "starttls")
1751	{
1752	$self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = 1;
1753	my @required = &XPath($tls[0],"required");
1754	if ($#required > -1)
1755	{
1756	$self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = "required";
1757	}
1758	}
1759	}
1760
1761	#-------------------------------------------------------------------------
1762	# XMPP-Bind - 1.0
1763	#-------------------------------------------------------------------------
1764	my @bind = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-bind').'"]');
1765	if ($#bind > -1)
1766	{
1767	$self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-bind'} = 1;
1768	}
1769
1770	#-------------------------------------------------------------------------
1771	# XMPP-Session - 1.0
1772	#-------------------------------------------------------------------------
1773	my @session = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-session').'"]');
1774	if ($#session > -1)
1775	{
1776	$self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-session'} = 1;
1777	}
1778
1779	}
1780
1781
1782	##############################################################################
1783	#
1784	# GetStreamFeature - Return the value of the stream feature (if any).
1785	#
1786	##############################################################################
1787	sub GetStreamFeature
1788	{
1789	my $self = shift;
1790	my $sid = shift;
1791	my $feature = shift;
1792
1793	return unless exists($self->{SIDS}->{$sid}->{streamfeatures}->{$feature});
1794	return $self->{SIDS}->{$sid}->{streamfeatures}->{$feature};
1795	}
1796
1797
1798	##############################################################################
1799	#
1800	# ReceivedStreamFeatures - Have we received the stream:features yet?
1801	#
1802	##############################################################################
1803	sub ReceivedStreamFeatures
1804	{
1805	my $self = shift;
1806	my $sid = shift;
1807	my $feature = shift;
1808
1809	return $self->{SIDS}->{$sid}->{streamfeatures}->{received};
1810	}
1811
1812
1813
1814
1815	##############################################################################
1816	#+----------------------------------------------------------------------------
1817	#\|
1818	#\| TLS Functions
1819	#\|
1820	#+----------------------------------------------------------------------------
1821	##############################################################################
1822
1823	##############################################################################
1824	#
1825	# ProcessTLSPacket - process a TLS based packet.
1826	#
1827	##############################################################################
1828	sub ProcessTLSPacket
1829	{
1830	my $self = shift;
1831	my $sid = shift;
1832	my $node = shift;
1833
1834	my $tag = &XPath($node,"name()");
1835
1836	if ($tag eq "failure")
1837	{
1838	$self->TLSClientFailure($sid,$node);
1839	}
1840
1841	if ($tag eq "proceed")
1842	{
1843	$self->TLSClientProceed($sid,$node);
1844	}
1845	}
1846
1847
1848	##############################################################################
1849	#
1850	# StartTLS - client function to have the socket start TLS.
1851	#
1852	##############################################################################
1853	sub StartTLS
1854	{
1855	my $self = shift;
1856	my $sid = shift;
1857	my $timeout = shift;
1858	$timeout = 120 unless defined($timeout);
1859	$timeout = 120 if ($timeout eq "");
1860
1861	$self->TLSStartTLS($sid);
1862
1863	my $endTime = time + $timeout;
1864	while(!$self->TLSClientDone($sid) && ($endTime >= time))
1865	{
1866	$self->Process(1);
1867	}
1868
1869	if (!$self->TLSClientSecure($sid))
1870	{
1871	return;
1872	}
1873
1874	return $self->OpenStream($sid,$timeout);
1875	}
1876
1877
1878	##############################################################################
1879	#
1880	# TLSStartTLS - send a <starttls/> in the TLS namespace.
1881	#
1882	##############################################################################
1883	sub TLSStartTLS
1884	{
1885	my $self = shift;
1886	my $sid = shift;
1887
1888	$self->Send($sid,"<starttls xmlns='".&ConstXMLNS('xmpp-tls')."'/>");
1889	}
1890
1891
1892	##############################################################################
1893	#
1894	# TLSClientProceed - handle a <proceed/> packet.
1895	#
1896	##############################################################################
1897	sub TLSClientProceed
1898	{
1899	my $self = shift;
1900	my $sid = shift;
1901	my $node = shift;
1902
1903	$self->debug(1,"TLSClientProceed: Convert normal socket to SSL");
1904	$self->debug(1,"TLSClientProceed: sock($self->{SIDS}->{$sid}->{sock})");
1905	if (!$self->LoadSSL())
1906	{
1907	$self->{SIDS}->{$sid}->{tls}->{error} = "Could not load IO::Socket::SSL.";
1908	$self->{SIDS}->{$sid}->{tls}->{done} = 1;
1909	return;
1910	}
1911
1912	IO::Socket::SSL->start_SSL($self->{SIDS}->{$sid}->{sock},{SSL_verify_mode=>0x00});
1913
1914	$self->debug(1,"TLSClientProceed: ssl_sock($self->{SIDS}->{$sid}->{sock})");
1915	$self->debug(1,"TLSClientProceed: SSL: We are secure")
1916	if ($self->{SIDS}->{$sid}->{sock});
1917
1918	$self->{SIDS}->{$sid}->{tls}->{done} = 1;
1919	$self->{SIDS}->{$sid}->{tls}->{secure} = 1;
1920	}
1921
1922
1923	##############################################################################
1924	#
1925	# TLSClientSecure - return 1 if the socket is secure, 0 otherwise.
1926	#
1927	##############################################################################
1928	sub TLSClientSecure
1929	{
1930	my $self = shift;
1931	my $sid = shift;
1932
1933	return $self->{SIDS}->{$sid}->{tls}->{secure};
1934	}
1935
1936
1937	##############################################################################
1938	#
1939	# TLSClientDone - return 1 if the TLS process is done
1940	#
1941	##############################################################################
1942	sub TLSClientDone
1943	{
1944	my $self = shift;
1945	my $sid = shift;
1946
1947	return $self->{SIDS}->{$sid}->{tls}->{done};
1948	}
1949
1950
1951	##############################################################################
1952	#
1953	# TLSClientError - return the TLS error if any
1954	#
1955	##############################################################################
1956	sub TLSClientError
1957	{
1958	my $self = shift;
1959	my $sid = shift;
1960
1961	return $self->{SIDS}->{$sid}->{tls}->{error};
1962	}
1963
1964
1965	##############################################################################
1966	#
1967	# TLSClientFailure - handle a <failure/>
1968	#
1969	##############################################################################
1970	sub TLSClientFailure
1971	{
1972	my $self = shift;
1973	my $sid = shift;
1974	my $node = shift;
1975
1976	my $type = &XPath($node,"*/name()");
1977
1978	$self->{SIDS}->{$sid}->{tls}->{error} = $type;
1979	$self->{SIDS}->{$sid}->{tls}->{done} = 1;
1980	}
1981
1982
1983	##############################################################################
1984	#
1985	# TLSFailure - Send a <failure/> in the TLS namespace
1986	#
1987	##############################################################################
1988	sub TLSFailure
1989	{
1990	my $self = shift;
1991	my $sid = shift;
1992	my $type = shift;
1993
1994	$self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-tls')."'><${type}/></failure>");
1995	}
1996
1997
1998
1999
2000	##############################################################################
2001	#+----------------------------------------------------------------------------
2002	#\|
2003	#\| SASL Functions
2004	#\|
2005	#+----------------------------------------------------------------------------
2006	##############################################################################
2007
2008	##############################################################################
2009	#
2010	# ProcessSASLPacket - process a SASL based packet.
2011	#
2012	##############################################################################
2013	sub ProcessSASLPacket
2014	{
2015	my $self = shift;
2016	my $sid = shift;
2017	my $node = shift;
2018
2019	my $tag = &XPath($node,"name()");
2020
2021	if ($tag eq "challenge")
2022	{
2023	$self->SASLAnswerChallenge($sid,$node);
2024	}
2025
2026	if ($tag eq "failure")
2027	{
2028	$self->SASLClientFailure($sid,$node);
2029	}
2030
2031	if ($tag eq "success")
2032	{
2033	$self->SASLClientSuccess($sid,$node);
2034	}
2035	}
2036
2037
2038	##############################################################################
2039	#
2040	# SASLAnswerChallenge - when we get a <challenge/> we need to do the grunt
2041	# work to return a <response/>.
2042	#
2043	##############################################################################
2044	sub SASLAnswerChallenge
2045	{
2046	my $self = shift;
2047	my $sid = shift;
2048	my $node = shift;
2049
2050	my $challenge64 = &XPath($node,"text()");
2051	my $challenge = MIME::Base64::decode_base64($challenge64);
2052
2053	#-------------------------------------------------------------------------
2054	# As far as I can tell, if the challenge contains rspauth, then we authed.
2055	# If you try to send that to Authen::SASL, it will spew warnings about
2056	# the missing qop, nonce, etc... However, in order for jabberd2 to think
2057	# that you answered, you have to send back an empty response. Not sure
2058	# which approach is right... So let's hack for now.
2059	#-------------------------------------------------------------------------
2060	my $response = "";
2061	if ($challenge !~ /rspauth\=/)
2062	{
2063	$response = $self->{SIDS}->{$sid}->{sasl}->{client}->client_step($challenge);
2064	}
2065
2066	my $response64 = MIME::Base64::encode_base64($response,"");
2067	$self->SASLResponse($sid,$response64);
2068	}
2069
2070
2071	##############################################################################
2072	#
2073	# SASLAuth - send an <auth/> in the SASL namespace
2074	#
2075	##############################################################################
2076	sub SASLAuth
2077	{
2078	my $self = shift;
2079	my $sid = shift;
2080
2081	my $first_step = $self->{SIDS}->{$sid}->{sasl}->{client}->client_start();
2082	my $first_step64 = MIME::Base64::encode_base64($first_step,"");
2083
2084	$self->Send($sid,"<auth xmlns='".&ConstXMLNS('xmpp-sasl')."' mechanism='".$self->{SIDS}->{$sid}->{sasl}->{client}->mechanism()."'>".$first_step64."</auth>");
2085	}
2086
2087
2088	##############################################################################
2089	#
2090	# SASLChallenge - Send a <challenge/> in the SASL namespace
2091	#
2092	##############################################################################
2093	sub SASLChallenge
2094	{
2095	my $self = shift;
2096	my $sid = shift;
2097	my $challenge = shift;
2098
2099	$self->Send($sid,"<challenge xmlns='".&ConstXMLNS('xmpp-sasl')."'>${challenge}</challenge>");
2100	}
2101
2102
2103	###############################################################################
2104	#
2105	# SASLClient - This is a helper function to perform all of the required steps
2106	# for doing SASL with the server.
2107	#
2108	###############################################################################
2109	sub SASLClient
2110	{
2111	my $self = shift;
2112	my $sid = shift;
2113	my $username = shift;
2114	my $password = shift;
2115
2116	my $mechanisms = $self->GetStreamFeature($sid,"xmpp-sasl");
2117
2118	return unless defined($mechanisms);
2119
2120	my $sasl = new Authen::SASL(mechanism=>join(" ",@{$mechanisms}),
2121	callback=>{
2122	# authname => $username."@".$self->{SIDS}->{$sid}->{hostname},
2123	user => $username,
2124	pass => $password
2125	}
2126	);
2127
2128	$self->{SIDS}->{$sid}->{sasl}->{client} = $sasl->client_new('xmpp', $self->{SIDS}->{$sid}->{hostname});
2129	$self->{SIDS}->{$sid}->{sasl}->{username} = $username;
2130	$self->{SIDS}->{$sid}->{sasl}->{password} = $password;
2131	$self->{SIDS}->{$sid}->{sasl}->{authed} = 0;
2132	$self->{SIDS}->{$sid}->{sasl}->{done} = 0;
2133
2134	$self->SASLAuth($sid);
2135	}
2136
2137
2138	##############################################################################
2139	#
2140	# SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise
2141	#
2142	##############################################################################
2143	sub SASLClientAuthed
2144	{
2145	my $self = shift;
2146	my $sid = shift;
2147
2148	return $self->{SIDS}->{$sid}->{sasl}->{authed};
2149	}
2150
2151
2152	##############################################################################
2153	#
2154	# SASLClientDone - return 1 if the SASL process is finished
2155	#
2156	##############################################################################
2157	sub SASLClientDone
2158	{
2159	my $self = shift;
2160	my $sid = shift;
2161
2162	return $self->{SIDS}->{$sid}->{sasl}->{done};
2163	}
2164
2165
2166	##############################################################################
2167	#
2168	# SASLClientError - return the error if any
2169	#
2170	##############################################################################
2171	sub SASLClientError
2172	{
2173	my $self = shift;
2174	my $sid = shift;
2175
2176	return $self->{SIDS}->{$sid}->{sasl}->{error};
2177	}
2178
2179
2180	##############################################################################
2181	#
2182	# SASLClientFailure - handle a received <failure/>
2183	#
2184	##############################################################################
2185	sub SASLClientFailure
2186	{
2187	my $self = shift;
2188	my $sid = shift;
2189	my $node = shift;
2190
2191	my $type = &XPath($node,"*/name()");
2192
2193	$self->{SIDS}->{$sid}->{sasl}->{error} = $type;
2194	$self->{SIDS}->{$sid}->{sasl}->{done} = 1;
2195	}
2196
2197
2198	##############################################################################
2199	#
2200	# SASLClientSuccess - handle a received <success/>
2201	#
2202	##############################################################################
2203	sub SASLClientSuccess
2204	{
2205	my $self = shift;
2206	my $sid = shift;
2207	my $node = shift;
2208
2209	$self->{SIDS}->{$sid}->{sasl}->{authed} = 1;
2210	$self->{SIDS}->{$sid}->{sasl}->{done} = 1;
2211	}
2212
2213
2214	##############################################################################
2215	#
2216	# SASLFailure - Send a <failure/> tag in the SASL namespace
2217	#
2218	##############################################################################
2219	sub SASLFailure
2220	{
2221	my $self = shift;
2222	my $sid = shift;
2223	my $type = shift;
2224
2225	$self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-sasl')."'><${type}/></failure>");
2226	}
2227
2228
2229	##############################################################################
2230	#
2231	# SASLResponse - Send a <response/> tag in the SASL namespace
2232	#
2233	##############################################################################
2234	sub SASLResponse
2235	{
2236	my $self = shift;
2237	my $sid = shift;
2238	my $response = shift;
2239
2240	$self->Send($sid,"<response xmlns='".&ConstXMLNS('xmpp-sasl')."'>${response}</response>");
2241	}
2242
2243
2244
2245
2246	##############################################################################
2247	#+----------------------------------------------------------------------------
2248	#\|
2249	#\| Packet Handlers
2250	#\|
2251	#+----------------------------------------------------------------------------
2252	##############################################################################
2253
2254
2255	##############################################################################
2256	#
2257	# ProcessStreamPacket - process the <stream:XXXX/> packet
2258	#
2259	##############################################################################
2260	sub ProcessStreamPacket
2261	{
2262	my $self = shift;
2263	my $sid = shift;
2264	my $node = shift;
2265
2266	my $tag = &XPath($node,"name()");
2267	my $stream_prefix = $self->StreamPrefix($sid);
2268	my ($type) = ($tag =~ /^${stream_prefix}\:(.+)$/);
2269
2270	$self->ProcessStreamError($sid,$node) if ($type eq "error");
2271	$self->ProcessStreamFeatures($sid,$node) if ($type eq "features");
2272	}
2273
2274
2275	##############################################################################
2276	#
2277	# _handle_root - handles a root tag and checks that it is a stream:stream tag
2278	# with the proper namespace. If not then it sets the STATUS
2279	# to -1 and let's the outer code know that an error occurred.
2280	# Then it changes the Start tag handlers to the methond listed
2281	# in $self->{DATASTYLE}
2282	#
2283	##############################################################################
2284	sub _handle_root
2285	{
2286	my $self = shift;
2287	my ($sax, $tag, %att) = @_;
2288	my $sid = $sax->getSID();
2289
2290	$self->debug(2,"_handle_root: sid($sid) sax($sax) tag($tag) att(",%att,")");
2291
2292	$self->{SIDS}->{$sid}->{rootTag} = $tag;
2293
2294	if ($self->{SIDS}->{$sid}->{connectiontype} ne "file")
2295	{
2296	#---------------------------------------------------------------------
2297	# Make sure we are receiving a valid stream on the same namespace.
2298	#---------------------------------------------------------------------
2299
2300	$self->debug(3,"_handle_root: ($self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})");
2301	$self->{SIDS}->{$sid}->{status} =
2302	((($tag eq "stream:stream") &&
2303	exists($att{'xmlns'}) &&
2304	($att{'xmlns'} eq $self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})
2305	) ?
2306	1 :
2307	-1
2308	);
2309	$self->debug(3,"_handle_root: status($self->{SIDS}->{$sid}->{status})");
2310	}
2311	else
2312	{
2313	$self->{SIDS}->{$sid}->{status} = 1;
2314	}
2315
2316	#-------------------------------------------------------------------------
2317	# Get the root tag attributes and save them for later. You never know when
2318	# you'll need to check the namespace or the from attributes sent by the
2319	# server.
2320	#-------------------------------------------------------------------------
2321	$self->{SIDS}->{$sid}->{root} = \%att;
2322
2323	#-------------------------------------------------------------------------
2324	# Run through the various xmlns:*** attributes and register the namespace
2325	# to prefix map.
2326	#-------------------------------------------------------------------------
2327	foreach my $key (keys(%att))
2328	{
2329	if ($key =~ /^xmlns\:(.+?)$/)
2330	{
2331	$self->debug(5,"_handle_root: RegisterPrefix: prefix($att{$key}) ns($1)");
2332	$self->RegisterPrefix($sid,$att{$key},$1);
2333	}
2334	}
2335
2336	#-------------------------------------------------------------------------
2337	# Sometimes we will get an error, so let's parse the tag assuming that we
2338	# got a stream:error
2339	#-------------------------------------------------------------------------
2340	my $stream_prefix = $self->StreamPrefix($sid);
2341	$self->debug(5,"_handle_root: stream_prefix($stream_prefix)");
2342
2343	if ($tag eq $stream_prefix.":error")
2344	{
2345	&XML::Stream::Tree::_handle_element($self,$sax,$tag,%att)
2346	if ($self->{DATASTYLE} eq "tree");
2347	&XML::Stream::Node::_handle_element($self,$sax,$tag,%att)
2348	if ($self->{DATASTYLE} eq "node");
2349	}
2350
2351	#---------------------------------------------------------------------------
2352	# Now that we have gotten a root tag, let's look for the tags that make up
2353	# the stream. Change the handler for a Start tag to another function.
2354	#---------------------------------------------------------------------------
2355	$sax->setHandlers(startElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{startElement}}($self,@_) },
2356	endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
2357	characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
2358	);
2359	}
2360
2361
2362	##############################################################################
2363	#
2364	# _node - internal callback for nodes. All it does is place the nodes in a
2365	# list so that Process() can return them later.
2366	#
2367	##############################################################################
2368	sub _node
2369	{
2370	my $self = shift;
2371	my $sid = shift;
2372	my @node = shift;
2373
2374	if (ref($node[0]) eq "XML::Stream::Node")
2375	{
2376	push(@{$self->{SIDS}->{$sid}->{nodes}},$node[0]);
2377	}
2378	else
2379	{
2380	push(@{$self->{SIDS}->{$sid}->{nodes}},\@node);
2381	}
2382	}
2383
2384
2385
2386
2387	##############################################################################
2388	#+----------------------------------------------------------------------------
2389	#\|
2390	#\| Error Functions
2391	#\|
2392	#+----------------------------------------------------------------------------
2393	##############################################################################
2394
2395	##############################################################################
2396	#
2397	# GetErrorCode - if you are returned an undef, you can call this function
2398	# and hopefully learn more information about the problem.
2399	#
2400	##############################################################################
2401	sub GetErrorCode
2402	{
2403	my $self = shift;
2404	my $sid = shift;
2405
2406	$sid = "newconnection" unless defined($sid);
2407
2408	$self->debug(3,"GetErrorCode: sid($sid)");
2409	return ((exists($self->{SIDS}->{$sid}->{errorcode}) &&
2410	(ref($self->{SIDS}->{$sid}->{errorcode}) eq "HASH")) ?
2411	$self->{SIDS}->{$sid}->{errorcode} :
2412	{ type=>"system",
2413	text=>$!,
2414	}
2415	);
2416	}
2417
2418
2419	##############################################################################
2420	#
2421	# SetErrorCode - sets the error code so that the caller can find out more
2422	# information about the problem
2423	#
2424	##############################################################################
2425	sub SetErrorCode
2426	{
2427	my $self = shift;
2428	my $sid = shift;
2429	my $errorcode = shift;
2430
2431	$self->{SIDS}->{$sid}->{errorcode} = $errorcode;
2432	}
2433
2434
2435	##############################################################################
2436	#
2437	# ProcessStreamError - Take the XML packet and extract out the error.
2438	#
2439	##############################################################################
2440	sub ProcessStreamError
2441	{
2442	my $self = shift;
2443	my $sid = shift;
2444	my $node = shift;
2445
2446	$self->{SIDS}->{$sid}->{streamerror}->{type} = "unknown";
2447	$self->{SIDS}->{$sid}->{streamerror}->{node} = $node;
2448
2449	#-------------------------------------------------------------------------
2450	# Check for older 0.9 streams and handle the errors for them.
2451	#-------------------------------------------------------------------------
2452	if (!exists($self->{SIDS}->{$sid}->{root}->{version}) \|\|
2453	($self->{SIDS}->{$sid}->{root}->{version} eq "") \|\|
2454	($self->{SIDS}->{$sid}->{root}->{version} < 1.0)
2455	)
2456	{
2457	$self->{SIDS}->{$sid}->{streamerror}->{text} =
2458	&XPath($node,"text()");
2459	return;
2460	}
2461
2462	#-------------------------------------------------------------------------
2463	# Otherwise we are in XMPP land with real stream errors.
2464	#-------------------------------------------------------------------------
2465	my @errors = &XPath($node,'*[@xmlns="'.&ConstXMLNS("xmppstreams").'"]');
2466
2467	my $type;
2468	my $text;
2469	foreach my $error (@errors)
2470	{
2471	if (&XPath($error,"name()") eq "text")
2472	{
2473	$self->{SIDS}->{$sid}->{streamerror}->{text} =
2474	&XPath($error,"text()");
2475	}
2476	else
2477	{
2478	$self->{SIDS}->{$sid}->{streamerror}->{type} =
2479	&XPath($error,"name()");
2480	}
2481	}
2482	}
2483
2484
2485	##############################################################################
2486	#
2487	# StreamError - Given a type and text, generate a <stream:error/> packet to
2488	# send back to the other side.
2489	#
2490	##############################################################################
2491	sub StreamError
2492	{
2493	my $self = shift;
2494	my $sid = shift;
2495	my $type = shift;
2496	my $text = shift;
2497
2498	my $root = $self->GetRoot($sid);
2499	my $stream_base = $self->StreamPrefix($sid);
2500	my $error = "<${stream_base}:error>";
2501
2502	if (exists($root->{version}) && ($root->{version} ne ""))
2503	{
2504	$error .= "<${type} xmlns='".&ConstXMLNS('xmppstreams')."'/>";
2505	if (defined($text))
2506	{
2507	$error .= "<text xmlns='".&ConstXMLNS('xmppstreams')."'>";
2508	$error .= $text;
2509	$error .= "</text>";
2510	}
2511	}
2512	else
2513	{
2514	$error .= $text;
2515	}
2516
2517	$error .= "</${stream_base}:error>";
2518
2519	return $error;
2520	}
2521
2522
2523
2524
2525	##############################################################################
2526	#+----------------------------------------------------------------------------
2527	#\|
2528	#\| Activity Monitoring Functions
2529	#\|
2530	#+----------------------------------------------------------------------------
2531	##############################################################################
2532
2533	##############################################################################
2534	#
2535	# IgnoreActivity - Set the flag that will ignore the activity monitor.
2536	#
2537	##############################################################################
2538	sub IgnoreActivity
2539	{
2540	my $self = shift;
2541	my $sid = shift;
2542	my $ignoreActivity = shift;
2543	$ignoreActivity = 1 unless defined($ignoreActivity);
2544
2545	$self->debug(3,"IgnoreActivity: ignoreActivity($ignoreActivity)");
2546	$self->debug(4,"IgnoreActivity: sid($sid)");
2547
2548	$self->{SIDS}->{$sid}->{ignoreActivity} = $ignoreActivity;
2549	}
2550
2551
2552	##############################################################################
2553	#
2554	# LastActivity - Return the time of the last activity.
2555	#
2556	##############################################################################
2557	sub LastActivity
2558	{
2559	my $self = shift;
2560	my $sid = shift;
2561
2562	$self->debug(3,"LastActivity: sid($sid)");
2563	$self->debug(1,"LastActivity: lastActivity($self->{SIDS}->{$sid}->{lastActivity})");
2564
2565	return $self->{SIDS}->{$sid}->{lastActivity};
2566	}
2567
2568
2569	##############################################################################
2570	#
2571	# MarkActivity - Record the current time for this sid.
2572	#
2573	##############################################################################
2574	sub MarkActivity
2575	{
2576	my $self = shift;
2577	my $sid = shift;
2578
2579	return if (exists($self->{SIDS}->{$sid}->{ignoreActivity}) &&
2580	($self->{SIDS}->{$sid}->{ignoreActivity} == 1));
2581
2582	$self->debug(3,"MarkActivity: sid($sid)");
2583
2584	$self->{SIDS}->{$sid}->{lastActivity} = time;
2585	}
2586
2587
2588
2589
2590	##############################################################################
2591	#+----------------------------------------------------------------------------
2592	#\|
2593	#\| XML Node Interface functions
2594	#\|
2595	#\| These are generic wrappers around the Tree and Node data types. The
2596	#\| problem being that the Tree class cannot support methods.
2597	#\|
2598	#+----------------------------------------------------------------------------
2599	##############################################################################
2600
2601	##############################################################################
2602	#
2603	# SetXMLData - takes a host of arguments and sets a portion of the specified
2604	# data strucure with that data. The function works in two
2605	# modes "single" or "multiple". "single" denotes that the
2606	# function should locate the current tag that matches this
2607	# data and overwrite it's contents with data passed in.
2608	# "multiple" denotes that a new tag should be created even if
2609	# others exist.
2610	#
2611	# type - single or multiple
2612	# XMLTree - pointer to XML::Stream data object (tree or node)
2613	# tag - name of tag to create/modify (if blank assumes
2614	# working with top level tag)
2615	# data - CDATA to set for tag
2616	# attribs - attributes to ADD to tag
2617	#
2618	##############################################################################
2619	sub SetXMLData
2620	{
2621	return &XML::Stream::Node::SetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node");
2622	return &XML::Stream::Tree::SetXMLData(@_) if (ref($_[1]) eq "ARRAY");
2623	}
2624
2625
2626	##############################################################################
2627	#
2628	# GetXMLData - takes a host of arguments and returns various data structures
2629	# that match them.
2630	#
2631	# type - "existence" - returns 1 or 0 if the tag exists in the
2632	# top level.
2633	# "value" - returns either the CDATA of the tag, or the
2634	# value of the attribute depending on which is
2635	# sought. This ignores any mark ups to the data
2636	# and just returns the raw CDATA.
2637	# "value array" - returns an array of strings representing
2638	# all of the CDATA in the specified tag.
2639	# This ignores any mark ups to the data
2640	# and just returns the raw CDATA.
2641	# "tree" - returns a data structure that represents the
2642	# XML with the specified tag as the root tag.
2643	# Depends on the format that you are working with.
2644	# "tree array" - returns an array of data structures each
2645	# with the specified tag as the root tag.
2646	# "child array" - returns a list of all children nodes
2647	# not including CDATA nodes.
2648	# "attribs" - returns a hash with the attributes, and
2649	# their values, for the things that match
2650	# the parameters
2651	# "count" - returns the number of things that match
2652	# the arguments
2653	# "tag" - returns the root tag of this tree
2654	# XMLTree - pointer to XML::Stream data structure
2655	# tag - tag to pull data from. If blank then the top level
2656	# tag is accessed.
2657	# attrib - attribute value to retrieve. Ignored for types
2658	# "value array", "tree", "tree array". If paired
2659	# with value can be used to filter tags based on
2660	# attributes and values.
2661	# value - only valid if an attribute is supplied. Used to
2662	# filter for tags that only contain this attribute.
2663	# Useful to search through multiple tags that all
2664	# reference different name spaces.
2665	#
2666	##############################################################################
2667	sub GetXMLData
2668	{
2669	return &XML::Stream::Node::GetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node");
2670	return &XML::Stream::Tree::GetXMLData(@_) if (ref($_[1]) eq "ARRAY");
2671	}
2672
2673
2674	##############################################################################
2675	#
2676	# XPath - run an xpath query on a node and return back the result.
2677	#
2678	##############################################################################
2679	sub XPath
2680	{
2681	my $tree = shift;
2682	my $path = shift;
2683
2684	my $query = new XML::Stream::XPath::Query($path);
2685	my $result = $query->execute($tree);
2686	if ($result->check())
2687	{
2688	my %attribs = $result->getAttribs();
2689	return %attribs if (scalar(keys(%attribs)) > 0);
2690
2691	my @values = $result->getValues();
2692	@values = $result->getList() unless ($#values > -1);
2693	return @values if wantarray;
2694	return $values[0];
2695	}
2696	return;
2697	}
2698
2699
2700	##############################################################################
2701	#
2702	# XPathCheck - run an xpath query on a node and return 1 or 0 if the path is
2703	# valid.
2704	#
2705	##############################################################################
2706	sub XPathCheck
2707	{
2708	my $tree = shift;
2709	my $path = shift;
2710
2711	my $query = new XML::Stream::XPath::Query($path);
2712	my $result = $query->execute($tree);
2713	return $result->check();
2714	}
2715
2716
2717	##############################################################################
2718	#
2719	# XML2Config - takes an XML data tree and turns it into a hash of hashes.
2720	# This only works for certain kinds of XML trees like this:
2721	#
2722	# <foo>
2723	# <bar>1</bar>
2724	# <x>
2725	# <y>foo</y>
2726	# </x>
2727	# <z>5</z>
2728	# <z>6</z>
2729	# </foo>
2730	#
2731	# The resulting hash would be:
2732	#
2733	# $hash{bar} = 1;
2734	# $hash{x}->{y} = "foo";
2735	# $hash{z}->[0] = 5;
2736	# $hash{z}->[1] = 6;
2737	#
2738	# Good for config files.
2739	#
2740	##############################################################################
2741	sub XML2Config
2742	{
2743	return &XML::Stream::Node::XML2Config(@_) if (ref($_[0]) eq "XML::Stream::Node");
2744	return &XML::Stream::Tree::XML2Config(@_) if (ref($_[0]) eq "ARRAY");
2745	}
2746
2747
2748	##############################################################################
2749	#
2750	# Config2XML - takes a hash and produces an XML string from it. If the hash
2751	# looks like this:
2752	#
2753	# $hash{bar} = 1;
2754	# $hash{x}->{y} = "foo";
2755	# $hash{z}->[0] = 5;
2756	# $hash{z}->[1] = 6;
2757	#
2758	# The resulting xml would be:
2759	#
2760	# <foo>
2761	# <bar>1</bar>
2762	# <x>
2763	# <y>foo</y>
2764	# </x>
2765	# <z>5</z>
2766	# <z>6</z>
2767	# </foo>
2768	#
2769	# Good for config files.
2770	#
2771	##############################################################################
2772	sub Config2XML
2773	{
2774	my ($tag,$hash,$indent) = @_;
2775	$indent = "" unless defined($indent);
2776
2777	my $xml;
2778
2779	if (ref($hash) eq "ARRAY")
2780	{
2781	foreach my $item (@{$hash})
2782	{
2783	$xml .= &XML::Stream::Config2XML($tag,$item,$indent);
2784	}
2785	}
2786	else
2787	{
2788	if ((ref($hash) eq "HASH") && ((scalar keys(%{$hash})) == 0))
2789	{
2790	$xml .= "$indent<$tag/>\n";
2791	}
2792	else
2793	{
2794	if (ref($hash) eq "")
2795	{
2796	if ($hash eq "")
2797	{
2798	return "$indent<$tag/>\n";
2799	}
2800	else
2801	{
2802	return "$indent<$tag>$hash</$tag>\n";
2803	}
2804	}
2805	else
2806	{
2807	$xml .= "$indent<$tag>\n";
2808	foreach my $item (sort {$a cmp $b} keys(%{$hash}))
2809	{
2810	$xml .= &XML::Stream::Config2XML($item,$hash->{$item}," $indent");
2811	}
2812	$xml .= "$indent</$tag>\n";
2813	}
2814	}
2815	}
2816	return $xml;
2817	}
2818
2819
2820	##############################################################################
2821	#
2822	# EscapeXML - Simple function to make sure that no bad characters make it into
2823	# in the XML string that might cause the string to be
2824	# misinterpreted.
2825	#
2826	##############################################################################
2827	sub EscapeXML
2828	{
2829	my $data = shift;
2830
2831	if (defined($data))
2832	{
2833	$data =~ s/&/&/g;
2834	$data =~ s/</</g;
2835	$data =~ s/>/>/g;
2836	$data =~ s/\"/"/g;
2837	$data =~ s/\'/'/g;
2838	}
2839
2840	return $data;
2841	}
2842
2843
2844	##############################################################################
2845	#
2846	# UnescapeXML - Simple function to take an escaped string and return it to
2847	# normal.
2848	#
2849	##############################################################################
2850	sub UnescapeXML
2851	{
2852	my $data = shift;
2853
2854	if (defined($data))
2855	{
2856	$data =~ s/&/&/g;
2857	$data =~ s/</</g;
2858	$data =~ s/>/>/g;
2859	$data =~ s/"/\"/g;
2860	$data =~ s/'/\'/g;
2861	}
2862
2863	return $data;
2864	}
2865
2866
2867	##############################################################################
2868	#
2869	# BuildXML - takes one of the data formats that XML::Stream supports and call
2870	# the proper BuildXML_xxx function on it.
2871	#
2872	##############################################################################
2873	sub BuildXML
2874	{
2875	return &XML::Stream::Node::BuildXML(@_) if (ref($_[0]) eq "XML::Stream::Node");
2876	return &XML::Stream::Tree::BuildXML(@_) if (ref($_[0]) eq "ARRAY");
2877	return &XML::Stream::Tree::BuildXML(@_) if (ref($_[1]) eq "ARRAY");
2878	}
2879
2880
2881
2882	##############################################################################
2883	#+----------------------------------------------------------------------------
2884	#\|
2885	#\| Namespace/Prefix Functions
2886	#\|
2887	#+----------------------------------------------------------------------------
2888	##############################################################################
2889
2890	##############################################################################
2891	#
2892	# ConstXMLNS - Return the namespace from the constant string.
2893	#
2894	##############################################################################
2895	sub ConstXMLNS
2896	{
2897	my $const = shift;
2898
2899	return $XMLNS{$const};
2900	}
2901
2902
2903	##############################################################################
2904	#
2905	# StreamPrefix - Return the prefix of the <stream:stream/>
2906	#
2907	##############################################################################
2908	sub StreamPrefix
2909	{
2910	my $self = shift;
2911	my $sid = shift;
2912
2913	return $self->ns2prefix($sid,&ConstXMLNS("stream"));
2914	}
2915
2916
2917	##############################################################################
2918	#
2919	# RegisterPrefix - setup the map for namespace to prefix
2920	#
2921	##############################################################################
2922	sub RegisterPrefix
2923	{
2924	my $self = shift;
2925	my $sid = shift;
2926	my $ns = shift;
2927	my $prefix = shift;
2928
2929	$self->{SIDS}->{$sid}->{ns2prefix}->{$ns} = $prefix;
2930	}
2931
2932
2933	##############################################################################
2934	#
2935	# ns2prefix - for a stream, return the prefix for the given namespace
2936	#
2937	##############################################################################
2938	sub ns2prefix
2939	{
2940	my $self = shift;
2941	my $sid = shift;
2942	my $ns = shift;
2943
2944	return $self->{SIDS}->{$sid}->{ns2prefix}->{$ns};
2945	}
2946
2947
2948
2949
2950	##############################################################################
2951	#+----------------------------------------------------------------------------
2952	#\|
2953	#\| Helper Functions
2954	#\|
2955	#+----------------------------------------------------------------------------
2956	##############################################################################
2957
2958	##############################################################################
2959	#
2960	# GetRoot - returns the hash of attributes for the root <stream:stream/> tag
2961	# so that any attributes returned can be accessed. from and any
2962	# xmlns:foobar might be important.
2963	#
2964	##############################################################################
2965	sub GetRoot
2966	{
2967	my $self = shift;
2968	my $sid = shift;
2969	return unless exists($self->{SIDS}->{$sid}->{root});
2970	return $self->{SIDS}->{$sid}->{root};
2971	}
2972
2973
2974	##############################################################################
2975	#
2976	# GetSock - returns the Socket so that an outside function can access it if
2977	# desired.
2978	#
2979	##############################################################################
2980	sub GetSock
2981	{
2982	my $self = shift;
2983	my $sid = shift;
2984	return $self->{SIDS}->{$sid}->{sock};
2985	}
2986
2987
2988	##############################################################################
2989	#
2990	# LoadSSL - simple call to set everything up for SSL one time.
2991	#
2992	##############################################################################
2993	sub LoadSSL
2994	{
2995	my $self = shift;
2996
2997	$self->debug(1,"LoadSSL: Load the IO::Socket::SSL module");
2998
2999	if (defined($SSL) && ($SSL == 1))
3000	{
3001	$self->debug(1,"LoadSSL: Success");
3002	return 1;
3003	}
3004
3005	if (defined($SSL) && ($SSL == 0))
3006	{
3007	$self->debug(1,"LoadSSL: Failure");
3008	return;
3009	}
3010
3011	my $SSL_Version = "0.81";
3012	eval "use IO::Socket::SSL $SSL_Version";
3013	if ($@)
3014	{
3015	croak("You requested that XML::Stream turn the socket into an SSL socket, but you don't have the correct version of IO::Socket::SSL v$SSL_Version.");
3016	}
3017	IO::Socket::SSL::context_init({SSL_verify_mode=>0x00});
3018	$SSL = 1;
3019
3020	$self->debug(1,"LoadSSL: Success");
3021	return 1;
3022	}
3023
3024
3025	##############################################################################
3026	#
3027	# Host2SID - For a server this allows you to lookup the SID of a stream server
3028	# based on the hostname that is is listening on.
3029	#
3030	##############################################################################
3031	sub Host2SID
3032	{
3033	my $self = shift;
3034	my $hostname = shift;
3035
3036	foreach my $sid (keys(%{$self->{SIDS}}))
3037	{
3038	next if ($sid eq "default");
3039	next if ($sid =~ /^server/);
3040
3041	return $sid if ($self->{SIDS}->{$sid}->{hostname} eq $hostname);
3042	}
3043	return;
3044	}
3045
3046
3047	##############################################################################
3048	#
3049	# NewSID - returns a session ID to send to an incoming stream in the return
3050	# header. By default it just increments a counter and returns that,
3051	# or you can define a function and set it using the SetCallBacks
3052	# function.
3053	#
3054	##############################################################################
3055	sub NewSID
3056	{
3057	my $self = shift;
3058	return &{$self->{CB}->{sid}}() if (exists($self->{CB}->{sid}) &&
3059	defined($self->{CB}->{sid}));
3060	return $$.time.$self->{IDCOUNT}++;
3061	}
3062
3063
3064	###########################################################################
3065	#
3066	# SetCallBacks - Takes a hash with top level tags to look for as the keys
3067	# and pointers to functions as the values.
3068	#
3069	###########################################################################
3070	sub SetCallBacks
3071	{
3072	my $self = shift;
3073	while($#_ >= 0) {
3074	my $func = pop(@_);
3075	my $tag = pop(@_);
3076	if (($tag eq "node") && !defined($func))
3077	{
3078	$self->SetCallBacks(node=>sub { $self->_node(@_) });
3079	}
3080	else
3081	{
3082	$self->debug(1,"SetCallBacks: tag($tag) func($func)");
3083	$self->{CB}->{$tag} = $func;
3084	}
3085	}
3086	}
3087
3088
3089	##############################################################################
3090	#
3091	# StreamHeader - Given the arguments, return the opening stream header.
3092	#
3093	##############################################################################
3094	sub StreamHeader
3095	{
3096	my $self = shift;
3097	my (%args) = @_;
3098
3099	my $stream;
3100	$stream .= "<?xml version='1.0'?>";
3101	$stream .= "<stream:stream ";
3102	$stream .= "version='1.0' ";
3103	$stream .= "xmlns:stream='".&ConstXMLNS("stream")."' ";
3104	$stream .= "xmlns='$args{xmlns}' ";
3105	$stream .= "to='$args{to}' " if exists($args{to});
3106	$stream .= "from='$args{from}' " if exists($args{from});
3107	$stream .= "xml:lang='$args{xmllang}' " if exists($args{xmllang});
3108
3109	foreach my $ns (@{$args{namespaces}})
3110	{
3111	$stream .= " ".$ns->GetStream();
3112	}
3113
3114	$stream .= ">";
3115
3116	return $stream;
3117	}
3118
3119
3120	###########################################################################
3121	#
3122	# debug - prints the arguments to the debug log if debug is turned on.
3123	#
3124	###########################################################################
3125	sub debug
3126	{
3127	return if ($_[1] > $_[0]->{DEBUGLEVEL});
3128	my $self = shift;
3129	my ($limit,@args) = @_;
3130	return if ($self->{DEBUGFILE} eq "");
3131	my $fh = $self->{DEBUGFILE};
3132	if ($self->{DEBUGTIME} == 1)
3133	{
3134	my ($sec,$min,$hour) = localtime(time);
3135	print $fh sprintf("[%02d:%02d:%02d] ",$hour,$min,$sec);
3136	}
3137	print $fh "XML::Stream: @args\n";
3138	}
3139
3140
3141	##############################################################################
3142	#
3143	# nonblock - set the socket to be non-blocking.
3144	#
3145	##############################################################################
3146	sub nonblock
3147	{
3148	my $self = shift;
3149	my $socket = shift;
3150
3151	#--------------------------------------------------------------------------
3152	# Code copied from POE::Wheel::SocketFactory...
3153	# Win32 does things one way...
3154	#--------------------------------------------------------------------------
3155	if ($^O eq "MSWin32")
3156	{
3157	ioctl( $socket, 0x80000000 \| (4 << 16) \| (ord('f') << 8) \| 126, 1) \|\|
3158	croak("Can't make socket nonblocking (win32): $!");
3159	return;
3160	}
3161
3162	#--------------------------------------------------------------------------
3163	# And UNIX does them another
3164	#--------------------------------------------------------------------------
3165	my $flags = fcntl($socket, F_GETFL, 0)
3166	or die "Can't get flags for socket: $!\n";
3167	fcntl($socket, F_SETFL, $flags \| O_NONBLOCK)
3168	or die "Can't make socket nonblocking: $!\n";
3169	}
3170
3171
3172	##############################################################################
3173	#
3174	# printData - debugging function to print out any data structure in an
3175	# organized manner. Very useful for debugging XML::Parser::Tree
3176	# objects. This is a private function that will only exist in
3177	# in the development version.
3178	#
3179	##############################################################################
3180	sub printData
3181	{
3182	print &sprintData(@_);
3183	}
3184
3185
3186	##############################################################################
3187	#
3188	# sprintData - debugging function to build a string out of any data structure
3189	# in an organized manner. Very useful for debugging
3190	# XML::Parser::Tree objects and perl hashes of hashes.
3191	#
3192	# This is a private function.
3193	#
3194	##############################################################################
3195	sub sprintData
3196	{
3197	my ($preString,$data) = @_;
3198
3199	my $outString = "";
3200
3201	if (ref($data) eq "HASH")
3202	{
3203	my $key;
3204	foreach $key (sort { $a cmp $b } keys(%{$data}))
3205	{
3206	if (ref($$data{$key}) eq "")
3207	{
3208	my $value = defined($$data{$key}) ? $$data{$key} : "";
3209	$outString .= $preString."{'$key'} = \"".$value."\";\n";
3210	}
3211	else
3212	{
3213	if (ref($$data{$key}) =~ /Net::Jabber/)
3214	{
3215	$outString .= $preString."{'$key'} = ".ref($$data{$key}).";\n";
3216	}
3217	else
3218	{
3219	$outString .= $preString."{'$key'};\n";
3220	$outString .= &sprintData($preString."{'$key'}->",$$data{$key});
3221	}
3222	}
3223	}
3224	}
3225	else
3226	{
3227	if (ref($data) eq "ARRAY")
3228	{
3229	my $index;
3230	foreach $index (0..$#{$data})
3231	{
3232	if (ref($$data[$index]) eq "")
3233	{
3234	$outString .= $preString."[$index] = \"$$data[$index]\";\n";
3235	}
3236	else
3237	{
3238	if (ref($$data[$index]) =~ /Net::Jabber/)
3239	{
3240	$outString .= $preString."[$index] = ".ref($$data[$index]).";\n";
3241	}
3242	else
3243	{
3244	$outString .= $preString."[$index];\n";
3245	$outString .= &sprintData($preString."[$index]->",$$data[$index]);
3246	}
3247	}
3248	}
3249	}
3250	else
3251	{
3252	if (ref($data) eq "REF")
3253	{
3254	$outString .= &sprintData($preString."->",$$data);
3255	}
3256	else
3257	{
3258	if (ref($data) eq "")
3259	{
3260	$outString .= $preString." = \"$data\";\n";
3261	}
3262	else
3263	{
3264	$outString .= $preString." = ".ref($data).";\n";
3265	}
3266	}
3267	}
3268	}
3269
3270	return $outString;
3271	}
3272
3273
3274	1;

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

Download in other formats: