[JOB] 2016-05-01, A TclOO class template to extend tablelist functionality. Might be useful as a starting point to create a tablelist megawidget with extended functionality. ====== # ----------------------------------------------------------------------------- # xtablelist_template.tcl --- # ----------------------------------------------------------------------------- # (c) 2016, Johann Oberdorfer - Engineering Support | CAD | Software # johann.oberdorfer [at] gmail.com # www.johann-oberdorfer.eu # ----------------------------------------------------------------------------- # This source file is distributed under the BSD license. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # See the BSD License for more details. # ----------------------------------------------------------------------------- # Purpose: # A TclOO class template to extend tablelist functionality. # Might be usefull as a starting point. # ----------------------------------------------------------------------------- # TclOO naming conventions: # public methods - starts with lower case declaration names, whereas # private methods - starts with uppercase naming, so we are going to use CamelCase ... # ----------------------------------------------------------------------------- set this_file [file normalize [file dirname [info script]]] # where to find required packages... # set auto_path [linsert $auto_path 0 [file join $this_file ".." "contrib" ]] package require Tk package require TclOO package require tablelist_tile package provide xtablelist 0.1 namespace eval xtablelist { # this is a tk-like wrapper around my... class so that # object creation works like other tk widgets proc xtablelist {path args} { set obj [obj_tablelist create tmp $path {*}$args] # rename oldName newName rename $obj ::$path return $path } oo::class create obj_tablelist { variable widget variable widgetOptions constructor {path args} { my variable widget # declaration of all additional widget options array set widgetOptions { -xtabheader {} \ } my Build $path # we must rename the widget command # since it clashes with the object being created set widget ${path}_ rename $path $widget my configure {*}$args } # add a destructor to clean up the widget destructor { set w [namespace tail [self]] catch {bind $w {}} catch {destroy $w} } method Build {path args} { my variable widget my variable tblwidget # we use a frame for this specific widget class set widget [ttk::frame $path -class Xtablelist] # pack everything together into a container frame set f [ttk::frame $path.f] pack $f -side left -fill both -expand true ::tablelist::tablelist $f.tlist pack $f.tlist -side top -fill both -expand true set tblwidget $f.tlist } # implementation of our new subcommands method cget { {opt "" } } { my variable tblwidget my variable widgetOptions if { [string length $opt] == 0 } { return [array get widgetOptions] } if { [info exists widgetOptions($opt) ] } { return $widgetOptions($opt) } return [$tblwidget cget $opt] } method configure { args } { my variable widget my variable tblwidget my variable widgetOptions if {[llength $args] == 0} { # return all tablelist options set opt_list [$tblwidget configure] # as well as all custom options foreach xopt [array get widgetOptions] { lappend opt_list $xopt } return $opt_list } elseif {[llength $args] == 1} { # return configuration value for this option set opt $args if { [info exists widgetOptions($opt) ] } { return $widgetOptions($opt) } return [$tblwidget cget $opt] } # error checking if {[expr {[llength $args]%2}] == 1} { return -code error "value for \"[lindex $args end]\" missing" } # process the new configuration options... array set opts $args foreach opt_name [array names opts] { set opt_value $opts($opt_name) # overwrite with new value if { [info exists widgetOptions($opt_name)] } { set widgetOptions($opt_name) $opt_value } # some options need action from the widgets side switch -- $opt_name { -xtabheader { my InitializeTabHeader $opt_value } default { # ------------------------------------------------------- # if the configure option wasn't one of our special one's, # pass control over to the original tablelist widget # ------------------------------------------------------- if {[catch {$tblwidget configure $opt_name $opt_value} result]} { return -code error $result } } } } } method enablemoveover {} { my variable tblwidget # move-over effect: bind [$tblwidget bodypath] {+ set t [winfo parent %W] set x [expr {%x + [winfo x %W]}] set y [expr {%y + [winfo y %W]}] # set cell [$t nearestcell $x $y] # puts "Clicked on cell: $cell " # set rownum [lindex [split $cell ","] 0] focus $t $t configure -activestyle frame $t activate "@$x,$y" } bind [$tblwidget bodypath] {+ set t [winfo parent %W] $t configure -activestyle none } } # -------------------------------------------------- # if the command wasn't one of our special one's, # pass control over to the original tablelist widget # -------------------------------------------------- method unknown {method args} { my variable tblwidget if {[catch {$tblwidget $method {*}$args} result]} { return -code error $result } } } } # -------------------- # Private Functions... # -------------------- oo::define ::xtablelist::obj_tablelist \ \ method InitializeTabHeader {kword_list} { my variable tblwidget set cols "" set cnt 0 foreach i $kword_list { set descr [lindex $i 0] set visual [lindex $i 1] set orient [lindex $i 2] if {[string length $orient] == 0} { set orient "left" } regsub -all " " $descr "_" descr if {$descr != "..." && [string range $descr end end] != ":"} { set descr "${descr}:" } # could be either a string or an integer: if {$visual == "hidden"} { set width 20 } else { set width $visual } append cols "$width $descr $orient " incr cnt } $tblwidget configure -columns $cols # hide specific columns as indicated with "hidden" in declaration array set cnt 0 foreach i $kword_list { if {[set width [lindex $i 1]] == "hidden"} { $tblwidget columnconfigure $cnt -hide yes } incr cnt } # expand last *visible* column # ---------------------------- set cnt 0 set lastcol 0 # tablelist -columns option are always 3 attributes each... foreach {w col pos} [$tblwidget cget -columns] { if {[$tblwidget columncget $cnt -hide] == 0} {set lastcol $cnt} incr cnt } if {$lastcol > 0} { $tblwidget configure -stretch $lastcol } } # demo code if {1} { catch {console show} set t [xtablelist::xtablelist .t \ -showseparators yes \ -selectmode single \ -labelcommand "tablelist::sortByColumn"] pack $t -fill both -expand true set header \ {{"hidden_column" "hidden" left} {"Category" 22 left} {"test-column" 16 left} {"Hello\\nWorld" 10 left} {"test" 11 center} {"last\\ncolumn" 10 left}} $t configure \ -xtabheader $header # create some random test data... set data_list {} set cnt 0 while {$cnt < 40} { lappend data_list [list $cnt \ [expr {$cnt +1}] [expr {$cnt +2}] \ [expr {$cnt +3}] [expr {$cnt +4}] \ [expr {$cnt +5}]] incr cnt } # --------------------- # object introspection: # --------------------- # puts [winfo class $t] # puts [$t configure] # catch { [$t blabla 1] } msg # puts $msg # return foreach item $data_list { $t insert end $item } # puts [$t cget -xtabheader] # how to access the tablelist widget: # [$t getwidgetpath] configure -columns \ # "12 Test1 left 12 Test2 left" # $t selection clear 0 end # puts [$t curselection] $t enablemoveover } ====== <>TclOO