Jabber::Lite - Standalone library for communicating with Jabber servers.

  use Jabber::Lite;

  my $jlobj = Jabber::Lite->new();

  $jlobj->connect( %args );
  $jlobj->authenticate( %args );
  my $stillgoing = 1;
  while( $stillgoing ){
	my $tval = $jlobj->process();
	if( $tval == 1 ){
		my $curobj = $jlobj->get_latest();

		# Process based on the object.

	}elsif( $tval < 0 ){
		$stillgoing = 0;
	}
  }

	RunProcess - Invoke ->process internally
	ProcessTime - time to pass to ->process (default 0 )

	RunProcess - Invoke ->process internally
	ProcessTime - time to pass to ->process (default 0 )

	-2: Invalid XML was read.

	-1: EOF was reached.

	 0: No action.  Data may or may not have been read.

	 1: A complete object has been read, and is available for
	    retrieval via get_latest().

	 2: A complete object was read, but was eaten 
	    by a defined handler.

	PendingOnly (default 0) - Only process the pending data, do not
	attempt to read from the socket.

	-2 Invalid XML
	0 No errors
	1 Complete object

	-2 if a parsing error was found.
	0 if no obvious bugs were found.
	1 if a complete object was found.

	encode(), decode() and some function names: Jabber::NodeFactory.
	ConstXMLNS(), SASL handling: XML::Stream

###################################################################
# Jabber::Lite
# $Id: Jabber::Lite.pm,v 1.64 2007/01/29 20:44:34 bc Exp bc $
# Copyright (C) 2005-2007 Bruce Campbell <beecee@cpan.zerlargal.org>
# ( For my mail sorting, replace the above 'beecee' with the name
#   of the module, eg 'Jabber::Lite' or 'Jabber-Lite' )
#
# This is a perl library intended to be a small and light implementation
# of Jabber libraries.  Nearly a third of this file is documentation of
# one sort or another.
#
# What you should be able to do with this library:
#	Connect to a Jabber server.
#	Send and receive packets.
#	Create new packets.
#	List attributes on packets.
#	List tags on packets.
#
# This library implements a progressive XML parser within itself; it 
# does not use an seperate parser which your perl installation may not
# be able to install.  
#
# This library is fairly dumb.  It doesn't understand anything other than
# ASCII, and its correctness checks are limited.  Unicode is right out.
# Basically, this is a Jabber library where the most complicated thing
# being dealt with is the base64-encoded stuff in SASL authentication.
#
###########################################################################
#
#

# Do proxy thing as per Matt Sergeant's article:
# http://www.perl.com/pub/a/2002/08/07/proxyobject.html?page=3
# This may reduce some memory usage.

package Jabber::Lite;

use strict;
our $AUTOLOAD;

BEGIN {
	eval "use Scalar::Util qw(weaken);";
	if ($@) {
		$Jabber::Lite::WeakRefs = 0;
	} else {
		$Jabber::Lite::WeakRefs = 1;
	}
}

sub new {
	my $class = shift;
	no strict 'refs';
	my $impl = $class . "::Impl";
	my $this = $impl->new(@_);
	if ($Jabber::Lite::WeakRefs) {
		return $this;
	}
	my $self = \$this;
	return bless $self, $class;
}

sub AUTOLOAD {
	my $method = $AUTOLOAD;
	$method =~ s/.*:://; # strip the package name
	no strict 'refs';
	*{$AUTOLOAD} = sub {
		my $self = shift;
		my $olderror = $@; # store previous exceptions
		my $obj = eval { $$self };
		if ($@) {
			if ($@ =~ /Not a SCALAR reference/) {
				croak("No such method $method in " . ref($self));
			}
			croak $@;
		}
		if ($obj) {
			# make sure $@ propogates if this method call was the 
			# result of losing scope because of a die().
			if ($method =~ /^(DESTROY|del_parent_link)$/) {
				$obj->$method(@_);
				$@ = $olderror if $olderror;
				return;
			}
			return $obj->$method(@_);
		}
	};
	goto &$AUTOLOAD;
}

# sub DESTROY { my $self = shift; warn("Lite::DESTROY $self\n") }

# Now for the actual package.
package Jabber::Lite::Impl;
use constant r_HANDLED => -522201;
use Exporter;

use vars qw/@ISA $VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS/;
@ISA=qw(Exporter);

@EXPORT = qw(r_HANDLED);


%EXPORT_TAGS = (
  'handled' => [qw(r_HANDLED)],
	);

my $con;
push @EXPORT_OK, @$con while (undef, $con) = each %EXPORT_TAGS;

$VERSION = "0.8";

use IO::Socket::INET;
use IO::Select;

sub DESTROY { 
	my $self = shift; 
	# warn("Impl::DESTROY $self\n");

	# Remove references to this instance.  If it is being called
	# manually, may trigger garbage collection of other objects.
	$self->hidetree();

}

sub new {

	my ($class, %args) = @_;
	my $self = {};

	bless $self, $class ;

	$self->init( %args );

	return( $self);

}

sub init {

	my $self = shift;
	my %args = (	readsize => 1500,
			disconnectonmax => 0,
			@_ );

	# First clear the object.
	foreach my $kkey ( keys %{$self} ){
		delete( $self->{"$kkey"} );
	}

	# Then apply any arguments.
	my %validargs = ( "readsize", "1",
			  "debug", "1",
			  "disconnectonmax", "1",
			  "maxobjectsize", "1",
			  "maxnamesize", "1",
			  "maxobjectdepth", "1",
			 );

	# Run through the possible known args, overwriting any that
	# already exist.
	foreach my $kkey( keys %args ){
		next unless( defined( $validargs{"$kkey"} ) );
		$self->{"_$kkey"} = $args{"$kkey"};
	}

	# Clear the handlers.
	%{$self->{'handlers'}} = ();

}

sub resolve {
	my $self = shift;
	my %args = (	Domain => undef,
			Type => 'client',
			Protocol => 'tcp',
			Timeout => 90,
			@_,
			);

	# We just dump it all to bgresolve.
	$self->bgresolve( %args );

	# Loop until we do not have '-1' as the result.  bgresolve takes
	# care of any timeouts.
	my $curresult = $self->bgresolved;
	while( $curresult == -1 ){
		$curresult = $self->bgresolved;

		select( undef, undef, undef, 0.1 );
	}

	return( $curresult );
}
	

sub resolved {
	my $self = shift;

	# Do the ordering of hosts in this function.
	# The results have been stored in a hash: 
	#	$self->{'_resolved'}{'hostname'}
	# Each of these contains another hash, of @'srv' and $'address',
	# amongst others.
	my @list = ();

	# Run through the hosts, and see if any have 'srv' records.  There 
	# should only be one, and it holds indirections to other hosts.
	my $srvrec = undef;
	foreach my $host( keys %{$self->{'_resolved'}} ){
		next unless( defined( $self->{'_resolved'}{$host}{'srv'} ) );
		$srvrec = $host;
	}

	if( ! defined( $srvrec ) ){
		foreach my $host( keys %{$self->{'_resolved'}} ){
			next unless( defined( $self->{'_resolved'}{$host}{'address'} ) );
			next if( $self->{'_resolved'}{$host}{'address'} =~ /^\s*$/ );
			push @list, $self->{'_resolved'}{$host}{'address'};
		}
	}else{
		# Run through the srv listing in order.
		my %uhosts = ();
		foreach my $prio ( sort { $a <=> $b } keys %{$self->{'_resolved'}{$srvrec}{'srv'}} ){
			# Collect all of the weights.
			my %weights = ();
			my $wghtcnt = scalar @{$self->{'_resolved'}{$srvrec}{'srv'}{$prio}};
			my $wghthigh = 0;
			foreach my $wghtrec( @{$self->{'_resolved'}{$srvrec}{'srv'}{$prio}} ){
				next unless( $wghtrec =~ /^\s*(\d+)\s+(\d+)\s+(\S+)\s*$/ );
				my $wghtnum = $1;
				my $port = $2;
				my $host = $3;
				if( $wghtnum > $wghthigh ){
					$wghthigh = $wghtnum;
				}
			}

			# Run through again, now that we know the highest
			# weight.
			my $posmax = 0;
			foreach my $wghtrec( @{$self->{'_resolved'}{$srvrec}{'srv'}{$prio}} ){
				next unless( $wghtrec =~ /^\s*(\d+)\s+(\d+)\s+(\S+)\s*$/ );
				my $wghtnum = $1;
				my $port = $2;
				my $host = $3;

				# Work out a position for this weight, between
				# 0 and $wghtcnt (inclusive).
				my $wghtpos = abs( int( rand( $wghtcnt + 1 ) + ( $wghthigh - $wghtnum ) ) );
				my $trycnt = 0;
				while( defined( $weights{"$wghtpos"} ) && $trycnt < $wghtcnt ){
					$wghtpos = abs( int( rand( $wghtcnt + 1 ) + ( $wghthigh - $wghtnum ) ) );
					$trycnt++;
				}

				# Did the loop exit due to success, or because
				# of too many iterations?
				if( defined( $weights{"$wghtpos"} ) ){
					# Count up until we find one.
					$wghtpos = 0;
					while( defined( $weights{"$wghtpos"} ) ){
						$wghtpos++;
					}
				}

				# Save the port and host.
				$weights{"$wghtpos"} = "$port $host";

				if( $wghtpos > $posmax ){
					$posmax = $wghtpos;
				}	
				# print "Found SRV $srvrec and priority $prio and weight $wghtnum and pos $wghtpos and port $port and host $host\n";
			}

			# Now output the hosts seen in the semi-random
			# order chosen.
			foreach my $weightkey ( sort { $b <= $a } keys %weights ){
				next unless( defined( $weights{"$weightkey"} ) );
				next unless( $weights{"$weightkey"} =~ /^\s*(\d+)\s+(\S+)\s*$/ );
				my $port = $1;
				my $host = $2;
				next unless( defined( $self->{'_resolved'}{$host}{'address'} ) );
				next if( $self->{'_resolved'}{$host}{'address'}  =~ /^\s*$/ );
				# addresses can be multiple!
				foreach my $address( @{$self->{'_resolved'}{$host}{'address'}} ){
					# Only output a given IP and port combination once.
					next if( defined( $uhosts{$port . $address} ) );
					push @list, $address . "," . $port;
					$uhosts{$port . $address}++;
				}
			}
		}
	}
	return( @list );
}

