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 <Destroy> {}}
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] <Motion> {+
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] <Leave> {+
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
}