(See modification at the bottom of the page)socktest.tcl
################################################################################
# Module : socktest.tcl
# Last Chg.: 30.10.2005
# Purpose : test availability of a sockets-port without waiting on a
# nonconfigurable, os dependant timeout, using an async socket; test
# if a local socket server can be started at a given port
# Author : M.Hoffmann, partially based on http://wiki.tcl.tk/1114
# ToDo : more tests
# History
# 29.10.05 : generalized as a simple package, namespace, test, optimized,
# enhanced
################################################################################
package provide socktest 0.1
namespace eval socktest {
namespace export socktest sockmesg localsockfree
variable resulttext
array set resulttext {
-2 SocketError
-1 NameError
0 Timeout
1 OK
9 Undefined
}
# test if port 'sock' at adress 'host' is responding
proc socktest {host sock {timeout 1000}} {
if {[catch {socket -async $host $sock} s]} {
return -1
}
variable done$sock 9; # allow parallel instances
# if socket becomes writable, test further
fileevent $s writable [list namespace eval socktest "sockvrfy $s done$sock"]
# prepare for cancellation after user supplied timeout
set aid [after $timeout namespace eval socktest "set done$sock 0"]
# waiting for timeout or other result
vwait [namespace current]::done$sock
catch {close $s}
after cancel $aid; # catch not neccessary
set ret [set done$sock]
unset done$sock; # save mem
return $ret
}
proc sockvrfy {sock flag} {
upvar $flag done
if {[string length [fconfigure $sock -error]] == 0} {
set done 1
} else {
set done -2
}
}
proc sockmesg {rc} {
variable resulttext
catch {set resulttext($rc)} ret
return $ret
}
# test if port 'sock' at localhost is available or already in use
proc localsockfree {sock} {
if {[catch {socket -server {} $sock} rc]} {
return 0
} else {
# server could be started, so the port is not in use locally
catch {close $rc}
return 1
}
}
}socktest_test.bat
::if 0 {
@tclsh %~n0.bat %* & @goto :EOF
}
# test the socktest-package, 30.10.2005
lappend auto_path ./
package require socktest 0.1
namespace import socktest::*
# puts [info commands socktest::*]
# test parallel behaviour
after 10000 [list set done 1]
foreach {host sock} {wronghost wrongport
localhost wrongport
localhost 80
localhost ftp
wrong wrong} {
after 1000 puts [sockmesg [socktest $host $sock 3000]]
}
vwait done
puts [localsockfree 80]
puts [localsockfree 23]
puts [localsockfree ftp]pkgIndex.tcl
package ifneeded socktest 0.1 [list source [file join $dir socktest.tcl]]
# Module : socktest.tcl
# Last Chg.: 02.03.2015
# Purpose : test availability of a sockets-port without waiting on a non
# configurable, os dependant timeout, using an async socket; test if
# a local socket server can be started at a given port
# Author : M.Hoffmann, partially based on http://wiki.tcl.tk/1114
# ToDo : more tests
# History
# 30.10.05 : generalized as a simple package, namespace, test, optimized,
# enhanced
# 02.03.15 : Timeout 0 means not using -async and vwait to avoid unintentionally
# creating nested eventloops. Relies on OS-timeout then, sorry.
# Timout should only be used in simple programs where no complicated
# events are used....
package provide socktest 0.2
namespace eval socktest {
namespace export socktest sockmesg localsockfree
variable resulttext
array set resulttext {
-2 SocketError
-1 NameError
0 Timeout
1 OK
9 Undefined
}
# test if port 'sock' at adress 'host' is responding within timeout
# note: socket -async requires a running eventloop
proc socktest {host sock {timeout 1000}} {
if {$timeout == 0} {
# return codes compatible
if {[catch {socket $host $sock} s]} {
return -2
} else {
catch {close $s}
return 1
}
}
if {[catch {socket -async $host $sock} s]} {
return -1
}
variable done$sock 9; # allow parallel instances
# if socket becomes writable, test further
fileevent $s writable [list namespace eval socktest "sockvrfy $s done$sock"]
# prepare for cancellation after user supplied timeout
set aid [after $timeout namespace eval socktest "set done$sock 0"]
# waiting for timeout or other result
vwait [namespace current]::done$sock
catch {close $s}
after cancel $aid; # catch not neccessary
set ret [set done$sock]
unset done$sock; # save mem
return $ret
}
proc sockvrfy {sock flag} {
upvar $flag done
if {[string length [fconfigure $sock -error]] == 0} {
set done 1
} else {
set done -2
}
}
proc sockmesg {rc} {
variable resulttext
catch {set resulttext($rc)} ret
return $ret
}
# test if port 'sock' at localhost is available or already in use
proc localsockfree {sock} {
if {[catch {socket -server {} $sock} rc]} {
return 0
} else {
# server could be started, so the port is not in use locally
catch {close $rc}
return 1
}
}
}