sub bgresolve {
	my $self = shift;
	my %args = (	Domain => undef,
			Type => 'client',
			Protocol => 'tcp',
			Timeout => 90,
			@_,
			);

	my $retval = 0;

	# Wipe out previous resolution records.
	delete( $self->{'_resolved'} );
	delete( $self->{'_queries'} );

	if( ! defined( $args{"Timeout"} ) ){
		$args{"Timeout"} = 90;
	}elsif( $args{"Timeout"} !~ /^\s*\d+\s*$/ ){
		$args{"Timeout"} = 90;
	}elsif( $args{"Timeout"} < 11 ){
		# Try to stop the application from shooting off its own foot.
		$args{"Timeout"} = 11;
	}

	# If we have all of a domain, a type and a protocol, then we can
	# make a query.
	if( defined( $args{"Domain"} ) && defined( $args{"Type"} ) && defined( $args{"Protocol"} ) && $self->_got_Net_DNS() ){
		# Set up the initial query.
		my $res = Net::DNS::Resolver->new();
		$res->retry(2);
		$res->retrans(5);
		$res->tcp_timeout( $args{"Timeout"} - 1 );

		# udp_timeout is effectively the #retries * #retransmissions,
		# which we've set to 2 * 5 == 10.

		# No spaces in $qname.
		$args{"Type"} =~ s/\s*//g;
		$args{"Protocol"} =~ s/\s*//g;
		$args{"Domain"} =~ s/\s*//g;
		my $qname = "_xmpp-" . $args{"Type"} . "._" . $args{"Protocol"} . "." . $args{"Domain"};

		# Make sure the query makes sense.
		if( $qname =~ /^_xmpp-(server|client)\._([^\.]+)\.(\S+)$/i ){

			# Send it.
			my $sock = $res->bgsend( $qname, "SRV", "IN" );

			# Store it.
			my $sname = $args{"Domain"} . ";1";
			$self->{'_queries'}{";;base"} = $args{"Domain"};
			$self->{'_queries'}{";;q1"} = $sname;
			$self->{'_queries'}{";;start"} = time;
			$self->{'_queries'}{";;end"} = $self->{'_queries'}{";;start"} + $args{"Timeout"};
			$self->{'_queries'}{";;res"} = $res;
			$self->{'_queries'}{"$sname"}{"start"} = $self->{'_queries'}{";;start"};
			$self->{'_queries'}{"$sname"}{"sock"} = $sock;
			$self->{'_queries'}{"$sname"}{"qname"} = $qname;
			$self->{'_queries'}{"$sname"}{"qtype"} = "SRV";

			# Increment the return value.
			$retval++;
		}


		# If the query was for a 'server' type, send off a second
		# query for '_jabber._tcp.HOST' in case the first query
		# fails.  This should cut down on the wait time.  This code
		# should be removed when that portion of XMPP-CORE gets
		# relegated to 'do not use'.
		$qname = "_jabber._" . $args{"Protocol"} . "." . $args{"Domain"};
		if( $qname =~ /^_jabber\._([^\.]+)\.(\S+)$/i && $args{"Type"} =~ /^server$/i ){
			# Send it.
			my $sock = $res->bgsend( $qname, "SRV", "IN" );

			# Store it.
			my $sname = $args{"Domain"} . ";2";
			$self->{'_queries'}{";;res"} = $res;
			$self->{'_queries'}{";;q2"} = $sname;
			$self->{'_queries'}{"$sname"}{"start"} = $self->{'_queries'}{";;start"};
			$self->{'_queries'}{"$sname"}{"sock"} = $sock;
			$self->{'_queries'}{"$sname"}{"qname"} = $qname;
			$self->{'_queries'}{"$sname"}{"qtype"} = "SRV";

			# Increment the return value.
			$retval++;
		}

	}

	# Return true or false.
	if( $retval > 0 ){
		return( 1 );
	}else{
		return( 0 );
	}
}

