tcl-hacks

    proc atexit {script args} {
        set ns [uplevel 1 {namespace current}]
        set script "$script $args"
        trace add execution exit enter [thunk $script $ns]
    }


    proc lshift {_list} {
        upvar 1 $_list list
        if {[llength $list] == 0} {
            throw {LSHIFT EMPTY} "Attempt to shift an empty list!"
        }
        set list [lassign $list r]
        return $r
    }

    proc main {args} {

        set cmds {}
        while {[string match -* [lindex $args 0]]} {
            set arg [lshift args]
            switch $arg {
                -c { lappend cmds [lshift args] }
                -m { lappend cmds "package require [lshift args]" }
                -- { break }
            }
        }
        foreach script $args {
            lappend cmds [list source $script]
        }

        exec stty raw -echo <@ stdin
        finally {exec stty -raw echo <@ stdin}
        atexit  {exec stty -raw echo <@ stdin}  ;# finally might not be enough!

        set prompt "\[[info patch]\]% "

        Getline create getline \
                            -prompt $prompt \
                            -completer [callback complete-word] \
        ;#

        finally [callback getline destroy]

        foreach cmd $cmds {
            puts "# % $cmd"
            try {
                uplevel #0 $cmd
            } on ok {res opt} {
                if {$res eq ""} continue
                puts #\ [tty::attr bold][list $res][tty::attr]
            } on error {res opt} {
                puts #\ [tty::attr fg red bold]$res[tty::attr]
            }
        }

        while 1 {
            set input [getline getline]             ;# can return -code break/continue
            try {
                uplevel #0 $input
            } on ok {res opt} {
                if {$res eq ""} continue
                puts [tty::attr bold]\ [list $res][tty::attr]
            } on error {res opt} {
                puts [tty::attr fg red bold]\ $res[tty::attr]
            }
        }
        puts ""
    }

    coroutine Main try {
        tclish::main {*}$::argv
        exit
    }
    vwait forever
}

#!/usr/bin/env tclsh
#
#lappend auto_path [file normalize [info script]/../modules]
#::tcl::tm::path add [file normalize [info script]/../modules]
proc boot {args} [format {
    {*}$args [list lappend auto_path %1$s]
    {*}$args [list ::tcl::tm::path add %1$s]
} [list [file normalize [info script]/../modules]]]
boot eval
package provide boot 0.1

