tcl-hacks

Check-in [afa40a75e9]
Login

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

Overview
Comment:more tidy
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:afa40a75e914de82eba5cea7f52a16ccb69ba7b1
User & Date: aspect 2018-05-15 15:40:52
Context
2018-05-17
12:43
Multi-line input working, by putting it in [class Getline] rather than the failed separation through subclassing. Net code reduction and getline.tcl still <400loc, so it seems sound. check-in: 6aa8964556 user: aspect tags: trunk
2018-05-15
15:40
more tidy check-in: afa40a75e9 user: aspect tags: trunk
11:51
fix history cursor next-matching check-in: 7f6388e856 user: aspect tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to getline/getline.tcl.

148
149
150
151
152
153
154
155
156
157

158
159
160
161
162
163
164
...
193
194
195
196
197
198
199

200
201
202
203
204
205
206
207

208
209
210
211
212
213
214

    method clear {} {
        set r [input get]
        if {[input rpos]} {my kill-after}
        if {[input pos]} {my kill-before}
        return $r
    }
    method replace-input {s} {
        my clear
        my insert $s

    }

    method set-state {{s ""} {p 0}} {
        input set-state $s $p
        ssplit $s $p -> a b
        set a [srep $a]; set b [srep $b]    ;# attrs? :(
        output set-state $Prompt$a$b [string length $Prompt$a]
................................................................................
        if {$s eq ""}   { my beep "no more history!"; return }
        my replace-input $s
    }
    method history-prev-starting {} {
        set pos [input pos]
        set s [my History prev-starting [input pre] [my get]]
        if {$s eq ""}   { my beep "no more matching history!"; return }

        my kill-after
        my insert [string range $s $pos end]
        my goto $pos
    }
    method history-next-starting {} {
        set pos [input pos]
        set s [my History next-starting [input pre] [my get]]
        if {$s eq ""}   { my beep "no more matching history!"; return }

        my kill-after
        my insert [string range $s $pos end]
        my goto $pos
    }

    method accept {} {
        set input [my get]







|


>







 







>








>







148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
...
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217

    method clear {} {
        set r [input get]
        if {[input rpos]} {my kill-after}
        if {[input pos]} {my kill-before}
        return $r
    }
    method replace-input {s {pos 0}} {
        my clear
        my insert $s
        my goto $pos
    }

    method set-state {{s ""} {p 0}} {
        input set-state $s $p
        ssplit $s $p -> a b
        set a [srep $a]; set b [srep $b]    ;# attrs? :(
        output set-state $Prompt$a$b [string length $Prompt$a]
................................................................................
        if {$s eq ""}   { my beep "no more history!"; return }
        my replace-input $s
    }
    method history-prev-starting {} {
        set pos [input pos]
        set s [my History prev-starting [input pre] [my get]]
        if {$s eq ""}   { my beep "no more matching history!"; return }
        # my replace-input $s $pos
        my kill-after
        my insert [string range $s $pos end]
        my goto $pos
    }
    method history-next-starting {} {
        set pos [input pos]
        set s [my History next-starting [input pre] [my get]]
        if {$s eq ""}   { my beep "no more matching history!"; return }
        # my replace-input $s $pos
        my kill-after
        my insert [string range $s $pos end]
        my goto $pos
    }

    method accept {} {
        set input [my get]

Changes to getline/getlines.tcl.

16
17
18
19
20
21
22


23
24



25
26
27
28
29
30
31

    method reset {} {
        set Lines [list ""]
        set Lineidx 0
        next
    }



    method getline {} {
        my reset



        try {
            next
        } on break {} {
            return -code break
        } on continue {} {
            return -code continue
        }







>
>
|

>
>
>







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

    method reset {} {
        set Lines [list ""]
        set Lineidx 0
        next
    }

    # method goto .. count lines

    method clear {} {
        my reset
    }

    method getline {} {
        try {
            next
        } on break {} {
            return -code break
        } on continue {} {
            return -code continue
        }

Changes to getline/main.tcl.














1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
68
69
70
71
72
73
74

75
76
77

78
79

80

81
82
83
84
85
86
87













# TODO:
#  _ eliminate the bugs I've added with multiline + history + state
#   _ getlines superclass getline is the real culprit here
#  x char-wise nav
#  x line-wise nav
#  x wrap handling
#  x word-wise nav
#  x history (basic)
#  x history-search
#  x basic yank
#  x C-x C-e EDITOR (get smarter)
#  x flash message
#  x tcloo'ify
#  x multi-line input (debug further)
#   - fix line joinage: too much redraw by far
#   - continuation prompts
#   - multi-line redraw (just a keymap / action naming thing?)
#  x fix up history
#  x objectify keymap
#  x -options to Getline, move history etc into components
#  x chan independence
#  - use throw for accept .. and beep?
................................................................................

source getline.tcl
source getlines.tcl

proc main {args} {
    exec stty raw -echo <@ stdin
    trace add variable args unset {apply {args {exec stty -raw echo <@ stdin}}}

    chan configure stdin -blocking 0
    chan configure stdout -buffering none
    chan event stdin readable [info coroutine]

    set prompt "\[[info patch]\]% "
    Getline create getline -prompt $prompt

    finally getline destroy

    while 1 {
        set input [getline getline]             ;# can return -code break/continue
        puts " -> {[srep $input]}"
    }
}

if 0 {
>
>
>
>
>
>
>
>
>
>
>
>
>

<
<











|







 







>



>

|
>

>







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
..
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
#
# The sticky point right now is the relationship between Getline and Getlines:
# as a subclass, Getlines wants to redefine some of its parent's methods to
# provide whole-input behaviour, while other methods it wants to preserve as
# single-line actions.  This, in an inheritance scenario, leads to some odd
# conflicts.
#
# I think the solution is (of course) composition:
#  - Getlines has-a Getline
#  - Getlines getline tries to dispatch on its own methods first
#  - those explicitly call down to Getline where appropriate
#  - whole-input-replacing actions (history-*) need to "call up"

# TODO:


#  x char-wise nav
#  x line-wise nav
#  x wrap handling
#  x word-wise nav
#  x history (basic)
#  x history-search
#  x basic yank
#  x C-x C-e EDITOR (get smarter)
#  x flash message
#  x tcloo'ify
#  x multi-line input (debug further)
#   x fix line joinage: too much redraw by far
#   - continuation prompts
#   - multi-line redraw (just a keymap / action naming thing?)
#  x fix up history
#  x objectify keymap
#  x -options to Getline, move history etc into components
#  x chan independence
#  - use throw for accept .. and beep?
................................................................................

source getline.tcl
source getlines.tcl

proc main {args} {
    exec stty raw -echo <@ stdin
    trace add variable args unset {apply {args {exec stty -raw echo <@ stdin}}}

    chan configure stdin -blocking 0
    chan configure stdout -buffering none
    chan event stdin readable [info coroutine]

    set prompt "\[[info patch]\]% "
    Getlines create getline -prompt $prompt

    finally getline destroy

    while 1 {
        set input [getline getline]             ;# can return -code break/continue
        puts " -> {[srep $input]}"
    }
}

if 0 {

Changes to getline/output.tcl.

46
47
48
49
50
51
52


53
54
55
56
57
58
59
    method rpos {} {expr {[string length $output]-$pos}}

    method reset {prompt} {
        #my flash-message [list [self] reset from [info level -1] from [info level -2]]
        set r [my get]
        set output ""
        set pos 0


        my insert $prompt
        #my redraw
        return $r
    }
    method set-state {s p} {
        set output $s
        set pos $p







>
>







46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
    method rpos {} {expr {[string length $output]-$pos}}

    method reset {prompt} {
        #my flash-message [list [self] reset from [info level -1] from [info level -2]]
        set r [my get]
        set output ""
        set pos 0
        my emit [tty::goto-col 0]
        my emit [tty::erase-to-end]
        my insert $prompt
        #my redraw
        return $r
    }
    method set-state {s p} {
        set output $s
        set pos $p

Changes to getline/util.tcl.

54
55
56
57
58
59
60
61
62
63


64

65
66
67








68
69
70
71
72
73
74

proc prepend {_str prefix} {
    upvar 1 $_str str
    set str $prefix$str
}

proc watchproc {name} {
    rename $name _$name
    proc $name args [format {
        puts "> %1$s $args"


        set r [uplevel 1 _%1$s $args]

        puts "< $r"
        return $r
    } $name]








}

proc watchvar {varname} {
    uplevel 1 [list trace add variable $varname {read write unset} [callback watchvar_cb]]
}

proc watchvar_cb args {







|
<
<
>
>
|
>
|
<
|
>
>
>
>
>
>
>
>







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

proc prepend {_str prefix} {
    upvar 1 $_str str
    set str $prefix$str
}

proc watchproc {name} {
    uplevel 1 [list trace add execution $name {enter leave} [callback watchproc_cb]]


}

proc watchproc_cb {cmd args} {
    if {[lindex $args end] eq "enter"} {
        puts "TRACE > $cmd"

        while 1 {
            try {
                puts "      | [info level [incr l -1]]"
            } on error {} break
        }
    } else {
        lassign $args code result
        puts "TRA $code < $result"
    }
}

proc watchvar {varname} {
    uplevel 1 [list trace add variable $varname {read write unset} [callback watchvar_cb]]
}

proc watchvar_cb args {