proc sockvrfy {sock done} {
upvar $done flag
if {[string length [fconfigure $sock -error]] == 0} {
set flag 1; # { 1 = OK!!!}
} else {
set flag -2; # {-2 = SockErr, errorinfo get's lost...}
}
}
# (take a look at wiki.tcl.tk/1114)
proc socktest {host {port 445} {timeout 1000}} {
if {[catch {socket -async $host $port} s]} {
return -1; # {-1 = wrong DNS name}
}; # else: formally ok
set ::done 9; # {9 = undefined}
# further testing if socket becomes open
fileevent $s writable [list sockvrfy $s ::done]
# but don't wait longer than the given amount (in msecs)
set aid [after $timeout [list set ::done 0]]; # { 0 = Timeout}
# waiting for test to succeed or timeout to happen...
vwait ::done; # blocking the caller but keeping eventloop alive!
catch {close $s}
after cancel $aid
return $::done
}
# Testcase
puts "nonexistentserver should return -1 => [socktest nonexistentserver]"
puts "runningserver should return 1 => [socktest runningserver ]"
puts "offlineserver should return 0 => [socktest offlineserver ]"The whole thing only works with tcp/ip-networking, of course. Alternatively, one can specify port 139 instead of 445.See Testing socketports.
