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 key_exists {key}
  21                 method select_page {key}
  22                 method selected_page_widget {}
  23                 method remove_page {key}
  24                 method notify_change {key}
  25                 method list_pages {}
  26                 method selected_signal_ref {signame {default 0}}
  27         }
  28
  29         private {
  30                 variable assoc
  31                 variable idx
  32                 variable selectors
  33                 variable selected_page
  34                 variable toggles
  35                 variable mode
  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         eval itk_initialize $args
  58
  59         if {[info commands ::ttk::notebook] == "::ttk::notebook"} {
  60                 set mode                "ttk"
  61                 ttk::notebook $w.tabset -width 750 -height 160
  62         } else {
  63                 set mode                "blt"
  64                 blt::tabset $w.tabset -width 750 -height 160 -tearoff 1 \
  65                                 -borderwidth 0 -highlightthickness 0 -slant right
  66         }
  67
  68         ttk::label $w.close -text "X" \
  69                         -font [$tlc::theme setting boldfont]
  70         bind $w.close <ButtonRelease-1> [code $this close_current]
  71
  72         tlc::StateToggle #auto toggles(close_current) $w.close \
  73                         -state {disabled normal}
  74         $toggles(close_current) attach_signal $signals(empty) inverted
  75
  76         blt::table $w \
  77                         $w.tabset       1,1 -fill both
  78
  79         if {$itk_option(-closebutton)} {
  80                 blt::table $w \
  81                                 $w.close        1,1 -anchor ne -pady {2 0} -padx {0 2}
  82         }
  83
  84         if {$mode == "ttk"} {
  85                 bind $w.tabset <<NotebookTabChanged>> [code $this tab_changed]
  86         }
  87 }
  88
  89
  90 body tlc::MDT::destructor {} { #<<<1
  91         log debug $w
  92         foreach {key widget} [list_pages] {
  93                 remove_page $key
  94         }
  95 }
  96
  97
  98 body tlc::MDT::new_page {key name widget {index end}} { #<<<1
  99         log debug
 100         if {[info exists assoc($key)]} {
 101                 error "page already exists with that key: ($key)"
 102         }
 103         if {$mode == "ttk"} {
 104                 set res [$w.tabset insert $index $widget -text $name]
 105         } else {
 106                 set res [$w.tabset insert $index $name -window $widget \
 107                                 -fill both -ipady 0]
 108         }
 109         set assoc($key) [list $key $name $widget]
 110         recalc_idx
 111         set id  $idx($key)
 112
 113         foreach {sigcode signal} [array get selectors] {
 114                 set signame     [lindex $sigcode 0]
 115                 if {[catch {
 116                         log debug "attaching signal $signame associated with $key"
 117                         $selectors($sigcode) attach_input $key [$widget signal_ref $signame]
 118                 } errmsg]} {
 119                         log error "error attaching signal $signame associated with key $key:\n$::errorInfo"
 120                 }
 121         }
 122
 123         log debug "id: ($id) res: ($res)"
 124         if {$mode == "blt"} {
 125                 #$w.tabset tab configure $id -command [code $this onselect $key]
 126                 $w.tabset tab configure $name -command [code $this onselect $key]
 127         }
 128
 129         if {$itk_option(-autoselect)} {
 130                 select_tab $id
 131         }
 132
 133         #trace add command $widget delete [list apply {
 134         #       {key oldname newname op} {
 135         #               puts stderr "oldname: ($oldname) newname: ($newname) op: ($op) key: ($key)"
 136         #       }} $key]
 137         trace add command $widget delete [code widget_died $key]
 138         $signals(empty) set_state 0
 139 }
 140
 141
 142 body tlc::MDT::select_page {key} { #<<<1
 143         log debug
 144         if {![info exists idx($key)]} {
 145                 error "no such page: ($key)"
 146         }
 147
 148         set id  $idx($key)
 149         select_tab $id
 150 }
 151
 152
 153 body tlc::MDT::remove_page {key} { #<<<1
 154         log debug
 155         if {![info exists assoc($key)]} {
 156                 error "no such page: ($key)"
 157         }
 158         catch {
 159                 set id  $idx($key)
 160         }
 161         foreach {key name widget} $assoc($key) break
 162         array unset assoc $key
 163         array unset idx $key
 164
 165         if {[llength [array names assoc]] == 0} {
 166                 $signals(empty) set_state 1
 167                 catch {unset selected_page}
 168         }
 169
 170         if {$mode == "ttk"} {
 171                 catch {
 172                         $w.tabset forget $id
 173                 }
 174         } else {
 175                 $w.tabset delete $id
 176         }
 177         recalc_idx
 178         set last_key    [lindex [array names assoc] end]
 179         log debug "calling destroy ($widget)"
 180         if {[winfo exists $widget]} {
 181                 if {[itcl::is object $widget]} {
 182                         delete object $widget
 183                 } else {
 184                         destroy $widget
 185                 }
 186         }
 187         log debug "done calling destroy ($widget)"
 188         if {$last_key != ""} {
 189                 catch {
 190                         select_tab $idx($last_key)
 191                 }
 192         }
 193
 194         if {$mode == "ttk"} {
 195                 set size        [llength [$w.tabset tabs]]
 196         } else {
 197                 set size        [$w.tabset size]
 198         }
 199         if {$size == 0} {
 200                 invoke_handlers nopages
 201         }
 202 }
 203
 204
 205 body tlc::MDT::notify_change {key} { #<<<1
 206         log debug
 207         if {![info exists assoc($key)]} {
 208                 error "no such page: ($key)"
 209         }
 210         foreach {key name widget} $assoc($key) break
 211
 212         if {$mode == "blt"} {
 213                 $w.tabset tab configure $name -foreground $itk_option(-changedcolour)
 214         }
 215 }
 216
 217
 218 body tlc::MDT::list_pages {} { #<<<1
 219         log debug
 220         return [array get assoc]
 221 }
 222
 223
 224 body tlc::MDT::onselect {key} { #<<<1
 225         log debug
 226         if {![info exists assoc($key)]} {
 227                 error "no such page: ($key)"
 228         }
 229         foreach {key name widget} $assoc($key) break
 230         foreach {sigcode signal} [array get selectors] {
 231                 log debug "selecting token $key from selectors($sigcode)"
 232                 $signal select $key
 233         }
 234         set selected_page       $key
 235         if {$mode == "blt"} {
 236                 $w.tabset tab configure $name -foreground ""
 237         }
 238         invoke_handlers tab_raised $key
 239 }
 240
 241
 242 body tlc::MDT::recalc_idx {} { #<<<1
 243         log debug
 244         array unset idx
 245         array set idx   {}
 246         foreach key [array names assoc] {
 247                 foreach {key name widget} $assoc($key) break
 248                 if {$mode == "ttk"} {
 249                         catch {
 250                                 set idx($key)   [$w.tabset index $widget]
 251                         }
 252                 } else {
 253                         set idx($key)   [$w.tabset index -name "$name"]
 254                 }
 255         }
 256 }
 257
 258
 259 body tlc::MDT::selected_signal_ref {signame {default 0}} { #<<<1
 260         log debug
 261         set sigcode     [list $signame $default]
 262         if {![info exists selectors($sigcode)]} {
 263                 tlc::Selector #auto selectors($sigcode) \
 264                                 -name "$w selector $signame,$default" \
 265                                 -default $default
 266
 267                 foreach {akey data} [array get assoc] {
 268                         set key         [lindex $data 0]
 269                         set name        [lindex $data 1]
 270                         set widget      [lindex $data 2]
 271                         if {[catch {
 272                                 log debug "attaching signal $signame associated with $key"
 273                                 $selectors($sigcode) attach_input $key \
 274                                                 [$widget signal_ref $signame]
 275                         } errmsg]} {
 276                                 log error "\nerror attaching signal $signame associated with key $key: $errmsg\n$::errorInfo"
 277                         }
 278                 }
 279         }
 280         return $selectors($sigcode)
 281 }
 282
 283
 284 body tlc::MDT::selected_page_widget {} { #<<<1
 285         log debug
 286         if {![info exists selected_page]} {
 287                 error "No page selected"
 288         }
 289         if {![info exists assoc($selected_page)]} {
 290                 error "No associated data for selected page: ($selected_page)"
 291         }
 292         foreach {key name widget} $assoc($selected_page) break
 293
 294         return $widget
 295 }
 296
 297
 298 body tlc::MDT::key_exists {key} { #<<<1
 299         set exists      [info exists assoc($key)]
 300         log debug "exists? $exists"
 301         return $exists
 302 }
 303
 304
 305 body tlc::MDT::close_current {} { #<<<1
 306         if {![info exists selected_page] || ![key_exists $selected_page]} {
 307                 log error "No selected page"
 308                 return
 309         }
 310
 311         remove_page $selected_page
 312 }
 313
 314
 315 body tlc::MDT::select_tab {id} { #<<<1
 316         if {$mode == "ttk"} {
 317                 $w.tabset select $id
 318         } else {
 319                 blt::SelectTab $w.tabset $id
 320         }
 321 }
 322
 323
 324 body tlc::MDT::tab_changed {} { #<<<1
 325         set sel_w               [$w.tabset select]
 326         if {$sel_w == ""} return
 327
 328         foreach {akey data} [array get assoc] {
 329                 set key         [lindex $data 0]
 330                 set name        [lindex $data 1]
 331                 set widget      [lindex $data 2]
 332                 if {$widget == $sel_w} {
 333                         onselect $key
 334                         return
 335                 }
 336         }
 337
 338         log debug "Selected widget not found: ($sel_w)"
 339 }
 340
 341
 342 body tlc::MDT::widget_died {key oldname newname op} { #<<<1
 343         remove_page $key
 344 }
 345
 346