sub bgresolved {
	my $self = shift;

	my $retval = -1;

	# The resolving chain goes something like:
	#	Look up the SRV records for '_xmpp-TYPE._PROTOCOL.HOST' .
	#	If successful: 
	#		look up in turn the A or AAAA records for the
	#		hostnames mentioned in the SRV records.
	#	If unsuccessful and TYPE is 'server':
	#		look up the SRV records for '_jabber._PROTOCOL.HOST'
	#		If successful:
	#			look up in turn the A or AAAA records for
	#			the hostnames mentioned in the SRV records
	#	If unsuccessful so far in looking up SRV records:
	#		look up the A or AAAA records for the 'HOST'
	#
	#	If unsuccessful in resolving hostnames supplied by SRV records:
	#		treat resolution as unsuccessful.

	# _xmpp-client._tcp.example.com.
	# _xmpp-server._tcp.example.com.
	# jabberserverhostname. 86400 A jabberserverip
	# _xmpp-server._tcp.jabberserverhostname. 86400 IN SRV 5 0 5269 jabberserverhostname.
	# _xmpp-client._tcp.jabberserverhostname. 86400 IN SRV 5 0 5222 jabberserverhostname.
	# _jabber._tcp.jabberserverhostname. 86400 IN SRV 5 0 5269 jabberserverhostname.
	# 
	# SRV lookups (RFC2781) say:
	#        Do a lookup for QNAME=_service._protocol.target, QCLASS=IN,
	#        QTYPE=SRV.
	#
	#        If the reply is NOERROR, ANCOUNT>0 and there is at least one
	#        SRV RR which specifies the requested Service and Protocol in
	#        the reply:
	#
	#            If there is precisely one SRV RR, and its Target is "."
	#            (the root domain), abort.


	# Does 'abort' in the above mean 'do not continue with SRV processing,
	# but attempt to resolve the HOST via A or AAAA queries',
	# 'do not continue with processing this QNAME', or 'do not continue
	# with resolving the original HOST' ?  For example, what happens if 
	# _xmpp-server._tcp.HOST fails in this way, but _jabber._tcp.HOST has 
	# usable information in it?  

	# See what the basename is.  Then see if basename;1 has completed.
	my $bname = $self->{'_queries'}{';;base'};
	my $res = $self->{'_queries'}{';;res'};
	my $q1 = $self->{'_queries'}{';;q1'};
	my $q2 = $self->{'_queries'}{';;q2'};
	my $srvcompleted = 0;
	my $srvabort = 0;

	if( defined( $bname ) && defined( $res ) && defined( $q1 ) ){
		# There is a query.  See if we have exceeded our timeout
		# value.
		my $q1pkt = undef;
		my $q2pkt = undef;
		my $colsrv = 0;
		if( $self->{'_queries'}{';;end'} < time ){
			$retval = 0;
		}elsif( ! defined( $self->{'_queries'}{$q1}{'completed'} ) && defined( $self->{'_queries'}{$q1}{'start'} ) ){
			# See if the first query has completed.
			my $q1sock = $self->{'_queries'}{$q1}{'sock'};
			if( $res->bgisready( $q1sock ) ){
				# It is.  Read in the value.
				$q1pkt = $res->bgread( $q1sock );
				$q1sock = undef;
				delete( $self->{'_queries'}{$q1}{'sock'} );
				$self->{'_queries'}{$q1}{'completed'} = time;
				$colsrv++;
			}
		}elsif( defined( $q2 ) && ! defined( $self->{'_queries'}{$q2}{'completed'} ) && defined( $self->{'_queries'}{$q2}{'start'} ) ){
			# There is a second query, which must be collected
			# to avoid memory leakage.
			my $q2sock = $self->{'_queries'}{$q2}{'sock'};
			if( $res->bgisready( $q2sock ) ){
				$q2pkt = $res->bgread( $q2sock );
				$q2sock = undef;
				delete( $self->{'_queries'}{$q2}{'sock'} );
				$self->{'_queries'}{$q2}{'completed'} = time;
				$colsrv++;
			}
		}

		# If the first one was completed, then set a flag for later.
		if( defined( $self->{'_queries'}{$q1}{'completed'} ) && defined( $self->{'_queries'}{$q1}{'start'} ) ){
			$srvcompleted++;
		}

		# If we collected a SRV result this time, then the return
		# value is -1, as we're about to send off another few 
		# queries.
		if( $colsrv ){
			$retval = -1;

			# If we collected the q2 result, check whether the
			# q1 result was successful.  If it was, throw out the
			# q2 result, as its just extra.
			my $wrkpkt = $q1pkt;
			if( defined( $q2pkt ) && defined( $self->{'_queries'}{$q1}{';;success'} ) ){
				$q2pkt = undef;
			}elsif( defined( $q2pkt ) ){
				$wrkpkt = $q2pkt;
			}

			# Did we actually get a packet?  It could be undef
			# if q2pkt was something, but q1 was successful.
			if( defined( $wrkpkt ) ){
				# Take it apart.
				my @answers = $wrkpkt->answer;

				# Count how many there are.
				my $ancount = scalar @answers;

				foreach my $answer( @answers ){
					next unless( $answer->type eq 'SRV' );
					my $prio = $answer->priority;
					my $wght = $answer->weight;
					my $port = $answer->port;
					my $target = $answer->target;

					# If there is just one answer, and
					# the target is '.', then mark this
					# one as failed and continue.
					if( $ancount == 1 && $target eq '.' ){
						# Was this q1?
						if( defined( $q1pkt ) ){
							$self->{'_queries'}{$q1}{'fail'}++;
						}else{
							$self->{'_queries'}{$q2}{'fail'}++;
						}
					}elsif( $prio =~ /^\s*\d+\s*$/ && $wght =~ /^\s*\d+\s*$/ && $port =~ /^\s*\d+\s*$/ && $target =~ /^\S{2,}$/ ){
						my $qname = $self->{'_queries'}{$q1}{'qname'};
						if( defined( $q1pkt ) ){
							# Success.
							$self->{'_queries'}{$q1}{'success'}++;
						}else{
							# Success.
							$self->{'_queries'}{$q1}{'success'}++;
							$qname = $self->{'_queries'}{$q2}{'qname'};
						}

						# Add the result to the 
						# '_resolved' hash as 
						# appropriate.
						push @{$self->{'_resolved'}{$qname}{'srv'}{$prio}}, $answer->weight . " " . $port . " " . $target;

						# Start queries for 'A' and
						# 'AAAA'.  Should these go
						# into the _queries or 
						# _resolved hash ?  _queries,
						# as that gets cleaned out
						# and the keys time gets shorter
						my $sname = $target . ";1";
						if( ! defined( $self->{'_queries'}{$sname} ) ){
							my $sock = $res->bgsend( $target, "IN", "AAAA" );
							$self->{'_queries'}{"$sname"}{"start"} = time;
							$self->{'_queries'}{"$sname"}{"sock"} = $sock;
							$self->{'_queries'}{"$sname"}{"qname"} = $target;
							$self->{'_queries'}{"$sname"}{"qtype"} = "AAAA";
						}
						$sname = $target . ";2";
						if( ! defined( $self->{'_queries'}{$sname} ) ){
							my $sock = $res->bgsend( $target, "IN", "A" );
							$self->{'_queries'}{"$sname"}{"start"} = time;
							$self->{'_queries'}{"$sname"}{"sock"} = $sock;
							$self->{'_queries'}{"$sname"}{"qname"} = $target;
							$self->{'_queries'}{"$sname"}{"qtype"} = "A";
						}
					}
				}
			}
		}else{		# colsrv.
			$retval = -1;
			# Run through the normal queries that we've got, 
			# and see if any came back.
			my %todel = ();
			my $foundcount = 0;
			foreach my $sname ( keys %{$self->{'_queries'}} ){
				next unless( $sname =~ /\;\d+$/ );
				next unless( defined( $self->{'_queries'}{$sname}{'qtype'} ) );
				next unless( $self->{'_queries'}{$sname}{'qtype'} =~ /^(A|AAAA)$/ );
				$foundcount++;
				my $sock = $self->{'_queries'}{"$sname"}{"sock"};
				my $dpkt = undef;
				if( defined( $sock ) ){
					if( $res->bgisready( $sock ) ){
						$dpkt = $res->bgread( $sock );
					}
				}
				# Store the socket again.
				$self->{'_queries'}{"$sname"}{"sock"} = $sock;

				# Run through the packet.
				if( defined( $dpkt ) ){
					$todel{"$sname"}++;
					my @answers = $dpkt->answers;
					foreach my $answer( @answers ){
						next unless( defined( $answer ) );
						next unless( $answer->type =~ /^(a|aaaa)$/i );
						push @{$self->{'_resolved'}{$self->{'_queries'}{"$sname"}{"qname"}}{'address'}}, $answer->address;
					}
				}
			}

			# Run through the queries that have been collected.
			foreach my $delkey( keys %todel ){
				delete( $self->{'_queries'}{$delkey} );
			}

			if( $foundcount == 0 && $srvcompleted == 1 ){
				$retval = 1;
			}
		}
	}

	#
	#            Else, for all such RR's, build a list of (Priority, Weight,
	#            Target) tuples
	#
	#            Sort the list by priority (lowest number first)
	#
	#            Create a new empty list
	#
	#            For each distinct priority level
	#                While there are still elements left at this priority
	#                level
	#                    Select an element as specified above, in the
	#                    description of Weight in "The format of the SRV
	#                    RR" Section, and move it to the tail of the new
	#                    list
	#
	#            For each element in the new list
	#
	#                query the DNS for address records for the Target or
	#                use any such records found in the Additional Data
	#                section of the earlier SRV response.
	#
	#                for each address record found, try to connect to the
	#               (protocol, address, service).
	#
	#        else
	#
	#            Do a lookup for QNAME=target, QCLASS=IN, QTYPE=A
	#
	#            for each address record found, try to connect to the
	#           (protocol, address, service)
	#

}
	

