scripts/mdt.itk

   1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4
   2
   3 # Signals fired:
   4 #       nopages                 - when no pages are left in the tabset
   5 #       tab_raised              - when a tab is selected / raised
   6
   7 class tlc::MDT {
   8         inherit tlc::Mywidget tlc::Signalsource tlc::Baselog tlc::Handlers
   9
  10         constructor {args} {}
  11         destructor {}
  12
  13         itk_option define -autoselect autoSelect AutoSelect "1"
  14         itk_option define -showifone showIfOne ShowIfOne "1"
  15         itk_option define -changedcolour changedColour ChangedColour "red"
  16         itk_option define -closebutton closeButton CloseButton 1
  17
  18         public {
  19                 method new_page {key name widget {index end}}
  20                 method child_base {} {return [list $w.tabset]}
  21                 method key_exists {key}
  22                 method select_page {key}
  23                 method selected_page_widget {}
  24                 method remove_page {key}
  25                 method notify_change {key}
  26                 method list_pages {}
  27                 method selected_signal_ref {signame {default 0}}
  28         }
  29
  30         private {
  31                 variable assoc
  32                 variable idx
  33                 variable selectors
  34                 variable selected_page
  35                 variable toggles
  36
  37                 method onselect {id}
  38                 method recalc_idx {}
  39                 method close_current {}
  40                 method select_tab {id}
  41                 method tab_changed {}
  42                 method widget_died {key oldname newname op}
  43         }
  44 }
  45
  46
  47 body tlc::MDT::constructor {args} { #<<<1
  48         log debug $w
  49         array set assoc         {}
  50         array set idx           {}
  51         array set selectors     {}
  52         array set toggles       {}
  53
  54         tlc::Signal #auto signals(empty) -name "$w empty"
  55         $signals(empty) set_state 1
  56
  57         itk_initialize {*}$args
  58
  59         ttk::notebook $w.tabset -width 750 -height 160
  60
  61         ttk::label $w.close -text "X" \
  62                         -font [$tlc::theme setting boldfont]
  63         bind $w.close <ButtonRelease-1> [code $this close_current]
  64
  65         tlc::StateToggle #auto toggles(close_current) $w.close \
  66                         -state {disabled normal}
  67         $toggles(close_current) attach_signal $signals(empty) inverted
  68
  69         blt::table $w \
  70                         $w.tabset       1,1 -fill both
  71
  72         if {$itk_option(-closebutton)} {
  73                 blt::table $w \
  74                                 $w.close        1,1 -anchor ne -pady {2 0} -padx {0 2}
  75         }
  76
  77         bind $w.tabset <<NotebookTabChanged>> [code $this tab_changed]
  78 }
  79
  80
  81 body tlc::MDT::destructor {} { #<<<1
  82         log debug $w
  83         foreach {key widget} [list_pages] {
  84                 remove_page $key
  85         }
  86 }
  87
  88
  89 body tlc::MDT::new_page {key name widget {index end}} { #<<<1
  90         log debug
  91         if {[info exists assoc($key)]} {
  92                 error "page already exists with that key: ($key)"
  93         }
  94         set res [$w.tabset insert $index $widget -text $name]
  95         set assoc($key) [list $key $name $widget]
  96         recalc_idx
  97         set id  $idx($key)
  98
  99         foreach {sigcode signal} [array get selectors] {
 100                 set signame     [lindex $sigcode 0]
 101                 if {[catch {
 102                         log debug "attaching signal $signame associated with $key"
 103                         $selectors($sigcode) attach_input $key [$widget signal_ref $signame]
 104                 } errmsg]} {
 105                         log error "error attaching signal $signame associated with key $key:\n$::errorInfo"
 106                 }
 107         }
 108
 109         log debug "id: ($id) res: ($res)"
 110
 111         if {$itk_option(-autoselect)} {
 112                 select_tab $id
 113         }
 114
 115         #trace add command $widget delete [list apply {
 116         #       {key oldname newname op} {
 117         #               puts stderr "oldname: ($oldname) newname: ($newname) op: ($op) key: ($key)"
 118         #       }} $key]
 119         trace add command $widget delete [code widget_died $key]
 120         $signals(empty) set_state 0
 121 }
 122
 123
 124 body tlc::MDT::select_page {key} { #<<<1
 125         log debug
 126         if {![info exists idx($key)]} {
 127                 error "no such page: ($key)"
 128         }
 129
 130         set id  $idx($key)
 131         select_tab $id
 132 }
 133
 134
 135 body tlc::MDT::remove_page {key} { #<<<1
 136         log debug
 137         if {![info exists assoc($key)]} {
 138                 error "no such page: ($key)"
 139         }
 140         catch {
 141                 set id  $idx($key)
 142         }
 143         foreach {key name widget} $assoc($key) break
 144         array unset assoc $key
 145         array unset idx $key
 146
 147         if {[llength [array names assoc]] == 0} {
 148                 $signals(empty) set_state 1
 149                 catch {unset selected_page}
 150         }
 151
 152         catch {
 153                 $w.tabset forget $id
 154         }
 155         recalc_idx
 156         set last_key    [lindex [array names assoc] end]
 157         log debug "calling destroy ($widget)"
 158         if {[winfo exists $widget]} {
 159                 if {[itcl::is object $widget]} {
 160                         delete object $widget
 161                 } else {
 162                         destroy $widget
 163                 }
 164         }
 165         log debug "done calling destroy ($widget)"
 166         if {$last_key != ""} {
 167                 catch {
 168                         select_tab $idx($last_key)
 169                 }
 170         }
 171
 172         set size        [llength [$w.tabset tabs]]
 173         if {$size == 0} {
 174                 invoke_handlers nopages
 175         }
 176 }
 177
 178
 179 body tlc::MDT::notify_change {key} { #<<<1
 180         log debug
 181         if {![info exists assoc($key)]} {
 182                 error "no such page: ($key)"
 183         }
 184         foreach {key name widget} $assoc($key) break
 185 }
 186
 187
 188 body tlc::MDT::list_pages {} { #<<<1
 189         log debug
 190         return [array get assoc]
 191 }
 192
 193
 194 body tlc::MDT::onselect {key} { #<<<1
 195         log debug
 196         if {![info exists assoc($key)]} {
 197                 error "no such page: ($key)"
 198         }
 199         foreach {key name widget} $assoc($key) break
 200         foreach {sigcode signal} [array get selectors] {
 201                 log debug "selecting token $key from selectors($sigcode)"
 202                 $signal select $key
 203         }
 204         set selected_page       $key
 205         invoke_handlers tab_raised $key
 206 }
 207
 208
 209 body tlc::MDT::recalc_idx {} { #<<<1
 210         log debug
 211         array unset idx
 212         array set idx   {}
 213         foreach key [array names assoc] {
 214                 foreach {key name widget} $assoc($key) break
 215                 catch {
 216                         set idx($key)   [$w.tabset index $widget]
 217                 }
 218         }
 219 }
 220
 221
 222 body tlc::MDT::selected_signal_ref {signame {default 0}} { #<<<1
 223         log debug
 224         set sigcode     [list $signame $default]
 225         if {![info exists selectors($sigcode)]} {
 226                 tlc::Selector #auto selectors($sigcode) \
 227                                 -name "$w selector $signame,$default" \
 228                                 -default $default
 229
 230                 foreach {akey data} [array get assoc] {
 231                         set key         [lindex $data 0]
 232                         set name        [lindex $data 1]
 233                         set widget      [lindex $data 2]
 234                         if {[catch {
 235                                 log debug "attaching signal $signame associated with $key"
 236                                 $selectors($sigcode) attach_input $key \
 237                                                 [$widget signal_ref $signame]
 238                         } errmsg]} {
 239                                 log error "\nerror attaching signal $signame associated with key $key: $errmsg\n$::errorInfo"
 240                         }
 241                 }
 242         }
 243         return $selectors($sigcode)
 244 }
 245
 246
 247 body tlc::MDT::selected_page_widget {} { #<<<1
 248         log debug
 249         if {![info exists selected_page]} {
 250                 error "No page selected"
 251         }
 252         if {![info exists assoc($selected_page)]} {
 253                 error "No associated data for selected page: ($selected_page)"
 254         }
 255         foreach {key name widget} $assoc($selected_page) break
 256
 257         return $widget
 258 }
 259
 260
 261 body tlc::MDT::key_exists {key} { #<<<1
 262         set exists      [info exists assoc($key)]
 263         log debug "exists? $exists"
 264         return $exists
 265 }
 266
 267
 268 body tlc::MDT::close_current {} { #<<<1
 269         if {![info exists selected_page] || ![key_exists $selected_page]} {
 270                 log error "No selected page"
 271                 return
 272         }
 273
 274         remove_page $selected_page
 275 }
 276
 277
 278 body tlc::MDT::select_tab {id} { #<<<1
 279         $w.tabset select $id
 280 }
 281
 282
 283 body tlc::MDT::tab_changed {} { #<<<1
 284         set sel_w               [$w.tabset select]
 285         if {$sel_w == ""} return
 286
 287         foreach {akey data} [array get assoc] {
 288                 set key         [lindex $data 0]
 289                 set name        [lindex $data 1]
 290                 set widget      [lindex $data 2]
 291                 if {$widget == $sel_w} {
 292                         onselect $key
 293                         return
 294                 }
 295         }
 296
 297         log debug "Selected widget not found: ($sel_w)"
 298 }
 299
 300
 301 body tlc::MDT::widget_died {key oldname newname op} { #<<<1
 302         remove_page $key
 303 }
 304
 305