Posted to tcl by kostix at Wed Dec 06 14:14:46 GMT 2006view raw

  1. #! /usr/bin/wish
  2.  
  3. set host aquinas.domain007.com
  4. set port 6666
  5. set timeout 2000 ;# msec
  6. variable socket
  7.  
  8. proc connect {host port timeout} {
  9. set sock [socket -async $host $port]
  10. fileevent $sock writable [list connected $host $port $sock]
  11.  
  12. after $timeout timed_out $sock
  13. }
  14.  
  15. proc connected {host port sock} {
  16. after cancel timed_out $sock
  17. fileevent $sock writable {}
  18.  
  19. set failed [catch {fconfigure $sock -peername} msg]
  20. if {$failed} {
  21. tk_messageBox -message "Failed to connect:\
  22. [fconfigure $sock -error]"
  23. } else {
  24. global socket
  25. set socket $sock
  26. tk_messageBox -message "Connected: [fconfigure $sock]"
  27. }
  28. .connect config -state normal
  29. }
  30.  
  31. proc timed_out {sock} {
  32. shutdown $sock
  33. .connect config -state normal
  34. tk_messageBox -message "Connection timed out"
  35. }
  36.  
  37. proc shutdown {sock} {
  38. catch { close $sock }
  39. }
  40.  
  41. proc do_connect {} {
  42. global host port timeout
  43.  
  44. .connect config -state disabled
  45.  
  46. connect $host $port $timeout
  47. }
  48.  
  49. proc do_disc {} {
  50. global socket
  51. shutdown $socket
  52. }
  53.  
  54. foreach t {host port timeout} {
  55. pack [entry .$t -textvariable ::$t]
  56. }
  57. pack [button .connect -text "Connect" -command do_connect]
  58. pack [button .disc -text "Disconnect" -command do_disc]
  59.  
  60.