sub connect {
	my $self = shift;

	$self->debug( "connect: Starting up\n" );
	my %args = (	Host => undef,
			Port => 5222,
			Domain => undef,
			UseSSL => 0,		# Initiate SSL right away.
			UseTLS => 1,		# If found a <starttls> tag,
						# take them up on it.
			MustEncrypt => 0,	# Connection must be encrypted
						# before proceeding
			JustConnect => 0,	# Just connect, ok.
			JustConnectAndStream => 0, # Just connect and send the
						# opening <stream:stream> tag.
			AllowRedirect => 1,	# The domain that the server
						# returns must be the same
						# as the domain we supplied.
			StreamXMLNS => $self->ConstXMLNS( "client" ),
			StreamXMLLANG => undef,	# Default language.
			StreamId => undef,	# Client-side Id.  Optional.
			Timeout => 30,		# Various timeouts
			Version => "1.0",	# What version do we support?
			OwnSocket => 0,		# We have our own socket.
			_redo => 0,		# Used internally to renegotiate
						# due to SSL/TLS starting up.
			_connectbg => 0,	# Used internally as handover
						# from bgconnect.
			@_,
			);


	# Only one connection at a time.
	my $cango = 0;
	if( ! $args{"_redo"} ){

		if( ! $self->{"OwnSocket"} ){
			if( defined( $self->socket ) ){
				$self->disconnect();
			}
		}
		
		$self->{'_is_connected'} = undef;
		$self->{'_is_eof'} = undef;

		# Do you grok incomplete tags?  A stream to a Jabber server
		# is completely within a '<stream:stream>' tag, just a very
		# big one.  The problem is that this parser will only return
		# a complete tag, meaning that ordinarily, it would not
		# indicate that it had completed an object until the
		# server disconnected us, supplying the closing
		# '</stream:stream>' text.  By setting a tag name within
		# the '_expect-incomplete' hash, the parser will consider
		# the tag to be complete as soon as it sees a '>' character,
		# and will assume it was '/>' instead.  This makes logging on 
		# work much better.
		$self->{'_expect-incomplete'}{"stream:stream"} = 1;
		$self->debug( "connect: setting up incomplete as " . $self->{'_expect-incomplete'} . " X\n" );

		# Attempt to connect to the host.
		# Background connecting can be done via the tricks
		# shown in Cache::Memcached library, which supports
		# background connections.

		# Alternatively, we can forgo supplying the PeerAddr and
		# PeerPort when creating the socket, and continually
		# invoke the socket's ->connect method until it returns
		# something other than EINPROGRESS.  Thus, we get 
		# TCP connections in the background.  Yay!
		my $socket = undef;
		if( $args{"OwnSocket"} ){
			$socket = $self->socket();
		}else{
			$socket = new IO::Socket::INET ( PeerAddr => $args{"Host"},
						PeerPort => $args{"Port"},
						Proto => "tcp",
						MultiHomed => 1,
						Timeout => $args{"Timeout"},
						Blocking => 0,
						);
		}

		# Were we able to connect; ie, do we have a socket?
		if( defined( $socket ) ){
			$cango = 1;

			$self->{'_is_connected'} = 1;
			$self->{'_is_encrypted'} = undef;
			$self->{'_is_authenticated'} = undef;
			$self->{'_ask_encrypted'} = undef;

			# Save it.  Also sets up the IO::Select construct.
			$self->socket( $socket );
		}

	}elsif( defined( $self->socket() ) ){
		$cango = 1;
	}

	if( $cango ){
		# Start up SSL or TLS as required.
		# Has SSL been requested?
		if( ( $args{"UseSSL"} || $args{"MustEncrypt"} ) && ! $self->_check_val( '_is_encrypted') ){
			# Start SSL.
			my $gotssl = $self->_got_IO_Socket_SSL();

			if( $gotssl ){
				# We have to hand over the socket to the
				# IO::Socket::SSL library for conversion.
				$gotssl = 0;
				my %SSLHash = ();
				foreach my $kkey( keys %args ){
					next unless( $kkey =~ /^SSL/ );
					$SSLHash{"$kkey"} = $args{"$kkey"};
				}

				$self->debug( "connect: Starting up SSL\n" );
				my $newsock = IO::Socket::SSL->start_SSL( $self->socket,
								%SSLHash,
								);
				if( defined( $newsock ) ){
					$self->socket( $newsock );
					$gotssl = 1;
					$self->{'_is_encrypted'} = 1;
					$self->debug( "connect: Successfully started SSL\n" ) ;
				}else{
					$self->debug( "connect: Could not start SSL\n" );
				}
			}

			# If we could not open the ssl libraries or negotiate
			# an SSL connection, see if we consider this a failure.
			if( ! $gotssl && $args{"MustEncrypt"} ){
				$cango = 0;

				# Disconnect.
				# print STDERR "NO SSL AND MUST ENCRYPT!\n";
				$self->abort();
			}
		}
	}

	# Were we asked just to connect?
	if( $args{"JustConnect"} ){
		return( $cango );
	}

	# print STDERR "CONNECT1 HAS $cango\n";

	# Can we still go?  
	if( $cango ){
		# Output the initial tags.
		# RFC3920 11.4 says that implementations SHOULD supply
		# the opening text declaration (xml version/encoding)
		my $xmlobj = $self->newNode( "?xml" );
		$xmlobj->attr( "version", "1.0" );
		$self->send( $xmlobj );

		if( ! defined( $args{"Domain"} ) ){
			$args{"Domain"} = $args{"Host"};
		}

		my $streamobj = $self->newNode( "stream:stream", $args{"StreamXMLNS"} );
		$streamobj->attr( "xmlns:stream", $self->ConstXMLNS( "stream" ) );
		$streamobj->attr( "to", $args{"Domain"} );
		$streamobj->attr( "version", $args{"Version"} );

		if( defined( $args{"StreamXMLLANG"} ) ){
			$streamobj->attr( "xml:lang", $args{"StreamXMLLANG"} );
		}
		if( defined( $args{"StreamId"} ) ){
			$streamobj->attr( "id:lang", $args{"StreamId"} );
		}

		# We must send this object without a closing '/'.
		$cango = $self->send( $streamobj->toStr( GenClose => 0 ) );
	}

	# print STDERR "CONNECT2 HAS $cango\n";

	# Were we asked just to connect and send the initial stream headers?
	if( $args{"JustConnectAndStream"} ){
		return( $cango );
	}

	# We possibly have output the stream header.  Now, we have to wait
	# for a response.  Were we able to write?
	my $robj = undef;
	if( $cango ){
		# Set up the initial handlers.  This makes the whole connection
		# process read much better
		$self->register_handler( '?xml', sub { $self->_connect_handler(@_) }, "connect" );
		$self->register_handler( 'stream:stream', sub { $self->_connect_handler( @_ ) }, "connect" );
		$self->register_handler( 'stream:error', sub { $self->_connect_handler( @_ ) }, "connect" );
		$self->register_handler( 'stream:features', sub { $self->_connect_handler( @_ ) }, "connect" );
		$self->register_handler( 'proceed', sub { $self->_connect_starttls( @_ ) }, "connect" );
		$self->register_handler( 'failure', sub { $self->_connect_starttls( @_ ) }, "connect" );

		# Save the original args.
		%{$self->{'_connectargs'}} = %args;

		# Set some variables.
		$self->{'_is_connected'} = 1;
		$self->{'_is_authenticated'} = undef;
		$self->{'_connect_jid'} = undef;
		$self->{'confirmedns'} = undef;
		$self->{'streamid'} = undef;
		$self->{'streamversion'} = undef;
		$self->{'streamxmlns'} = undef;
		$self->{'streamxml:lang'} = undef;
		$self->{'streamstream:xmlns'} = undef;
		$self->{'stream:error'} = undef;
		$self->{'stream:features'} = undef;

		%{$self->{'authmechs'}} = ();

		# Wait until the connection checker finishes.
		if( ! $args{"_connectbg"} ){
			my $endtime = time + $args{"Timeout"};
			my $stillgoing = 1;
			while( $stillgoing ){
				$stillgoing = 0 if( time > $endtime );
				$self->debug( "connect: invoking bgconnected\n" );
				my $tval = $self->bgconnected( RunProcess => 1 );
				if( $tval >= 0 ){
					$cango = $tval;
					$stillgoing = 0;
				}else{
					select( undef, undef, undef, 0.01 );
				}
			}
		}
	}
	# print STDERR "CONNECT3 HAS $cango\n";

	if( ! $cango ){
		# print STDERR "CONNECT HAS NO CANGO!\n";
		$self->abort();
	}

	$self->debug( "connect: returning $cango\n" );
	return( $cango );
}

sub bgconnect {
	my $self = shift;
	return( $self->connect( @_, "_connectbg" => 1 ) );
}

sub bgconnected {
	my $self = shift;
	my %args = ( RunProcess => 0,
			ProcessTime => 0,
			@_,
			);

	my $retval = -1;

	if( $args{"RunProcess"} ){
		$self->debug( "bgconnected: invoking process\n" );
		my $tval = $self->process( $args{"ProcessTime"} );
		$self->debug( "bgconnected: invoked process - $tval\n" );
		if( $tval == 1 ){
			my $objthrowaway = $self->get_latest();
			$objthrowaway->hidetree;
		}
	}

	$self->debug( "bgconnected: invoked\n" );

	# Test a few variables.
	if( $self->is_eof() ){
		$self->debug( "bgconnected: found eof\n" );
		# print STDERR ( "bgconnected: found eof\n" );
		$retval = 0;
	}elsif( $self->is_connected() > 0 ){
		$retval = 1;
		# If we wanted encryption, did we get encryption?
		if( $self->{'_connectargs'}{"MustEncrypt"} && ! $self->is_encrypted() ){
			$self->debug( "wanted encryption but no encryption\n");
			$retval = -1;

		# Have we asked for encryption to be started?
		}elsif( $self->_check_val( '_ask_encrypted' ) && ! $self->is_encrypted() ){
			$self->debug( " asked for encryption but no encryption\n" );
			$retval = -1;
		}

		# If we have got a reply host?
		if( $retval == 1 && $self->_check_val( "confirmedns" ) ){
			if( ! $self->{'_connectargs'}{"AllowRedirect"} ){
				if( lc( $self->{'confirmedns'} ) ne lc( $self->{'_connectargs'}{"Domain"} ) ){
					$self->debug( " domain mismatch\n" );
					# print STDERR ( "bgconnected: domain mismatch\n" );
					$retval = 0;
				}
			}
		}else{
			$self->debug( " retval is not 1 and we do not have a confirmedns yet\n");
			$retval = -1;
		}

		# All servers MUST provide a stream id value.
		if( $retval == 1 && ! $self->_check_val( 'streamid' ) ){
			$self->debug( " no streamid yet");
			$retval = -1;
		}

		# All 1.x servers MUST provide the stream:features tag.
		if( $retval == 1 && $self->_check_val( 'streamversion' ) ){
			if( $self->{'streamversion'} >= 1.0 && ! $self->_check_val( 'stream:features' ) ){
				$self->debug( " streamversion >= 1.0 but no stream:features yet");
				$retval = -1;
			}
		}

		# When using encryption or compression, it is possible that 
		# the encryption engine has not completely sent out the last 
		# packet that we sent.  Lets kick it.
		if( $retval == -1 ){
			if( ! defined( $self->{'_connecting_prod'} ) ){
				$self->{'_connecting_prod'} = time;
			}elsif( $self->{'_connecting_prod'} < ( time - 5 ) ){
				$self->debug( "prodding the connection" );
				$self->send( "\n" );
				$self->{'_connecting_prod'} = time;
			}
		}
	}else{
		$self->debug( " default set to 0\n");
		# print STDERR ( "bgconnected: default set to 0\n");
		$retval = 0;
	}

	$self->debug( " returning $retval\n");
	return( $retval );
}

