view release on metacpan or  search on metacpan

lib/Jabber/Lite.pm  view on Meta::CPAN

	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 );
}

=head2 bgresolve

As per ->resolve, but submit in the background.  This returns 1 if the query
could be submitted, and 0 if not.
( Actually, ->resolve is simply a wrapper around ->bgresolve and ->bgresolved )

=cut

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'} );