Tcl Source Code

Artifact 28d90ff5fdb25a4e0e0f49c80449961a1a5a9aa3ddc42d312c140e5a6ed12425:

Attachment "test-sock-time-wait - b6d0d8cc2c.tcl" to ticket [b6d0d8cc2c] added by sebres 2020-04-27 10:38:03.

---

proc log args {}
proc get_tw_count {port} {
  regexp -all [regsub {@port} {:@port\M[^\n]+TIME_WAIT} $port] [exec netstat -n]
}
proc test {port} {
  puts [string repeat -- 20]\t[get_tw_count $port]
  timerate {
    puts [timerate {
      close [set ch [socket 127.0.0.1 $port]]
      log C-closed-cli:\t$ch
    } 2000 50]
    after 100; puts [string repeat -- 20]\t[get_tw_count $port]
  } 2000
}
proc test_server {port onConnect} {
  package require Thread
  thread::send -async [set th [thread::create]] [list proc log args [info body log]]
  thread::send -async $th [list proc onConnect {ch args} $onConnect]
  thread::send -async $th [list set port $port]
  thread::send $th { set srv [socket -server onConnect $port] }
  test $port
  thread::send $th {close $srv; thread::release}
}

puts "================== extern (web-server) =============="
test 80

puts "================== simple-close ====================="
test_server 8055 {
  log S-close-srv:\t$ch; close $ch; log S-closed:\t$ch
}

puts "================== proper-close ====================="
test_server 8055 {
  chan event $ch readable [list apply {{ch} {
    if {[catch {string length [read $ch 1024]} s] || $s == 0} {
      log S-close-srv:\t$ch; close $ch; log S-closed:\t$ch
    }
  }} $ch]
}