tcl-hacks

Check-in [015a60358b]
Login

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

Overview
Comment:make getline a module: add tclish
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:015a60358bc96164f1ac7ba5c4ba6d5375dd50cd
User & Date: aspect 2018-05-24 10:20:42
Context
2018-05-24
10:22
update README check-in: f326ddc011 user: aspect tags: trunk
10:20
make getline a module: add tclish check-in: 015a60358b user: aspect tags: trunk
09:35
move TODO out of main check-in: ea6039b24d user: aspect tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added bin/tclish.











































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
#!/usr/bin/env tclsh
#
catch {source [file dirname [info script]]/../boot.tcl}

package require getline

namespace eval tclish {
    namespace path ::getline

    proc complete-word {s t} {
        regexp {([a-zA-Z0-9_:-]*)$} $s -> w
        if {$w eq ""} {return}
        set l [string length $w]
        set cs [info commands ${w}*]            ;# here's the dictionary!
        if {[llength $cs] == 1} {
            lassign $cs comp
            set comp [string range $comp [string length $w] end]
            return [list insert "$comp "]
        } else {
            set comp [common-prefix $cs]
            set comp [string range $comp [string length $w] end]
            if {$comp ne ""} {
                return [list insert $comp]
            } else {
                return [list flash-message $cs]     ;# FIXME: abbreviate
            }
        }
    }

    proc thunk {script {ns ::}} {
        list apply [list args $script $ns]
    }

    proc callback {cmd args} {
        set cmd [uplevel 1 [list namespace which $cmd]]
        list $cmd {*}$args
    }

    proc finally {script args} {
        set ns [uplevel 1 {namespace current}]
        set script "$script $args"
        tailcall trace add variable :#\; unset [list apply [list args $script $ns]]
    }

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

Added modules/getline-0.1.tm.



>
1
source [file dirname [info script]]/getline/getline.tcl

Name change from getline/README.completion to modules/getline/README.completion.

Name change from getline/README.md to modules/getline/README.md.

Name change from getline/README.multi-line to modules/getline/README.multi-line.

Name change from getline/TODO to modules/getline/TODO.

Name change from getline/getline.tcl to modules/getline/getline.tcl.

1
2
3
4
5
6
7

8
9
10
11
12
13
14
..
60
61
62
63
64
65
66
67
68
69






70
71
72
73
74
75
76
77
78
79
80
81
82
..
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
...
121
122
123
124
125
126
127







128
129
130
131
132
133
134
namespace eval getline {

    source input.tcl
    source output.tcl
    source keymap.tcl
    source history.tcl
    source util.tcl     ;# ssplit


    proc rep {c} {
        if {[string length $c] != 1}    { error "Bad input: [binary encode hex $c]" }
        if {[string is print $c]}       { return $c }
        return "\\x[binary encode hex $c]"
    }

................................................................................

        constructor {args} {
            namespace path [list [namespace qualifiers [self class]] {*}[namespace path]]
            set Yank ""
            set Lines {""}
            set Lineidx 0
            set Prompt "getline> "
            set Chan stdout

            my Configure {*}$args







            set Prompts [list $Prompt]

            Input create             input
            Output create            output $Chan
            keymap::KeyMapper create keymap [expr {$Chan eq "stdout" ? "stdin" : $Chan}]
        }

        method Configure {args} {
            set OptSpec {
                -prompt     { set Prompt $val }
                -chan       { set Chan $val }
                -history    { oo::objdefine [self] forward History     [uplevel 1 [list namespace which $val]] }
................................................................................
                    if {[string match $pat* $key]} {
                        try $script
                        set matched 1
                        break
                    }
                }
                if {!$matched} {
                    return -code error "Unknown option; expected one of [join [dict keys $OptSpec] ", "]."
                }
            }
        }