if {[info exists ::argv0] && ($::argv0 eq [info script])} {
    if {$::argv ne ""} {
        proc info_cmdline {} [list list [info nameofexe] $::argv0 $::argv]      ;# hack for restartability
        set ::argv [lassign $::argv ::argv0]
        source $::argv0
    } else {
        return
        # async repl:
        package require repl
        coroutine main repl::chan stdin stdout stderr
        trace add command main delete {unset ::forever; #}
        vwait forever
    }
}

#   - put commands into a namespace with docs
# [ ] modularise and use appdirs
# [ ] parse tclenv.txt -> uninstall
#   - empty interp
# [ ] assemble & distribute
# [ ] isatty() ?
#
# teaparty synthesises a pkgIndex.tcl for tm's.  I don't wanna do that, so install needs to know about libpath + tmpath.

#
# different path for native libs?  hm?  good for xplat starkits.  But makes vfs maintenance awful, so don't
#
# TODO:
#   * install directory names should not contain ::
#   * all repo commands should take a dict; {name dict} is awkward
#   * might as well support uninstall
#   * mkvfs for non-native arch
#
# Teapot deficiencies:  by understanding and consuming these, I can define & serve something better
#   * metadata (requires) is only available embedded - in text, zip or vfs-in-exe (!)
#   * text/binary only known from http response
#   * extension must be inferred (particularly windows applications!)
#   * no incremental index updates
# Some of these could be read from HTML data, but not reliably

proc log {text} {
    puts stderr "# $text"
}

proc isatty {} {
    # unix:
    expr {![catch {chan configure stdout -mode}]}
    # doesn't work on windows (according to wine).  But wine+tclkit does get
    #  -encoding unicode ... if tty  (unicode? what fucking sort of encoding is that?)
    #  -encoding [encoding system] ... if redirected
    # uglier alternative:
    #expr {![catch {exec sh -c {stty <&1 > /dev/null} <@stdin >@stdout}]}
}

proc geturl {url} {
    set redirs 2
    while {1} {
        set tok [http::geturl $url]
        try {

                        count or list of the particular product or product slot.  Vending
                        machines should NEVER NEVER EVER eat money.
                    } {puts $chan $line}
                }
            }
        }
    }

    service http/80 {   ;# rfc2616 - see minhttpd for a much more careful implementation

        chan configure $chan -encoding iso8859-1 -translation crlf

        gets $chan reqline

        if {![regexp {^GET (\S+) HTTP/1.1$} $reqline -> uri]} {
            puts $chan "HTTP/1.1 400 Bad Request"
            puts $chan "Connection: close"
            puts $chan ""
            throw {HTTP INVALID REQUEST} "Invalid request [list $reqline]"
        }

        while {[gets $chan line]>0} {}

        puts $chan "HTTP/1.1 200 OK"
        puts $chan "Connection: close"
        puts $chan ""
        puts $chan "Hello, world!"
    }


    service ident/113 { ;# rfc1413
        if {[gets $chan line] > 0} {
            set parts [lmap x [split $line ,] {string trim $x}]
            lassign $parts remote local

            if {![string is integer -strict $local] || $local < 1 || $local >= 2**16} {

#!/usr/bin/env tclsh
#
# Just the bare minimum to serve http.  See example at bottom.
#

namespace eval minhttpd {

    proc callback args {
        tailcall namespace code $args
    }
    proc finally args {
        set ns [uplevel 1 {namespace current}]
        set callback [list apply [list args $args $ns]]
        tailcall trace add variable :#:FINALLY:#: unset $callback
    }

    # an async gets that *must* consume a line + newline, and will reject lines > limit chars long
    proc http-gets {chan _line {limit 1024}} {
        upvar 1 $_line line
        while 1 {
            yield
            if {[gets $chan line] >= 0 && ![eof $chan]} break   ;# EOF will be true if we didn't get a line-terminator
            if {[chan pending input $chan] > $limit} {
                return -level 2 -code error -errorcode {MINHTTPD LINE_TOO_LONG} "Line too long: [chan pending $chan] > $limit bytes"
            }
            if {[eof $chan]} {
                return -level 2 -code error -errorcode {MINHTTPD EOF} "Premature EOF while reading line after [string length $line] bytes"
            }
        }
    }

    proc serve {callback port} {
        dict set sockargs -server [callback accept $callback]
        if {[regexp {(.*):(.*)} $port -> host port]} {
            dict set sockargs -myaddr $host
        }
        set listenfd [socket {*}$sockargs $port]
        return $listenfd
    }

    proc close {listenfd} {
        close $listenfd
        # timeouts will take care of existing clients
    }

    proc accept {callback chan caddr cport} {
        coroutine coro#$chan#[info cmdcount] Accept $callback $chan
    }

    proc Accept {callback chan} {
        finally close $chan

        set timeout [after 1000 [list rename [info coroutine] {}]]
        finally after cancel $timeout

        chan configure $chan -translation crlf -encoding iso8859-1 -blocking 0
        chan event $chan readable [info coroutine]

        http-gets $chan reqline

        if {![regexp {^GET (.*) HTTP/1.\d+$} $reqline -> uri]} {
            puts $chan "HTTP/1.1 400 Bad Request"
            puts $chan "Connection: close"
            puts $chan ""
            return -code error -errorcode {MINHTTPD INVALID REQUEST} "Invalid request [list $reqline]"
        }

        while 1 {
            http-gets $chan header
            if {$header eq ""} break
        }

        regsub {^https?://[^/]*} $uri {} uri

        set rc [catch {uplevel #0 [list {*}$callback $uri]} res opts]

        if {$rc == 0} {
            set code 200
            set data $res
        } elseif {$rc < 100} {
            set code 500
            set data ""
        } else {
            set code $rc
            set data $res
            set rc 0
        }

        if {$code in {301 302}} {
            if {![dict exists $opts -location]} {
                if {$res eq ""} {
                    throw {MINHTTPD BAD REDIRECT} "Redirect must specify -location or a result"
                } else {
                    dict set opts -location $res
                    set res ""
                }
            }
            set data $res
        }

        dict unset opts -level
        dict unset opts -code
        foreach errkey [dict keys $opts -error*] {
            dict unset opts $errkey
        }

        set httpcodes {
            200 "OK"
            204 "No Content"
            301 "Moved Permanently"
            302 "Found"
            403 "Forbidden"
            404 "Not Found"
            500 "Internal Server Error"
        }
        set codedesc [dict get $httpcodes $code]

        if {$data eq ""} {
            if {$code eq 200} {set code 204}
            if {$code ne 204} {set data $codedesc}
        }

        puts $chan "HTTP/1.1 $code $codedesc"
        puts $chan "Connection: close"

        set defheaders {
            -content-type text/html
        }

        set headers [dict merge $defheaders $opts]

        set is_text [string match text/* [dict get $headers -content-type]]

        if {$is_text} {
            dict append headers -content-type "; charset=utf-8"
        }

        if {$data eq ""} {
            dict unset headers -content-type
        }

        dict for {header value} $headers {
            regsub ^- $header {} header
            regsub :$ $header {} header
            regsub -all "\n\\s*" $value "\n "
            puts $chan "$header: $value"
        }
        puts $chan ""

        if {!$is_text} {
            chan configure $chan -translation binary
            puts -nonewline $chan $data
        } else {
            chan configure $chan -encoding utf-8
            if {$data ne ""} {
                puts $chan $data        ;# extra newline for friendliness
            }
        }

        # finally will close $chan

        if {$rc != 0} {
            return -code $rc {*}$opts $res
        }
    }
}

if {[info script] eq $::argv0} {

    set svrfd [minhttpd::serve httpGet 8080]

    proc httpGet {url} {
        if {$url eq "/"} {
            return -code 302 /index.html
        }
        if {$url eq "/admin"} {
            return -code 403 "You are not allowed!"
        }
        if {$url eq "/index.html"} {
            return "(\u2713) Hello, world!"
        }
        if {$url eq "/binary"} {
            return -content-type application/octet-stream \x0d\xea\xd0\x0b\xee\xf0
        }
        if {$url eq "/exit"} {
            after idle {incr ::forever}
            return "Exiting!"
        }
        if {$url eq "/empty"} {
            return ""
        }
        if {$url eq "/error"} {
            expr {1/0}
        }
        return -code 404
    }

    vwait forever

}