sub authenticate {
	my $self = shift;
	my %args = (	Username => undef,
			Password => undef,
			Resource => undef,
			ComponentSecret => undef,
			Domain => $self->{'_connectargs'}{'Domain'},
			Method => undef,
			Mechanism => undef,
			Timeout => 30,
			Idval => rand(65535) . $$ . rand(65536),
			DoBind => 1,
			DoSession => 1,
			AllowRandom => 0,
			_authbg => 0,
			@_,
			);

	my $retval = 0;

	if( ! defined( $args{"Resource"} ) ){
		# set a default value.
		$args{"Resource"} = "Jabber::Lite";
	}

	# See if we should add jabber:iq:auth method, in addition to 
	# what the server supplied.
	if( defined( $args{"Method"} ) ){
		if( $args{"Method"} eq "jabber:iq:auth" ){
			$self->{'authmechs'}{"jabber:iq:auth"} = "1";
		}
	}

	# This sets up a number of handlers to perform the authentication.
	# Set up the initial behaviour.
	$self->{'_ask_handshake'} = undef;
	$self->{'_got_handshake'} = undef;
	$self->{'_ask_iq_auth'} = undef;
	$self->{'_got_iq_auth'} = undef;
	$self->{'_started_auth'} = undef;
	$self->{'_done_auth_sasl'} = undef;
	$self->{'_auth_failed'} = undef;
	$self->{'_auth_finished'} = undef;
	$self->{'saslclient'} = undef;

	# Store the orginal arguments.  bgconnected wipes these when
	# it returns success or failure to avoid leakage.
	%{$self->{'_authenticateargs'}} = %args;

	# Prime listauths to send the initial packet asking for authentication
	# methods, if jabber:iq:auth is one of the options, and we haven't
	# been explicitly constrained to use sasl.  Yes, this does mean that
	# we might send an unneeded packet, but we don't care.
	my $doask = 1;
	if( defined( $args{"Method"} ) ){
		if( $args{"Method"} eq "sasl" ){
			$doask = 0;
		}
	}

	# Do not ask the question if we're authenticating as a 
	# component.
	if( defined( $args{"ComponentSecret"} ) && $self->_check_val( 'streamxmlns' ) ){
		# Make sure the server is expecting a component connection.
		if( $self->{'streamxmlns'} eq $self->ConstXMLNS( 'component' ) ){
			$doask = 0;
			# Request component authorisation.
			$self->{'_ask_handshake'} = time;
		}
	}

	# Ask away.
	if( $doask ){
		# print STDERR "AUTHENTICATE IS ASKING FOR AUTHS\n";
		$self->listauths( Want => 'dontcare', Username => $args{"Username"}, JustAsk => 1 );

		# If we did ask, set up a handler for the response.
		if( $self->_check_val( '_ask_iq_auth' ) ){
			$self->debug( "Asked for auths, setting up handler" );
			# print STDERR ( "Asked for auths, setting up handler" );
			$self->register_handler( "iq", sub { $self->_listauths_handler( @_ ) }, "authenticate" );
		}
	}

	# Exit if we've been told to.  Client will invoke bgauthenticated
	# themselves.
	if( $self->{'_authbg'} ){
		$self->debug( "client to execute bgauthenticated\n");
		return( -1 );
	}

	# Wait for bgauthenticate to do its work.
	my $stillgoing = 1;
	my $endtime = time + $args{"Timeout"};
	while( $stillgoing ){
		$stillgoing = 0 if( time > $endtime );

		$self->debug( "looping on bgauthenticated\n");
		my $tval = $self->bgauthenticated( RunProcess => 1 );

		if( $tval == 0 ){
			$stillgoing = 0;
			# print STDERR "BGAUTHENTICATED RETURNED 0!\n";
			$retval = 0;
		}elsif( $tval == 1 ){
			$stillgoing = 0;
			$retval = 1;
			$self->{'_is_authenticated'}++;
		}else{
			select( undef, undef, undef, 0.01 );
		}
	}

	return( $retval );
}
			

sub bgauthenticate {
	my $self = shift;
	return( $self->authenticate( @_, "_authbg" => 1 ) );
}

