[JOB] 16-08-11

A TclOO class implementing a breadcrumbs megawidget. Might be usefull as a starting point.

[WikiDbImage breadcrumbs.png]


****breadcrumbs.tcl****

======
# -----------------------------------------------------------------------------
# breadcrumbs.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 a breadcrumbs 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 ...
# -----------------------------------------------------------------------------
# Credits:
#  - Open Icon Library Packages, Archive Creator: Jeff Israel
# -----------------------------------------------------------------------------
# >>>
# >>>   What is the good thing to do today:
# >>>   to help to make the world a better place...
# >>>
# -----------------------------------------------------------------------------

# Documentation:
# --------------
#   draw a navigation - similar like web-page "breadcrump" navigation
#   might be somethimes usefull to e.g. indicate current settings
#   or to improve user experience
#
# widget commands:
#   <path> configure
#   <path> cget
#
# the widget's configuration options:
#         -foreground ... fgcolor
#   -background ... bgcolor
#   -textlist ..... list of strings specifying the "breadcrump" navigation bar

package provide breadcrumbs 0.1


namespace eval breadcrumbs {
        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"]
        
        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 breadcrumbs {path args} {
                set obj [BreadCrumpsClass create tmp $path {*}$args]
                # rename oldName newName
                rename $obj ::$path
                return $path
        }
        
        # font creation
        # -------------
        
        set fsize  8
        set ffamily "MS Sans Serif" ;# "Helvetica" / "Courier New"
        set fnames [font names]
        
        if {[lsearch $fnames MY_FONT_STD_NORMAL] == -1} {
                font create MY_FONT_STD_NORMAL -family $ffamily -size $fsize -weight normal
        } else {
                font configure MY_FONT_STD_NORMAL -family $ffamily -size $fsize -weight normal
        }
        
        if {[lsearch $fnames MY_FONT_STD_BOLD] == -1} {
                font create MY_FONT_STD_BOLD -family $ffamily -size $fsize -weight bold
        } else {
                font configure MY_FONT_STD_BOLD -family $ffamily -size $fsize -weight bold
        }
}


