tcl-hacks

Check-in [0227bf5899]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:merge tclish-args, which includes commits unrelated to its topic
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | trunk
Files: files | file ages | folders
SHA1:0227bf58991f9e7e68a36d82f672442d80d425ab
User & Date: aspect 2018-12-11 07:07:14
Context
2018-12-11
07:07
merge tclish-args, which includes commits unrelated to its topic Leaf check-in: 0227bf5899 user: aspect tags: trunk
07:06
boot.tcl can now pass args to a script correctly, tclish likes this Leaf check-in: d6f9265bbe user: aspect tags: tclish-args
2018-08-05
09:08
add select object check-in: e570c71b81 user: aspect tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to bin/tclish.

53
54
55
56
57
58
59









60













61
62
63
64
65
66
67
68
69
70
71
72
73












74
75
76
77
78
79
80
81
82
83
84
85

86
87
88
89
90
91
92
93
    proc atexit {script args} {
        set ns [uplevel 1 {namespace current}]
        set script "$script $args"
        trace add execution exit enter [thunk $script $ns]
    }











    proc main {} {














        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]













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

    }

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







>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>













>
>
>
>
>
>
>
>
>
>
>
>












>








53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
    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
}

Changes to boot.tcl.

5
6
7
8
9
10
11

12
13
14
15
16
17
18
19
20
21
22
23

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 {$::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
}








>
|
|
|
|
|
|
|
|
|
|
|
|
>
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
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
    }
}

Changes to hacks/cuppa/tpc.tcl.

20
21
22
23
24
25
26
27
28
29
30






31
32
33
34
35
36
37
..
94
95
96
97
98
99
100





101
102
103
104
105
106
107
108
#   - 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.






#
# 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 {exec sh -c {stty <&1} <@stdin >@stdout}]}
}

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







|
<

|
>
>
>
>
>
>







 







>
>
>
>
>
|







20
21
22
23
24
25
26
27

28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
..
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
#   - 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 {

Changes to inet/inet.tcl.

256
257
258
259
260
261
262






















263
264
265
266
267
268
269
                        count or list of the particular product or product slot.  Vending
                        machines should NEVER NEVER EVER eat money.
                    } {puts $chan $line}
                }
            }
        }
    }























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







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
                        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} {

Added modules/minhttpd-0.tm.

















































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
#!/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

}