sub bgauthenticated {
	my $self = shift;
	my %args = ( RunProcess => 0,
			ProcessTime => 0,
			@_,
			);

	my $retval = 1;

	my $authas = "client";

	if( $args{"RunProcess"} ){
		$self->debug( "invoking process\n");
		my $tval = $self->process( $args{"ProcessTime"} );
		$self->debug( "invoked process - $tval\n");
		if( $tval == 1 ){
			my $objthrowaway = $self->get_latest();
			$objthrowaway->hidetree;
		}elsif( $tval < 0 ){
			# print STDERR "BGAUTHENTICATED GOT $tval FROM process\n";
			$retval = 0;
		}
	}

	# Start considering the options.  Client authentication.
	my %availableauths = ();
	if( $self->_check_val( '_ask_iq_auth' ) ){
		if( ! $self->_check_val( '_got_iq_auth' ) ){
			$retval = -1;
		}
	}

	# Component checking.
	if( $retval && $self->_check_val( '_ask_handshake' ) ){
		$authas = "component";
		if( ! $self->_check_val( '_started_auth' ) ){
			$self->{'_started_auth'} = time;

			# This is JEP 114 stuff.
			my $handshake = $self->newNode( 'handshake' );
			my $gotdsha1 = $self->_got_Digest_SHA1();
			if( $gotdsha1 ){
				$handshake->data( lc( Digest::SHA1::sha1_hex( $self->{'streamid'} . $self->{'_authenticateargs'}{'ComponentSecret'} ) ) );
			}
			$self->send( $handshake );
			$self->register_handler( "handshake", sub { $self->_bgauthenticated_handler( @_ ) }, "authenticate" );
		}

		if( $self->_check_val( '_got_handshake' ) ){
			# XXXX - This is possibly incorrect.  
			# print STDERR "bgauthenticated: _got_handshake set, setting _auth_finished and retval to 1\n";
			$self->{'_auth_finished'} = 1;
			$retval = 1;
		}elsif( $self->_check_val( 'stream:error' ) ){
			$self->{'_auth_finished'} = 0;
			# If the wrong secret was supplied, then we disconnect.
			$self->debug( "GOT stream:error" );
			$retval = 0;
		}else{
			$retval = -1;
		}
	}

	if( $retval == 1 && ! $self->_check_val( '_started_auth' ) ){
		%availableauths = $self->listauths( Want => 'hash' );

		my $chosenauth = undef;
		my %rauths = ();
		my $somesasl = 0;

		# Strain out the auths that are not suitable.
		foreach my $kkey( keys %availableauths ){
			my $tkey = lc( $kkey );
			$self->debug( " Found auth $kkey\n");
			# print STDERR ( " Found auth $kkey\n");

			my $jiqauth = 0;

			if( defined( $self->{'_authenticateargs'}{"Method"} ) ){
				my $mtest = lc( $self->{'_authenticateargs'}{"Method"} );
				next unless( $kkey =~ /^$mtest\-/ );

				$jiqauth = 1 if( $kkey eq "jabber:iq:auth" );
			}

			if( defined( $self->{'_authenticateargs'}{"Mechanism"} ) ){
				my $mtest = lc( $self->{'_authenticateargs'}{"Mechanism"} );

				# Remap the name if preferring jabber:iq:auth
				# TODO 0.9 - Check this logic.
				# if( $jiqauth ){
					# $mtest = "token" if( $mtest eq "anonymous" );
					# $mtest = "digest" if( $mtest eq "digest-md5" );
					# $mtest = "password" if( $mtest eq "plain" );
# 
				# }
				next unless( $kkey =~ /^[^\-\]\-$mtest$/ );
			}

			# Bypass the 'sequence' tag; we catch the 'token' tag 
			# instead.
			next if( $tkey =~ /^jabber:iq:auth\-sequence$/i );

			# Get a score for the auth.
			$rauths{lc($tkey)}++;

			# print STDERR " Using $tkey?\n";

			if( $tkey =~ /^sasl\-/ ){
				$somesasl++;
			}
		}

		# Prepare possible packets to send.
		my $saslxmlns = $self->ConstXMLNS( "xmpp-sasl" );
		my $saslpkt = $self->newNode( "auth", $saslxmlns );

		my $idval = rand(65535) . $$ . rand(65536);
		my $iqpkt = $self->newNode( "iq" );
		$iqpkt->attr( 'type', 'set' );
		$iqpkt->attr( 'to', $self->{'_authenticateargs'}{"Domain"} );
		$iqpkt->attr( 'id', $idval );
		my $querytag = $iqpkt->insertTag( 'query', "jabber:iq:auth" );
		my $utag = $querytag->insertTag( 'username' );
		$utag->data( $self->{'_authenticateargs'}{"Username"} );
		my $rtag = $querytag->insertTag( 'resource' );
		$rtag->data( $self->{'_authenticateargs'}{"Resource"} );

		# See what libraries have been installed.  Try to load
		# both Digest::SHA1 and Authen::SASL.  If we can't load
		# Authen::SASL, then we fall back on Digest::SHA1, then
		# to plain, if we haven't eliminated it by a supplied
		# Method or Mechanism, and the server has provided
		# the 'plain' mechanism.  Phew.
		my $gotdsha1 = $self->_got_Digest_SHA1();
		my $gotasasl = $self->_got_Authen_SASL();
		my $gotmba64 = $self->_got_MIME_Base64();

		# Run through the auths known or approved.
		my $sendsasl = 0;
		my $sasl = undef;
		my $sendiq = 0;
		my $usedauth = undef;

		# We let Authen::SASL do the work.
		if( $somesasl && $gotasasl && $gotmba64 ){
			my @mechs = ();
			foreach my $kkey( keys %rauths ){
				next unless( $kkey =~ /^sasl\-(\S+)$/i );
				push @mechs, uc( $1 );
			}

			# Set up the Authen::SASL handle.  Copied from
			# XML::Stream
			$sasl = Authen::SASL->new( mechanism => join( " ", @mechs ),
						   callback => {
							authname => $self->{'_authenticateargs'}{"Username"} . "@" . $self->{'_authenticateargs'}{"Domain"},
							user => $self->{'_authenticateargs'}{"Username"},
							pass => $self->{'_authenticateargs'}{"Password"},
							},
						);
			$self->{'_saslclient'} = $sasl->client_new();

			my $first_step = $self->{'_saslclient'}->client_start();
			my $first_step64 = MIME::Base64::encode_base64( $first_step, "" );
			$saslpkt->attr( 'mechanism', $self->{'_saslclient'}->mechanism() );
			$saslpkt->data( $first_step64 );

			$sendsasl++;

		}elsif( defined( $rauths{"jabber:iq:auth-token"} ) && $gotdsha1 && 1 == 2 ){
			# zero knowledge.  We snarf the original values.
			# Copied from Jabber::Connection.  This code does not 
			# work against my server, so is disabled.
			$sendiq++;
			$usedauth = "jabber:iq:auth-zerok";
			my $htag = $querytag->insertTag( 'hash' );
			my $hval = DIGEST::SHA1::sha1_hex( $self->{'Password'} );
			my $seq = $availableauths{"jabber:iq:auth-sequence"};
			my $token = $availableauths{"jabber:iq:auth-token"};
			$self->debug( " Got seq of $seq and $token X\n");
			$hval = Digest::SHA1::sha1_hex( $hval . $token );
			# Aie! Keep hashing until sequence decremented to 0??
			$hval = Digest::SHA1::sha1_hex( $hval ) while( $seq-- );
			$htag->data( $hval );

		}elsif( defined( $rauths{"jabber:iq:auth-digest"} ) && $gotdsha1 ){
			# digest
			$sendiq++;
			$usedauth = "jabber:iq:auth-digest";
			my $dtag = $querytag->insertTag( 'digest' );
			$dtag->data( Digest::SHA1::sha1_hex( $self->{'streamid'} . $self->{'_authenticateargs'}{"Password"} ) );
		}elsif( defined( $rauths{"jabber:iq:auth-password"} ) ){
			# plain password.
			$sendiq++;
			$usedauth = "jabber:iq:auth-plain";
			my $ptag = $querytag->insertTag( 'password' );
			$ptag->data( $self->{'_authenticateargs'}{"Password"} );
		}

		if( $sendsasl ){		
			$self->debug( "bgauthenticate: Sending sasl packet: " . $saslpkt->toStr . "\n" ) if( $self->_check_val( '_debug' ) );
			$self->send( $saslpkt );
			$self->{'_started_auth'} = "sasl";
			$retval = -1;
			$self->register_handler( "failure", sub { $self->_bgauthenticated_handler( @_ ) }, "authenticate" );
			$self->register_handler( "success", sub { $self->_bgauthenticated_handler( @_ ) }, "authenticate" );
			$self->register_handler( "challenge", sub { $self->_bgauthenticated_handler( @_ ) }, "authenticate" );

		}elsif( $sendiq ){
			$self->debug( "bgauthenticate: Sending iq packet: " . $iqpkt->toStr . "\n" ) if( $self->_check_val( '_debug' ) );
			# print STDERR "Sending " . $iqpkt->toStr . "\n";
			$self->send( $iqpkt );
			$self->{'_started_auth'} = "iq-auth";

			# Say that we attempted authentication.
			$self->{'_sent_iq_auth'} = $idval;
			$retval = -1;

			# Set up a handler for this.
			$self->register_handler( "iq", sub { $self->_bgauthenticated_handler( @_ ) }, "authenticate" );
		}else{
			# We haven't been able to choose an authentication method.
			$self->debug( "INDECISIVE RE AUTH METHODS" );
			$retval = 0;
		}

	}elsif( $retval == 1 && $self->_check_val( '_started_auth' ) && $self->_check_val( "_sent_iq_auth" ) && $authas eq "client" ){
		# See if the value is set.

		if( $retval == 1 && $self->_check_val( '_auth_finished' ) ){
			$retval = $self->{'_auth_finished'};

		}

	}elsif( $retval == 1 && $self->_check_val( '_started_auth' ) && $authas eq "client" && ! $self->_check_val( '_auth_failed' ) ){

		# Check to see if we are waiting on the server to
		# reissue the <stream:stream> tag.
		if( $self->_check_val( '_need_auth_stream' ) ){
			if( $self->bgconnected != 1 ){
				$self->debug( "Waiting on auth stream" );
				$retval = -1;
			}
		}

		# Now, check to see if we need to set up resource binding.
		# if( $retval == 1 && ! $self->_check_val( '_need_auth_bind' ) && ! $self->_check_val( '_auth_finished' ) ){
		if( $retval == 1 && ! $self->_check_val( '_need_auth_bind' ) ){
			# Do we need to do the binding?
			if( $self->{'_authenticateargs'}{"DoBind"} ){
				$retval = $self->bind( Process => "if-required", Resource => $self->{'_authenticateargs'}{"Resource"}, AllowRandom => $self->{'_authenticateargs'}{"RandomResource"}, _bindbg => 1 );
			}else{
				$self->{'_done_auth_bind'} = 1;
			}
			$self->debug("Waiting on bind result" );
			$retval = -1;
		}elsif( $retval == 1 && $self->_check_val( '_need_auth_bind' ) && ! $self->_check_val( '_done_auth_bind' ) ){
			# Have we got the results from the bind back?
			$retval = -1;
			$self->debug( " checking result of bgbinded\n");
			if( $self->bgbinded() == 1 ){
				$retval = 1;
			}
		}

		# How about sessions?
		$self->debug( "About to check on session? retval is $retval, _need_auth_session is " . $self->_check_val( '_need_auth_session' ) . ", _auth_finished is " . $self->_check_val( '_auth_finished' ) . " E " );
		# if( $retval == 1 && ! $self->_check_val( '_need_auth_session' ) && ! $self->_check_val( '_auth_finished' ) ){
		if( $retval == 1 && ! $self->_check_val( '_need_auth_session' ) ){
			# Do we need to do the binding?
			$self->debug( " need session?" );
			if( $self->{'_authenticateargs'}{"DoSession"} ){
				$retval = $self->session( Process => "if-required", _sessionbg => 1 );
			}else{
				$self->{'_done_auth_session'} = 1;
			}
			$self->debug("Waiting on session result" );
			$retval = -1;
		# }elsif( $retval == 1 && $self->_check_val( '_need_auth_session' ) && ! $self->_check_val( '_auth_finished' ) ){
		}elsif( $retval == 1 && $self->_check_val( '_need_auth_session' ) ){
			# Have we got the results from the bind back?
			$retval = -1;
			$self->debug( " checking result of bgsessioned\n");
			if( $self->bgsessioned() == 1 ){
				$retval = 1;
			}
		}

		if( $retval == 1 && $self->_check_val( '_auth_finished' ) ){
			$retval = $self->{'_auth_finished'};

			# Make sure we record that we were authenticated.
			if( $retval > 0 ){
				$self->{'_is_authenticated'} = 1;
			}

		}elsif( ! $self->_check_val( '_auth_finished' ) ){
			# print STDERR "BGAUTHENTICATED IS UNKNOWN\n";
			$self->debug( "unknown condition - retval is 1 but _auth_finished is not set" );
			$retval = -1;
		}
	}elsif( $retval == 1 && $self->_check_val( '_started_auth' ) && $authas eq "client" && $self->_check_val( '_auth_failed' ) ){
		$retval = 0;
		$self->{'_is_authenticated'} = undef;
	}

	if( $retval >= 0 ){
		# Success or failure.  

		# Set the connect jid if required.
		if( $retval > 0 && ! defined( $self->{'_connect_jid'} ) ){
			# Save the connect_jid.
			$self->{'_connect_jid'} = $self->{'_authenticateargs'}{'Username'} . "@" . $self->{'_authenticateargs'}{"Domain"};
			if( defined( $self->{'_authenticateargs'}{"Resource"} ) ){
				$self->{'_connect_jid'} .= "/" . $self->{'_authenticateargs'}{"Resource"};
			}
		}

		# Delete the authenticate args
		delete( $self->{'_authenticateargs'} );
	}

	$self->debug( "Returning with $retval" );
	return( $retval );
}

