scripts/checkgroup.itk

   1 # vim: foldmarker=<<<,>>>
   2
   3 # BUGS:
   4 #       Setting the linked textvariable causes the linkage to be broken
   5 #       Need a way to set defaults
   6
   7 # Signals fired:
   8 #       ontoggle(key,value)             - Fired when a check button is toggled
   9
  10 proc tlc::checkgroup {pathname args} {
  11         uplevel [list tlc::Checkgroup $pathname] $args
  12 }
  13
  14
  15 class tlc::Checkgroup {
  16         inherit tlc::Mywidget tlc::Handlers tlc::Signalsource \
  17                         tlc::Tooltips tlc::Textvariable
  18
  19         constructor {args} {}
  20
  21         itk_option define -foreground foreground Foreground black need_rerender
  22         itk_option define -disabledforeground disabledForeground Foreground grey need_rerender
  23
  24         public {
  25                 variable state          ""
  26                 variable choices        {}                      need_rerender
  27                 variable orient         "v"                     need_rerender
  28                 variable cell_args      "-anchor w"     need_rerender
  29                 variable onvalue        1
  30                 variable offvalue       0
  31                 variable mode           "picklist"
  32
  33                 method attach_signal {key signal {sense normal}}
  34                 method path {key}
  35         }
  36
  37         protected {
  38                 method textvariable_changed {newvalue}
  39         }
  40
  41         private {
  42                 variable dominos
  43                 variable toggles
  44                 variable keymap
  45                 variable base
  46                 variable values
  47
  48                 method need_rerender {} {$dominos(need_rerender) tip}
  49                 method rerender {}
  50                 method option_changed {key newvalue}
  51                 method value_changed {}
  52         }
  53 }
  54
  55
  56 configbody tlc::Checkgroup::state { #<<<1
  57         [stategate_ref] configure -default [expr {$state == "normal"}]
  58 }
  59
  60
  61 body tlc::Checkgroup::constructor {args} { #<<<1
  62         if {[catch {
  63                 package require Tk 8.4
  64         } errmsg]} {
  65                 error "Need at least Tk 8.4 for Checkgroup"
  66         }
  67
  68         array set values        {}
  69         array set dominos       {}
  70         array set toggles       {}
  71         array set keymap        {}
  72
  73         tlc::Domino #auto dominos(need_rerender) -name "$w need_rerender"
  74         tlc::Gate #auto signals(item_selected) -name "$w item_selected" \
  75                         -mode "or" -default 0
  76         tlc::Vardomino #auto dominos(value_changed) -name "$w value_changed" \
  77                         -textvariable [scope values]
  78
  79         itk_component add border {
  80                 labelframe $w.border
  81         } {
  82                 keep -borderwidth -relief -text -labelanchor -labelwidget
  83         }
  84
  85         blt::table $w \
  86                         $w.border       1,1 -fill both
  87
  88         set base        $w.border.inner
  89
  90         $dominos(need_rerender) attach_output [code $this rerender]
  91         $dominos(value_changed) attach_output [code $this value_changed]
  92
  93         eval itk_initialize $args
  94
  95         if {[$dominos(need_rerender) pending]} {
  96                 $dominos(need_rerender) tip_now
  97         }
  98 }
  99
 100
 101 body tlc::Checkgroup::rerender {} { #<<<1
 102         foreach key [array names toggles] {
 103                 array unset toggles $key
 104         }
 105         array unset keymap
 106         array set keymap        {}
 107         catch {eval destroy [winfo children $w.border]}
 108         foreach signal [array names signals option_*] {
 109                 array unset signals($signal)
 110         }
 111         frame $w.border.inner
 112         pack $w.border.inner -fill both -expand true
 113
 114         set cseq 1
 115         set rseq 1
 116         foreach {name key} $choices {
 117                 if {![info exists values($key)]} {
 118                         set values($key)        $offvalue
 119                 }
 120
 121                 if {[string first " " $key]} {
 122                         # Itcl bug (still as of 3.3) prevents scope / resolver working
 123                         # with arrays whose keys contain spaces.  We craft our own here
 124                         # that works with the resolver
 125
 126                         set tmp         [scope values($key)]
 127                         set scoped_varname      [concat [lrange $tmp 0 1] [lindex $tmp 2]]
 128                 } else {
 129                         set scoped_varname      [scope values($key)]
 130                 }
 131
 132                 checkbutton $base.$cseq,$rseq -text "$name" \
 133                                 -onvalue $onvalue -offvalue $offvalue \
 134                                 -variable $scoped_varname
 135
 136                 tlc::StateToggle #auto toggles($cseq,$rseq) $base.$cseq,$rseq \
 137                                 -state {disabled normal} \
 138                                 -foreground [list $itk_option(-disabledforeground) \
 139                                         $itk_option(-foreground)]
 140                 $toggles($cseq,$rseq) attach_input [stategate_ref]
 141
 142                 tlc::Signal #auto signals(option_$key) -name "$w option $key selected"
 143                 $signals(item_selected) attach_input $signals(option_$key)
 144                 $signals(option_$key) attach_output [code $this option_changed $key]
 145
 146                 set keymap($key)        "$cseq,$rseq"
 147
 148                 eval [list blt::table $base $base.$cseq,$rseq $rseq,$cseq] \
 149                                 $cell_args
 150
 151                 if {$orient == "h"} {
 152                         incr cseq
 153                 } else {
 154                         incr rseq
 155                 }
 156         }
 157 }
 158
 159
 160 body tlc::Checkgroup::attach_signal {key signal {sense normal}} { #<<<1
 161         if {![info exists keymap($key)]} {error "No such key: ($key)"}
 162
 163         return [$toggles($keymap($key)) attach_input $signal $sense]
 164 }
 165
 166
 167 body tlc::Checkgroup::path {key} { #<<<1
 168         if {[$dominos(need_rerender) pending]} {
 169                 $dominos(need_rerender) tip_now
 170         }
 171
 172         if {![info exists keymap($key)]} {error "No such key: ($key)"}
 173
 174         return "$base.$keymap($key)"
 175 }
 176
 177
 178 body tlc::Checkgroup::option_changed {key newvalue} { #<<<1
 179         invoke_handlers toggle $key $newvalue
 180 }
 181
 182
 183 body tlc::Checkgroup::value_changed {} { #<<<1
 184         switch -- $mode {
 185                 "array" {
 186                         set_textvariable        [array get values]
 187                 }
 188
 189                 "picklist" {
 190                         set picklist    {}
 191                         foreach {key val} [array get values] {
 192                                 if {$val == $onvalue} {
 193                                         lappend picklist        $key
 194                                 }
 195                         }
 196
 197                         set_textvariable        $picklist
 198                 }
 199
 200                 default {
 201                         error "Invalid mode: ($mode)"
 202                 }
 203         }
 204
 205
 206         foreach key [array names keymap] {
 207                 $signals(option_$key) set_state [expr {$values($key) == $onvalue}]
 208         }
 209 }
 210
 211
 212 body tlc::Checkgroup::textvariable_changed {newvalue} { #<<<1
 213         switch -- $mode {
 214                 "array" {
 215                         array set values        $newvalue
 216                 }
 217
 218                 "picklist" {
 219                         foreach {name key} $choices {
 220                                 if {[lsearch $newvalue $key] == -1} {
 221                                         set new_values($key)    $offvalue
 222                                 } else {
 223                                         set new_values($key)    $onvalue
 224                                 }
 225                         }
 226                         array set values        [array get new_values]
 227                 }
 228
 229                 default {
 230                         error "Invalid mode: ($mode)"
 231                 }
 232         }
 233 }
 234
 235