Context Navigation

source: perl/lib/XML/Stream.pm @ b13438c

Visit:

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

Last change on this file since b13438c was a75309a, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 18 years ago
Stream.pm: Proper call to SASL. Roster.pm: Removing print statements.
Property mode set to `100644`
File size: 114.0 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 = new Net::DNS::Resolver();
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	delete($self->{SIDS}->{$currsid});
1164
1165	if (exists($self->GetRoot($sid)->{version}) &&
1166	($self->GetRoot($sid)->{version} ne ""))
1167	{
1168	while(!$self->ReceivedStreamFeatures($sid))
1169	{
1170	$self->Process(1);
1171	}
1172	}
1173
1174	return $self->GetRoot($sid);
1175	}
1176
1177
1178	##############################################################################
1179	#
1180	# OpenFile - starts the stream by opening a file and setting it up so that
1181	# Process reads from the filehandle to get the incoming stream.
1182	#
1183	##############################################################################
1184	sub OpenFile
1185	{
1186	my $self = shift;
1187	my $file = shift;
1188
1189	$self->debug(1,"OpenFile: file($file)");
1190
1191	$self->{SIDS}->{newconnection}->{connectiontype} = "file";
1192
1193	$self->{SIDS}->{newconnection}->{sock} = new FileHandle($file);
1194	$self->{SIDS}->{newconnection}->{sock}->autoflush(1);
1195
1196	$self->RegisterPrefix("newconnection",&ConstXMLNS("stream"),"stream");
1197
1198	#---------------------------------------------------------------------------
1199	# Create the XML::Stream::Parser and register our callbacks
1200	#---------------------------------------------------------------------------
1201	$self->{SIDS}->{newconnection}->{parser} =
1202	new XML::Stream::Parser(%{$self->{DEBUGARGS}},
1203	nonblocking=>$NONBLOCKING,
1204	sid=>"newconnection",
1205	style=>$self->{DATASTYLE},
1206	Handlers=>{
1207	startElement=>sub{ $self->_handle_root(@_) },
1208	endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
1209	characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
1210	}
1211	);
1212
1213	$self->{SIDS}->{newconnection}->{select} =
1214	new IO::Select($self->{SIDS}->{newconnection}->{sock});
1215
1216	$self->{SELECT} = new IO::Select($self->{SIDS}->{newconnection}->{sock});
1217
1218	$self->{SIDS}->{newconnection}->{status} = 0;
1219
1220	my $buff = "";
1221	while($self->{SIDS}->{newconnection}->{status} == 0)
1222	{
1223	$self->debug(5,"OpenFile: can_read(",join(",",$self->{SIDS}->{newconnection}->{select}->can_read(0)),")");
1224	if ($self->{SIDS}->{newconnection}->{select}->can_read(0))
1225	{
1226	$self->{SIDS}->{newconnection}->{status} = -1
1227	unless defined($buff = $self->Read("newconnection"));
1228	return unless($self->{SIDS}->{newconnection}->{status} == 0);
1229	return unless($self->ParseStream("newconnection",$buff) == 1);
1230	}
1231
1232	return if($self->{SIDS}->{newconnection}->{select}->has_exception(0) &&
1233	$self->{SIDS}->{newconnection}->{sock}->error());
1234	}
1235	return if($self->{SIDS}->{newconnection}->{status} != 1);
1236
1237
1238	my $sid = $self->NewSID();
1239	foreach my $key (keys(%{$self->{SIDS}->{newconnection}}))
1240	{
1241	$self->{SIDS}->{$sid}->{$key} = $self->{SIDS}->{newconnection}->{$key};
1242	}
1243	$self->{SIDS}->{$sid}->{parser}->setSID($sid);
1244
1245	$self->{SOCKETS}->{$self->{SIDS}->{newconnection}->{sock}} = $sid;
1246
1247	delete($self->{SIDS}->{newconnection});
1248
1249	return $sid;
1250	}
1251
1252
1253
1254
1255	##############################################################################
1256	#+----------------------------------------------------------------------------
1257	#\|
1258	#\| Common Functions
1259	#\|
1260	#+----------------------------------------------------------------------------
1261	##############################################################################
1262
1263	##############################################################################
1264	#
1265	# Disconnect - sends the closing XML tag and shuts down the socket.
1266	#
1267	##############################################################################
1268	sub Disconnect
1269	{
1270	my $self = shift;
1271	my $sid = shift;
1272
1273	$self->Send($sid,"</stream:stream>");
1274	close($self->{SIDS}->{$sid}->{sock})
1275	if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") \|\|
1276	($self->{SIDS}->{$sid}->{connectiontype} eq "http"));
1277	delete($self->{SOCKETS}->{$self->{SIDS}->{$sid}->{sock}});
1278	foreach my $key (keys(%{$self->{SIDS}->{$sid}}))
1279	{
1280	delete($self->{SIDS}->{$sid}->{$key});
1281	}
1282	delete($self->{SIDS}->{$sid});
1283	}
1284
1285
1286	##############################################################################
1287	#
1288	# InitConnection - Initialize the connection data structure
1289	#
1290	##############################################################################
1291	sub InitConnection
1292	{
1293	my $self = shift;
1294	my $sid = shift;
1295	my $serverid = shift;
1296
1297	#---------------------------------------------------------------------------
1298	# Set the default STATUS so that we can keep track of it throughout the
1299	# session.
1300	# 1 = no errors
1301	# 0 = no data has been received yet
1302	# -1 = error from handlers
1303	# -2 = error but keep the connection alive so that we can send some info.
1304	#---------------------------------------------------------------------------
1305	$self->{SIDS}->{$sid}->{status} = 0;
1306
1307	#---------------------------------------------------------------------------
1308	# A storage place for when we don't have a callback registered and we need
1309	# to stockpile the nodes we receive until Process is called and we return
1310	# them.
1311	#---------------------------------------------------------------------------
1312	$self->{SIDS}->{$sid}->{nodes} = ();
1313
1314	#---------------------------------------------------------------------------
1315	# If there is an error on the stream, then we need a place to indicate that.
1316	#---------------------------------------------------------------------------
1317	$self->{SIDS}->{$sid}->{streamerror} = {};
1318
1319	#---------------------------------------------------------------------------
1320	# Grab the init time so that we can keep the connection alive by sending " "
1321	#---------------------------------------------------------------------------
1322	$self->{SIDS}->{$sid}->{keepalive} = time;
1323
1324	#---------------------------------------------------------------------------
1325	# Keep track of the "server" we are connected to so we can check stuff
1326	# later.
1327	#---------------------------------------------------------------------------
1328	$self->{SIDS}->{$sid}->{serverid} = $serverid;
1329
1330	#---------------------------------------------------------------------------
1331	# Mark the stream:features as MIA.
1332	#---------------------------------------------------------------------------
1333	$self->{SIDS}->{$sid}->{streamfeatures}->{received} = 0;
1334
1335	#---------------------------------------------------------------------------
1336	# First acitivty is the connection... duh. =)
1337	#---------------------------------------------------------------------------
1338	$self->MarkActivity($sid);
1339	}
1340
1341
1342	##############################################################################
1343	#
1344	# ParseStream - takes the incoming stream and makes sure that only full
1345	# XML tags gets passed to the parser. If a full tag has not
1346	# read yet, then the Stream saves the incomplete part and
1347	# sends the rest to the parser.
1348	#
1349	##############################################################################
1350	sub ParseStream
1351	{
1352	my $self = shift;
1353	my $sid = shift;
1354	my $stream = shift;
1355
1356	$stream = "" unless defined($stream);
1357
1358	$self->debug(3,"ParseStream: sid($sid) stream($stream)");
1359
1360	$self->{SIDS}->{$sid}->{parser}->parse($stream);
1361
1362	if (exists($self->{SIDS}->{$sid}->{streamerror}->{type}))
1363	{
1364	$self->debug(3,"ParseStream: ERROR($self->{SIDS}->{$sid}->{streamerror}->{type})");
1365	$self->SetErrorCode($sid,$self->{SIDS}->{$sid}->{streamerror});
1366	return 0;
1367	}
1368
1369	return 1;
1370	}
1371
1372
1373	##############################################################################
1374	#
1375	# Process - checks for data on the socket and returns a status code depending
1376	# on if there was data or not. If a timeout is not defined in the
1377	# call then the timeout defined in Connect() is used. If a timeout
1378	# of 0 is used then the call blocks until it gets some data,
1379	# otherwise it returns after the timeout period.
1380	#
1381	##############################################################################
1382	sub Process
1383	{
1384	my $self = shift;
1385	my $timeout = shift;
1386	$timeout = "" unless defined($timeout);
1387
1388	$self->debug(4,"Process: timeout($timeout)");
1389	#---------------------------------------------------------------------------
1390	# We need to keep track of what's going on in the function and tell the
1391	# outside world about it so let's return something useful. We track this
1392	# information based on sid:
1393	# -1 connection closed and error
1394	# 0 connection open but no data received.
1395	# 1 connection open and data received.
1396	# array connection open and the data that has been collected
1397	# over time (No CallBack specified)
1398	#---------------------------------------------------------------------------
1399	my %status;
1400	foreach my $sid (keys(%{$self->{SIDS}}))
1401	{
1402	next if ($sid eq "default");
1403	$self->debug(5,"Process: initialize sid($sid) status to 0");
1404	$status{$sid} = 0;
1405	}
1406
1407	#---------------------------------------------------------------------------
1408	# Either block until there is data and we have parsed it all, or wait a
1409	# certain period of time and then return control to the user.
1410	#---------------------------------------------------------------------------
1411	my $block = 1;
1412	my $timeEnd = ($timeout eq "") ? "" : time + $timeout;
1413	while($block == 1)
1414	{
1415	$self->debug(4,"Process: let's wait for data");
1416
1417	my $now = time;
1418	my $wait = (($timeEnd eq "") \|\| ($timeEnd - $now > 10)) ? 10 :
1419	$timeEnd - $now;
1420
1421	foreach my $connection ($self->{SELECT}->can_read($wait))
1422	{
1423	$self->debug(4,"Process: connection($connection)");
1424	$self->debug(4,"Process: sid($self->{SOCKETS}->{$connection})");
1425	$self->debug(4,"Process: connection_status($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status})");
1426
1427	next unless (($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status} == 1) \|\|
1428	exists($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{activitytimeout}));
1429
1430	my $processit = 1;
1431	if (exists($self->{SIDS}->{server}))
1432	{
1433	foreach my $serverid (@{$self->{SIDS}->{server}})
1434	{
1435	if (exists($self->{SIDS}->{$serverid}->{sock}) &&
1436	($connection == $self->{SIDS}->{$serverid}->{sock}))
1437	{
1438	my $sid = $self->ConnectionAccept($serverid);
1439	$status{$sid} = 0;
1440	$processit = 0;
1441	last;
1442	}
1443	}
1444	}
1445	if ($processit == 1)
1446	{
1447	my $sid = $self->{SOCKETS}->{$connection};
1448	$self->debug(4,"Process: there's something to read");
1449	$self->debug(4,"Process: connection($connection) sid($sid)");
1450	my $buff;
1451	$self->debug(4,"Process: read");
1452	$status{$sid} = 1;
1453	$self->{SIDS}->{$sid}->{status} = -1
1454	if (!defined($buff = $self->Read($sid)));
1455	$buff = "" unless defined($buff);
1456	$self->debug(4,"Process: connection_status($self->{SIDS}->{$sid}->{status})");
1457	$status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1);
1458	$self->debug(4,"Process: parse($buff)");
1459	$status{$sid} = -1 unless($self->ParseStream($sid,$buff) == 1);
1460	}
1461	$block = 0;
1462	}
1463
1464	if ($timeout ne "")
1465	{
1466	if (time >= $timeEnd)
1467	{
1468	$self->debug(4,"Process: Everyone out of the pool! Time to stop blocking.");
1469	$block = 0;
1470	}
1471	}
1472
1473	$self->debug(4,"Process: timeout($timeout)");
1474
1475	if (exists($self->{CB}->{update}))
1476	{
1477	$self->debug(4,"Process: Calling user defined update function");
1478	&{$self->{CB}->{update}}();
1479	}
1480
1481	$block = 1 if $self->{SELECT}->can_read(0);
1482
1483	#---------------------------------------------------------------------
1484	# Check for connections that need to be kept alive
1485	#---------------------------------------------------------------------
1486	$self->debug(4,"Process: check for keepalives");
1487	foreach my $sid (keys(%{$self->{SIDS}}))
1488	{
1489	next if ($sid eq "default");
1490	next if ($sid =~ /^server/);
1491	next if ($status{$sid} == -1);
1492	if ((time - $self->{SIDS}->{$sid}->{keepalive}) > 10)
1493	{
1494	$self->IgnoreActivity($sid,1);
1495	$self->{SIDS}->{$sid}->{status} = -1
1496	if !defined($self->Send($sid," "));
1497	$status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1);
1498	if ($status{$sid} == -1)
1499	{
1500	$self->debug(2,"Process: Keep-Alive failed. What the hell happened?!?!");
1501	$self->debug(2,"Process: connection_status($self->{SIDS}->{$sid}->{status})");
1502	}
1503	$self->IgnoreActivity($sid,0);
1504	}
1505	}
1506	#---------------------------------------------------------------------
1507	# Check for connections that have timed out.
1508	#---------------------------------------------------------------------
1509	$self->debug(4,"Process: check for timeouts");
1510	foreach my $sid (keys(%{$self->{SIDS}}))
1511	{
1512	next if ($sid eq "default");
1513	next if ($sid =~ /^server/);
1514
1515	if (exists($self->{SIDS}->{$sid}->{activitytimeout}))
1516	{
1517	$self->debug(4,"Process: sid($sid) time(",time,") timeout($self->{SIDS}->{$sid}->{activitytimeout})");
1518	}
1519	else
1520	{
1521	$self->debug(4,"Process: sid($sid) time(",time,") timeout(undef)");
1522	}
1523
1524	$self->Respond($sid)
1525	if (exists($self->{SIDS}->{$sid}->{activitytimeout}) &&
1526	defined($self->GetRoot($sid)));
1527	$self->Disconnect($sid)
1528	if (exists($self->{SIDS}->{$sid}->{activitytimeout}) &&
1529	((time - $self->{SIDS}->{$sid}->{activitytimeout}) > 10) &&
1530	($self->{SIDS}->{$sid}->{status} != 1));
1531	}
1532
1533
1534	#---------------------------------------------------------------------
1535	# If any of the connections have status == -1 then return so that the
1536	# user can handle it.
1537	#---------------------------------------------------------------------
1538	foreach my $sid (keys(%status))
1539	{
1540	if ($status{$sid} == -1)
1541	{
1542	$self->debug(4,"Process: sid($sid) is broken... let's tell someone and watch it hit the fan... =)");
1543	$block = 0;
1544	}
1545	}
1546
1547	$self->debug(2,"Process: block($block)");
1548	}
1549
1550	#---------------------------------------------------------------------------
1551	# If the Select has an error then shut this party down.
1552	#---------------------------------------------------------------------------
1553	foreach my $connection ($self->{SELECT}->has_exception(0))
1554	{
1555	$self->debug(4,"Process: has_exception sid($self->{SOCKETS}->{$connection})");
1556	$status{$self->{SOCKETS}->{$connection}} = -1;
1557	}
1558
1559	#---------------------------------------------------------------------------
1560	# If there are data structures that have not been collected return
1561	# those, otherwise return the status which indicates if nodes were read or
1562	# not.
1563	#---------------------------------------------------------------------------
1564	foreach my $sid (keys(%status))
1565	{
1566	$status{$sid} = $self->{SIDS}->{$sid}->{nodes}
1567	if (($status{$sid} == 1) &&
1568	($#{$self->{SIDS}->{$sid}->{nodes}} > -1));
1569	}
1570
1571	return %status;
1572	}
1573
1574
1575	##############################################################################
1576	#
1577	# Read - Takes the data from the server and returns a string
1578	#
1579	##############################################################################
1580	sub Read
1581	{
1582	my $self = shift;
1583	my $sid = shift;
1584	my $buff;
1585	my $status = 1;
1586
1587	$self->debug(3,"Read: sid($sid)");
1588	$self->debug(3,"Read: connectionType($self->{SIDS}->{$sid}->{connectiontype})");
1589	$self->debug(3,"Read: socket($self->{SIDS}->{$sid}->{sock})");
1590
1591	return if ($self->{SIDS}->{$sid}->{status} == -1);
1592
1593	if (!defined($self->{SIDS}->{$sid}->{sock}))
1594	{
1595	$self->{SIDS}->{$sid}->{status} = -1;
1596	$self->SetErrorCode($sid,"Socket does not defined.");
1597	return;
1598	}
1599
1600	$self->{SIDS}->{$sid}->{sock}->flush();
1601
1602	$status = $self->{SIDS}->{$sid}->{sock}->sysread($buff,4*POSIX::BUFSIZ)
1603	if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") \|\|
1604	($self->{SIDS}->{$sid}->{connectiontype} eq "http") \|\|
1605	($self->{SIDS}->{$sid}->{connectiontype} eq "file"));
1606	$status = sysread(STDIN,$buff,1024)
1607	if ($self->{SIDS}->{$sid}->{connectiontype} eq "stdinout");
1608
1609	$buff =~ s/^HTTP[\S\s]+\n\n// if ($self->{SIDS}->{$sid}->{connectiontype} eq "http");
1610	$self->debug(1,"Read: buff($buff)");
1611	$self->debug(3,"Read: status($status)") if defined($status);
1612	$self->debug(3,"Read: status(undef)") unless defined($status);
1613	$self->{SIDS}->{$sid}->{keepalive} = time
1614	unless (($buff eq "") \|\| !defined($status) \|\| ($status == 0));
1615	if (defined($status) && ($status != 0))
1616	{
1617	$buff = Encode::decode_utf8($buff);
1618	return $buff;
1619	}
1620	#return $buff unless (!defined($status) \|\| ($status == 0));
1621	$self->debug(1,"Read: ERROR");
1622	return;
1623	}
1624
1625
1626	##############################################################################
1627	#
1628	# Send - Takes the data string and sends it to the server
1629	#
1630	##############################################################################
1631	sub Send
1632	{
1633	my $self = shift;
1634	my $sid = shift;
1635	$self->debug(1,"Send: (@_)");
1636	$self->debug(3,"Send: sid($sid)");
1637	$self->debug(3,"Send: status($self->{SIDS}->{$sid}->{status})");
1638
1639	$self->{SIDS}->{$sid}->{keepalive} = time;
1640
1641	return if ($self->{SIDS}->{$sid}->{status} == -1);
1642
1643	if (!defined($self->{SIDS}->{$sid}->{sock}))
1644	{
1645	$self->debug(3,"Send: socket not defined");
1646	$self->{SIDS}->{$sid}->{status} = -1;
1647	$self->SetErrorCode($sid,"Socket not defined.");
1648	return;
1649	}
1650	else
1651	{
1652	$self->debug(3,"Send: socket($self->{SIDS}->{$sid}->{sock})");
1653	}
1654
1655	$self->{SIDS}->{$sid}->{sock}->flush();
1656
1657	if ($self->{SIDS}->{$sid}->{select}->can_write(0))
1658	{
1659	$self->debug(3,"Send: can_write");
1660
1661	$self->{SENDSTRING} = Encode::encode_utf8(join("",@_));
1662
1663	$self->{SENDWRITTEN} = 0;
1664	$self->{SENDOFFSET} = 0;
1665	$self->{SENDLENGTH} = length($self->{SENDSTRING});
1666	while ($self->{SENDLENGTH})
1667	{
1668	$self->{SENDWRITTEN} = $self->{SIDS}->{$sid}->{sock}->syswrite($self->{SENDSTRING},$self->{SENDLENGTH},$self->{SENDOFFSET});
1669
1670	if (!defined($self->{SENDWRITTEN}))
1671	{
1672	$self->debug(4,"Send: SENDWRITTEN(undef)");
1673	$self->debug(4,"Send: Ok... what happened? Did we lose the connection?");
1674	$self->{SIDS}->{$sid}->{status} = -1;
1675	$self->SetErrorCode($sid,"Socket died for an unknown reason.");
1676	return;
1677	}
1678
1679	$self->debug(4,"Send: SENDWRITTEN($self->{SENDWRITTEN})");
1680
1681	$self->{SENDLENGTH} -= $self->{SENDWRITTEN};
1682	$self->{SENDOFFSET} += $self->{SENDWRITTEN};
1683	}
1684	}
1685	else
1686	{
1687	$self->debug(3,"Send: can't write...");
1688	}
1689
1690	return if($self->{SIDS}->{$sid}->{select}->has_exception(0));
1691
1692	$self->debug(3,"Send: no exceptions");
1693
1694	$self->{SIDS}->{$sid}->{keepalive} = time;
1695
1696	$self->MarkActivity($sid);
1697
1698	return 1;
1699	}
1700
1701
1702
1703
1704	##############################################################################
1705	#+----------------------------------------------------------------------------
1706	#\|
1707	#\| Feature Functions
1708	#\|
1709	#+----------------------------------------------------------------------------
1710	##############################################################################
1711
1712	##############################################################################
1713	#
1714	# ProcessStreamFeatures - process the <stream:featutres/> block.
1715	#
1716	##############################################################################
1717	sub ProcessStreamFeatures
1718	{
1719	my $self = shift;
1720	my $sid = shift;
1721	my $node = shift;
1722
1723	$self->{SIDS}->{$sid}->{streamfeatures}->{received} = 1;
1724
1725	#-------------------------------------------------------------------------
1726	# SASL - 1.0
1727	#-------------------------------------------------------------------------
1728	my @sasl = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-sasl').'"]');
1729	if ($#sasl > -1)
1730	{
1731	if (&XPath($sasl[0],"name()") eq "mechanisms")
1732	{
1733	my @mechanisms = &XPath($sasl[0],"mechanism/text()");
1734	$self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-sasl'} = \@mechanisms;
1735	}
1736	}
1737
1738	#-------------------------------------------------------------------------
1739	# XMPP-TLS - 1.0
1740	#-------------------------------------------------------------------------
1741	my @tls = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-tls').'"]');
1742	if ($#tls > -1)
1743	{
1744	if (&XPath($tls[0],"name()") eq "starttls")
1745	{
1746	$self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = 1;
1747	my @required = &XPath($tls[0],"required");
1748	if ($#required > -1)
1749	{
1750	$self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = "required";
1751	}
1752	}
1753	}
1754
1755	#-------------------------------------------------------------------------
1756	# XMPP-Bind - 1.0
1757	#-------------------------------------------------------------------------
1758	my @bind = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-bind').'"]');
1759	if ($#bind > -1)
1760	{
1761	$self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-bind'} = 1;
1762	}
1763
1764	#-------------------------------------------------------------------------
1765	# XMPP-Session - 1.0
1766	#-------------------------------------------------------------------------
1767	my @session = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-session').'"]');
1768	if ($#session > -1)
1769	{
1770	$self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-session'} = 1;
1771	}
1772
1773	}
1774
1775
1776	##############################################################################
1777	#
1778	# GetStreamFeature - Return the value of the stream feature (if any).
1779	#
1780	##############################################################################
1781	sub GetStreamFeature
1782	{
1783	my $self = shift;
1784	my $sid = shift;
1785	my $feature = shift;
1786
1787	return unless exists($self->{SIDS}->{$sid}->{streamfeatures}->{$feature});
1788	return $self->{SIDS}->{$sid}->{streamfeatures}->{$feature};
1789	}
1790
1791
1792	##############################################################################
1793	#
1794	# ReceivedStreamFeatures - Have we received the stream:features yet?
1795	#
1796	##############################################################################
1797	sub ReceivedStreamFeatures
1798	{
1799	my $self = shift;
1800	my $sid = shift;
1801	my $feature = shift;
1802
1803	return $self->{SIDS}->{$sid}->{streamfeatures}->{received};
1804	}
1805
1806
1807
1808
1809	##############################################################################
1810	#+----------------------------------------------------------------------------
1811	#\|
1812	#\| TLS Functions
1813	#\|
1814	#+----------------------------------------------------------------------------
1815	##############################################################################
1816
1817	##############################################################################
1818	#
1819	# ProcessTLSPacket - process a TLS based packet.
1820	#
1821	##############################################################################
1822	sub ProcessTLSPacket
1823	{
1824	my $self = shift;
1825	my $sid = shift;
1826	my $node = shift;
1827
1828	my $tag = &XPath($node,"name()");
1829
1830	if ($tag eq "failure")
1831	{
1832	$self->TLSClientFailure($sid,$node);
1833	}
1834
1835	if ($tag eq "proceed")
1836	{
1837	$self->TLSClientProceed($sid,$node);
1838	}
1839	}
1840
1841
1842	##############################################################################
1843	#
1844	# StartTLS - client function to have the socket start TLS.
1845	#
1846	##############################################################################
1847	sub StartTLS
1848	{
1849	my $self = shift;
1850	my $sid = shift;
1851	my $timeout = shift;
1852	$timeout = 120 unless defined($timeout);
1853	$timeout = 120 if ($timeout eq "");
1854
1855	$self->TLSStartTLS($sid);
1856
1857	my $endTime = time + $timeout;
1858	while(!$self->TLSClientDone($sid) && ($endTime >= time))
1859	{
1860	$self->Process(1);
1861	}
1862
1863	if (!$self->TLSClientSecure($sid))
1864	{
1865	return;
1866	}
1867
1868	return $self->OpenStream($sid,$timeout);
1869	}
1870
1871
1872	##############################################################################
1873	#
1874	# TLSStartTLS - send a <starttls/> in the TLS namespace.
1875	#
1876	##############################################################################
1877	sub TLSStartTLS
1878	{
1879	my $self = shift;
1880	my $sid = shift;
1881
1882	$self->Send($sid,"<starttls xmlns='".&ConstXMLNS('xmpp-tls')."'/>");
1883	}
1884
1885
1886	##############################################################################
1887	#
1888	# TLSClientProceed - handle a <proceed/> packet.
1889	#
1890	##############################################################################
1891	sub TLSClientProceed
1892	{
1893	my $self = shift;
1894	my $sid = shift;
1895	my $node = shift;
1896
1897	$self->debug(1,"TLSClientProceed: Convert normal socket to SSL");
1898	$self->debug(1,"TLSClientProceed: sock($self->{SIDS}->{$sid}->{sock})");
1899	if (!$self->LoadSSL())
1900	{
1901	$self->{SIDS}->{$sid}->{tls}->{error} = "Could not load IO::Socket::SSL.";
1902	$self->{SIDS}->{$sid}->{tls}->{done} = 1;
1903	return;
1904	}
1905
1906	IO::Socket::SSL->start_SSL($self->{SIDS}->{$sid}->{sock},{SSL_verify_mode=>0x00});
1907
1908	$self->debug(1,"TLSClientProceed: ssl_sock($self->{SIDS}->{$sid}->{sock})");
1909	$self->debug(1,"TLSClientProceed: SSL: We are secure")
1910	if ($self->{SIDS}->{$sid}->{sock});
1911
1912	$self->{SIDS}->{$sid}->{tls}->{done} = 1;
1913	$self->{SIDS}->{$sid}->{tls}->{secure} = 1;
1914	}
1915
1916
1917	##############################################################################
1918	#
1919	# TLSClientSecure - return 1 if the socket is secure, 0 otherwise.
1920	#
1921	##############################################################################
1922	sub TLSClientSecure
1923	{
1924	my $self = shift;
1925	my $sid = shift;
1926
1927	return $self->{SIDS}->{$sid}->{tls}->{secure};
1928	}
1929
1930
1931	##############################################################################
1932	#
1933	# TLSClientDone - return 1 if the TLS process is done
1934	#
1935	##############################################################################
1936	sub TLSClientDone
1937	{
1938	my $self = shift;
1939	my $sid = shift;
1940
1941	return $self->{SIDS}->{$sid}->{tls}->{done};
1942	}
1943
1944
1945	##############################################################################
1946	#
1947	# TLSClientError - return the TLS error if any
1948	#
1949	##############################################################################
1950	sub TLSClientError
1951	{
1952	my $self = shift;
1953	my $sid = shift;
1954
1955	return $self->{SIDS}->{$sid}->{tls}->{error};
1956	}
1957
1958
1959	##############################################################################
1960	#
1961	# TLSClientFailure - handle a <failure/>
1962	#
1963	##############################################################################
1964	sub TLSClientFailure
1965	{
1966	my $self = shift;
1967	my $sid = shift;
1968	my $node = shift;
1969
1970	my $type = &XPath($node,"*/name()");
1971
1972	$self->{SIDS}->{$sid}->{tls}->{error} = $type;
1973	$self->{SIDS}->{$sid}->{tls}->{done} = 1;
1974	}
1975
1976
1977	##############################################################################
1978	#
1979	# TLSFailure - Send a <failure/> in the TLS namespace
1980	#
1981	##############################################################################
1982	sub TLSFailure
1983	{
1984	my $self = shift;
1985	my $sid = shift;
1986	my $type = shift;
1987
1988	$self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-tls')."'><${type}/></failure>");
1989	}
1990
1991
1992
1993
1994	##############################################################################
1995	#+----------------------------------------------------------------------------
1996	#\|
1997	#\| SASL Functions
1998	#\|
1999	#+----------------------------------------------------------------------------
2000	##############################################################################
2001
2002	##############################################################################
2003	#
2004	# ProcessSASLPacket - process a SASL based packet.
2005	#
2006	##############################################################################
2007	sub ProcessSASLPacket
2008	{
2009	my $self = shift;
2010	my $sid = shift;
2011	my $node = shift;
2012
2013	my $tag = &XPath($node,"name()");
2014
2015	if ($tag eq "challenge")
2016	{
2017	$self->SASLAnswerChallenge($sid,$node);
2018	}
2019
2020	if ($tag eq "failure")
2021	{
2022	$self->SASLClientFailure($sid,$node);
2023	}
2024
2025	if ($tag eq "success")
2026	{
2027	$self->SASLClientSuccess($sid,$node);
2028	}
2029	}
2030
2031
2032	##############################################################################
2033	#
2034	# SASLAnswerChallenge - when we get a <challenge/> we need to do the grunt
2035	# work to return a <response/>.
2036	#
2037	##############################################################################
2038	sub SASLAnswerChallenge
2039	{
2040	my $self = shift;
2041	my $sid = shift;
2042	my $node = shift;
2043
2044	my $challenge64 = &XPath($node,"text()");
2045	my $challenge = MIME::Base64::decode_base64($challenge64);
2046
2047	#-------------------------------------------------------------------------
2048	# As far as I can tell, if the challenge contains rspauth, then we authed.
2049	# If you try to send that to Authen::SASL, it will spew warnings about
2050	# the missing qop, nonce, etc... However, in order for jabberd2 to think
2051	# that you answered, you have to send back an empty response. Not sure
2052	# which approach is right... So let's hack for now.
2053	#-------------------------------------------------------------------------
2054	my $response = "";
2055	if ($challenge !~ /rspauth\=/)
2056	{
2057	$response = $self->{SIDS}->{$sid}->{sasl}->{client}->client_step($challenge);
2058	}
2059
2060	my $response64 = MIME::Base64::encode_base64($response,"");
2061	$self->SASLResponse($sid,$response64);
2062	}
2063
2064
2065	##############################################################################
2066	#
2067	# SASLAuth - send an <auth/> in the SASL namespace
2068	#
2069	##############################################################################
2070	sub SASLAuth
2071	{
2072	my $self = shift;
2073	my $sid = shift;
2074
2075	my $first_step = $self->{SIDS}->{$sid}->{sasl}->{client}->client_start();
2076	my $first_step64 = MIME::Base64::encode_base64($first_step,"");
2077
2078	$self->Send($sid,"<auth xmlns='".&ConstXMLNS('xmpp-sasl')."' mechanism='".$self->{SIDS}->{$sid}->{sasl}->{client}->mechanism()."'>".$first_step64."</auth>");
2079	}
2080
2081
2082	##############################################################################
2083	#
2084	# SASLChallenge - Send a <challenge/> in the SASL namespace
2085	#
2086	##############################################################################
2087	sub SASLChallenge
2088	{
2089	my $self = shift;
2090	my $sid = shift;
2091	my $challenge = shift;
2092
2093	$self->Send($sid,"<challenge xmlns='".&ConstXMLNS('xmpp-sasl')."'>${challenge}</challenge>");
2094	}
2095
2096
2097	###############################################################################
2098	#
2099	# SASLClient - This is a helper function to perform all of the required steps
2100	# for doing SASL with the server.
2101	#
2102	###############################################################################
2103	sub SASLClient
2104	{
2105	my $self = shift;
2106	my $sid = shift;
2107	my $username = shift;
2108	my $password = shift;
2109
2110	my $mechanisms = $self->GetStreamFeature($sid,"xmpp-sasl");
2111
2112	return unless defined($mechanisms);
2113
2114	my $sasl = new Authen::SASL(mechanism=>join(" ",@{$mechanisms}),
2115	callback=>{
2116	# authname => $username."@".$self->{SIDS}->{$sid}->{hostname},
2117	user => $username,
2118	pass => $password
2119	}
2120	);
2121
2122	$self->{SIDS}->{$sid}->{sasl}->{client} = $sasl->client_new('xmpp', $self->{SIDS}->{$sid}->{hostname});
2123	$self->{SIDS}->{$sid}->{sasl}->{username} = $username;
2124	$self->{SIDS}->{$sid}->{sasl}->{password} = $password;
2125	$self->{SIDS}->{$sid}->{sasl}->{authed} = 0;
2126	$self->{SIDS}->{$sid}->{sasl}->{done} = 0;
2127
2128	$self->SASLAuth($sid);
2129	}
2130
2131
2132	##############################################################################
2133	#
2134	# SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise
2135	#
2136	##############################################################################
2137	sub SASLClientAuthed
2138	{
2139	my $self = shift;
2140	my $sid = shift;
2141
2142	return $self->{SIDS}->{$sid}->{sasl}->{authed};
2143	}
2144
2145
2146	##############################################################################
2147	#
2148	# SASLClientDone - return 1 if the SASL process is finished
2149	#
2150	##############################################################################
2151	sub SASLClientDone
2152	{
2153	my $self = shift;
2154	my $sid = shift;
2155
2156	return $self->{SIDS}->{$sid}->{sasl}->{done};
2157	}
2158
2159
2160	##############################################################################
2161	#
2162	# SASLClientError - return the error if any
2163	#
2164	##############################################################################
2165	sub SASLClientError
2166	{
2167	my $self = shift;
2168	my $sid = shift;
2169
2170	return $self->{SIDS}->{$sid}->{sasl}->{error};
2171	}
2172
2173
2174	##############################################################################
2175	#
2176	# SASLClientFailure - handle a received <failure/>
2177	#
2178	##############################################################################
2179	sub SASLClientFailure
2180	{
2181	my $self = shift;
2182	my $sid = shift;
2183	my $node = shift;
2184
2185	my $type = &XPath($node,"*/name()");
2186
2187	$self->{SIDS}->{$sid}->{sasl}->{error} = $type;
2188	$self->{SIDS}->{$sid}->{sasl}->{done} = 1;
2189	}
2190
2191
2192	##############################################################################
2193	#
2194	# SASLClientSuccess - handle a received <success/>
2195	#
2196	##############################################################################
2197	sub SASLClientSuccess
2198	{
2199	my $self = shift;
2200	my $sid = shift;
2201	my $node = shift;
2202
2203	$self->{SIDS}->{$sid}->{sasl}->{authed} = 1;
2204	$self->{SIDS}->{$sid}->{sasl}->{done} = 1;
2205	}
2206
2207
2208	##############################################################################
2209	#
2210	# SASLFailure - Send a <failure/> tag in the SASL namespace
2211	#
2212	##############################################################################
2213	sub SASLFailure
2214	{
2215	my $self = shift;
2216	my $sid = shift;
2217	my $type = shift;
2218
2219	$self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-sasl')."'><${type}/></failure>");
2220	}
2221
2222
2223	##############################################################################
2224	#
2225	# SASLResponse - Send a <response/> tag in the SASL namespace
2226	#
2227	##############################################################################
2228	sub SASLResponse
2229	{
2230	my $self = shift;
2231	my $sid = shift;
2232	my $response = shift;
2233
2234	$self->Send($sid,"<response xmlns='".&ConstXMLNS('xmpp-sasl')."'>${response}</response>");
2235	}
2236
2237
2238
2239
2240	##############################################################################
2241	#+----------------------------------------------------------------------------
2242	#\|
2243	#\| Packet Handlers
2244	#\|
2245	#+----------------------------------------------------------------------------
2246	##############################################################################
2247
2248
2249	##############################################################################
2250	#
2251	# ProcessStreamPacket - process the <stream:XXXX/> packet
2252	#
2253	##############################################################################
2254	sub ProcessStreamPacket
2255	{
2256	my $self = shift;
2257	my $sid = shift;
2258	my $node = shift;
2259
2260	my $tag = &XPath($node,"name()");
2261	my $stream_prefix = $self->StreamPrefix($sid);
2262	my ($type) = ($tag =~ /^${stream_prefix}\:(.+)$/);
2263
2264	$self->ProcessStreamError($sid,$node) if ($type eq "error");
2265	$self->ProcessStreamFeatures($sid,$node) if ($type eq "features");
2266	}
2267
2268
2269	##############################################################################
2270	#
2271	# _handle_root - handles a root tag and checks that it is a stream:stream tag
2272	# with the proper namespace. If not then it sets the STATUS
2273	# to -1 and let's the outer code know that an error occurred.
2274	# Then it changes the Start tag handlers to the methond listed
2275	# in $self->{DATASTYLE}
2276	#
2277	##############################################################################
2278	sub _handle_root
2279	{
2280	my $self = shift;
2281	my ($sax, $tag, %att) = @_;
2282	my $sid = $sax->getSID();
2283
2284	$self->debug(2,"_handle_root: sid($sid) sax($sax) tag($tag) att(",%att,")");
2285
2286	$self->{SIDS}->{$sid}->{rootTag} = $tag;
2287
2288	if ($self->{SIDS}->{$sid}->{connectiontype} ne "file")
2289	{
2290	#---------------------------------------------------------------------
2291	# Make sure we are receiving a valid stream on the same namespace.
2292	#---------------------------------------------------------------------
2293
2294	$self->debug(3,"_handle_root: ($self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})");
2295	$self->{SIDS}->{$sid}->{status} =
2296	((($tag eq "stream:stream") &&
2297	exists($att{'xmlns'}) &&
2298	($att{'xmlns'} eq $self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})
2299	) ?
2300	1 :
2301	-1
2302	);
2303	$self->debug(3,"_handle_root: status($self->{SIDS}->{$sid}->{status})");
2304	}
2305	else
2306	{
2307	$self->{SIDS}->{$sid}->{status} = 1;
2308	}
2309
2310	#-------------------------------------------------------------------------
2311	# Get the root tag attributes and save them for later. You never know when
2312	# you'll need to check the namespace or the from attributes sent by the
2313	# server.
2314	#-------------------------------------------------------------------------
2315	$self->{SIDS}->{$sid}->{root} = \%att;
2316
2317	#-------------------------------------------------------------------------
2318	# Run through the various xmlns:*** attributes and register the namespace
2319	# to prefix map.
2320	#-------------------------------------------------------------------------
2321	foreach my $key (keys(%att))
2322	{
2323	if ($key =~ /^xmlns\:(.+?)$/)
2324	{
2325	$self->debug(5,"_handle_root: RegisterPrefix: prefix($att{$key}) ns($1)");
2326	$self->RegisterPrefix($sid,$att{$key},$1);
2327	}
2328	}
2329
2330	#-------------------------------------------------------------------------
2331	# Sometimes we will get an error, so let's parse the tag assuming that we
2332	# got a stream:error
2333	#-------------------------------------------------------------------------
2334	my $stream_prefix = $self->StreamPrefix($sid);
2335	$self->debug(5,"_handle_root: stream_prefix($stream_prefix)");
2336
2337	if ($tag eq $stream_prefix.":error")
2338	{
2339	&XML::Stream::Tree::_handle_element($self,$sax,$tag,%att)
2340	if ($self->{DATASTYLE} eq "tree");
2341	&XML::Stream::Node::_handle_element($self,$sax,$tag,%att)
2342	if ($self->{DATASTYLE} eq "node");
2343	}
2344
2345	#---------------------------------------------------------------------------
2346	# Now that we have gotten a root tag, let's look for the tags that make up
2347	# the stream. Change the handler for a Start tag to another function.
2348	#---------------------------------------------------------------------------
2349	$sax->setHandlers(startElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{startElement}}($self,@_) },
2350	endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
2351	characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
2352	);
2353	}
2354
2355
2356	##############################################################################
2357	#
2358	# _node - internal callback for nodes. All it does is place the nodes in a
2359	# list so that Process() can return them later.
2360	#
2361	##############################################################################
2362	sub _node
2363	{
2364	my $self = shift;
2365	my $sid = shift;
2366	my @node = shift;
2367
2368	if (ref($node[0]) eq "XML::Stream::Node")
2369	{
2370	push(@{$self->{SIDS}->{$sid}->{nodes}},$node[0]);
2371	}
2372	else
2373	{
2374	push(@{$self->{SIDS}->{$sid}->{nodes}},\@node);
2375	}
2376	}
2377
2378
2379
2380
2381	##############################################################################
2382	#+----------------------------------------------------------------------------
2383	#\|
2384	#\| Error Functions
2385	#\|
2386	#+----------------------------------------------------------------------------
2387	##############################################################################
2388
2389	##############################################################################
2390	#
2391	# GetErrorCode - if you are returned an undef, you can call this function
2392	# and hopefully learn more information about the problem.
2393	#
2394	##############################################################################
2395	sub GetErrorCode
2396	{
2397	my $self = shift;
2398	my $sid = shift;
2399
2400	$sid = "newconnection" unless defined($sid);
2401
2402	$self->debug(3,"GetErrorCode: sid($sid)");
2403	return ((exists($self->{SIDS}->{$sid}->{errorcode}) &&
2404	(ref($self->{SIDS}->{$sid}->{errorcode}) eq "HASH")) ?
2405	$self->{SIDS}->{$sid}->{errorcode} :
2406	{ type=>"system",
2407	text=>$!,
2408	}
2409	);
2410	}
2411
2412
2413	##############################################################################
2414	#
2415	# SetErrorCode - sets the error code so that the caller can find out more
2416	# information about the problem
2417	#
2418	##############################################################################
2419	sub SetErrorCode
2420	{
2421	my $self = shift;
2422	my $sid = shift;
2423	my $errorcode = shift;
2424
2425	$self->{SIDS}->{$sid}->{errorcode} = $errorcode;
2426	}
2427
2428
2429	##############################################################################
2430	#
2431	# ProcessStreamError - Take the XML packet and extract out the error.
2432	#
2433	##############################################################################
2434	sub ProcessStreamError
2435	{
2436	my $self = shift;
2437	my $sid = shift;
2438	my $node = shift;
2439
2440	$self->{SIDS}->{$sid}->{streamerror}->{type} = "unknown";
2441	$self->{SIDS}->{$sid}->{streamerror}->{node} = $node;
2442
2443	#-------------------------------------------------------------------------
2444	# Check for older 0.9 streams and handle the errors for them.
2445	#-------------------------------------------------------------------------
2446	if (!exists($self->{SIDS}->{$sid}->{root}->{version}) \|\|
2447	($self->{SIDS}->{$sid}->{root}->{version} eq "") \|\|
2448	($self->{SIDS}->{$sid}->{root}->{version} < 1.0)
2449	)
2450	{
2451	$self->{SIDS}->{$sid}->{streamerror}->{text} =
2452	&XPath($node,"text()");
2453	return;
2454	}
2455
2456	#-------------------------------------------------------------------------
2457	# Otherwise we are in XMPP land with real stream errors.
2458	#-------------------------------------------------------------------------
2459	my @errors = &XPath($node,'*[@xmlns="'.&ConstXMLNS("xmppstreams").'"]');
2460
2461	my $type;
2462	my $text;
2463	foreach my $error (@errors)
2464	{
2465	if (&XPath($error,"name()") eq "text")
2466	{
2467	$self->{SIDS}->{$sid}->{streamerror}->{text} =
2468	&XPath($error,"text()");
2469	}
2470	else
2471	{
2472	$self->{SIDS}->{$sid}->{streamerror}->{type} =
2473	&XPath($error,"name()");
2474	}
2475	}
2476	}
2477
2478
2479	##############################################################################
2480	#
2481	# StreamError - Given a type and text, generate a <stream:error/> packet to
2482	# send back to the other side.
2483	#
2484	##############################################################################
2485	sub StreamError
2486	{
2487	my $self = shift;
2488	my $sid = shift;
2489	my $type = shift;
2490	my $text = shift;
2491
2492	my $root = $self->GetRoot($sid);
2493	my $stream_base = $self->StreamPrefix($sid);
2494	my $error = "<${stream_base}:error>";
2495
2496	if (exists($root->{version}) && ($root->{version} ne ""))
2497	{
2498	$error .= "<${type} xmlns='".&ConstXMLNS('xmppstreams')."'/>";
2499	if (defined($text))
2500	{
2501	$error .= "<text xmlns='".&ConstXMLNS('xmppstreams')."'>";
2502	$error .= $text;
2503	$error .= "</text>";
2504	}
2505	}
2506	else
2507	{
2508	$error .= $text;
2509	}
2510
2511	$error .= "</${stream_base}:error>";
2512
2513	return $error;
2514	}
2515
2516
2517
2518
2519	##############################################################################
2520	#+----------------------------------------------------------------------------
2521	#\|
2522	#\| Activity Monitoring Functions
2523	#\|
2524	#+----------------------------------------------------------------------------
2525	##############################################################################
2526
2527	##############################################################################
2528	#
2529	# IgnoreActivity - Set the flag that will ignore the activity monitor.
2530	#
2531	##############################################################################
2532	sub IgnoreActivity
2533	{
2534	my $self = shift;
2535	my $sid = shift;
2536	my $ignoreActivity = shift;
2537	$ignoreActivity = 1 unless defined($ignoreActivity);
2538
2539	$self->debug(3,"IgnoreActivity: ignoreActivity($ignoreActivity)");
2540	$self->debug(4,"IgnoreActivity: sid($sid)");
2541
2542	$self->{SIDS}->{$sid}->{ignoreActivity} = $ignoreActivity;
2543	}
2544
2545
2546	##############################################################################
2547	#
2548	# LastActivity - Return the time of the last activity.
2549	#
2550	##############################################################################
2551	sub LastActivity
2552	{
2553	my $self = shift;
2554	my $sid = shift;
2555
2556	$self->debug(3,"LastActivity: sid($sid)");
2557	$self->debug(1,"LastActivity: lastActivity($self->{SIDS}->{$sid}->{lastActivity})");
2558
2559	return $self->{SIDS}->{$sid}->{lastActivity};
2560	}
2561
2562
2563	##############################################################################
2564	#
2565	# MarkActivity - Record the current time for this sid.
2566	#
2567	##############################################################################
2568	sub MarkActivity
2569	{
2570	my $self = shift;
2571	my $sid = shift;
2572
2573	return if (exists($self->{SIDS}->{$sid}->{ignoreActivity}) &&
2574	($self->{SIDS}->{$sid}->{ignoreActivity} == 1));
2575
2576	$self->debug(3,"MarkActivity: sid($sid)");
2577
2578	$self->{SIDS}->{$sid}->{lastActivity} = time;
2579	}
2580
2581
2582
2583
2584	##############################################################################
2585	#+----------------------------------------------------------------------------
2586	#\|
2587	#\| XML Node Interface functions
2588	#\|
2589	#\| These are generic wrappers around the Tree and Node data types. The
2590	#\| problem being that the Tree class cannot support methods.
2591	#\|
2592	#+----------------------------------------------------------------------------
2593	##############################################################################
2594
2595	##############################################################################
2596	#
2597	# SetXMLData - takes a host of arguments and sets a portion of the specified
2598	# data strucure with that data. The function works in two
2599	# modes "single" or "multiple". "single" denotes that the
2600	# function should locate the current tag that matches this
2601	# data and overwrite it's contents with data passed in.
2602	# "multiple" denotes that a new tag should be created even if
2603	# others exist.
2604	#
2605	# type - single or multiple
2606	# XMLTree - pointer to XML::Stream data object (tree or node)
2607	# tag - name of tag to create/modify (if blank assumes
2608	# working with top level tag)
2609	# data - CDATA to set for tag
2610	# attribs - attributes to ADD to tag
2611	#
2612	##############################################################################
2613	sub SetXMLData
2614	{
2615	return &XML::Stream::Node::SetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node");
2616	return &XML::Stream::Tree::SetXMLData(@_) if (ref($_[1]) eq "ARRAY");
2617	}
2618
2619
2620	##############################################################################
2621	#
2622	# GetXMLData - takes a host of arguments and returns various data structures
2623	# that match them.
2624	#
2625	# type - "existence" - returns 1 or 0 if the tag exists in the
2626	# top level.
2627	# "value" - returns either the CDATA of the tag, or the
2628	# value of the attribute depending on which is
2629	# sought. This ignores any mark ups to the data
2630	# and just returns the raw CDATA.
2631	# "value array" - returns an array of strings representing
2632	# all of the CDATA in the specified tag.
2633	# This ignores any mark ups to the data
2634	# and just returns the raw CDATA.
2635	# "tree" - returns a data structure that represents the
2636	# XML with the specified tag as the root tag.
2637	# Depends on the format that you are working with.
2638	# "tree array" - returns an array of data structures each
2639	# with the specified tag as the root tag.
2640	# "child array" - returns a list of all children nodes
2641	# not including CDATA nodes.
2642	# "attribs" - returns a hash with the attributes, and
2643	# their values, for the things that match
2644	# the parameters
2645	# "count" - returns the number of things that match
2646	# the arguments
2647	# "tag" - returns the root tag of this tree
2648	# XMLTree - pointer to XML::Stream data structure
2649	# tag - tag to pull data from. If blank then the top level
2650	# tag is accessed.
2651	# attrib - attribute value to retrieve. Ignored for types
2652	# "value array", "tree", "tree array". If paired
2653	# with value can be used to filter tags based on
2654	# attributes and values.
2655	# value - only valid if an attribute is supplied. Used to
2656	# filter for tags that only contain this attribute.
2657	# Useful to search through multiple tags that all
2658	# reference different name spaces.
2659	#
2660	##############################################################################
2661	sub GetXMLData
2662	{
2663	return &XML::Stream::Node::GetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node");
2664	return &XML::Stream::Tree::GetXMLData(@_) if (ref($_[1]) eq "ARRAY");
2665	}
2666
2667
2668	##############################################################################
2669	#
2670	# XPath - run an xpath query on a node and return back the result.
2671	#
2672	##############################################################################
2673	sub XPath
2674	{
2675	my $tree = shift;
2676	my $path = shift;
2677
2678	my $query = new XML::Stream::XPath::Query($path);
2679	my $result = $query->execute($tree);
2680	if ($result->check())
2681	{
2682	my %attribs = $result->getAttribs();
2683	return %attribs if (scalar(keys(%attribs)) > 0);
2684
2685	my @values = $result->getValues();
2686	@values = $result->getList() unless ($#values > -1);
2687	return @values if wantarray;
2688	return $values[0];
2689	}
2690	return;
2691	}
2692
2693
2694	##############################################################################
2695	#
2696	# XPathCheck - run an xpath query on a node and return 1 or 0 if the path is
2697	# valid.
2698	#
2699	##############################################################################
2700	sub XPathCheck
2701	{
2702	my $tree = shift;
2703	my $path = shift;
2704
2705	my $query = new XML::Stream::XPath::Query($path);
2706	my $result = $query->execute($tree);
2707	return $result->check();
2708	}
2709
2710
2711	##############################################################################
2712	#
2713	# XML2Config - takes an XML data tree and turns it into a hash of hashes.
2714	# This only works for certain kinds of XML trees like this:
2715	#
2716	# <foo>
2717	# <bar>1</bar>
2718	# <x>
2719	# <y>foo</y>
2720	# </x>
2721	# <z>5</z>
2722	# <z>6</z>
2723	# </foo>
2724	#
2725	# The resulting hash would be:
2726	#
2727	# $hash{bar} = 1;
2728	# $hash{x}->{y} = "foo";
2729	# $hash{z}->[0] = 5;
2730	# $hash{z}->[1] = 6;
2731	#
2732	# Good for config files.
2733	#
2734	##############################################################################
2735	sub XML2Config
2736	{
2737	return &XML::Stream::Node::XML2Config(@_) if (ref($_[0]) eq "XML::Stream::Node");
2738	return &XML::Stream::Tree::XML2Config(@_) if (ref($_[0]) eq "ARRAY");
2739	}
2740
2741
2742	##############################################################################
2743	#
2744	# Config2XML - takes a hash and produces an XML string from it. If the hash
2745	# looks like this:
2746	#
2747	# $hash{bar} = 1;
2748	# $hash{x}->{y} = "foo";
2749	# $hash{z}->[0] = 5;
2750	# $hash{z}->[1] = 6;
2751	#
2752	# The resulting xml would be:
2753	#
2754	# <foo>
2755	# <bar>1</bar>
2756	# <x>
2757	# <y>foo</y>
2758	# </x>
2759	# <z>5</z>
2760	# <z>6</z>
2761	# </foo>
2762	#
2763	# Good for config files.
2764	#
2765	##############################################################################
2766	sub Config2XML
2767	{
2768	my ($tag,$hash,$indent) = @_;
2769	$indent = "" unless defined($indent);
2770
2771	my $xml;
2772
2773	if (ref($hash) eq "ARRAY")
2774	{
2775	foreach my $item (@{$hash})
2776	{
2777	$xml .= &XML::Stream::Config2XML($tag,$item,$indent);
2778	}
2779	}
2780	else
2781	{
2782	if ((ref($hash) eq "HASH") && ((scalar keys(%{$hash})) == 0))
2783	{
2784	$xml .= "$indent<$tag/>\n";
2785	}
2786	else
2787	{
2788	if (ref($hash) eq "")
2789	{
2790	if ($hash eq "")
2791	{
2792	return "$indent<$tag/>\n";
2793	}
2794	else
2795	{
2796	return "$indent<$tag>$hash</$tag>\n";
2797	}
2798	}
2799	else
2800	{
2801	$xml .= "$indent<$tag>\n";
2802	foreach my $item (sort {$a cmp $b} keys(%{$hash}))
2803	{
2804	$xml .= &XML::Stream::Config2XML($item,$hash->{$item}," $indent");
2805	}
2806	$xml .= "$indent</$tag>\n";
2807	}
2808	}
2809	}
2810	return $xml;
2811	}
2812
2813
2814	##############################################################################
2815	#
2816	# EscapeXML - Simple function to make sure that no bad characters make it into
2817	# in the XML string that might cause the string to be
2818	# misinterpreted.
2819	#
2820	##############################################################################
2821	sub EscapeXML
2822	{
2823	my $data = shift;
2824
2825	if (defined($data))
2826	{
2827	$data =~ s/&/&/g;
2828	$data =~ s/</</g;
2829	$data =~ s/>/>/g;
2830	$data =~ s/\"/"/g;
2831	$data =~ s/\'/'/g;
2832	}
2833
2834	return $data;
2835	}
2836
2837
2838	##############################################################################
2839	#
2840	# UnescapeXML - Simple function to take an escaped string and return it to
2841	# normal.
2842	#
2843	##############################################################################
2844	sub UnescapeXML
2845	{
2846	my $data = shift;
2847
2848	if (defined($data))
2849	{
2850	$data =~ s/&/&/g;
2851	$data =~ s/</</g;
2852	$data =~ s/>/>/g;
2853	$data =~ s/"/\"/g;
2854	$data =~ s/'/\'/g;
2855	}
2856
2857	return $data;
2858	}
2859
2860
2861	##############################################################################
2862	#
2863	# BuildXML - takes one of the data formats that XML::Stream supports and call
2864	# the proper BuildXML_xxx function on it.
2865	#
2866	##############################################################################
2867	sub BuildXML
2868	{
2869	return &XML::Stream::Node::BuildXML(@_) if (ref($_[0]) eq "XML::Stream::Node");
2870	return &XML::Stream::Tree::BuildXML(@_) if (ref($_[0]) eq "ARRAY");
2871	return &XML::Stream::Tree::BuildXML(@_) if (ref($_[1]) eq "ARRAY");
2872	}
2873
2874
2875
2876	##############################################################################
2877	#+----------------------------------------------------------------------------
2878	#\|
2879	#\| Namespace/Prefix Functions
2880	#\|
2881	#+----------------------------------------------------------------------------
2882	##############################################################################
2883
2884	##############################################################################
2885	#
2886	# ConstXMLNS - Return the namespace from the constant string.
2887	#
2888	##############################################################################
2889	sub ConstXMLNS
2890	{
2891	my $const = shift;
2892
2893	return $XMLNS{$const};
2894	}
2895
2896
2897	##############################################################################
2898	#
2899	# StreamPrefix - Return the prefix of the <stream:stream/>
2900	#
2901	##############################################################################
2902	sub StreamPrefix
2903	{
2904	my $self = shift;
2905	my $sid = shift;
2906
2907	return $self->ns2prefix($sid,&ConstXMLNS("stream"));
2908	}
2909
2910
2911	##############################################################################
2912	#
2913	# RegisterPrefix - setup the map for namespace to prefix
2914	#
2915	##############################################################################
2916	sub RegisterPrefix
2917	{
2918	my $self = shift;
2919	my $sid = shift;
2920	my $ns = shift;
2921	my $prefix = shift;
2922
2923	$self->{SIDS}->{$sid}->{ns2prefix}->{$ns} = $prefix;
2924	}
2925
2926
2927	##############################################################################
2928	#
2929	# ns2prefix - for a stream, return the prefix for the given namespace
2930	#
2931	##############################################################################
2932	sub ns2prefix
2933	{
2934	my $self = shift;
2935	my $sid = shift;
2936	my $ns = shift;
2937
2938	return $self->{SIDS}->{$sid}->{ns2prefix}->{$ns};
2939	}
2940
2941
2942
2943
2944	##############################################################################
2945	#+----------------------------------------------------------------------------
2946	#\|
2947	#\| Helper Functions
2948	#\|
2949	#+----------------------------------------------------------------------------
2950	##############################################################################
2951
2952	##############################################################################
2953	#
2954	# GetRoot - returns the hash of attributes for the root <stream:stream/> tag
2955	# so that any attributes returned can be accessed. from and any
2956	# xmlns:foobar might be important.
2957	#
2958	##############################################################################
2959	sub GetRoot
2960	{
2961	my $self = shift;
2962	my $sid = shift;
2963	return unless exists($self->{SIDS}->{$sid}->{root});
2964	return $self->{SIDS}->{$sid}->{root};
2965	}
2966
2967
2968	##############################################################################
2969	#
2970	# GetSock - returns the Socket so that an outside function can access it if
2971	# desired.
2972	#
2973	##############################################################################
2974	sub GetSock
2975	{
2976	my $self = shift;
2977	my $sid = shift;
2978	return $self->{SIDS}->{$sid}->{sock};
2979	}
2980
2981
2982	##############################################################################
2983	#
2984	# LoadSSL - simple call to set everything up for SSL one time.
2985	#
2986	##############################################################################
2987	sub LoadSSL
2988	{
2989	my $self = shift;
2990
2991	$self->debug(1,"LoadSSL: Load the IO::Socket::SSL module");
2992
2993	if (defined($SSL) && ($SSL == 1))
2994	{
2995	$self->debug(1,"LoadSSL: Success");
2996	return 1;
2997	}
2998
2999	if (defined($SSL) && ($SSL == 0))
3000	{
3001	$self->debug(1,"LoadSSL: Failure");
3002	return;
3003	}
3004
3005	my $SSL_Version = "0.81";
3006	eval "use IO::Socket::SSL $SSL_Version";
3007	if ($@)
3008	{
3009	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.");
3010	}
3011	IO::Socket::SSL::context_init({SSL_verify_mode=>0x00});
3012	$SSL = 1;
3013
3014	$self->debug(1,"LoadSSL: Success");
3015	return 1;
3016	}
3017
3018
3019	##############################################################################
3020	#
3021	# Host2SID - For a server this allows you to lookup the SID of a stream server
3022	# based on the hostname that is is listening on.
3023	#
3024	##############################################################################
3025	sub Host2SID
3026	{
3027	my $self = shift;
3028	my $hostname = shift;
3029
3030	foreach my $sid (keys(%{$self->{SIDS}}))
3031	{
3032	next if ($sid eq "default");
3033	next if ($sid =~ /^server/);
3034
3035	return $sid if ($self->{SIDS}->{$sid}->{hostname} eq $hostname);
3036	}
3037	return;
3038	}
3039
3040
3041	##############################################################################
3042	#
3043	# NewSID - returns a session ID to send to an incoming stream in the return
3044	# header. By default it just increments a counter and returns that,
3045	# or you can define a function and set it using the SetCallBacks
3046	# function.
3047	#
3048	##############################################################################
3049	sub NewSID
3050	{
3051	my $self = shift;
3052	return &{$self->{CB}->{sid}}() if (exists($self->{CB}->{sid}) &&
3053	defined($self->{CB}->{sid}));
3054	return $$.time.$self->{IDCOUNT}++;
3055	}
3056
3057
3058	###########################################################################
3059	#
3060	# SetCallBacks - Takes a hash with top level tags to look for as the keys
3061	# and pointers to functions as the values.
3062	#
3063	###########################################################################
3064	sub SetCallBacks
3065	{
3066	my $self = shift;
3067	while($#_ >= 0) {
3068	my $func = pop(@_);
3069	my $tag = pop(@_);
3070	if (($tag eq "node") && !defined($func))
3071	{
3072	$self->SetCallBacks(node=>sub { $self->_node(@_) });
3073	}
3074	else
3075	{
3076	$self->debug(1,"SetCallBacks: tag($tag) func($func)");
3077	$self->{CB}->{$tag} = $func;
3078	}
3079	}
3080	}
3081
3082
3083	##############################################################################
3084	#
3085	# StreamHeader - Given the arguments, return the opening stream header.
3086	#
3087	##############################################################################
3088	sub StreamHeader
3089	{
3090	my $self = shift;
3091	my (%args) = @_;
3092
3093	my $stream;
3094	$stream .= "<?xml version='1.0'?>";
3095	$stream .= "<stream:stream ";
3096	$stream .= "version='1.0' ";
3097	$stream .= "xmlns:stream='".&ConstXMLNS("stream")."' ";
3098	$stream .= "xmlns='$args{xmlns}' ";
3099	$stream .= "to='$args{to}' " if exists($args{to});
3100	$stream .= "from='$args{from}' " if exists($args{from});
3101	$stream .= "xml:lang='$args{xmllang}' " if exists($args{xmllang});
3102
3103	foreach my $ns (@{$args{namespaces}})
3104	{
3105	$stream .= " ".$ns->GetStream();
3106	}
3107
3108	$stream .= ">";
3109
3110	return $stream;
3111	}
3112
3113
3114	###########################################################################
3115	#
3116	# debug - prints the arguments to the debug log if debug is turned on.
3117	#
3118	###########################################################################
3119	sub debug
3120	{
3121	return if ($_[1] > $_[0]->{DEBUGLEVEL});
3122	my $self = shift;
3123	my ($limit,@args) = @_;
3124	return if ($self->{DEBUGFILE} eq "");
3125	my $fh = $self->{DEBUGFILE};
3126	if ($self->{DEBUGTIME} == 1)
3127	{
3128	my ($sec,$min,$hour) = localtime(time);
3129	print $fh sprintf("[%02d:%02d:%02d] ",$hour,$min,$sec);
3130	}
3131	print $fh "XML::Stream: @args\n";
3132	}
3133
3134
3135	##############################################################################
3136	#
3137	# nonblock - set the socket to be non-blocking.
3138	#
3139	##############################################################################
3140	sub nonblock
3141	{
3142	my $self = shift;
3143	my $socket = shift;
3144
3145	#--------------------------------------------------------------------------
3146	# Code copied from POE::Wheel::SocketFactory...
3147	# Win32 does things one way...
3148	#--------------------------------------------------------------------------
3149	if ($^O eq "MSWin32")
3150	{
3151	ioctl( $socket, 0x80000000 \| (4 << 16) \| (ord('f') << 8) \| 126, 1) \|\|
3152	croak("Can't make socket nonblocking (win32): $!");
3153	return;
3154	}
3155
3156	#--------------------------------------------------------------------------
3157	# And UNIX does them another
3158	#--------------------------------------------------------------------------
3159	my $flags = fcntl($socket, F_GETFL, 0)
3160	or die "Can't get flags for socket: $!\n";
3161	fcntl($socket, F_SETFL, $flags \| O_NONBLOCK)
3162	or die "Can't make socket nonblocking: $!\n";
3163	}
3164
3165
3166	##############################################################################
3167	#
3168	# printData - debugging function to print out any data structure in an
3169	# organized manner. Very useful for debugging XML::Parser::Tree
3170	# objects. This is a private function that will only exist in
3171	# in the development version.
3172	#
3173	##############################################################################
3174	sub printData
3175	{
3176	print &sprintData(@_);
3177	}
3178
3179
3180	##############################################################################
3181	#
3182	# sprintData - debugging function to build a string out of any data structure
3183	# in an organized manner. Very useful for debugging
3184	# XML::Parser::Tree objects and perl hashes of hashes.
3185	#
3186	# This is a private function.
3187	#
3188	##############################################################################
3189	sub sprintData
3190	{
3191	my ($preString,$data) = @_;
3192
3193	my $outString = "";
3194
3195	if (ref($data) eq "HASH")
3196	{
3197	my $key;
3198	foreach $key (sort { $a cmp $b } keys(%{$data}))
3199	{
3200	if (ref($$data{$key}) eq "")
3201	{
3202	my $value = defined($$data{$key}) ? $$data{$key} : "";
3203	$outString .= $preString."{'$key'} = \"".$value."\";\n";
3204	}
3205	else
3206	{
3207	if (ref($$data{$key}) =~ /Net::Jabber/)
3208	{
3209	$outString .= $preString."{'$key'} = ".ref($$data{$key}).";\n";
3210	}
3211	else
3212	{
3213	$outString .= $preString."{'$key'};\n";
3214	$outString .= &sprintData($preString."{'$key'}->",$$data{$key});
3215	}
3216	}
3217	}
3218	}
3219	else
3220	{
3221	if (ref($data) eq "ARRAY")
3222	{
3223	my $index;
3224	foreach $index (0..$#{$data})
3225	{
3226	if (ref($$data[$index]) eq "")
3227	{
3228	$outString .= $preString."[$index] = \"$$data[$index]\";\n";
3229	}
3230	else
3231	{
3232	if (ref($$data[$index]) =~ /Net::Jabber/)
3233	{
3234	$outString .= $preString."[$index] = ".ref($$data[$index]).";\n";
3235	}
3236	else
3237	{
3238	$outString .= $preString."[$index];\n";
3239	$outString .= &sprintData($preString."[$index]->",$$data[$index]);
3240	}
3241	}
3242	}
3243	}
3244	else
3245	{
3246	if (ref($data) eq "REF")
3247	{
3248	$outString .= &sprintData($preString."->",$$data);
3249	}
3250	else
3251	{
3252	if (ref($data) eq "")
3253	{
3254	$outString .= $preString." = \"$data\";\n";
3255	}
3256	else
3257	{
3258	$outString .= $preString." = ".ref($data).";\n";
3259	}
3260	}
3261	}
3262	}
3263
3264	return $outString;
3265	}
3266
3267
3268	1;

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

Download in other formats: