scripts/mycombobox.itk

   1 # vim: foldmarker=<<<,>>>
   2
   3 option add *Mycombobox.buttonBorderwidth                1               widgetDefault
   4 option add *Mycombobox.borderWidth                              1               widgetDefault
   5 option add *Mycombobox.relief                                   sunken  widgetDefault
   6 option add *Mycombobox.entryBorderwidth                 0               widgetDefault
   7 option add *Mycombobox.entryRelief                              flat    widgetDefault
   8
   9
  10 ::itk::usual Mycombobox {
  11         keep -background -cursor -foreground -font -textbackground
  12         keep -insertbackground -insertborderwidth -insertwidth
  13         keep -insertontime -insertofftime
  14         keep -selectbackground -selectborderwidth -selectforeground
  15         keep -highlightcolor -highlightthickness -state
  16 }
  17
  18
  19 proc tlc::mycombobox {pathName args} {
  20         uplevel tlc::Mycombobox [list $pathName] $args
  21 }
  22
  23
  24 class tlc::Mycombobox {
  25         inherit tlc::Mywidget Handlers
  26
  27         constructor {args} {}
  28
  29 #       itk_option define -choices choices Choices {}
  30 #       itk_option define -state state State normal
  31
  32         public {
  33                 variable choices                {}
  34                 variable cb                             {}
  35                 variable initial_choice ""
  36
  37                 method bbox {args}              {uplevel $w.e bbox $args}
  38 #               method cget {args}              {uplevel $w.e cget $args}
  39 #               method configure {args} {uplevel $w.e configure $args}
  40                 method delete {args}    {uplevel $w.e delete $args}
  41                 method get {args}               {uplevel $w.e get $args}
  42                 method icursor {args}   {uplevel $w.e icursor $args}
  43                 method index {args}             {uplevel $w.e index $args}
  44                 method insert {args}    {uplevel $w.e insert $args}
  45                 method scan {args}              {uplevel $w.e scan $args}
  46                 method selection {args} {uplevel $w.e selection $args}
  47                 method validate {args}  {uplevel $w.e validate $args}
  48                 method xview {args}             {uplevel $w.e xview $args}
  49
  50                 method set_choice {newidx text}
  51                 method set_choices {list}
  52                 method prev {}
  53                 method next {}
  54                 method popdown {}
  55                 method get_idx {}
  56                 method if_val {value}
  57                 method if_expr {expr}           ;# %v is the current value selected
  58         }
  59
  60
  61         private {
  62                 variable idx    0
  63                 variable expr_signals
  64                 variable val_signals
  65
  66                 common droparrow_icon
  67
  68                 variable listobj
  69
  70                 method key_popup {}
  71                 method dropdown {}
  72                 method popup {}
  73                 method statechange_cb {newstate}
  74                 method onselect {value}
  75                 method onselect_id {idx}
  76         }
  77 }
  78
  79
  80 configbody tlc::Mycombobox::initial_choice { #<<<1
  81         set nidx                [lsearch $choices $initial_choice]
  82         if {$nidx == -1} return
  83         set_choice $nidx [lindex $choices $nidx]
  84 }
  85
  86
  87 body tlc::Mycombobox::constructor {args} { #<<<1
  88         array set expr_signals {}
  89         array set val_signals {}
  90
  91         if {![info exists droparrow]} {
  92                 set droparrow_icon      [image create photo \
  93                                 -file [file join $::tlc::library scripts images droparrow.gif]]
  94         }
  95
  96         itk_component add entry {
  97                 entry $w.e -highlightbackground white -borderwidth 0
  98         } {
  99                 rename -background -textbackground textBackground TextBackground
 100                 rename -highlightbackground -background background Background
 101                 rename -borderwidth -entryborderwidth entryBorderwidth EntryBorderwidth
 102                 rename -relief -entryrelief entryRelief EntryRelief
 103
 104                 keep -cursor -exportselection -font -foreground \
 105                         -highlightbackground -highlightcolor -highlightthickness \
 106                         -insertbackground -insertborderwidth -insertofftime \
 107                         -insertontime -insertwidth -invalidcommand -justify \
 108                         -selectbackground -selectborderwidth -selectforeground \
 109                         -show -takefocus -textvariable -validate -validatecommand \
 110                         -width -xscrollcommand
 111                 keep -state
 112         }
 113
 114         itk_component add button {
 115                 button $w.b -image $droparrow_icon -pady 0 -padx 4 \
 116                         -command [code $this dropdown] -takefocus 0
 117         } {
 118 #               usual
 119                 rename -borderwidth -buttonborderwidth buttonBorderwidth Width
 120                 ignore -relief
 121                 ignore -command
 122                 ignore -takefocus
 123                 keep -state
 124         }
 125
 126         itk_component add popup {
 127                 set the_list [tlc::Comboselect $w.#auto -parent $this]
 128         } {
 129                 keep -maxheight -listwidth -textbackground
 130         }
 131         $the_list register_handler onselect [code $this onselect]
 132         $the_list register_handler onselect_id [code $this onselect_id]
 133
 134         # Hint to the parent class (Stategate_target) which widgets are to be
 135         # visually updated manually
 136         set bg_change   $w.e
 137
 138         set listobj             $itk_component(popup)
 139
 140         table $w \
 141                 $w.e            1,1 -fill x \
 142                 $w.b            1,2 -fill y
 143         table configure $w c2 -resize none
 144
 145         bind $w <Button> [code $this popdown]
 146         bind $w <Key> [code $this popdown]
 147 #       bind [$w.e component entry] <Key-Down> [code $this key_popup]
 148 #       bind [$w.e component entry] <Button-4> [code $this prev]
 149 #       bind [$w.e component entry] <Button-5> [code $this next]
 150         bind $w.e <Key-Down> [code $this key_popup]
 151         bind $w.e <Button-4> [code $this prev]
 152         bind $w.e <Button-5> [code $this next]
 153         $w.e configure -text $initial_choice
 154         eval itk_initialize $args
 155 }
 156
 157
 158 body tlc::Mycombobox::key_popup {} { #<<<1
 159         popup
 160         $listobj select 0
 161 }
 162
 163
 164 body tlc::Mycombobox::dropdown {} { #<<<1
 165         if {[winfo ismapped $listobj]} {
 166                 popdown
 167         } else {
 168                 popup
 169         }
 170 }
 171
 172
 173 body tlc::Mycombobox::popup {} { #<<<1
 174         grab -global $w
 175         set tmpx                [winfo rootx $w.b]
 176         set tmpy                [winfo rooty $w.b]
 177
 178         table arrange $w
 179         update idletasks
 180         foreach {id x y wd ht} [table extents $w c2] {break}
 181 #       puts stderr [list $id $tmpx $tmpy $wd $ht]
 182
 183         set botx                [expr $tmpx + $wd]
 184         set boty                [expr $tmpy + $ht]
 185
 186         $listobj set_choices [lrange $choices 0 end]
 187
 188 # populate
 189
 190         set listwidth   [winfo reqwidth $listobj]
 191 #       puts stderr "listwidth: ($listwidth)"
 192         wm overrideredirect $listobj 1
 193         wm positionfrom $listobj user
 194
 195         $itk_component(button) configure -relief sunken
 196
 197 #       puts stderr "xy ([expr $botx - $listwidth], $boty)"
 198         $listobj moveto [expr $botx - $listwidth] $boty
 199         $listobj show
 200
 201         focus [$listobj component list]
 202 }
 203
 204
 205 body tlc::Mycombobox::popdown {} { #<<<1
 206 #       puts stderr "popdown ([winfo ismapped $listobj])"
 207         if {[winfo ismapped $listobj]} {
 208                 grab release $w
 209                 $listobj hide
 210
 211                 $itk_component(button) configure -relief raised
 212
 213                 focus $w.e
 214                 if {[info exists idx]} {
 215                 }
 216         }
 217 }
 218
 219
 220 body tlc::Mycombobox::set_choice {newidx text} { #<<<1
 221         set idx         $newidx
 222         if {$itk_option(-textvariable) != ""} {
 223                 set $itk_option(-textvariable)  $text
 224         } else {
 225                 set os  [$w.e cget -state]
 226                 $w.e configure -state normal
 227                 delete 0 end
 228                 insert 0 $text
 229                 $w.e configure -state $os
 230         }
 231
 232         foreach {val sig} [array get val_signals] {
 233                 $sig set_state [expr {$text == $val}]
 234         }
 235         foreach {expr sig} [array get expr_signals] {
 236                 set expr        [string map [list %v $text] $expr]
 237                 $sig set_state [expr ($expr) ? 1 : 0]
 238         }
 239
 240         if {$cb != {}} {
 241                 uplevel #0 $cb [list $text]
 242         }
 243
 244         popdown
 245 }
 246
 247
 248 body tlc::Mycombobox::set_choices {list} { #<<<1
 249         set choices     $list
 250
 251         $listobj set_choices [lrange $choices 0 end]
 252 }
 253
 254
 255 body tlc::Mycombobox::prev {} { #<<<1
 256         if {$itk_option(-state) == "disabled"} return
 257         if {$idx > 0} {
 258                 incr idx        -1
 259                 set_choice $idx [lindex $choices $idx]
 260         }
 261 }
 262
 263
 264 body tlc::Mycombobox::next {} { #<<<1
 265         if {$itk_option(-state) == "disabled"} return
 266         if {$idx < [expr {[llength $choices] - 1}]} {
 267                 incr idx        1
 268                 set_choice $idx [lindex $choices $idx]
 269         }
 270 }
 271
 272
 273 body tlc::Mycombobox::statechange_cb {newstate} { #<<<1
 274 #       puts stderr "state: ($newstate)"
 275         $itk_component(button) configure -state $newstate
 276         $itk_component(entry) configure -state $newstate
 277
 278         if {$newstate == "disabled"} {
 279                 $itk_component(entry) configure -background $::cfg(disabledbackground)
 280                 popdown
 281         }
 282 }
 283
 284
 285 body tlc::Mycombobox::get_idx {} { #<<<1
 286         if {![info exists idx]} {
 287                 return {}
 288         } else {
 289                 return $idx
 290         }
 291 }
 292
 293
 294 body tlc::Mycombobox::onselect {val} { #<<<1
 295         invoke_handlers onselect [list $val]
 296 }
 297
 298
 299 body tlc::Mycombobox::onselect_id {idx} { #<<<1
 300         invoke_handlers onselect_id [list $idx]
 301 }
 302
 303
 304 body tlc::Mycombobox::if_val {value} { #<<<1
 305         if {![info exists val_signals($value)]} {
 306                 Signal #auto val_signals($value) -name "$w val_signal $value"
 307         }
 308
 309         return $val_signals($value)
 310 }
 311
 312
 313 body tlc::Mycombobox::if_expr {expr} { #<<<1
 314         if {![info exists expr_signals($expr)]} {
 315                 Signal #auto expr_signals($expr) -name "$w expr_signal $expr"
 316         }
 317
 318         return $expr_signals($expr)
 319 }
 320
 321