Tcl Source Code

Hello, everybody

We are currently in the process of porting our application from Tcl/Tk 8.6 to 9.0. In the process, we have encountered a problem with zooming in and out within our WMS (Web Map Service) module.

The error occurs under Linux (openSUSE Leap 16.0 and Debian 13) with Tcl 9.0.3 (and most likely with 9.0.4 as well), but not with Tcl 8.6.16.

The source code for Tcl 9.0.3 contains the file `library/http/http.tcl`, and line 1727 reads as follows:
    set sock [namespace eval :: $state(openCmd)]
Here, the command previously registered via `http::register` is executed. If this command, for example, executes a `vwait` (as occurs, for instance, in the `autoproxy` package [autoproxy::tls_socket]), then events are processed in the meantime and their handlers are executed. These handlers can, in turn, call `http::reset` and `http::cleanup`, so that the token (the variable `state` in ::http::OpenSocket) no longer exists after returning from line 1727.

The HTTP module then terminates, for example, with the following error message, which is difficult to catch/handle:
    can't read "state(-keepalive)": no such element in array

I have attached a small script that can be used to reproduce the error, and also a quick-and-dirty patch (see below).

Kind regards,

Robert

#!/usr/bin/env wish
package require http
package require tls

wm title . "Logo"
wm minsize . 300 300

set waitForMe 0

proc lameTlsSocket {args} {
   # Let's wait a little bit
   vwait ::waitForMe
   return [tls::socket {*}$args]
}
http::register https 443 lameTlsSocket

label .label -text "Use the keyboard or mouse to generate a series of events" -wraplength 300
pack .label -expand 1

proc getLogo {args} {
   .label configure -image ""

   if {[info exists ::currentRequest]} {
      # Stop current request
      puts "Stop current request $::currentRequest"
      http::reset $::currentRequest
   }

   # Start new request
   set ::currentRequest [http::geturl "https://thumb.wikimedia.org/wikipedia/commons/thumb/4/41/Tcl.svg/120px-Tcl.svg.png" -command displayLogo]
   puts "New request $::currentRequest"
}
bind . <MouseWheel> getLogo
bind . <Button> getLogo
bind . <Key> getLogo

proc displayLogo {token} {
   if {[http::status $token] eq "ok"} {
      set data [http::data $token]
      try {
         image create photo logo -format png -data $data
         .label configure -image logo
      } on error {err} {
         puts $err
      }
   }

   puts "Cleanup $token"
   http::cleanup $token

   if {$token eq $::currentRequest} {
      unset ::currentRequest
   }
}

proc goOn {} {
   incr ::waitForMe
   after 1000 goOn
}
goOn
### END OF SCRIPT

--- library/http/http.tcl
+++ library/http/http.tcl
@@ -1754,7 +1754,7 @@
     dict unset socketCoEvent($state(socketinfo)) $token
     unset -nocomplain state(socketcoro)

-    if {[catch {
+    try {
        if {$state(reusing)} {
            # If ($state(reusing)) is true, then we do not need to create a new
            # socket, even if $sockOld is only a placeholder for a socket.
@@ -1765,6 +1765,10 @@
            ##Log pre socket opened, - token $token
            ##Log $state(openCmd) - token $token
            set sock [namespace eval :: $state(openCmd)]
+       if {![info exists state]} {
+          catch {close $sock}
+          return
+       }
            set state(sock) $sock
            # Normal return from $state(openCmd) always returns a valid socket.
            # A TLS proxy connection with 407 or other failure from the
@@ -1791,7 +1795,7 @@
        # Code above has set state(sock) $sock
        ConfigureNewSocket $token $sockOld $DoLater
        ##Log OpenSocket success $sock - token $token
-    } result errdict]} {
+    } on error {result errdict} {
        ##Log OpenSocket failed $result - token $token
        # There may be other requests in the socketPhQueue.
        # Prepare socketPlayCmd so that Finish will replay them.