Posted to tcl by aspect at Sun Jun 26 08:25:19 GMT 2011view pretty

package require Tcl 8.6

proc nbsock {args} {   
    set args [lassign $args chan cmd]
    puts "nbsock $chan $cmd $args"
    switch -exact $cmd {
        initialize {
            return {initialize finalize read write watch}
        }
        read {
            lassign $args id count
            chan read $chan $count
        }
        write {
            lassign $args id data
            chan puts -nonewline $chan $data
            string length $data
        }
        finalize {
            close $chan
        }
        default {
            error "Unsupported subcommand: $cmd"
        }
    }
}

proc echo {sock host port} {  
    while {![chan eof $sock]} {
        chan puts $sock [chan gets $sock]
    }
}

namespace eval clients {}

proc handle {sock host port} {
    puts "Connect: $host:$port"
    set sock [chan create [list read write] [list nbsock $sock]]
    yield
    if {[catch {echo $sock $host $port} result]} {
        puts "Error: $host:$port: $result"
    }
    puts "Closing: $host:$port"
    if {[catch {close $sock} res]} {
        puts "Error closing $host:$port: $res"
    }
}


proc accept {sock host port} {
    coroutine clients::$host:$port handle $sock $host $port
    chan configure $sock -blocking 0 -buffering line
    chan event $sock readable clients::$host:$port
}


socket -server accept 1234
 
if {!$::tcl_interactive} {vwait forever}