        method Prompt {} {
            if {[lindex $Prompts $Lineidx] eq ""} {
                regexp {^(.*)(\S)(\s*)$} $Prompt -> prefix char space
................................................................................

        method Mode {mixin args} {
            oo::objdefine [self] mixin $mixin
        }

        method getline {} {








            my reset

            while 1 {
                # {TOKEN tok {c c c}} or {LITERAL "" {c c c}}
                lassign [keymap gettok] kind tok chars
                if {$kind eq "TOKEN"} {
                    try {


|
|
|
|
|
>







 







|


>
>
>
>
>
>




|
|







 







|







 







>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
..
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
..
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
...
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
namespace eval getline {

    source [file dirname [info script]]/input.tcl
    source [file dirname [info script]]/output.tcl
    source [file dirname [info script]]/keymap.tcl
    source [file dirname [info script]]/history.tcl
    source [file dirname [info script]]/util.tcl     ;# ssplit
    source [file dirname [info script]]/tty.tcl

    proc rep {c} {
        if {[string length $c] != 1}    { error "Bad input: [binary encode hex $c]" }
        if {[string is print $c]}       { return $c }
        return "\\x[binary encode hex $c]"
    }

................................................................................

        constructor {args} {
            namespace path [list [namespace qualifiers [self class]] {*}[namespace path]]
            set Yank ""
            set Lines {""}
            set Lineidx 0
            set Prompt "getline> "
            set Chan stdin

            my Configure {*}$args

            if {$Chan eq "stdout"} {set Chan stdin}
            set outchan [expr {$Chan eq "stdin" ? "stdout" : $Chan}]

            chan configure $Chan -blocking 0
            chan configure $outchan -buffering none

            set Prompts [list $Prompt]

            Input create             input
            Output create            output $outchan
            keymap::KeyMapper create keymap $Chan
        }

        method Configure {args} {
            set OptSpec {
                -prompt     { set Prompt $val }
                -chan       { set Chan $val }
                -history    { oo::objdefine [self] forward History     [uplevel 1 [list namespace which $val]] }
................................................................................
                    if {[string match $pat* $key]} {
                        try $script
                        set matched 1
                        break
                    }
                }
                if {!$matched} {
                    return -code error "Unknown option \"$opt\"; expected one of [join [dict keys $OptSpec] ", "]."
                }
            }
        }

        method Prompt {} {
            if {[lindex $Prompts $Lineidx] eq ""} {
                regexp {^(.*)(\S)(\s*)$} $Prompt -> prefix char space
................................................................................

        method Mode {mixin args} {
            oo::objdefine [self] mixin $mixin
        }

        method getline {} {

            if {[info coroutine] eq ""} {
                return -code error "getline must be called within a coroutine!"
            }

            finally chan event $Chan readable [chan event $Chan readable]
            chan event $Chan readable [info coroutine]

            my reset

            while 1 {
                # {TOKEN tok {c c c}} or {LITERAL "" {c c c}}
                lassign [keymap gettok] kind tok chars
                if {$kind eq "TOKEN"} {
                    try {

Name change from getline/history.tcl to modules/getline/history.tcl.

Name change from getline/input.tcl to modules/getline/input.tcl.

1
2
3
4
5
6
7
8
source util.tcl ;# ssplit prepend

oo::class create Input {

    variable input
    variable moreinput

    constructor {{in ""} {idx end}} {
|







1
2
3
4
5
6
7
8
#source util.tcl ;# ssplit prepend

oo::class create Input {

    variable input
    variable moreinput

    constructor {{in ""} {idx end}} {

Name change from getline/keymap.tcl to modules/getline/keymap.tcl.

Name change from getline/main.tcl to modules/getline/main.tcl.

Name change from getline/output.tcl to modules/getline/output.tcl.

1
2
3
4
5
6
7
8
9
source util.tcl     ;# sinsert
source tty.tcl

oo::class create Output {

    # insert has to take {str ?attr? ?...?}
    # repwrap takes the same
    # output becomes an {attr str ...} list
    # .. all the operations using $output need to be re-jiggerd
|
|







1
2
3
4
5
6
7
8
9
#source util.tcl     ;# sinsert
#source tty.tcl

oo::class create Output {

    # insert has to take {str ?attr? ?...?}
    # repwrap takes the same
    # output becomes an {attr str ...} list
    # .. all the operations using $output need to be re-jiggerd

Name change from getline/tty.tcl to modules/getline/tty.tcl.

1
2
3
4
5
6
7
8
source util.tcl    ;# lshift

namespace eval tty {
    namespace path [namespace parent]

    # http://real-world-systems.com/docs/ANSIcode.html#Esc
    proc _def {name args result} {
        set CSI \x1b\[      ;# or \x9b ?
|







1
2
3
4
5
6
7
8
#source util.tcl    ;# lshift

namespace eval tty {
    namespace path [namespace parent]

    # http://real-world-systems.com/docs/ANSIcode.html#Esc
    proc _def {name args result} {
        set CSI \x1b\[      ;# or \x9b ?

Name change from getline/util.tcl to modules/getline/util.tcl.