Tcl Source Code

Artifact a27a67e0efdd5dac666835d06a6b20d21f81874a:

Attachment "bug1555698-tcp.tcl" to ticket [1555698fff] added by patthoyts 2006-09-12 20:20:46.

---

# bug1555698.tcl - Copyright (C) 2006 Pat Thoyts <[email protected]>
#
# Investigate bug 1555698 where the user is getting two sockets with the same
# name created during a dns package callback.
#
# Doing this with tcp sockets using HTTP servers yields no problem
# on Windows XP.

set sockets {}
proc CreateSocket {host port {clientData 0}} {
    global sockets
    set s [socket -async ripon 80]
    fconfigure $s -blocking 1 -buffering line -translation crlf
    fileevent $s writable [list OnWritable $s $clientData]
    fileevent $s readable [list OnReadable $s $clientData]
    puts "created $s [lindex [fconfigure $s -sockname] 2]"
    lappend sockets $s
    return $s
}

proc OnWritable {chan clientData} {
    if {$clientData < 5} {
        foreach {ip host port} [fconfigure $chan -sockname] break
        CreateSocket $ip $port [incr clientData]
    }
    fileevent $chan writable {}
    puts $chan "HEAD / HTTP/1.0\n"
}

proc OnReadable {chan clientData} {
    global sockets forever
    if {[eof $chan]} {
        fileevent $chan readable {}
        puts "eof $chan"
        set ndx [lsearch -exact $sockets $chan]
        set sockets [lreplace $sockets $ndx $ndx]
        if {[llength $sockets] == 0} { set forever ok }
        return
    }
    puts "$chan: {[string length [read $chan]]}"
}

if {!$tcl_interactive} {
    if {[llength $argv] != 2} {
        puts "[file tail [info script]] host port"
        puts "  eg: somewebserver 80"
        exit
    }
    eval [linsert $argv 0 CreateSocket]
    after 5000 {set forever timeout}
    set forever running
    vwait ::forever
    puts "$forever $sockets"
    exit 0
}