Version 3 of Testing socketports

Updated 2006-04-12 10:23:52

socktest.tcl

 ################################################################################
 # Module   : socktest.tcl
 # Last Chg.: 30.10.2005
 # Purpose  : test availibility of a socktes-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, partiallay 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]]

No [Category Network] available???