sub _bgauthenticated_handler {
	my $self = shift;
	my $node = shift;
	my $persisdata = shift;

	my $retval = undef;

	$self->debug( "invoked\n" );
	my $sendtype = $self->{'_started_auth'};

	if( defined( $node ) && defined( $sendtype ) ){
		my $saslxmlns = $self->ConstXMLNS( 'xmpp-sasl' );

		if( $node->name eq 'handshake' ){
			# Handshake is empty if all good.
			if( $self->_check_val( '_ask_handshake' ) ){
				$self->{'_got_handshake'} = time;
				$retval = r_HANDLED;
			}
			$self->debug( "got " . $node->toStr . " X \n" ) if( $self->_check_val( '_debug' ) );
		}elsif( $sendtype eq "iq-auth" && $node->name eq 'iq' ){
			my $idval = $self->{'_sent_iq_auth'};
			$self->debug( "got back iq result - want $idval" );
			# print STDERR ( "got back iq result (" . $node->attr('id') . ") - want $idval " . $node->toStr . "\n" );
			if( defined( $idval ) ){
				if( $node->attr('id') eq $idval ){
					$retval = r_HANDLED;
					if( $node->attr('type') eq 'result' ){
# XXXX - check for error here??
						$self->debug( "got back iq result - auth successful?" );
						$self->{'_auth_finished'} = 1;
						$self->{'_connect_jid'} = $self->{'_authenticateargs'}{'Username'} . "@" . $self->{'_authenticateargs'}{"Domain"};
						if( defined( $self->{'_authenticateargs'}{"Resource"} ) ){
							$self->{'_connect_jid'} .= "/" . $self->{'_authenticateargs'}{"Resource"};
						}
					}else{
						# Not successful.
						$self->debug( "got back iq something, auth not successful." );
						$self->{'_auth_finished'} = 0;
						$self->{'_auth_failed'} = 1;
					}
				}
			}

			# No?  Maybe its the next step in the sasl 
			# authentication.
		}elsif( $sendtype eq "sasl" ){
			if( ( $node->name eq 'failure' || $node->name eq 'abort' ) && $node->xmlns() eq $saslxmlns ){
				# Failed to authenticate.  Return 0 to
				# the caller; note that the connection
				# is still in place (RFC3920 6.2).
				# 'abort' is slightly odd here, in that
				# we are the initiating entity, but
				# just in case we're talking to some
				# braindead server...
				$self->{'_auth_finished'} = 0;
				$self->{'_done_auth_sasl'} = 1;
				$self->{'_auth_failed'} = 1;
				$retval = r_HANDLED;
			}elsif( $node->name eq 'success' && $node->xmlns() eq $saslxmlns ){
				# We've succeeded.
				$self->{'_auth_finished'} = 1;
				$self->{'_done_auth_sasl'} = 1;
				$self->{'_auth_failed'} = undef;
				$retval = r_HANDLED;

				# We need to resend the initial 
				# '<stream:stream>' header (RFC3920 6.2) again.
				# If we've done SSL, that means that we'll have
				# done 3 so far.  We re-use bgconnected to test
				# for the appearance of the <stream:features> 
				# tag again;  Remember that those connect 
				# handlers are still set up.
				$self->{'stream:features'} = undef;

				# Implementation bug: Missing the domain 
				# ('to') from the <stream:stream> tag after 
				# successful SASL authentication results in 
				# jabberd2's c2s component dying.  
				$self->connect( '_redo' => 1, JustConnectAndStream => 1, Domain => $self->{'_authenticateargs'}{"Domain"} );
				$self->{'_need_auth_stream'} = 1;

			}elsif( $node->name eq 'challenge' && $node->xmlns() eq $saslxmlns ){
				$retval = r_HANDLED;
				my $ctext64 = $node->data();
				my $ctext = MIME::Base64::decode_base64( $ctext64 );
				my $rtext = "";
				# XML::Stream notes that a challenge
				# containing 'rspauth=' is essentially
				# a no-op; we've successfully authed.
				# Authen::SASL whinges about it though.
				if( $ctext !~ /rspauth\=/ ){
					$rtext = $self->{'_saslclient'}->client_step( $ctext );
				}
				my $rtext64 = MIME::Base64::encode_base64( $rtext , "" );
				my $saslpkt = $self->newNode( 'response', $saslxmlns );
				$saslpkt->data( $rtext64 );
				$self->send( $saslpkt );
			}
		}
	}

	return( $retval );
}

sub auth {
	my $self = shift;
	my $username = shift;
	my $password = shift;
	my $resource = shift;

	my $retval = 0;

	if( ! defined( $password ) ){
		$retval = $self->authenticate( ComponentSecret => $username );
	}else{
		$retval = $self->authenticate(	Username => $username,
						Password => $password,
						Resource => $resource,
						);
	}

	return( $retval );
}

sub AuthSend {
	my $self = shift;
	my %args = (	username => undef,
			password => undef,
			resource => undef,
			secret => undef,
			@_,
			);

	my $retval = "not ok";
	my $retmsg = "Reason unknown";

	my $tval = $self->authenticate(	Username => $args{"username"},
					Password => $args{"password"},
					Resource => $args{"resource"},
					ComponenetSecret => $args{"secret"},
					);

	if( $tval == 1 ){
		$retval = "ok";
		$retmsg = "authentication successful, happy jabbering";
	}elsif( $tval == 0 ){
		$retval = "not ok";
		$retmsg = "authenticate returned 0";
	}

	return( $retval, $retmsg );
}

sub stream_features {
	my $self = shift;

	return( $self->{'stream:features'} );
}

