libdb/test/tcl_utils/common_test_utils.tcl

# See the file LICENSE for redistribution information.
#
# Copyright (c) 2012, 2012 Oracle and/or its affiliates.  All rights reserved.
#
# $Id$
#
# Utility functions for tests in Core and SQL

# Return a list of TCP port numbers that are not currently in use on
# the local system.  Note that this doesn't actually reserve the
# ports, so it's possible that by the time the caller tries to use
# them, another process could have taken one of them.  But for our
# purposes that's unlikely enough that this is still useful: it's
# still better than trying to find hard-coded port numbers that will
# always be available.
#
# Using a starting baseport value that falls in the non-ephemeral port
# range on most platforms.  Can override starting baseport by setting
# environment variable BDBBASEPORT.
#
# Must test explicit 127.0.0.1 host rather than localhost because
# localhost can be configured differently on different platforms or
# machines and that can cause this routine to return ports that are
# actually in use.
#
proc available_ports { n { rangeincr 10 } } {
	global env

	if { [info exists env(BDBBASEPORT)] } {
		set baseport $env(BDBBASEPORT)
	} else {
		set baseport 30100
	}

	# Try sets of contiguous ports ascending from baseport.
	for { set i $baseport } { $i < $baseport + $rangeincr * 100 } \
	    { incr i $rangeincr } {
		set ports {}
		set socks {}
		set numports $n
		set curport $i

		# Try one set of contiguous ports.
		while { [incr numports -1] >= 0 } {
			incr curport
			if [catch { socket -server Unused \
			    -myaddr 127.0.0.1 $curport } sock] {
				# A port is unavailable, try another set.
				break
			}
			lappend socks $sock
			lappend ports $curport
		}
		foreach sock $socks {
			close $sock
		}
		if { $numports == -1 } {
			# We have all the ports we need.
			break
		}
	}
	if { $numports == -1 } {
		return $ports
	} else {
		error "available_ports: could not get ports for $baseport"
	}
}