JOB 16-08-11
A TclOO class implementing a breadcrumbs megawidget. Might be usefull as a starting point.
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]]