# This method gets called by ->authenticate, and is mainly useful
# for finding out jabber:iq:auth methods.
sub listauths {
	my $self = shift;
	my %args = ( Username => undef,
			Domain => $self->{'_connectargs'}{'Domain'},
			Ask => 0,		# Whether to ask the server.
			JustAsk => 0,		# Used by ->authenticate.
			Want => 'hash',		# The return type.
			Timeout => 30,		# How long to wait for
						# a valid answer.
			_internalvar => 0,	# Preparation to doing
						# a handler-based method.
			HaveAsked => 0,		# This is not used yet.
			Idval => rand(65535) . $$ . rand(65536),
			@_,
			);

	my @retarr = ();
	my %rethash = ();
	my %retint = ();

	# Run through the listings that we have cached.  If we have
	# a Username, and 'jabber:iq:auth' is in the listing, set up
	# a handler and send off a question.
	my $stillgoing = 1;
	my $havesent = $args{"HaveAsked"};
	my $gotans = 0;

	# Work out a random identifier if required.
	my $idval = $args{"Idval"};
	my $endtime = time + $args{"Timeout"};
	my $deliqauth = 0;
	while( $stillgoing && time < $endtime ){
		$stillgoing = 0;
		foreach my $thisauth ( keys %{$self->{'authmechs'}} ){
			$self->debug( " Found auth $thisauth\n" );
			if( $thisauth eq 'jabber:iq:auth' ){
				if( ( $args{"Ask"} || $args{"JustAsk"} ) && ! $havesent ){
					# Send off the query.
					my $sendpkt = $self->newNode( "iq" );
					$sendpkt->attr( 'type', 'get' );
					$sendpkt->attr( 'id', $idval );
					$sendpkt->attr( 'to', $args{"Domain"} );
					my $querytag = $sendpkt->insertTag( 'query', 'jabber:iq:auth' );
					if( defined( $args{"Username"} ) ){
						my $utag = $querytag->insertTag( 'username' );
						$utag->data( $args{"Username"} );
					}
					$self->{'_ask_iq_auth'} = $idval;
					$self->debug( "Asking about authentication methods" );
					$havesent = $self->send( $sendpkt );
					$stillgoing = 1 if( ! $self->{"JustAsk"} );
					$self->{'_authask'} = $idval;
				}elsif( $args{"Ask"} && $havesent && ! $gotans ){
					$stillgoing = 1;

					# Invoke ->process to see if we got 
					# something.

					# XXXX This is the only place we
					# collect an object directly during the
					# authentication process, and thats
					# only if 'JustAsk' is not specified.
					$self->debug( "looping for result\n");
					my $tval = $self->process( 1 );
					my $tobj = undef;
					my $querytag = undef;
					if( $tval == 1 ){
						$tobj = $self->get_latest();
					}

					# We hand the processing off to the
					# normal handler function for this
					# packet type manually.  This is only 
					# relevant if 'Ask' is specified.
					if( defined( $tobj ) ){
						my $tval = $self->_listauths_handler( $tobj, undef );
						if( defined( $tval ) ){
							if( $tval eq r_HANDLED ){
								$gotans++;
								$deliqauth++;
							}
						}
						$tobj->hidetree;
					}
				}
			}else{
				$rethash{"$thisauth"} = $self->{"authmechs"}{"$thisauth"};
			}
		}
	}

	# Delete the 'jabber:iq:auth' string from the available authentication
	# mechanisms, to avoid retriggering the same query/response pattern 
	# if this is used later.  Would probably screw something up then.
	if( $deliqauth ){
		delete( $self->{'authmechs'}{'jabber:iq:auth'} );
	}

	# Find out if an @array is wanted in response.
	if( $args{"Want"} eq "array" ){
		foreach my $thisauth( keys %rethash ){
			$self->debug( " Array? Sending back $thisauth as " . $rethash{"$thisauth"} . " X \n" );
			push @retarr, $thisauth;
		}
		return( @retarr );
	}elsif( $args{"Want"} eq "hash" ){
		foreach my $thisauth( keys %rethash ){
			$self->debug( " Hash? Sending back $thisauth as " . $rethash{"$thisauth"} . " X \n" );
		}
		return( %rethash );
	}
}

sub _listauths_handler {
	my $self = shift;
	my $node = shift;
	my $persisdata = shift;
	my $retval = undef;
	my $gotans = 0;

	$self->debug( "invoked\n" );
	my $idval = $self->{'_ask_iq_auth'};
	if( defined( $node ) && defined( $idval ) ){
		my $querytag = undef;
		if( $node->name() eq 'iq' && $node->attr('id') eq $idval ){
			if( $node->attr( 'type' ) eq 'result' ){
				# Get the query tag.
				$querytag = $node->getTag( 'query', 'jabber:iq:auth' );
				$gotans++;
			}elsif( $node->attr( 'type' ) eq 'error' ){
				# Don't we need to set something for negative?
				$self->{'_got_iq_auth'} = time;
				$retval = r_HANDLED;
			}
		}

		# Run through the list that we
		# received in response.
		if( defined( $querytag ) ){
			$retval = r_HANDLED;
			foreach my $cnode( $querytag->getChildren() ){
				$self->debug( "Received back " . $cnode->name . "\n" );
				next if( lc($cnode->name) =~ /^(username|resource)$/i );
				$self->{"authmechs"}{"jabber:iq:auth-" . lc( $cnode->name() )}++;
				# Special case.
				if( lc($cnode->name) =~ /^(token|sequence)$/i ){
					$self->{"authmechs"}{"jabber:iq:auth-" . lc( $cnode->name() )} = $cnode->data();
				}
				# $deliqauth++;
				$self->{'_got_iq_auth'} = time;
			}
		}
	}
	return( $retval );
}

sub session {
	my $self = shift;
	my %args = (	Process => "if-required",
			Timeout => 60,
			_sessionbg => 0,
			@_,
			);

	my $retval = 0;

	# See if we have to do this.
	my $doso = 0;
	if( $args{"Process"} eq "if-required" ){
		my $stag = $self->stream_features();
		if( defined( $stag ) ){
			my $btag = $stag->getTag( "session", $self->ConstXMLNS( "xmpp-session" ) );
			if( defined( $btag ) ){
				# We got the tag.  We must do this.
				$doso = 1;
			}
		}
	}elsif( $args{"Process"} eq "always" ){
		# We don't care.
		$doso = 1;
	}

	# Do we get to go? 
	my $stillgoing = 0;
	if( $doso ){

		# Send the initial packet.
		my $idval = rand(65535 . time );
		my $iqpkt = $self->newNode( 'iq' );
		$iqpkt->attr( 'id', $idval );
		$iqpkt->attr( 'type', 'set' );
		$iqpkt->attr( 'to', $self->{'_authenticateargs'}{"Domain"} );
		my $bindtag = $iqpkt->insertTag( 'session', $self->ConstXMLNS( 'xmpp-session' ) );

		$self->{'_need_auth_session'} = $idval;
		$self->{'_done_auth_session'} = undef;
		$stillgoing = $self->send( $iqpkt );
		$self->register_handler( 'iq', sub { $self->_session_handler(@_) }, "authenticate" );
		%{$self->{'_sessionargs'}} = %args;
	}

	if( $doso && $stillgoing ){
		if( ! $args{"_sessionbg"} ){
			my $endtime = time + $args{"Timeout"};

			while( $stillgoing ){
				$stillgoing = 0 if( time > $endtime );
				my $tval = $self->bgsessioned( RunProcess => 1 );
				if( $tval >= 0 ){
					$stillgoing = 0;
					$retval = $tval;
				}
			}
		}else{
			$retval = -1;
		}
	}

	return( $retval );
}

sub bgsessioned {
	my $self = shift;
	my %args = ( RunProcess => 0,
			ProcessTime => 0,
			@_,
			);

	my $retval = -1;

	if( $args{"RunProcess"} ){
		$self->debug( " invoking process\n" );
		my $tval = $self->process( $args{"ProcessTime"} );
		$self->debug( " invoked process - $tval\n" );
		if( $tval == 1 ){
			my $objthrowaway = $self->get_latest();
			$objthrowaway->hidetree;
		}
	}

	if( $self->_check_val( '_done_auth_session' ) ){
		$retval = $self->{'_done_auth_session'};
	}
	return( $retval );
}

sub _session_handler {
	my $self = shift;
	my $node = shift;
	my $persisdata = shift;

	$self->debug( "invoked\n" );
	my $retval = undef;
	my $idval = $self->{'_need_auth_session'};

	if( defined( $node ) && defined( $idval ) ){
		if( $node->name() eq 'iq' ){
			if( $node->attr( 'id' ) eq $idval ){
				$retval = r_HANDLED;
				$self->{'_done_auth_session'} = 1;

				# XXXX This needs fixing up.
				if( $node->attr( 'type' ) eq 'result' ){
					# Search for the session and jid tag.
					my $btag = $node->getTag( "session", $self->ConstXMLNS( "xmpp-session" ) );
					if( defined( $btag ) ){
						# Finished.
					}
				}elsif( $node->attr( 'type' ) eq 'error' ){
					# What error?
					my $etag = $node->getTag( "error" );
					if( defined( $etag ) ){
						my $notallowed = $etag->getTag( 'not-allowed' );
						my $conflict = $etag->getTag( 'conflict' );
						my $badreq = $etag->getTag( 'bad-request' );
						if( ( $etag->type eq 'modify' && defined( $badreq ) ) || ( $etag->type eq 'cancel' && defined( $conflict ) ) ){
						}elsif( $etag->type eq 'cancel' ){
							# Foo.
						}
					}
				}
			}
		}
	}

	# Mild cleanup.
	if( $retval == 1 ){
		delete( $self->{'_sessionargs'} );
	}

	return( $retval );
}