[Bug TclHttpd 2.3.2] Tclhttd hangs on fileevent when opening a new process

[jay . schmidgall]

TclHttpd 2.3.2 Bug

Name:  Jay Schmidgall
email:  [EMAIL PROTECTED]
Support:  None
Severity:  2
OperatingSystem:  All
OperatingSystemVersion:  Windows NT and Solaris 2.5.7
Synopsis:  Tclhttd hangs on fileevent when opening a new process

ReproducibleScript:
If you run tclhttpd as wish httpd.tcl -config bug.rc, you can access three pages, 
/nohang1, /nohang2 and /hang. The /hang page will cause the incorrect behavior.

# 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
}


ObservedBehavior:
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 immediately, everything is fine.

DesiredBehavior:
I would expect to not have tcl-httpd hang.

Comments:
    I'm seeing this problem with both tcl-http2 2.3.1 and 2.3.7.
    
Posted To comp.lang.tcl: Posted Successfully