1# -*- tcl -*- 2# ### ### ### ######### ######### ######### 3## Terminal packages - string -> action mappings 4## (menu objects). For use with 'receive listen'. 5## In essence a DFA with tree structure. 6 7# ### ### ### ######### ######### ######### 8## Requirements 9 10package require snit 11package require textutil::repeat 12package require textutil::tabify 13package require term::ansi::send 14package require term::receive::bind 15package require term::ansi::code::ctrl 16 17namespace eval ::term::receive::menu {} 18 19# ### ### ### ######### ######### ######### 20 21snit::type ::term::interact::menu { 22 23 option -in -default stdin 24 option -out -default stdout 25 option -column -default 0 26 option -line -default 0 27 option -height -default 25 28 option -actions -default {} 29 option -hilitleft -default 0 30 option -hilitright -default end 31 option -framed -default 0 -readonly 1 32 33 # ### ### ### ######### ######### ######### 34 ## 35 36 constructor {dict args} { 37 $self configurelist $args 38 Save $dict 39 40 install bind using ::term::receive::bind \ 41 ${selfns}::bind $options(-actions) 42 43 $bind map [cd::cu] [mymethod Up] 44 $bind map [cd::cd] [mymethod Down] 45 $bind map \n [mymethod Select] 46 #$bind default [mymethod DEF] 47 48 return 49 } 50 51 # ### ### ### ######### ######### ######### 52 ## 53 54 method interact {} { 55 Show 56 $bind listen $options(-in) 57 vwait [myvar done] 58 $bind unlisten $options(-in) 59 return $map($done) 60 } 61 62 method done {} {set done $at ; return} 63 method clear {} {Clear ; return} 64 65 # ### ### ### ######### ######### ######### 66 ## 67 68 component bind 69 70 # ### ### ### ######### ######### ######### 71 ## 72 73 variable map -array {} 74 variable header 75 variable labels 76 variable footer 77 variable empty 78 79 proc Save {dict} { 80 upvar 1 header header labels labels footer footer 81 upvar 1 empty empty at at map map top top 82 upvar 1 options(-height) height 83 84 set max 0 85 foreach {l code} $dict { 86 if {[set len [string length $l]] > $max} {set max $len} 87 } 88 89 set header [cd::groptim [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]] 90 set footer [cd::groptim [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc]] 91 92 set labels {} 93 set at 0 94 foreach {l code} $dict { 95 set map($at) $code 96 lappend labels ${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]] 97 incr at 98 } 99 100 set h $height 101 if {$h > [llength $labels]} {set h [llength $labels]} 102 103 set eline " [textutil::repeat::strRepeat { } $max]" 104 set empty $eline 105 for {set i 0} {$i <= $h} {incr i} { 106 append empty \n$eline 107 } 108 109 set at 0 110 set top 0 111 return 112 } 113 114 variable top 0 115 variable at 0 116 variable done . 117 118 proc Show {} { 119 upvar 1 header header labels labels footer footer at at 120 upvar 1 options(-in) in options(-column) col top top 121 upvar 1 options(-out) out options(-line) row 122 upvar 1 options(-height) height options(-framed) framed 123 upvar 1 options(-hilitleft) left 124 upvar 1 options(-hilitright) right 125 126 set bot [expr {$top + $height - 1}] 127 set fr [expr {$framed ? [cd::vl] : { }}] 128 129 set text $header\n 130 set i $top 131 foreach l [lrange $labels $top $bot] { 132 append text $fr 133 if {$i != $at} { 134 append text $l 135 } else { 136 append text [string replace $l $left $right \ 137 [cd::sda_revers][string range $l $left $right][cd::sda_reset]] 138 } 139 append text $fr \n 140 incr i 141 } 142 append text $footer 143 144 vt::wrch $out [cd::showat $row $col $text] 145 return 146 } 147 148 proc Clear {} { 149 upvar 1 empty empty options(-column) col 150 upvar 1 options(-out) out options(-line) row 151 152 vt::wrch $out [cd::showat $row $col $empty] 153 return 154 } 155 156 # ### ### ### ######### ######### ######### 157 ## 158 159 method Up {str} { 160 if {$at == 0} return 161 incr at -1 162 if {$at < $top} {incr top -1} 163 Show 164 return 165 } 166 167 method Down {str} { 168 upvar 0 options(-height) height 169 if {$at == ([llength $labels]-1)} return 170 incr at 171 set bot [expr {$top + $height - 1}] 172 if {$at > $bot} {incr top} 173 Show 174 return 175 } 176 177 method Select {str} { 178 $self done 179 return 180 } 181 182 method DEF {str} { 183 puts stderr "($str)" 184 exit 185 } 186 187 ## 188 # ### ### ### ######### ######### ######### 189} 190 191# ### ### ### ######### ######### ######### 192## Ready 193 194namespace eval ::term::interact::menu { 195 term::ansi::code::ctrl::import cd 196 term::ansi::send::import vt 197} 198 199package provide term::interact::menu 0.1 200 201## 202# ### ### ### ######### ######### ######### 203