oo::class create BreadCrumpsClass {
        
        variable txtwidget
        variable widgetOptions
        variable widgetCompounds
        
        constructor {path args} {
                
                set image_file $::breadcrumbs::image_file
                set image_dir $::breadcrumbs::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 [::breadcrumbs::LoadImages \
                                        [file join $image_dir] {"*.gif" "*.png"}]
                }
                # ---------------------------------------------------------------
                
                array set widgetCompounds {
                        img_cnt 0
                }
                
                # declaration of all additional widget options
                
                # retrieve option settings from ttk
                set fg [ttk::style configure . -foreground]
                set bg [ttk::style configure . -background]
                
                array set widgetOptions [list \
                                -textlist {} \
                                -foreground $fg \
                                -background $bg \
                                ]
                
                # we use a frame for this specific widget class
                my Build [ttk::frame $path -class breadcrumbs]
                
                # 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 cget { {opt "" }  } {
                my variable txtwidget
                my variable widgetOptions
                
                if { [string length $opt] == 0 } {
                        return [array get widgetOptions]
                }
                if { [info exists widgetOptions($opt) ] } {
                        return $widgetOptions($opt)
                }
                return [$txtwidget cget $opt]
        }
        
        method configure { args } {
                my variable txtwidget
                my variable widgetOptions
                
                if {[llength $args] == 0}  {
                        
                        # return all text widget options
                        set opt_list [$txtwidget 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 [$txtwidget 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 {
                                -foreground {
                                        ttk::style configure myCustom.TLabel -foreground $opt_value
                                        $txtwidget configure -fg $opt_value
                                }
                                -background {
                                        ttk::style configure myCustom.TLabel -background $opt_value
                                        $txtwidget configure -bg $opt_value
                                }
                                -textlist {
                                        my InsertTextItems $opt_value
                                }
                                default {
                                        # if the configure option wasn't one of our special one's,
                                        # pass control over to the original text widget
                                        
                                        if {[catch {$txtwidget configure $opt_name $opt_value} result]} {
                                                return -code error $result
                                        }
                                }
                        }
                }
        }
        
        # if the command wasn't one of our special one's,
        # pass control over to the original text widget
        
        method unknown {method args} {
                my variable txtwidget
                
                if {[catch {$txtwidget $method {*}$args} result]} {
                        return -code error $result
                }
                return $result
        }
}


oo::define BreadCrumpsClass {
        
        # --------------------------------
        # Private interface implementation
        # --------------------------------
        
        method InsertTextItems {textlist} {
                my variable txtwidget
                my variable widgetCompounds
                
                $txtwidget configure -state normal
                $txtwidget delete 0.0 end
                
                set cnt 0
                foreach item $textlist {
                        set item [string trim $item]
                        
                        if {[string length $item] == 0} {
                                continue
                        }
                        
                        # create unique widget reference
                        incr widgetCompounds(img_cnt)
                        set img_label $txtwidget.$widgetCompounds(img_cnt)
                        
                        if {$cnt == 0} {
                                set img $widgetCompounds(insert-comments)
                        } else {
                                set img $widgetCompounds(media-playback-play-blue)
                        }
                        
                        # create embedded widget to display image ...
                        ttk::label $img_label \
                                        -image $img \
                                        -style myCustom.TLabel
                        
                        $txtwidget window create end -window $img_label
                        $txtwidget insert end " "
                        
                        incr cnt
                        
                        if {$cnt < [llength $textlist]} {
                                $txtwidget insert end $item ATTR_TXT0
                                $txtwidget insert end " "
                        } else {
                                $txtwidget insert end $item ATTR_TXT1
                        }
                }
                
                $txtwidget configure -state disabled
        }
        
        method Build {frm} {
                my variable widgetCompounds
                my variable txtwidget
                
                set f [ttk::frame $frm.bttn]
                pack $f -fill x -side top -expand true
                
                # ------------------------
                # text widget goes here...
                # ------------------------
                
                text $f.txt \
                                -wrap word \
                                -relief flat \
                                -state disabled \
                                -height 1.5 \
                                -padx 4
                
                pack $f.txt -fill x -expand true
                
                set txtwidget $f.txt
                
                $txtwidget tag configure ATTR_TXT0 \
                                -font MY_FONT_STD_NORMAL \
                                -foreground "DarkBlue"
                
                $txtwidget tag configure ATTR_TXT1 \
                                -font MY_FONT_STD_NORMAL \
                                -foreground "DarkRed"
        }
}

# ---
# eof
# ---

======


****breadcrumbs_demo.tcl****


======

# 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 ".."]]
set auto_path [linsert $auto_path 0 [file join $this_file "../../lib"]]


package require Tk
package require TclOO

package require breadcrumbs

# ---------
# demo code
# ---------
catch {console show}


set b [breadcrumbs::breadcrumbs .b]

pack $b -side top -fill x ;# -expand true


$b configure -textlist {"Hello" "World," "here" "we" "are:"}
$b configure -background "LightGrey" ;# "LightBlue"
======


****ImageLib.tcl****


======
# ImageLib.tcl ---
# Automatically created by: CreateImageLib.tcl

set images(media-playback-play-blue) [image create photo -data {
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAAK/INwWK6QAAAAZiS0dE
AAAAAAAA+UO7fwAAAAlwSFlzAAAASAAAAEgARslrPgAAAAl2cEFnAAAAEAAAABAAXMatwwAAAtJJ
REFUOMulk01vG1UUhh/PjD3+mNSxE7txgqxAE2OsVAqipQvYIEWFf0D32WTb/oL+AMS6KrsuqrBE
qipk9WMDVVGbkooqTF0lDSEThzih9ow/xvbMPSwcV5Vgx5XO5uo+R++5530jIsK75/INZoE5IAek
T69bQANwqmscvPs+Mm5w+QYWUL444166cNatzCb95VQ0KIsIbl+zD9rm5sZReuvZceYXwK6u0X7b
4BT+eHWpvlKZ7l3J56ZLqWSCuGkA0POHeO0Oe/sHNfsksX57+4N7wK/VNdrGqZLy6lJ9ZSnnXzs3
X7TipkFvEOJ1AwQwozqz+QxnJlKl8IV97ev5V3y/u9gDnuqPZq7PXpxxV74ouqsL7xcLcdPg2B3Q
HwqPXjYpZOL4gcLrhUxNmGSzmZj3106hNYg63/5sORowdyHfquRz06UxrARE4Fa1xuNaExFQStg/
8bESMYrz86WF2G4FmNOAXCHpL6eSCTr9kFCNYIUgorhVtXlcawKgBNxuQHYyjaWOl4GcBqSTxrAc
Nw38gQIgFEEpAUa1/nCXV/UuSgluLyBtmURVpwykNYDxKkWEUAQRYWwPXY8R9LucL1ooGanwByHD
4RAADWi5fc1udweYUQ2lRrAS0PUowcDn5tXPcHshIsJEXOfoTYf2QLeBlgY0HC+26bptrLiBEgjV
aIQx3OoGKCUoBVbCYN+pcxKkN4GGBjhPj9Jb2zs7tTeeT3E6TqhGCm5e/ZxmJ0Cp0b8sFJLsHbb4
7flGbY/FLcDRt+9c9775KSlT+t9Dr/H6k3RmKvbeVBItEqHdD9E0mLSizEyavK43uftjtX3Yz373
e+TTB9U1Xo6daP9QP5/4cvIJzfsPryyWPioVzubInEkShMLhiceTPx1ePN+oNVR+/Vn0q3uA/Z9h
Ohf749Kcsiup4Gg5Jt1yEIT4Ytotspt1o7LlaB/+O0z/J87/ALPahd78pgKZAAAAJXRFWHRjcmVh
dGUtZGF0ZQAyMDA5LTExLTE2VDIyOjE4OjE2LTA3OjAw/Xf1dQAAACV0RVh0ZGF0ZTpjcmVhdGUA
MjAxMC0wMS0xMVQwNjo1MzowNy0wNzowMDD5qPMAAAAldEVYdGRhdGU6bW9kaWZ5ADIwMTAtMDEt
MTFUMDY6NTM6MDctMDc6MDBBpBBPAAAAYnRFWHRMaWNlbnNlAGh0dHA6Ly9jcmVhdGl2ZWNvbW1v
bnMub3JnL2xpY2Vuc2VzL2J5LzMuMC8gb3IgaHR0cDovL2NyZWF0aXZlY29tbW9ucy5vcmcvbGlj
ZW5zZXMvYnkvMi41L4uGPGUAAAAldEVYdG1vZGlmeS1kYXRlADIwMDYtMDMtMTJUMjE6NTE6MzQt
MDc6MDCfAsjjAAAAGXRFWHRTb2Z0d2FyZQBBZG9iZSBJbWFnZVJlYWR5ccllPAAAABt0RVh0U291
cmNlAEZBTUZBTUZBTSBTaWxrIEljb25zgnpk+wAAADN0RVh0U291cmNlX1VSTABodHRwOi8vd3d3
LmZhbWZhbWZhbS5jb20vbGFiL2ljb25zL3NpbGsvwsQNDQAAAABJRU5ErkJggg==
}]
set images(insert-comments) [image create photo -data {
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAAK/INwWK6QAAAAZiS0dE
AAAAAAAA+UO7fwAAAAlwSFlzAAAASAAAAEgARslrPgAAAAl2cEFnAAAAEAAAABAAXMatwwAAAfFJ
REFUOMuNkk1rE1EUhp+ZJkOtk1pqqStBLVEXdSG0bly5GlBcCok/oKAgbseNukvwHyilkWwCZilC
klJdJEgFCRRqSkiJ2NLiV1OKxiTzcY+bpCVhUvrC5cK95z3nvQ9XiyVyV4EFYIZgtYECsJyxra3B
yxDwYOH27OxcdBrpncrR1nE9s7S+ez9b3DwPPB9soAMX56LT+AK+As8HRwmOL3Q8hREOMX/5HMCl
oHih3iQR8JQgIoiAEkEJgOI4hQBN00AJSNdU3W6Mv12tz/w6aEW0oxepeDJ/t+trAmkgHQI6jqPG
ImNhGk2FiPDu09fonRsXzgRwMbpcJkrru0+yxc0rOpB7vVzhy7c9zpphpiIG3/ebp0/I5Zqesa3F
z7Wfz15ky3v7fzt8WNvB9VQfF08pfF9wfYXrC453xEUHyNhWCWit1X+TKlRcoD3IpQdVKUEpYUTX
AMI6QDyZPwVMLuUrDvAIaDqOwhwd6WsS0jVGwzqTpoHrK4CO3k1iAmXgYca2akAqvbJBdbtxyGUq
YuC6Hn/+dXhTrGEvfWwBrzSRQ859iifz94DFl49vja9u/CBVqAhQB1rAe+BpxrYOuh8neMUSuWqh
vCWxRK4dS+SuB9Ucl8AEdgADuJmxrXJQnc5wTQArwPwwMzA8wUn1H+DSNPT2LId8AAAAJXRFWHRj
cmVhdGUtZGF0ZQAyMDA5LTExLTE2VDIyOjE4OjE2LTA3OjAw/Xf1dQAAACV0RVh0ZGF0ZTpjcmVh
dGUAMjAxMC0wMS0xMVQwNjo1MzowMC0wNzowMPVeln0AAAAldEVYdGRhdGU6bW9kaWZ5ADIwMTAt
MDEtMTFUMDY6NTM6MDAtMDc6MDCEAy7BAAAAYnRFWHRMaWNlbnNlAGh0dHA6Ly9jcmVhdGl2ZWNv
bW1vbnMub3JnL2xpY2Vuc2VzL2J5LzMuMC8gb3IgaHR0cDovL2NyZWF0aXZlY29tbW9ucy5vcmcv
bGljZW5zZXMvYnkvMi41L4uGPGUAAAAldEVYdG1vZGlmeS1kYXRlADIwMDYtMDMtMTJUMjE6NTE6
MTAtMDc6MDApaOuNAAAAGXRFWHRTb2Z0d2FyZQBBZG9iZSBJbWFnZVJlYWR5ccllPAAAABt0RVh0
U291cmNlAEZBTUZBTUZBTSBTaWxrIEljb25zgnpk+wAAADN0RVh0U291cmNlX1VSTABodHRwOi8v
d3d3LmZhbWZhbWZhbS5jb20vbGFiL2ljb25zL3NpbGsvwsQNDQAAAABJRU5ErkJggg==
}]

======


****pkgIndex.tcl****

======
package ifneeded breadcrumbs 0.1 [list source [file join $dir breadcrumbs.tcl]]
======



<<categories>> widget