home *** CD-ROM | disk | FTP | other *** search
/ Practical Programming in Tcl & Tk (4th Edition) / TCLBOOK4.BIN / pc / exsource / 21_12.tcl < prev    next >
Text File  |  2003-04-16  |  2KB  |  101 lines
  1. #
  2. # Example 21-12
  3. # A multi-threaded echo server.
  4. #
  5.  
  6. package require Tcl 8.4
  7. package require Thread 2.5
  8.  
  9. if {$argc > 0} {
  10.     set port [lindex $argv 0]
  11. } else {
  12.     set port 9001
  13. }
  14.  
  15. socket -server _ClientConnect $port
  16.  
  17. proc _ClientConnect {sock host port} {
  18.  
  19.     # Tcl holds a reference to the client socket during
  20.     # this callback, so we can't transfer the channel to our
  21.     # worker thread immediately. Instead, we'll schedule an
  22.     # after event to create the worker thread and transfer
  23.     # the channel once we've re-entered the event loop.
  24.  
  25.     after 0 [list ClientConnect $sock $host $port]
  26. }
  27.  
  28. proc ClientConnect {sock host port} {
  29.  
  30.     # Create a separate thread to manage this client. The
  31.     # thread initialization script defines all of the client
  32.     # communication procedures and puts the thread in its
  33.     # event loop.
  34.  
  35.     set thread [thread::create {
  36.         proc ReadLine {sock} {
  37.         if {[catch {gets $sock line} len] || [eof $sock]} {
  38.                 catch {close $sock}
  39.                 thread::release
  40.             } elseif {$len >= 0} {
  41.                 EchoLine $sock $line
  42.         }
  43.         } ;# proc ReadLine
  44.  
  45.         proc EchoLine {sock line} {
  46.             if {[string equal -nocase $line quit]} {
  47.                 SendMessage $sock \
  48.                     "Closing connection to Echo server"
  49.                 catch {close $sock}
  50.                 thread::release
  51.             } else {
  52.                 SendMessage $sock $line
  53.             }
  54.         } ;# proc EchoLine
  55.  
  56.         proc SendMessage {sock msg} {
  57.             if {[catch {puts $sock $msg} error]} {
  58.                 puts stderr "Error writing to socket: $error"
  59.                 catch {close $sock}
  60.                 thread::release
  61.             }
  62.         } ;# proc SendMessage
  63.         
  64.         # Initialize socket drivers to work around Tcl bug
  65.         
  66.         close [socket -server {} 0]
  67.         
  68.         # Enter the event loop
  69.         
  70.         thread::wait
  71.         
  72.     }] ;# thread::create
  73.  
  74.     # Release the channel from the main thread. We use
  75.     # thread::detach/thread::attach in this case to prevent
  76.     # blocking thread::transfer and synchronous thread::send
  77.     # commands from blocking our listening socket thread.
  78.  
  79.  
  80.     thread::detach $sock
  81.  
  82.     # Copy the value of the socket ID into the
  83.     # client's thread
  84.  
  85.     thread::send -async $thread [list set sock $sock]
  86.  
  87.     # Attach the communication socket to the client-servicing
  88.     # thread, and finish the socket setup.
  89.  
  90.     thread::send -async $thread {
  91.         thread::attach $sock
  92.         fconfigure $sock -buffering line -blocking 0
  93.         fileevent $sock readable [list ReadLine $sock]
  94.         SendMessage $sock "Connected to Echo server"
  95.     }
  96. } ;# proc ClientConnect
  97.  
  98. vwait forever
  99.  
  100.  
  101.