tcl-hacks

Check-in [d67dd249f2]
Login

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

Overview
Comment:a bit of tidy
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:d67dd249f2705ec7df211b7c1fadef010ea40e0e
User & Date: aspect 2018-05-15 10:20:27
Context
2018-05-15
10:52
more tidy, note some introduced bugs found interactively check-in: 71103c9573 user: aspect tags: trunk
10:20
a bit of tidy check-in: d67dd249f2 user: aspect tags: trunk
10:05
put some utils where they belong check-in: 0f12101f26 user: aspect tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to getline/getline.tcl.

44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
...
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
...
312
313
314
315
316
317
318











319
320
321
322
323
324
325
...
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
    return "\\x[binary encode hex $c]"
}

proc srep {s} {
    join [lmap c [split $s ""] {rep $c}] ""
}

proc complete? {s} {info complete $s\n}

proc word-length-before {s i} {
    set j 0
    foreach ab [regexp -inline -indices -all {.\m} $s] {
        lassign $ab a b
        incr a
        if {$a >= $i} break
        set j $a
................................................................................
                    engine $tok
                    continue
                } trap {TCL LOOKUP METHOD *} {} { }
            }
            foreach char $chars {
                engine insert $char
            }
            # if [getline display-rows] has changed, redraw-following
        }
    }

    method beep {msg} {
        output beep
        if {$msg ne ""} {tailcall output flash-message $msg}
    }
................................................................................

    constructor {args} {
        set Lines   [list ""]
        set Lineidx 0
        next {*}$args
        set Prompts [list $Prompt]
    }












    method get {} {
        lset Lines $Lineidx [input get]
        join $Lines \n
    }

    method redraw-following {} {
................................................................................
        }
        my set-state $line $pos
    }

    # [insert \n] might create a new line!
    method newline {} {
        set input [my get]
        if {[complete? $input]} {
            # FIXME: go down
            tailcall my accept
        }
        my insert \n
    }

    method insert {s} {







<
<







 







<







 







>
>
>
>
>
>
>
>
>
>
>







 







|







44
45
46
47
48
49
50


51
52
53
54
55
56
57
...
134
135
136
137
138
139
140

141
142
143
144
145
146
147
...
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
...
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
    return "\\x[binary encode hex $c]"
}

proc srep {s} {
    join [lmap c [split $s ""] {rep $c}] ""
}



proc word-length-before {s i} {
    set j 0
    foreach ab [regexp -inline -indices -all {.\m} $s] {
        lassign $ab a b
        incr a
        if {$a >= $i} break
        set j $a
................................................................................
                    engine $tok
                    continue
                } trap {TCL LOOKUP METHOD *} {} { }
            }
            foreach char $chars {
                engine insert $char
            }

        }
    }

    method beep {msg} {
        output beep
        if {$msg ne ""} {tailcall output flash-message $msg}
    }
