Tcl Source Code

Artifact 5f12aa4c4ad65109986a5f44bdd0336b31b47241:

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

---

# 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.
#
# This version tries UDP and TCP together to see if it is a problem with the
# tcludp package. We are expecting to call to a TIME service so use port
# 37 as that can often listen for both tcp and udp requests.

package require udp

set sockets {}

proc CreateUDPSocket {host port {clientData 0}} {
    global sockets
    if {[catch {
        set s [udp_open]
        fconfigure $s -remote [list $host $port]
        fconfigure $s -blocking 0 -buffering none -translation binary
        fileevent $s readable [list OnReadable $s $clientData]
        lappend sockets $s
        puts "$s udp created"
        puts -nonewline $s \x0b\x00\x00\x00
    } err]} {
        puts "$s error '$err'"
    }
    return $s
}

proc CreateTCPSocket {host port {clientData 0}} {
    global sockets
    if {[catch {
        set s [socket -async $host $port]
        fconfigure $s -blocking 0 -buffering none -translation binary
        fileevent $s writable [list OnWritable $s $clientData]
        fileevent $s readable [list OnReadable $s $clientData]
        puts "$s tcp created [lindex [fconfigure $s -sockname] 2]"
        lappend sockets $s
    } err]} {
        puts "$s error '$err'"
    }
    return $s
}

proc OnWritable {chan clientData} {
    fileevent $chan writable {}
    puts -nonewline $chan \x0b\x00\x00\x00
}

proc OnReadable {chan clientData} {
    if {[catch {
        if {$clientData < 10} {
            if {$clientData & 1} {
                foreach {ip host port} [fconfigure $chan -peername] break
                CreateUDPSocket $ip $port [incr clientData]
            } else {
                foreach {host port} [fconfigure $chan -remote] break
                CreateTCPSocket $host $port [incr clientData]
            }
        }
        if {[eof $chan]} {
            fileevent $chan readable {}
            puts "eof $chan"
            Close $chan
            return
        }
        puts "$chan $clientData [string length [read $chan]]"
        Close $chan
    } err]} { 
        puts "$chan error '$err'"
        Close $chan
    }
}

proc Close {chan} {
    global sockets forever
    set ndx [lsearch -exact $sockets $chan]
    set sockets [lreplace $sockets $ndx $ndx]
    puts "$chan closed"
    close $chan
    if {[llength $sockets] == 0} { set forever ok }
}

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