BUG: tcl-httpd hangs?

[Schmidgall, Jay]

I'm seeing an unusual hanging problem, and I don't know if I'm hitting some
sort of race condition or am just misunderstanding what I'm trying to do.
I'm seeing this on both Windows NT and Solaris 2.5.7.

What's happening is that when I access a particular URL, I have tcl-httpd
spawn off a new process. I then establish a fileevent to grab output so I
can keep track of when the spawned process exits.

The problem I'm seeing is that if that process produces output immediately
but does not exit, tcl-httpd hangs until the process exits. If no output is
produced or the process exits, everything is fine.

I've managed to hack up config file which duplicates the problem. If you
save the bottom of this email as bug.rc, and run

    wish httpd.tcl -config bug.rc

you can try accessing /nohang1, /nohang2, and /hang. The last one will
reproduce the problem. If you try this under NT, you'll need something like
MKS or the GNU utils to have a sleep and ls command available.

# bug.rc
#
# This is the default configuration file for TclHttpd, the Tcl Web Server

# The Config array is set from the command line options or
# from defaults defined in httpd
# You can set them here, but then they smash any command-line values

# Config Array
# Element   Default
# host      [info hostname]
# port      8015
# debug     0
# docRoot   [file join $home htdocs]
# ipaddr    {}
# webmaster webmaster@[info hostname]
# uid       50
# gid       100

# Force running with wish

if { ! [ info exists tk_version ] } {
    puts {Please run this with wish, not tclsh}
    exit
}

# Add a text widget so we can see some output

text .text -width 30 -height 10 \
    -yscrollcommand { .textvsb set }
scrollbar .textvsb -command { .text yview }
grid configure .text .textvsb -sticky news

# These packages are required for "normal" web servers

package require doc     ;# Basic file URLS
package require include     ;# Server side includes
package require cgi     ;# Standard CGI
package require dirlist     ;# Directory listings

# These packages are for special things built right into the server

package require direct      ;# Application Direct URLs
package require status      ;# Built in status counters
package require mail        ;# Crude email support
package require admin       ;# Url-based administration
package require session     ;# Session state module (better Safe-Tcl)
package require debug       ;# Debug utilites

# This is currently broken
if {0} {
    package require safetcl ;# External process running safetcl shells
}

# These packages are for the SNMP demo application

if {[catch {
    package require snmp       ;# SNMP form creation
    package require Tnm        ;# Low level network stuff
}]} {
    puts "No SNMP support"
}

# For information about these calls, see htdocs/reference.html

Doc_Root        $Config(docRoot)
Doc_IndexFile       index.{tml,html,shtml,thtml,htm,subst}
Doc_PublicHtml      public_html
Cgi_Directory       /cgi-bin
Status_Url      /status
Debug_Url       /debug
Mail_Url        /mail
Admin_Url       /admin
Doc_TemplateInterp  {}
Doc_CheckTemplates  1
Doc_TemplateLibrary [file join $Config(docRoot) libtml]
Doc_ErrorPage       /error.html
Doc_NotFoundPage    /notfound.html
Doc_Webmaster       $Config(webmaster)
if {[catch {
    Auth_AccessFile .htaccess       ;# Enable Basic Auth
} err]} {
    puts "No Basic Authentication support: $err"
}

Log_SetFile     C:/Temp/log$Config(port)_
Log_FlushMinutes    1

# Establish mapping for URLs to test

Direct_Url /hang hang
Direct_Url /nohang1 nohang1
Direct_Url /nohang2 nohang2

proc nohang1 {} {
    textout nohang1 entered
    if { 0 == [ catch { open "| sleep 5 " } spawned ] } {
        fileevent $spawned readable [ list output $spawned nohang1 ]
    }
    textout nohang1 leaving
    return nohang1
}

proc nohang2 {} {
    textout nohang2 entered
    if { 0 == [ catch { open "| ls " } spawned ] } {
        fileevent $spawned readable [ list output $spawned nohang2 ]
    }
    textout nohang2 leaving
    return nohang2
}

proc hang {} {
    textout hang entered
    if { 0 == [ catch { open "| sleep 5 | ls " } spawned ] } {
        textout About to hang -- you cannot depress
        textout the Quit button now.
        update
        fileevent $spawned readable [ list output $spawned hang]
    }
    textout hang leaving
    return hang
}

proc output { channel which } {
    if { [ eof $channel ] } {
        close $channel
        textout $which exited.
    } else {
        set out [ read $channel ]
        textout $which output: $out
    }
}

proc textout { args } {
    set time [ clock format [ clock seconds ] -format "%H:%M:%S " ]
    .text insert end $time$args
    .text insert end \n
}