blob: 7166b31692a816e5261827f97878767007f314f6 (
plain)
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
201
202
|
# -*- tcl -*-
# ### ### ### ######### ######### #########
## Terminal packages - string -> action mappings
## (menu objects). For use with 'receive listen'.
## In essence a DFA with tree structure.
# ### ### ### ######### ######### #########
## Requirements
package require snit
package require textutil::repeat
package require textutil::tabify
package require term::ansi::send
package require term::receive::bind
package require term::ansi::code::ctrl
namespace eval ::term::receive::menu {}
# ### ### ### ######### ######### #########
snit::type ::term::interact::menu {
option -in -default stdin
option -out -default stdout
option -column -default 0
option -line -default 0
option -height -default 25
option -actions -default {}
option -hilitleft -default 0
option -hilitright -default end
option -framed -default 0 -readonly 1
# ### ### ### ######### ######### #########
##
constructor {dict args} {
$self configurelist $args
Save $dict
install bind using ::term::receive::bind \
${selfns}::bind $options(-actions)
$bind map [cd::cu] [mymethod Up]
$bind map [cd::cd] [mymethod Down]
$bind map \n [mymethod Select]
#$bind default [mymethod DEF]
return
}
# ### ### ### ######### ######### #########
##
method interact {} {
Show
$bind listen $options(-in)
vwait [myvar done]
$bind unlisten $options(-in)
return $map($done)
}
method done {} {set done $at ; return}
method clear {} {Clear ; return}
# ### ### ### ######### ######### #########
##
component bind
# ### ### ### ######### ######### #########
##
variable map -array {}
variable header
variable labels
variable footer
variable empty
proc Save {dict} {
upvar 1 header header labels labels footer footer
upvar 1 empty empty at at map map top top
upvar 1 options(-height) height
set max 0
foreach {l code} $dict {
if {[set len [string length $l]] > $max} {set max $len}
}
set header [cd::groptim [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]]
set footer [cd::groptim [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc]]
set labels {}
set at 0
foreach {l code} $dict {
set map($at) $code
lappend labels ${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]]
incr at
}
set h $height
if {$h > [llength $labels]} {set h [llength $labels]}
set eline " [textutil::repeat::strRepeat { } $max]"
set empty $eline
for {set i 0} {$i <= $h} {incr i} {
append empty \n$eline
}
set at 0
set top 0
return
}
variable top 0
variable at 0
variable done .
proc Show {} {
upvar 1 header header labels labels footer footer at at
upvar 1 options(-in) in options(-column) col top top
upvar 1 options(-out) out options(-line) row
upvar 1 options(-height) height options(-framed) framed
upvar 1 options(-hilitleft) left
upvar 1 options(-hilitright) right
set bot [expr {$top + $height - 1}]
set fr [expr {$framed ? [cd::vl] : { }}]
set text $header\n
set i $top
foreach l [lrange $labels $top $bot] {
append text $fr
if {$i != $at} {
append text $l
} else {
append text [string replace $l $left $right \
[cd::sda_revers][string range $l $left $right][cd::sda_reset]]
}
append text $fr \n
incr i
}
append text $footer
vt::wrch $out [cd::showat $row $col $text]
return
}
proc Clear {} {
upvar 1 empty empty options(-column) col
upvar 1 options(-out) out options(-line) row
vt::wrch $out [cd::showat $row $col $empty]
return
}
# ### ### ### ######### ######### #########
##
method Up {str} {
if {$at == 0} return
incr at -1
if {$at < $top} {incr top -1}
Show
return
}
method Down {str} {
upvar 0 options(-height) height
if {$at == ([llength $labels]-1)} return
incr at
set bot [expr {$top + $height - 1}]
if {$at > $bot} {incr top}
Show
return
}
method Select {str} {
$self done
return
}
method DEF {str} {
puts stderr "($str)"
exit
}
##
# ### ### ### ######### ######### #########
}
# ### ### ### ######### ######### #########
## Ready
namespace eval ::term::interact::menu {
term::ansi::code::ctrl::import cd
term::ansi::send::import vt
}
package provide term::interact::menu 0.1
##
# ### ### ### ######### ######### #########
|
