---- '''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]] <>Networking