................................................................................

    constructor {args} {
        set Lines   [list ""]
        set Lineidx 0
        next {*}$args
        set Prompts [list $Prompt]
    }

    method getline {} {
        try {
            next
        } on break {} {
            return -code break
        } on continue {} {
            return -code continue
        }
        # FIXME: if [my display-rows] has changed, redraw-following
    }

    method get {} {
        lset Lines $Lineidx [input get]
        join $Lines \n
    }

    method redraw-following {} {
................................................................................
        }
        my set-state $line $pos
    }

    # [insert \n] might create a new line!
    method newline {} {
        set input [my get]
        if {[my Complete? $input]} {
            # FIXME: go down
            tailcall my accept
        }
        my insert \n
    }

    method insert {s} {

Changes to getline/history.tcl.

63
64
65
66
67
68
69

70
71
72
73
74
75
76
    }
    destructor {
        my cursor destroy
    }

    method cursor {args} {
        if {$Cursor eq ""} {

            set Cursor [HistoryCursor new $Items]
        }
        if {$args eq {destroy}} {
            $Cursor destroy
            set Cursor ""
            return
        }







>







63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
    }
    destructor {
        my cursor destroy
    }

    method cursor {args} {
        if {$Cursor eq ""} {
            if {$args eq {destroy}} return
            set Cursor [HistoryCursor new $Items]
        }
        if {$args eq {destroy}} {
            $Cursor destroy
            set Cursor ""
            return
        }

Changes to getline/output.tcl.

4
5
6
7
8
9
10

11
12
13
14
15
16
17




18
19
20
21
22
23
24
...
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
oo::class create Output {

    variable chan
    variable output
    variable pos
    variable cols
    variable rows


    constructor {Chan} {
        set pos 0
        set output ""
        lassign [exec stty size <@ stdin] rows cols
        set chan $Chan
    }





    method emit {s} {
        if {[string match \x1b* $s]} {
            puts -nonewline $chan $s
        } else {
            foreach c [split $s ""] {
                puts -nonewline $chan $c
................................................................................
        my delete $n
    }

    method beep {} {
        my emit \x07
    }
    method flash-message {msg} {
        variable flashid
        catch {after cancel $flashid}
        my emit [tty::save]
        lassign [exec stty size] rows cols
        my emit [tty::goto 0 [expr {$cols - [string length $msg] - 2}]]
        my emit [tty::attr bold]
        my emit " $msg "
        my emit [tty::attr]
        my emit [tty::restore]
        if {[string is space $msg]} return
        regsub -all . $msg " " msg
        set flashid [after 1000 [list [self] flash-message $msg]]
    }
}







>







>
>
>
>







 







<













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
...
133
134
135
136
137
138
139

140
141
142
143
144
145
146
147
148
149
150
151
152
oo::class create Output {

    variable chan
    variable output
    variable pos
    variable cols
    variable rows
    variable flashid

    constructor {Chan} {
        set pos 0
        set output ""
        lassign [exec stty size <@ stdin] rows cols
        set chan $Chan
    }

    destructor {
        catch {after cancel $flashid}
    }

    method emit {s} {
        if {[string match \x1b* $s]} {
            puts -nonewline $chan $s
        } else {
            foreach c [split $s ""] {
                puts -nonewline $chan $c
................................................................................
        my delete $n
    }

    method beep {} {
        my emit \x07
    }
    method flash-message {msg} {

        catch {after cancel $flashid}
        my emit [tty::save]
        lassign [exec stty size] rows cols
        my emit [tty::goto 0 [expr {$cols - [string length $msg] - 2}]]
        my emit [tty::attr bold]
        my emit " $msg "
        my emit [tty::attr]
        my emit [tty::restore]
        if {[string is space $msg]} return
        regsub -all . $msg " " msg
        set flashid [after 1000 [list [self] flash-message $msg]]
    }
}

Changes to getline/util.tcl.

1
2
3
4
5
6





7
8
9
10
11
12
13
..
57
58
59
60
61
62
63









64
65
66
67
68
69
70
71
72
73
proc putl args {puts $args}

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






proc alias {alias cmd args} {
    set ns [uplevel 1 {namespace current}]
    set cmd [uplevel 1 namespace which $cmd]
    interp alias ${ns}::$alias $cmd {*}$args
}

................................................................................
    proc $name args [format {
        puts "> %1$s $args"
        set r [uplevel 1 _%1$s $args]
        puts "< $r"
        return $r
    } $name]
}










proc lshift {varName} {
    upvar 1 $varName ls
    if {$ls eq ""} {
        throw {LSHIFT EMPTY} "Attempt to shift empty list\$$varName"
    }
    set ls [lassign $ls r]
    return $r
}







>
>
>
>
>







 







>
>
>
>
>
>
>
>
>










1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
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
proc putl args {puts $args}

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

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

proc alias {alias cmd args} {
    set ns [uplevel 1 {namespace current}]
    set cmd [uplevel 1 namespace which $cmd]
    interp alias ${ns}::$alias $cmd {*}$args
}

................................................................................
    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 {
    puts "WATCH $args"
    puts " < [info level -1]"
}

proc lshift {varName} {
    upvar 1 $varName ls
    if {$ls eq ""} {
        throw {LSHIFT EMPTY} "Attempt to shift empty list\$$varName"
    }
    set ls [lassign $ls r]
    return $r
}