A TclOO megawidget based on tablelist (tabelistbrowser)
JOB 2016-05-03 Playing with TclOO...
The following code implements a tablelistbrowser megawidget with the aid of TclOO.
The tablelist operates in "browse" mode, if nothing is selected, the content of each table item is shown on the rhs window on the fly. Current selection is handled within the object (and won't get lost, in case something else is going to be selected). Horizontal / vertical view can be toggled interactively. When doing so, current selected tablelist item is kept visible. Binding for keyboard navigation within the tablelist is available (although quite slow).
Found out that:
- performance under OSX (tablelist with images) is a bit slow ?
- ttk::panedwindow does not allow to dynamically toggle the orientation e.g. with "<widget> configure -orient "horizontal""
- tk::panedwindow has to be used instead ?
TclOO:
- Looks quite promising in respect of megawidget class layout.
- Used the A TclOO tablelist template as a starting point for the megawidget.
Here is the code - pls. enjoy. Of corse any comments are very welcome!
* tablelistbrowser.tcl
# -----------------------------------------------------------------------------
# tablelistbrowser.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 implementing the tablelistbrowser megawidget.
# 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 ...
# -----------------------------------------------------------------------------
# for development: try to find autoscroll, etc ...
# 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 ".."]]
package require autoscroll
package require tablelist_tile
package provide tablelistbrowser 0.2
# workaround for aqua
if { [tk windowingsystem] eq "aqua" } {
interp alias {} ttk::scrollbar {} ::scrollbar
}
namespace eval tablelistbrowser {
variable image_dir
variable image_file
set this_dir [file dirname [info script]]
set image_dir [file join $this_dir "images"]
set image_file [file join $this_dir "ImageLib.tcl"]
variable cnt 0
proc LoadImages {image_dir {patterns {*.gif}}} {
foreach p $patterns {
foreach file [glob -nocomplain -directory $image_dir $p] {
set img [file tail [file rootname $file]]
if { ![info exists images($img)] } {
set images($img) [image create photo -file $file]
}
}}
return [array get images]
}
# this is a tk-like wrapper around my... class so that
# object creation works like other tk widgets
proc tablelistbrowser {path args} {
variable cnt
set obj [TablelistbrowserClass create tmp${cnt} $path {*}$args]
incr cnt
# rename oldName newName
rename $obj ::$path
return $path
}
oo::class create TablelistbrowserClass {
constructor {path args} {
my variable tblwidget
my variable widgetOptions
my variable widgetCompounds
set image_file $::tablelistbrowser::image_file
set image_dir $::tablelistbrowser::image_dir
# ---------------------------------------------------------------
# read images from library file or alternatively one by one
# ---------------------------------------------------------------
if { [file exists $image_file] } {
source $image_file
array set widgetCompounds [array get images]
} else {
array set widgetCompounds [::tablelistbrowser::LoadImages \
[file join $image_dir] {"*.gif" "*.png"}]
}
# ---------------------------------------------------------------
array set widgetCompounds {
init_bindings 0
}
# declaration of all additional widget options
array set widgetOptions {
-xtabheader {}
-xpaneorient "horizontal"
-xselectcommand ""
-xstatusmessagetype ""
-xstatusmessage ""
}
# incorporate arguments to local widget options
array set widgetOptions $args
# we use a frame for this specific widget class
set f [ttk::frame $path -class tablelistbrowser]
# we must rename the widget command
# since it clashes with the object being created
set widget ${path}_
my Build $f
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 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 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
my AddTextTags
}
-xpaneorient {
my SetPaneOrientation $opt_value
}
-xselectcommand {}
-xstatusmessagetype {
my SetStatusMessageType $opt_value
}
-xstatusmessage {
my SetStatusMessage $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
}
}
}
}
}
# overloaded tablelist method !
method insert {method args} {
my variable tblwidget
# my SetStatusMessage "" "item_count"
# after 8000 "[namespace code {my SetStatusMessageType}]"
if {[catch {$tblwidget insert $method {*}$args} result]} {
return -code error $result
}
my modifyColumnImage "init" "unused"
my EnableMoveoverBindings
}
# overloaded tablelist method !
method insertlist {method args} {
my variable tblwidget
# my SetStatusMessage "" "item_count"
# after 8000 "[namespace code {my SetStatusMessageType}]"
if {[catch {$tblwidget insertlist $method {*}$args} result]} {
return -code error $result
}
my modifyColumnImage "init" "unused"
my EnableMoveoverBindings
}
# --------------------------------------------------
# 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
# puts ">>>>>>>> $method ::: $args <<<<<<<<<<<<"
if {[catch {$tblwidget $method {*}$args} result]} {
return -code error $result
}
return $result
}
}
}
# works, but maybe a not so good idea - might clash in the future
# interp alias {} OOD {} oo::define ::tablelistbrowser::obj_tablelistbrowser method
# --------------------------------------------------------
# Public Functions / implementation of our new subcommands
# --------------------------------------------------------
oo::define ::tablelistbrowser::TablelistbrowserClass {
method gettablelist_widget {} {
my variable tblwidget
return $tblwidget
}
method modifyColumnImage {mode row_num} {
my variable tblwidget
my variable widgetCompounds
if { [llength [$tblwidget get 0 end]] == 0 } {
# prevent error, when clicking on an empty tablelist widget
return
}
set col_num [my CalculateColIndex]
switch -- $mode {
"init" {
# setup images for the 1st time
set cnt 0
foreach item [$tblwidget get 0 end] {
$tblwidget cellconfigure "$cnt,$col_num" \
-image $widgetCompounds(img_unchecked)
incr cnt
}
}
"toggle_selection" {
$tblwidget selection clear 0 end
# search for the 1st occurance of img_checked, deselect and continue...
set cnt 0
foreach item [$tblwidget get 0 end] {
# puts "$cnt,0 ---- $item"
if {[$tblwidget cellcget "$cnt,$col_num" -image] == $widgetCompounds(img_checked)} {
$tblwidget cellconfigure "$cnt,$col_num" -image $widgetCompounds(img_unchecked)
$tblwidget rowconfigure $cnt -font {} -foreground {} -background {}
break
}
incr cnt
}
# --------------------------------------
# evaluate command in parent namespace:
# --------------------------------------
set select_cmd [my cget -xselectcommand]
if {$select_cmd != ""} {
uplevel $select_cmd
}
# --------------------------------------
}
"set_selection" {
# finally, do our own selection (which isn't lost, once
# another "normal" (text-)widget selection is done ...
# -----------------------------------------------------
# check, if this code can be reached ??!
# "DarkRed" / "White"
$tblwidget cellconfigure "$row_num,$col_num" -image $widgetCompounds(img_checked)
$tblwidget rowconfigure $row_num \
-font APP_FONT_STD_BOLD \
-foreground [ttk::style configure . -selectforeground] \
-background [ttk::style configure . -selectbackground]
# --------------------------------------
# evaluate command in parent namespace:
# --------------------------------------
set select_cmd [my cget -xselectcommand]
if {$select_cmd != ""} {
uplevel $select_cmd
}
# --------------------------------------
}
}
}
# -----------------------------------------------------------------------------
# returns row number of current selection
# or -1 if nothing is selected
# -----------------------------------------------------------------------------
method getSelectedIndex {} {
my variable tblwidget
my variable widgetCompounds
set col_num [my CalculateColIndex]
set cnt 0
foreach item [$tblwidget get 0 end] {
if {[$tblwidget cellcget "$cnt,$col_num" -image] == $widgetCompounds(img_checked)} {
return $cnt
}
incr cnt
}
return -1
}
method setSelection {row_num} {
my variable tblwidget
$tblwidget selection clear 0 end
my modifyColumnImage "set_selection" $row_num
my displayItemInfo "motion" $row_num
}
method clearSelection {} {
my variable tblwidget
$tblwidget selection clear 0 end
my modifyColumnImage "toggle_selection" "unused"
}
# -----------------------------------------------------------------------------
# -----------------------------------------------------------------------------
method displayItemInfo {mode rownum} {
my variable tblwidget
my variable widgetCompounds
set txt $widgetCompounds(txtwidget)
# manipulate tablelist (if required)
switch -- $mode {
"button_pressed" {
$txt delete 0.0 end
}
"motion" {}
}
# show tablelist data item in the text widget
set kwd_list [my cget -xtabheader]
if {[llength $kwd_list] == 0} {
return
}
set maxattr_len [string length [my GetMaxAttributeString $kwd_list]]
set data [lindex [$tblwidget get $rownum $rownum] 0]
$txt configure -state normal
$txt delete 0.0 end
set cnt 0
foreach d $data {
# skip hidden attributes
if {[lindex [lindex $kwd_list $cnt] 1] == "hidden"} {
incr cnt
continue
}
set descr [lindex [lindex $kwd_list $cnt] 0]
if {[string range $descr end end] != ":"} {
append descr ":"
}
while {[string length $descr] < $maxattr_len} {
append descr " "
}
$txt insert end $descr ATTR_NAME
if {$cnt == 0} {
$txt insert end "$d " ATTR_TXT0
} else {
$txt insert end "$d " ATTR_TXT1
}
$txt insert end "\n"
incr cnt
}
$txt configure -state disabled
}
method clearItemInfo {} {
my variable widgetCompounds
if {[my getSelectedIndex] == -1} {
set txt $widgetCompounds(txtwidget)
$txt configure -state normal
$txt delete 0.0 end
$txt configure -state disabled
}
}
# --------------------
# Private Functions...
# --------------------
# process each item of the table header declaration list,
# to find 1st occurance of non-hidden attribute,
# which defines, where to place the selection box image...
method CalculateColIndex {} {
# take hidden attributes into account !
set kwd_list [my cget -xtabheader]
set col_num 0
foreach item $kwd_list {
if {[lindex $item 1] != "hidden"} {
break
}
incr col_num
}
return $col_num
}
method EnableMoveoverBindings {} {
my variable widgetCompounds
my variable tblwidget
if {$widgetCompounds(init_bindings) != 0} {
return
}
# select/deselect ButtonRelease
bind [$tblwidget bodypath] <Button-1> {
set x [expr {%x + [winfo x %W]}]
set y [expr {%y + [winfo y %W]}]
set t [winfo parent %W]
set cell [$t nearestcell $x $y]
set rownum [lindex [split $cell ","] 0]
set oo_my [winfo parent $t]
while { [winfo exists $oo_my] } {
if { [winfo class $oo_my] == "tablelistbrowser" } { break }
set oo_my [winfo parent $oo_my]
}
if {[llength [set idx [$t curselection]]] != 0 && $idx == $rownum} {
$oo_my modifyColumnImage "toggle_selection" "unused"
} else {
$oo_my modifyColumnImage "toggle_selection" "unused"
$oo_my modifyColumnImage "set_selection" $rownum
$oo_my displayItemInfo "button_pressed" $rownum
}
}
# 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]
set rownum [lindex [split $cell ","] 0]
set oo_my [winfo parent $t]
# move up hierachy until our own class is reached:
# notes:
# - maybe there is a more convinient way to adress a class member function ?
# - pls note that the member function needs to start with lowercase char
# otherwise it's hidden in global namespace
while { [winfo exists $oo_my] } {
if { [winfo class $oo_my] == "tablelistbrowser" } { break }
set oo_my [winfo parent $oo_my]
}
if {[$oo_my getSelectedIndex] == -1} {
$t selection clear 0 end
$oo_my displayItemInfo "motion" $rownum
}
focus $t
$t configure -activestyle frame
$t activate "@$x,$y"
}
# works (but a bit slow):
bind $tblwidget <KeyPress> {
set t %W
set key %K
if { [lsearch {"Up" "Down"} $key] != -1 &&
[llength [set idx [$t curselection]]] != 0} {
set rownum [lindex $idx 0]
set within_bounds 1
if {$key == "Up" && $rownum == 0} {
set within_bounds 0
} elseif \
{$key == "Up" && $rownum > 0} {
incr rownum -1
} elseif \
{$key == "Down" && $rownum < [expr {[llength [$t get 0 end]] - 1}] } {
incr rownum
} else {
set within_bounds 0
}
if {$within_bounds != 0} {
set oo_my [winfo parent $t]
while { [winfo exists $oo_my] } {
if { [winfo class $oo_my] == "tablelistbrowser" } { break }
set oo_my [winfo parent $oo_my]
}
# deselect
$oo_my modifyColumnImage "toggle_selection" "unused"
# select & zoom (if required)
$t selection set $rownum $rownum
$t see $rownum
$oo_my modifyColumnImage "set_selection" $rownum
$oo_my displayItemInfo "motion" $rownum
}
}
}
bind [$tblwidget bodypath] <Leave> {+
set t [winfo parent %W]
$t configure -activestyle none
set oo_my [winfo parent $t]
while { [winfo exists $oo_my] } {
if { [winfo class $oo_my] == "tablelistbrowser" } { break }
set oo_my [winfo parent $oo_my]
}
$oo_my clearItemInfo
}
set widgetCompounds(init_bindings) 1
}
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
}
}
# type:
# controls the image to be displayed, could be one off:
# information / warning / error
method SetStatusMessageType { {msgtype ""} } {
my variable widgetCompounds
set txt [$widgetCompounds(status_msg) cget -text]
switch -- $msgtype {
"information" { set img $widgetCompounds(dialog-information) }
"warning" { set img $widgetCompounds(dialog-warning-2) }
"error" { set img $widgetCompounds(dialog-error-4) }
"" - default {
set img ""
set txt ""
}
}
$widgetCompounds(status_msg) configure -image $img -text $txt -compound left
}
method SetStatusMessage { msg {mode ""} } {
my variable tblwidget
my variable widgetCompounds
switch -- $mode {
"item_count" {
set msg ""
set data [$tblwidget get 0 end]
# update status message:
if {[llength $data] > 0} {
set msg "There "
if {[llength $data] == 1} {
append msg "is [llength $data] item available."
} else {
append msg "are [llength $data] items available."
}
}
}
"" - default {
# use msg argument value
}
}
set img [$widgetCompounds(status_msg) cget -image]
$widgetCompounds(status_msg) configure -image $img -text $msg -compound left
}
method GetTime {} {
my variable widgetCompounds
# disabled, going to use catch instead...
# if {![winfo exists widgetCompounds(date)]} { return }
catch {
# https://wiki.tcl-lang.org/13996, localized clock
$widgetCompounds(date) configure \
-text [clock format [clock seconds] -format "%a %d. %B, %H:%M:%S" -locale de]
}
after 1000 "catch { [namespace code {my GetTime}] }"
}
method Zoom2Selection {} {
my variable tblwidget
my variable widgetCompounds
# standard tablelist behaviour
if {[set idx_lst [$tblwidget curselection]] != {}} {
$tblwidget see [lindex $idx_lst 0]
return
}
# 2nd approach in the case our custom selection is set
set col_num 0
set cnt 0
foreach item [$tblwidget get 0 end] {
if {[$tblwidget cellcget "$cnt,$col_num" -image] == $widgetCompounds(img_checked)} {
$tblwidget see $cnt
break
}
incr cnt
}
}
method SetPaneOrientation {orient} {
my variable widgetOptions
my variable widgetCompounds
set widgetOptions(-xpaneorient) $orient
switch -- $orient {
"horizontal" {
set img $widgetCompounds(img_leftright)
}
"vertical" {
set img $widgetCompounds(img_topbottom)
}
}
$widgetCompounds(pane) configure -orient $orient
$widgetCompounds(pane_bttn) configure -image $img
my Zoom2Selection
}
method TogglePaneOrientation {{mode ""}} {
my variable widgetCompounds
set orient [my cget -xpaneorient]
switch -- $mode {
"set_image" {
# setup icon images and return
if {$orient == "horizontal"} {
set img $widgetCompounds(img_leftright)
} else {
set img $widgetCompounds(img_topbottom)
}
$widgetCompounds(pane_bttn) configure -image $img
return
}
"" - default {
# pane toggle mode
if {$orient == "horizontal"} {
set orient "vertical"
} else {
set orient "horizontal"
}
my SetPaneOrientation $orient
}
}
}
method GetMaxAttributeString {lst} {
set rstr ""
foreach item $lst {
# skip hidden attributes
if {[lindex $item 1] == "hidden"} {
continue
}
set str [lindex $item 0]
# don't forget to add:
append str ": "
if {$rstr == ""} {set rstr $str}
if {[string length $str] > [string length $rstr]} {set rstr $str}
}
return $rstr
}
method AddTextTags {} {
my variable widgetCompounds
my variable tblwidget
set txt $widgetCompounds(txtwidget)
set lst [my cget -xtabheader]
if {[llength $lst] == 0} {
return
}
set attr_str [my GetMaxAttributeString $lst]
# font metrics:
# font measure font ?-displayof window? text
# Measures the amount of space the string text would use in the
# given font when displayed in window.
# The return value is the total width in pixels of text.
set margin [font measure APP_FONT_BIG_BOLD -displayof $txt $attr_str]
# puts "--> $attr_str : $margin"
# text widget tag definitions
# ---------------------------
$txt tag configure ATTR_NAME \
-font APP_FONT_STD_BOLD_FIXED -spacing1 5
$txt tag configure ATTR_TXT0 \
-font APP_FONT_BIG_BOLD \
-foreground "DarkRed"
$txt tag configure ATTR_TXT1 \
-font APP_FONT_STD_NORMAL_FIXED \
-foreground "DarkBlue" -lmargin2 $margin
}
method Build {frm} {
my variable widgetCompounds
my variable tblwidget
set f [ttk::frame $frm.bttn]
pack $f -fill x -side top
ttk::button $f.bttn \
-text "" -compound left \
-command "[namespace code {my TogglePaneOrientation}]" \
-style Toolbutton
ttk::style configure myCustom.TLabel -foreground "Grey"
ttk::label $f.date \
-text "" \
-font APP_FONT_STD_BOLD \
-style myCustom.TLabel
pack $f.bttn $f.date -side right -pady 2
# status message
ttk::label $f.lbl_msg \
-text "" -compound left \
-font APP_FONT_STD_NORMAL \
-style myCustom.TLabel
pack $f.lbl_msg -side left -padx 5 -pady 2
set widgetCompounds(pane_bttn) $f.bttn
set widgetCompounds(date) $f.date
set widgetCompounds(status_msg) $f.lbl_msg
# unused
# set f [ttk::frame $frm.status]
# pack $f -fill x -side bottom
set f [ttk::frame $frm.tbl]
pack $f -fill both -expand true -side bottom
# note: ttk::panedwindow does not allow:
# "configure -orient ..." (option is read-only ?!...)
set pane [tk::panedwindow $f.pane \
-orient [my cget -xpaneorient] \
-sashwidth 5 \
-opaqueresize true \
-bg LightGrey]
pack $pane -fill both -expand true
$pane add [set pane_uppr [ttk::frame $frm.pane_uppr]] ;# -weight 1
$pane add [set pane_lowr [ttk::frame $frm.pane_lowr]] ;# -weight 1
set widgetCompounds(pane) $pane
bind $f.pane <ButtonRelease-1> "[namespace code {my Zoom2Selection}]"
bind $f.pane <3> "[namespace code {my TogglePaneOrientation}]"
# ----------------------
# tablelist goes here...
# ----------------------
tablelist::tablelist $pane_uppr.tbl \
-showseparators yes \
-selectmode single \
-labelcommand "::tablelist::sortByColumn" \
-stretch 2 \
-xscrollcommand "$pane_uppr.scrollx set" \
-yscrollcommand "$pane_uppr.scrolly set" \
-stripebackground "#FDFEFE"
set tblwidget $pane_uppr.tbl
ttk::scrollbar $pane_uppr.scrollx \
-command "$pane_uppr.tbl xview" -orient horizontal
ttk::scrollbar $pane_uppr.scrolly \
-command "$pane_uppr.tbl yview" -orient vertical
pack $pane_uppr.scrollx -side bottom -fill x
pack $pane_uppr.scrolly -side right -fill y
pack $pane_uppr.tbl -side left -fill both -expand true
autoscroll::autoscroll $pane_uppr.scrollx
autoscroll::autoscroll $pane_uppr.scrolly
# -----------
# text-widget
# -----------
text $pane_lowr.txt \
-wrap word \
-yscrollcommand "$pane_lowr.scrolly set" \
-relief flat \
-state disabled
set widgetCompounds(txtwidget) $pane_lowr.txt
ttk::scrollbar $pane_lowr.scrolly \
-command "$pane_lowr.txt yview" -orient vertical
pack $pane_lowr.scrolly -side right -fill y
pack $pane_lowr.txt -side left -fill both -expand true
autoscroll::autoscroll $pane_lowr.scrolly
# retrieve option settings from ttk
$widgetCompounds(txtwidget) configure \
-fg [ttk::style configure . -foreground] \
-bg [ttk::style configure . -background]
$tblwidget configure \
-selectforeground [ttk::style configure . -selectforeground] \
-selectbackground [ttk::style configure . -selectbackground]
# ---------------------------
# initialization starts here:
# ---------------------------
my TogglePaneOrientation "set_image"
my GetTime
}
}
# ---
# eof
# ---
- ImageLib.tcl
# ImageLib.tcl ---
# Automatically created by: CreateImageLib.tcl
set images(img_unchecked) [image create photo -data {
R0lGODlhDQANAPIFABxRgOLi3erq5vHx7/n5+QAAAAAAAAAAACH5BAEBAAUALAAAAAANAA0AAANk
CAAAgAAAAAgQEYEhIjM4ABGBISIzOAMQgSEiM0hDAIEhIjM4RASAISIyOEREgCAiMzhERIQAIjI4
RESEBCAzOEREhEQAMjhERIREBDA4RESEREQAOENEhEREBAgAAIAAAAAICQA7
}]
set images(img_checked) [image create photo -data {
R0lGODlhDQANAPIGABxRgCGhIeLi3erq5vHx7/n5+AAAAAAAACH5BAEBAAYALAAAAAANAA0AAANk
CAAAgAAAAAggIoIyM0RIACKCMjNESAQggjIzRBhVAIIjM0QYUQWAIjFEGBFVgDATQRgRVYUAMxEY
EVWFBTBEGBFVhVUAREgVVYVVBUBIVVWFVVUASFRVhVVVBQgAAIAAAAAICQA7
}]
set images(img_leftright) [image create photo -data {
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAALGOfPtRkwAACj1pQ0NQ
aWNjAAB42p1TZ1RT6RY99970QkuIgJRLb1IVCCBSQouAVGmiEpIAoYQYEkDsiKjAiKIighUZFHHA
0RGQsSKKhUGx9wF5CCjj4Cg2VN4P3hp9s+a9N2/2r732OWed75x9PgBGYLBEmoWqAWRKFfKIAB88
Ni4eJ3cDClQggQOAQJgtC4n0jwIA4Pvx8OyIAB/4AgTgzW1AAABu2ASG4Tj8f1AXyuQKACQMAKaL
xNlCAKQQADJyFTIFADIKAOykdJkCACUAAFseGxcPgGoBADtlkk8DAHbSJPcCALYoUyoCQKMAQCbK
FIkA0A4AWJejFIsAsGAAKMqRiHMBsJsAYJKhzJQAYO8AgJ0pFmQDEBgAYKIQC1MBCPYAwJBHRfAA
CDMBKIyUr3jSV1whzlMAAPCyZIvlkpRUBW4htMQdXF25eKA4N0OsUNiECYTpArkI52VlygTSxQCT
MwMAgEZ2RIAPzvfjOTu4OjvbONo6fLWo/xr8i4iNi/+XP6/CAQEAhNP1RfuzvKwaAO4YALbxi5a0
HaBlDYDW/S+ayR4A1UKA5qtfzcPh+/HwVIVC5mZnl5ubaysRC22FqV/1+Z8JfwFf9bPl+/Hw39eD
+4qTBcoMBR4R4IMLszKylHI8WyYQinGbPx7x3y7883dMixAni+ViqVCMR0vEuRJpCs7LkookCkmW
FJdI/5OJf7PsD5i8awBg1X4G9kJbULvKBuyXLiCw6IAl7AIA5HffgqnREAYAMQaDk3cPADD5m/8d
aBkAoNmSFBwAgBcRhQuV8pzJGAEAgAg0UAU2aIM+GIMF2IAjuIA7eIEfzIZQiII4WABCSIVMkEMu
LIVVUAQlsBG2QhXshlqoh0Y4Ai1wAs7CBbgC1+AWPIBeGIDnMApvYBxBEDLCRFiINmKAmCLWiCPC
RWYhfkgwEoHEIYlICiJFlMhSZDVSgpQjVchepB75HjmOnEUuIT3IPaQPGUZ+Qz6gGMpA2ageaoba
oVzUGw1Co9D5aAq6CM1HC9ENaCVagx5Cm9Gz6BX0FtqLPkfHMMDoGAczxGwwLsbDQrF4LBmTY8ux
YqwCq8EasTasE7uB9WIj2HsCicAi4AQbgjshkDCXICQsIiwnlBKqCAcIzYQOwg1CH2GU8JnIJOoS
rYluRD4xlphCzCUWESuIdcRjxPPEW8QB4hsSicQhmZNcSIGkOFIaaQmplLST1EQ6Q+oh9ZPGyGSy
Ntma7EEOJQvICnIReTv5EPk0+Tp5gPyOQqcYUBwp/pR4ipRSQKmgHKScolynDFLGqWpUU6obNZQq
oi6mllFrqW3Uq9QB6jhNnWZO86BF0dJoq2iVtEbaedpD2is6nW5Ed6WH0yX0lfRK+mH6RXof/T1D
g2HF4DESGErGBsZ+xhnGPcYrJpNpxvRixjMVzA3MeuY55mPmOxWWiq0KX0WkskKlWqVZ5brKC1Wq
qqmqt+oC1XzVCtWjqldVR9SoamZqPDWB2nK1arXjanfUxtRZ6g7qoeqZ6qXqB9UvqQ9pkDXMNPw0
RBqFGvs0zmn0szCWMYvHErJWs2pZ51kDbBLbnM1np7FL2N+xu9mjmhqaMzSjNfM0qzVPavZyMI4Z
h8/J4JRxjnBucz5M0ZviPUU8Zf2UxinXp7zVmqrlpSXWKtZq0rql9UEb1/bTTtfepN2i/UiHoGOl
E66Tq7NL57zOyFT2VPepwqnFU49Mva+L6lrpRugu0d2n26U7pqevF6An09uud05vRJ+j76Wfpr9F
/5T+sAHLYJaBxGCLwWmDZ7gm7o1n4JV4Bz5qqGsYaKg03GvYbThuZG4016jAqMnokTHNmGucbLzF
uN141MTAJMRkqUmDyX1TqinXNNV0m2mn6Vszc7MYs7VmLWZD5lrmfPN88wbzhxZMC0+LRRY1Fjct
SZZcy3TLnZbXrFArJ6tUq2qrq9aotbO1xHqndc804jTXadJpNdPu2DBsvG1ybBps+mw5tsG2BbYt
ti/sTOzi7TbZddp9tneyz7CvtX/goOEw26HAoc3hN0crR6FjtePN6czp/tNXTG+d/nKG9QzxjF0z
7jqxnEKc1jq1O31ydnGWOzc6D7uYuCS67HC5w2Vzw7il3IuuRFcf1xWuJ1zfuzm7KdyOuP3qbuOe
7n7QfWim+UzxzNqZ/R5GHgKPvR69s/BZibP2zOr1NPQUeNZ4PvEy9hJ51XkNelt6p3kf8n7hY+8j
9znm85bnxlvGO+OL+Qb4Fvt2+2n4zfWr8nvsb+Sf4t/gPxrgFLAk4EwgMTAocFPgHb4eX8iv54/O
dpm9bHZHECMoMqgq6EmwVbA8uC0EDZkdsjnk4RzTOdI5LaEQyg/dHPoozDxsUdiP4aTwsPDq8KcR
DhFLIzojWZELIw9GvonyiSqLejDXYq5ybnu0anRCdH302xjfmPKY3li72GWxV+J04iRxrfHk+Oj4
uvixeX7zts4bSHBKKEq4Pd98ft78Swt0FmQsOLlQdaFg4dFEYmJM4sHEj4JQQY1gLImftCNpVMgT
bhM+F3mJtoiGxR7icvFgskdyefJQikfK5pThVM/UitQRCU9SJXmZFpi2O+1temj6/vSJjJiMpkxK
ZmLmcamGNF3akaWflZfVI7OWFcl6F7kt2rpoVB4kr8tGsudntyrYCpmiS2mhXKPsy5mVU53zLjc6
92ieep40r2ux1eL1iwfz/fO/XUJYIlzSvtRw6aqlfcu8l+1djixPWt6+wnhF4YqBlQErD6yirUpf
9VOBfUF5wevVMavbCvUKVxb2rwlY01CkUiQvurPWfe3udYR1knXd66ev377+c7Go+HKJfUlFycdS
Yenlbxy+qfxmYkPyhu4y57JdG0kbpRtvb/LcdKBcvTy/vH9zyObmLfiW4i2vty7ceqliRsXubbRt
ym29lcGVrdtNtm/c/rEqtepWtU910w7dHet3vN0p2nl9l9euxt16u0t2f9gj2XN3b8De5hqzmop9
pH05+57WRtd2fsv9tr5Op66k7tN+6f7eAxEHOupd6usP6h4sa0AblA3DhxIOXfvO97vWRpvGvU2c
ppLDcFh5+Nn3id/fPhJ0pP0o92jjD6Y/7DjGOlbcjDQvbh5tSW3pbY1r7Tk++3h7m3vbsR9tf9x/
wvBE9UnNk2WnaKcKT02czj89dkZ2ZuRsytn+9oXtD87FnrvZEd7RfT7o/MUL/hfOdXp3nr7ocfHE
JbdLxy9zL7dccb7S3OXUdewnp5+OdTt3N191udp6zfVaW8/MnlPXPa+fveF748JN/s0rt+bc6rk9
9/bdOwl3eu+K7g7dy7j38n7O/fEHKx8SHxY/UntU8Vj3cc3Plj839Tr3nuzz7et6EvnkQb+w//k/
sv/xcaDwKfNpxaDBYP2Q49CJYf/ha8/mPRt4Lns+PlL0i/ovO15YvPjhV69fu0ZjRwdeyl9O/Fb6
SvvV/tczXrePhY09fpP5Zvxt8Tvtdwfec993foj5MDie+5H8sfKT5ae2z0GfH05kTkz8EwOY8/wl
YzOiAAAAIGNIUk0AAHolAACAgwAA+f8AAIDpAAB1MAAA6mAAADqYAAAXb5JfxUYAAAAGYktHRAAA
AAAAAPlDu38AAAAJcEhZcwAACxMAAAsTAQCanBgAAAAJdnBBZwAAABAAAAAQAFzGrcMAAAGUSURB
VDjLpZPLalRBEIa/uvSZk8GoG13oQiRbd0LiRvA5fKC8gBvXPoqoEARB3JpFFgZFFB285JzTXeVi
MiYamYXT0DRd1f1T9fXfkplsMnz/0ZPHw8l4o9aWLYIWQUSezgBAVVARRIWuOKaKm0kIx16H8eGD
+3vbJ8PEME4MY2WaJsapMdWGAMWN4oYX5+r2nH5WmHWF5wevvvj1K531+Z2+g2aN1gXT1Ahg8XXg
5/CDy7M5W33PfF7ot5KuE8yCm9cuue/s3PbdvV1abYhAiKAJpTgvXr4mIrl39w5Ta5goZgoimCqL
byfuqoqpYp1eABSReCm4O+7+T4i6BjApibD+ldYLJCDy/wI0kNxEwCAk1hwQfOXEiLNeI8BdyBQI
LuRhaa7IxDmFlBmna7IULTiJigL5O3/GZxn31YVVJef35orpUjwikHNAMxMycREVEUHV/qAvIpSu
pyuOiC0N9FcLoooff/j45umzg1vDOEZkUmtlGiu1VT59XmBmHB6+xcxxM1QNVWHWFT169/5INv3O
vwAQJMu2Z9D/4wAAACV0RVh0Y3JlYXRlLWRhdGUAMjAwOS0xMS0yOFQxNzoxODoyOC0wNzowMDGR
siwAAAAldEVYdGRhdGU6Y3JlYXRlADIwMTAtMDItMjBUMjM6MjQ6MjAtMDc6MDDeeaT4AAAAJXRF
WHRkYXRlOm1vZGlmeQAyMDEwLTAxLTExVDA4OjQyOjQzLTA3OjAw5QuC6AAAADV0RVh0TGljZW5z
ZQBodHRwOi8vY3JlYXRpdmVjb21tb25zLm9yZy9saWNlbnNlcy9MR1BMLzIuMS87wbQYAAAAJXRF
WHRtb2RpZnktZGF0ZQAyMDA5LTExLTI4VDE0OjMxOjI4LTA3OjAwd5M63QAAABZ0RVh0U291cmNl
AENyeXN0YWwgUHJvamVjdOvj5IsAAAAndEVYdFNvdXJjZV9VUkwAaHR0cDovL2V2ZXJhbGRvLmNv
bS9jcnlzdGFsL6WRk1sAAAAASUVORK5CYII=
}]
set images(img_topbottom) [image create photo -data {
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABmJLR0QAAAAAAAD5Q7t/AAAACXBI
WXMAAABIAAAASABGyWs+AAAACXZwQWcAAAAQAAAAEABcxq3DAAABLklEQVQ4y62Tr04EQQyHv850
dw+SC0hyCad4BxTheA0eCE2CQaDAIXgADCAQGAgeTZDI292ZFrF7wCH4c0czzaSiv/z6dUbcnWVC
D45Oj+tpM0opezYjm2HmfRoAIQhBBAlCWSgxBDRGMeFZU93sT3a2h9O6pW5a6ibRti1Nm2lTRoBC
I4VGtFDWh6sMqoKqLLi9u3/VSklbozWQQAiCiHQ3AenrLgGkP4Jq5OExtlqUJZvj8ULzx6iEJRkS
lmv/BwEFuLq+AQnY5xW60W3R38EGEWQGG/8Q2Jvs8vVBSYf923g6u0DplRYRcPfOgXtnew7OL+lo
L8XMyZ8hClLklMhmnUQ/iqr+2CwiaKyqy8OT842UM9kcy4a5Y7kTijHi2FxdamSlGtB4epFlv/Mb
xG2MLzGlDgAAAAAldEVYdGNyZWF0ZS1kYXRlADIwMDktMTEtMjhUMTc6MTg6MjgtMDc6MDAxkbIs
AAAAJXRFWHRkYXRlOmNyZWF0ZQAyMDEwLTAyLTIwVDIzOjI0OjIwLTA3OjAw3nmk+AAAACV0RVh0
ZGF0ZTptb2RpZnkAMjAxMC0wMS0xMVQwODo0Mjo1MS0wNzowML4+k18AAAA1dEVYdExpY2Vuc2UA
aHR0cDovL2NyZWF0aXZlY29tbW9ucy5vcmcvbGljZW5zZXMvTEdQTC8yLjEvO8G0GAAAACV0RVh0
bW9kaWZ5LWRhdGUAMjAwOS0xMS0yOFQxNDozMTozMS0wNzowMC6hf5AAAAAWdEVYdFNvdXJjZQBD
cnlzdGFsIFByb2plY3Tr4+SLAAAAJ3RFWHRTb3VyY2VfVVJMAGh0dHA6Ly9ldmVyYWxkby5jb20v
Y3J5c3RhbC+lkZNbAAAAAElFTkSuQmCC
}]
- tablelistbrowser_demo.tcl
# -----------------------------------------------------------------------------
# tablelistbrowser.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 ...
# -----------------------------------------------------------------------------
# for development: try to find autoscroll, etc ...
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 ".."]]
package require Tk
package require TclOO
package require autoscroll
package require tablelist_tile
package require tablelistbrowser
set fnames [font names]
set fsize 10
set ffamily "Courier"
font create APP_FONT_STD_NORMAL -family $ffamily -size $fsize -weight normal
font create APP_FONT_STD_BOLD -family $ffamily -size $fsize -weight bold
font create APP_FONT_SMALL_NORMAL -family $ffamily -size [expr {$fsize - 2}] -weight normal
font create APP_FONT_BIG_BOLD -family $ffamily -size [expr {$fsize + 0}] -weight bold
# ---------
# demo code
# ---------
catch {console show}
set t [tablelistbrowser::tablelistbrowser .t \
-showseparators yes \
-selectmode single \
-labelcommand "tablelist::sortByColumn"]
pack $t -fill both -expand true
# create some random test data...
set demo "info_procs"
switch -- $demo {
"random" {
set header \
{{"ID" 10 left}
{"Category" 22 left}
{"test-column" 16 left}
{"Hello\\nWorld" 10 left}
{"test" "hidden" center}
{"last\\ncolumn" 10 left}}
$t configure \
-xtabheader $header
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
}
foreach item $data_list {
$t insert end $item
}
}
"info_procs" {
set header \
{{"ID" 10 left}
{"Info_Procs" 20 left}
{"Body" hidden left}}
$t configure \
-xtabheader $header \
-snipstring "..."
set data_list {}
set cnt 0
foreach p [lsort -dictionary [info procs]] {
# set body [string map {"\n" " "} [info body $p]]
set row [list $cnt $p [string trim [info body $p]]]
$t insert end $row
incr cnt
}
}
}
# ---------------------
# object introspection:
# ---------------------
# puts [winfo class $t]
# puts [$t configure]
# catch { [$t blabla 1] } msg
# puts $msg
# return
# 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 modifyColumnImage "dummy,0" "init"
- pkgIndex.tcl
# Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. package ifneeded tablelistbrowser 0.2 [list source [file join $dir tablelistbrowser.tcl]]