scripts/tablelist.itk

   1 # vim: foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 ft=tcl
   2
   3 class tlc::Tablelist {
   4         inherit tlc::Mywidget tlc::Handlers tlc::Textvariable tlc::Signalsource
   5
   6         constructor {args} {}
   7
   8         itk_option define -allow_add allowAdd AllowAdd 1 need_rerender
   9         itk_option define -allow_remove allowRemove AllowRemove 1 need_rerender
  10         itk_option define -allow_reorder allowReorder AllowReorder 1 need_rerender
  11
  12         public {
  13                 variable schema         {}      need_rerender
  14                 variable state
  15
  16                 method set_rows {args}
  17                 method set_tags {args}
  18                 method get_rows {}
  19         }
  20
  21         protected {
  22                 method textvariable_changed {newvalue}
  23         }
  24
  25         private {
  26                 variable oldschema      {}
  27                 variable colmap
  28                 variable rowidx         0
  29                 variable td
  30                 variable arrdat         {}
  31                 variable colschema
  32                 variable colvarname
  33                 variable titlerows      1
  34                 variable titlecols      0
  35                 variable dominos
  36                 variable row_args
  37
  38                 method need_rerender {}
  39                 method rerender {}
  40                 method cannonize_type {intype}
  41                 method render_row {r arr}
  42                 method tableclick {row col idx wid}
  43                 method destroy_children {}
  44                 method td_changed {}
  45         }
  46 }
  47
  48
  49 configbody tlc::Tablelist::state { #<<<1
  50         log warning "$w -state not implemented yet"
  51 }
  52
  53
  54 body tlc::Tablelist::constructor {args} { #<<<1
  55         log debug $w
  56
  57         # This requires tktable, and to ensure no conflict with blt::table
  58         # the user must arrange to have the command 'tktable' refer to the
  59         # Tktable widget
  60
  61         array set colmap                {}
  62         array set colschema             {}
  63         array set td                    {}
  64         array set dominos               {}
  65         array set colvarname    {}
  66         array set row_args              {}
  67
  68         itk_component add list {
  69                 tktable $w.list \
  70                                 -rows 1 \
  71                                 -cols 1 \
  72                                 -cursor "" \
  73                                 -cache 1 \
  74                                 -titlerows $titlerows \
  75                                 -titlecols $titlecols \
  76                                 -colstretch last -rowstretch none \
  77                                 -variable [scope td] \
  78                                 -yscrollcommand [list $w.vsb set] \
  79                                 -background white \
  80                                 -resizeborders col \
  81                                 -ipadx 2 \
  82                                 -sparsearray 0 \
  83                                 -selecttype cell \
  84                                 -browsecommand [code $this tableclick %r %c %s %W] \
  85                                 -relief sunken \
  86                                 -borderwidth 1 \
  87                                 -highlightthickness 1
  88         } {
  89                 keep -autoclear
  90         }
  91
  92         bind $w.list <Return> {
  93                 set r   [%W index active row]
  94                 set c   [%W index active col]
  95                 set tc  [%W cget -cols]
  96                 incr tc -1
  97                 if {$c == $tc} {
  98                         %W activate [incr r],1
  99                 } else {
 100                         %W activate $r,[incr c]
 101                 }
 102                 %W see active
 103         }
 104         bind $w.list <KP_Enter> [bind $w.list <Return>]
 105         bind $w.list <Tab> [bind $w.list <Return>]
 106
 107         itk_component add vsb {
 108                 tlc::myscrollbar_win32 $w.vsb -orient v -command [list $w.list yview] \
 109                         -mode static
 110         } {
 111         }
 112
 113         tlc::Signal #auto signals(item_selected) -name "$w item_selected"
 114         tlc::Domino #auto dominos(need_rerender) -name "$w need_rerender"
 115         tlc::Vardomino #auto dominos(td_changed) -name "$w td_changed" \
 116                         -textvariable [scope td]
 117
 118         $dominos(need_rerender) attach_output [code $this rerender]
 119         $dominos(td_changed) attach_output [code $this td_changed]
 120
 121         # Styles <<<
 122         $w.list tag configure lastrow \
 123                         -background #b2b2b2 \
 124                         -relief sunken \
 125                         -state disabled
 126         # Styles >>>
 127
 128         eval itk_initialize $args
 129
 130         blt::table $w \
 131                         $w.list         1,1 -fill both \
 132                         $w.vsb          1,2 -fill y
 133         blt::table configure $w c2 -resize none
 134
 135         $w.list configure -flashmode 1 -flashtime 2
 136
 137         $dominos(need_rerender) tip
 138 }
 139
 140
 141 body tlc::Tablelist::need_rerender {} { #<<<1
 142         $dominos(need_rerender) tip
 143 }
 144
 145
 146 body tlc::Tablelist::rerender {} { #<<<1
 147         if {[info exists oldschema] && $schema == $oldschema} return
 148         set oldschema $schema
 149
 150         destroy_children
 151
 152         array unset colmap *
 153         array unset colschema *
 154
 155         set colidx              0
 156         set datacols    0
 157         array set colwidths     {}
 158         array set colsettings   {}
 159
 160         array set layout {
 161                 col_width_sticky                default
 162                 col_args_sticky                 {
 163                         -multiline 0
 164                         -anchor w
 165                 }
 166                 row_args                        {}
 167                 row_args_even           {}
 168                 row_args_odd            {}
 169                 table_args                      {}
 170         }
 171
 172         if {$itk_option(-allow_remove)} {
 173                 set td(0,$colidx) "Del"
 174                 set colwidths($colidx)  -25
 175                 incr colidx
 176         }
 177
 178         if {$itk_option(-allow_reorder)} {
 179                 set td(0,$colidx) ""
 180                 set colwidths($colidx)  -35
 181                 incr colidx
 182         }
 183
 184         set reset       1
 185         foreach {label info} [tlc::decomment $schema] {
 186                 if {$reset} {
 187                         set layout(col_width)           $layout(col_width_sticky)
 188                         set layout(col_args)            $layout(col_args_sticky)
 189                 }
 190
 191                 if {[string index $label 0] == "_"} {
 192                         switch -- $label {
 193                                 "_layout" {
 194                                         switch -- [lindex $info 0] {
 195                                                 "col_width" {
 196                                                         set layout(col_width)   [lindex $info 1]
 197                                                         set reset       0
 198                                                 }
 199
 200                                                 "col_width_sticky" {
 201                                                         set layout(col_width_sticky)    [lindex $info 1]
 202                                                 }
 203
 204                                                 "col_args" {
 205                                                         array set tmp   $layout(col_args)
 206                                                         array set tmp   [lrange $info 1 end]
 207                                                         set layout(col_args)    [array get tmp]
 208                                                         set reset       0
 209                                                 }
 210
 211                                                 "col_args_sticky" {
 212                                                         array set tmp   $layout(col_args_sticky)
 213                                                         array set tmp   [lrange $info 1 end]
 214                                                         set layout(col_args_sticky)     [array get tmp]
 215                                                 }
 216
 217                                                 "row_args" {
 218                                                         set layout(row_args)            [lrange $info 1 end]
 219                                                 }
 220
 221                                                 "row_args_even" {
 222                                                         set layout(row_args_even)       [lrange $info 1 end]
 223                                                 }
 224
 225                                                 "row_args_odd" {
 226                                                         set layout(row_args_odd)        [lrange $info 1 end]
 227                                                 }
 228
 229                                                 "table_args" {
 230                                                         array set tmp   $layout(table_args)
 231                                                         array set tmp   [lrange $info 1 end]
 232                                                         set layout(table_args)          [array get tmp]
 233                                                 }
 234
 235                                                 default {
 236                                                         log error "Invalid layout type: ([lindex $info 0])"
 237                                                 }
 238                                         }
 239                                 }
 240
 241                                 "_validation" {
 242                                         log warning "Validation not implemented yet"
 243                                 }
 244
 245                                 default {
 246                                         log error "Invalid schema directive: ($label)"
 247                                 }
 248                         }
 249
 250                         continue
 251                 }
 252
 253                 set reset       1
 254
 255                 set varname [lindex $info 0]
 256                 set colschema($varname) [lrange $info 1 end]
 257
 258                 set colmap($varname)    $colidx
 259                 set colvarname($colidx) $varname
 260                 set td(0,$colidx)               $label
 261                 set colwidths($colidx)  $layout(col_width)
 262
 263                 set colsettings($colidx)        $layout(col_args)
 264
 265                 incr datacols
 266                 incr colidx
 267         }
 268
 269         log debug "Before:\n\t[join $arrdat \n\t]"
 270         parray td
 271
 272         $w.list configure -cols $colidx
 273
 274         for {set i 0} {$i < $colidx} {incr i} {
 275                 if {![info exists colwidths($i)]} {
 276                         log error "Missing column width setting for column $i"
 277                 } else {
 278                         $w.list width $i $colwidths($i)
 279                 }
 280                 if {![info exists colsettings($i)]} {
 281                         log error "Missing column settings for column $i"
 282                 } else {
 283                         set settings    [string map [list "\n" " "] $colsettings($i)]
 284                         log debug "Configuring col tags for $i ($colvarname($i)): ($settings)"
 285                         eval [list $w.list tag configure col$i] $settings
 286                         $w.list tag col col$i $i
 287                 }
 288         }
 289
 290         array unset tmp
 291         array set tmp           $layout(row_args)
 292         array set tmp           $layout(row_args_even)
 293         set row_args(even)      [array get tmp]
 294
 295         array unset tmp
 296         array set tmp           $layout(row_args)
 297         array set tmp           $layout(row_args_odd)
 298         set row_args(odd)       [array get tmp]
 299         array unset tmp
 300
 301         if {[llength $layout(table_args)] > 0} {
 302                 eval [list $w.list configure] \
 303                                 [string map [list "\n" " "] $layout(table_args)]
 304         }
 305
 306         set_rows $arrdat
 307
 308         foreach {label info} [tlc::decomment $schema] {
 309                 if {$label == "_set_tags"} {
 310                         foreach {tag settings} $info {
 311                                 set_tags $tag $settings
 312                         }
 313                 }
 314         }
 315
 316         log debug "After:"
 317         parray td
 318 }
 319
 320
 321 body tlc::Tablelist::set_rows {args} { #<<<1
 322         $dominos(need_rerender) force_if_pending
 323         log debug [tlc::stackdump]
 324         $dominos(td_changed) lock
 325
 326         tlc::try {
 327                 destroy_children
 328                 array set tmp   {}
 329                 for {set r 0} {$r < $titlerows} {incr r} {
 330                         array set tmp   [array get td $r,*]
 331                 }
 332                 array unset td *
 333                 array set td    [array get tmp]
 334
 335                 log debug "Setting arrdat to \$args"
 336                 set arrdat      $args
 337
 338                 set drows       [expr {[llength $arrdat] + $titlerows}]
 339                 if {$itk_option(-allow_add)} {
 340                         incr drows
 341                 }
 342                 $w.list config -rows $drows
 343
 344                 log debug "rendering rows"
 345                 log debug "colschema:"
 346                 parray colschema
 347                 set r   $titlerows
 348                 foreach row $arrdat {
 349                         render_row $r $row
 350                         incr r
 351                 }
 352         } onerr {
 353                 default {STDMSG}
 354         }
 355
 356         log debug "releasing td_changed lock"
 357         $dominos(td_changed) unlock
 358         log debug "arrdat: ($arrdat)"
 359         parray td
 360         log debug "exiting set_rows"
 361 }
 362
 363
 364 body tlc::Tablelist::render_row {r arr} { #<<<1
 365         log debug
 366         foreach {varname value} $arr {
 367                 log debug "varname: ($varname)\[[info exists colschema($varname)]\], value: \"$value\""
 368                 if {![info exists colschema($varname)]} continue
 369                 set s                   $colschema($varname)
 370                 set c                   $colmap($varname)
 371
 372                 set type                [cannonize_type [lindex $s 0]]
 373                 set arglist             [lrange $s 1 end]
 374                 log debug "setting td($r,$c) to \"$value\""
 375                 set td($r,$c)   $value
 376
 377                 set scoped_varname      [scope td($r,$c)]
 378                 set wn                          $w.list.$type,$r,$c
 379
 380                 switch -- $type {
 381                         plain {
 382                         }
 383
 384                         combobox {
 385                                 tlc::mycombobox $wn -textvariable $scoped_varname
 386                         }
 387
 388                         spinner {
 389                                 tlc::Spinner $wn -textvariable $scoped_varname
 390                         }
 391
 392                         default {
 393                                 error "Unknown type: ($type)" "" [list unknown_type $type]
 394                         }
 395                 }
 396
 397                 if {[winfo exists $wn]} {
 398                         if {[llength $arglist] != 0} {
 399                                 eval [list $wn configure] $arglist
 400                         }
 401                         log debug "Configuring $type in row $r with value \"$td($r,$c)\""
 402                         $w.list window config $r,$c -window $wn -sticky news
 403                 }
 404         }
 405         if {$r % 2 == 0} {
 406                 set tags        $row_args(even)
 407         } else {
 408                 set tags        $row_args(odd)
 409         }
 410         eval [list $w.list tag configure row$r] [string map [list "\n" " "] $tags]
 411         $w.list tag row row$r $r
 412 }
 413
 414
 415 body tlc::Tablelist::set_tags {args} { #<<<1
 416         log debug
 417         foreach {tag settings} $args {
 418                 set settings    [string map [list "\n" " "] $settings]
 419                 eval [list $w.list tag configure $tag] $settings
 420         }
 421 }
 422
 423
 424 body tlc::Tablelist::get_rows {} { #<<<1
 425         log debug
 426         # Ensure no pending updates of arrdat are in flight
 427         $dominos(td_changed) force_if_pending
 428
 429         log debug "[llength $arrdat] items"
 430         return $arrdat
 431 }
 432
 433
 434 body tlc::Tablelist::cannonize_type {intype} { #<<<1
 435         switch -- $intype {
 436                 "" -
 437                 plain {
 438                         return "plain"
 439                 }
 440
 441                 combobox -
 442                 mycombobox {
 443                         return "combobox"
 444                 }
 445
 446                 spinner {
 447                         return "spinner"
 448                 }
 449
 450                 default {
 451                         error "Unknown type: ($intype)" "" [list unknown_type $intype]
 452                 }
 453         }
 454 }
 455
 456
 457 body tlc::Tablelist::tableclick {row col idx wid} { #<<<1
 458         # Appending of new blank row to be handled by transcriber of td to arrdat
 459 }
 460
 461
 462 body tlc::Tablelist::destroy_children {} { #<<<1
 463         foreach child [winfo children $w.list] {
 464                 try {
 465                         if {[itcl::is object $child]} {
 466                                 delete object $child
 467                         } else {
 468                                 destroy $child
 469                         }
 470                 } onerr {
 471                         default {STDMSG}
 472                 }
 473         }
 474 }
 475
 476
 477 body tlc::Tablelist::td_changed {} { #<<<1
 478         array set rowinf {}
 479         set max_r                -1
 480         foreach {key value} [array get td] {
 481                 foreach {r c} [split $key ,] break
 482
 483                 if {$r < $titlerows} continue
 484                 if {![info exists colvarname($c)]} continue
 485
 486                 set varname     $colvarname($c)
 487                 lappend rowinf($r)      $varname $value
 488                 if {$max_r < $r} {
 489                         set max_r       $r
 490                 }
 491         }
 492
 493         log debug "td to arrdat conversion, first stage:"
 494         parray rowinf
 495         set build               {}
 496         for {set r $titlerows} {$r <= $max_r} {incr r} {
 497                 if {![info exists rowinf($r)]} {
 498                         log warning "No data found for row $r"
 499                         lappend build   {}
 500                 } else {
 501                         lappend build   $rowinf($r)
 502                 }
 503         }
 504         log debug "setting arrdat to \$build: [llength $build] items, from [tlc::stackdump]"
 505         set arrdat      $build
 506
 507         set_textvariable $arrdat
 508 }
 509
 510
 511 body tlc::Tablelist::textvariable_changed {newvalue} { #<<<1
 512         set_rows $newvalue
 513 }
 514
 515