Sample using tcl thread pool with sockets to flog an SMTP server.

# Demonstrate the use of asynchronous sockets with a thread pool
# This expects to connect to an SMTP server. The task we are to
# perform is to connect to the server, and then immediately issue a QUIT
#

package require Thread

set program {
    variable uid 0
    
    proc OnWrite {State} {
        upvar #0 $State state
        lappend state(calls) w
        fileevent $state(socket) writable {}
    }
    
    proc OnRead {State} {
        upvar #0 $State state
        set rd r
        if {[eof $state(socket)]} {
            fileevent $state(socket) readable {}
            set state(wait) eof
            lappend state(calls) re
            return
        }
        if {[gets $state(socket) line] != -1} {
            #lappend state(input) $line
            append rd [string length $line]
            if {!$state(quit)} {
                set state(quit) 1
                puts $state(socket) "QUIT"
            }
        } else {
            append rd 0
        }
        lappend state(calls) $rd
    }
    
    proc Test {host port} {
        variable uid
        set State [namespace current]::test[incr uid]
        upvar #0 $State state
        array set state [list tid [thread::id] quit 0 calls {}]
        if {[catch {set state(socket) [socket -async $host $port]} err]} {
            set result "ERROR: $err"
        } else {
            set state(aid) [after 5000 [list set [set State](wait) timeout]]
            fconfigure $state(socket) -blocking 1 -buffering line -translation crlf
            fileevent $state(socket) writable [list OnWrite $State]
            fileevent $state(socket) readable [list OnRead $State]
            
            vwait [set State](wait)
            after cancel $state(aid)
            catch {close $state(socket)}
            set result [array get state]
        }
        unset $State
        return $result
    }
}

proc Threaded {host port} {
    variable program
    # Create a pool of threads and initialize them with our code
    set poolid [tpool::create -maxworkers 20 -initcmd $program]
    
    # Create a number of job requests and submit the jobs to the pool.
    # We keep an id for each job so we can track when they complete
    set jids {}
    for {set n 0} {$n < 5000} {incr n} {
        lappend jids [tpool::post -nowait $poolid [list Test $host $port]]
    }
    
    # Wait for the jobs we submitted to complete. Collect the results
    # and remove completed jobs from the set of job ids so that we can
    # wait on the running jobs each time around the outer loop.
    set limit 0
    array set r {}
    while {[llength $jids] > 0 && $limit < 5000} {
        set done [tpool::wait $poolid $jids]
        foreach id $done {
            #puts "[format %2d $id]: [tpool::get $poolid $id]"
            array set a [tpool::get $poolid $id]
            if {![info exists r($a(tid))]} {
                set r($a(tid)) 1
            } else {
                incr r($a(tid))
            }
            set ndx [lsearch -exact $jids $id]
            if {$ndx != -1} {
                set jids [lreplace $jids $ndx $ndx]
            }
        }
        incr limit
    }
    if {$limit > 999} { puts "hit limit"}

    # Clean up and report
    tpool::release $poolid
    foreach tid [array names r] {
        puts "$tid [format {% 3d} $r($tid)]\
            [string repeat . [expr {int((60/400.0) * $r($tid))}]]"
    }
    return
}

if {!$tcl_interactive} {
    set r [catch [linsert $argv 0 Threaded] err]
    if {$r} {puts $::errorInfo} else {puts $err}
    exit
}