Tcl Source Code

Artifact 73dd9ae73fa4b0c7c4fc8fed7cef43bbe0f7d464:

Attachment "segfault.tcl" to ticket [2978773fff] added by andreas_kupries 2010-03-31 01:41:14.

---

#!/usr/bin/tclsh

fconfigure stdout -buffering none
set level 0
proc L {args} {
    global level
    puts [string repeat { } $level]$args
    return
}
proc --> {args} { global level ; L Enter/ {*}$args [info level -1] ; incr level  4 }
proc <-- {args} { global level ; incr level -4 ; L /Exit {*}$args [info level -1] }

proc getstr {fd var} { -->
    upvar 1 $var line
    set cnt [gets $fd line]
    L "gets ($cnt): '$line'"
    <--
    return $cnt
}

proc xyzrequest {s} { -->
    set f [chan create read refchan]
    fconfigure $f -blocking 0
    chan event $f readable [list xyzexec $f $s]
    refchan::output $f "Content-Type: text/html\n"
    refchan::output $f "Line 1"
    refchan::output $f "Line 2"
    refchan::output $f "Line 3"
    refchan::done $f
    <--
}

proc xyzexec {f s} { --> CALLBACK
    if {[eof $f]} {
	# Should not happen - error
    } elseif {[getstr $f line] == -1} {
	# Not a full line available
	L "Not a full line"
	<-- CALLBACK
	return
    } elseif {![string length $line]} {
	# Empty line indicates the end of header information
	L "Empty line"
	<-- CALLBACK
	return
    } elseif {[regexp {^(\S+)\s*:\s*(.+)} $line -> var val]} {
	# Found a valid header line
	L "Header: $var=$val"
	<-- CALLBACK
	return
    }
    L "Invalid output"
    close $f
    L "Connection from webhost($f) closed, $f"
    <-- CALLBACK
    return
}

namespace eval refchan {
    namespace ensemble create -subcommands {
        initialize finalize watch read write
    }

    proc initialize {id mode} { --> HANDLER
        variable chan
        variable buffer

        set chan($id) [dict create watch {} eof 0 event ""]
        set buffer($id) ""

	<-- HANDLER
        return [namespace ensemble configure refchan -subcommands]
    }

    proc watch {id spec} { --> HANDLER
        variable chan
        dict set chan($id) watch $spec
        postevent $id
	<-- HANDLER
    }

    proc read {id count} { --> HANDLER
        variable chan
        variable buffer
        if {[info exists chan($id)]} {
            L STATE = $chan($id)
            if {$buffer($id) eq ""} {
                if {[dict get $chan($id) eof]} {
                    L "=> EOF"
		    <-- HANDLER
                    return ""
                } else {
                    L "=> EAGAIN"
		    <-- HANDLER
                    return -code error EAGAIN
                }
            }
            # Bug in Tcl? Work-around: Only provide one line per request
            set x [string first \n $buffer($id)]
            # if {$x >= 0} {set count [expr {$x + 1}]}
            set rc [string replace $buffer($id) $count end]
            set buffer($id) [string range $buffer($id) $count end]
            L "\t[info level 0] -> '$rc'"
	    <-- HANDLER
            return $rc
        } else {
	    L "\t[info level 0] => EOF"
	    <-- HANDLER
            return ""
        }
    }

    proc finalize id { --> HANDLER
        variable chan
        set after [dict get $chan($id) event]
        after cancel $after
        unset chan($id)
	<-- HANDLER
    }




    # Code to full the channel buffer with data to be read ...

    proc output {id str} { --> FILL
        variable chan
        variable buffer
        if {[info exists chan($id)]} {
            append buffer($id) $str \n
            postevent $id
        }
	<-- FILL
    }

    proc done {id} { --> FILL
        variable chan
        dict set chan($id) eof 1
        postevent $id
	<-- FILL
    }

    proc postevent {id} { --> SIGNAL
        variable chan
        variable buffer
        dict with chan($id) {}
        after cancel $event
        if {"read" in $watch} {
            if {$buffer($id) ne "" || $eof} {
                dict set chan($id) event [after 10 [list refchan::postevent $id]]
		L [list chan postevent $id read]
                chan postevent $id read
            }
        }

	<-- SIGNAL
    }
}

xyzrequest stdout

if {[catch {vwait forever}]} exit