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.

WikiDBImage tablelistbrowser_demo.png

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]]