################################################################################
 # 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 https://wiki.tcl-lang.org/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
         }
    }

 }

 ::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]

 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 https://wiki.tcl-lang.org/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
        }
   }

}