if 0 {[Richard Suchenwirth] 2004-10-23 - [BWidget]'s [Tree] is a powerful widget, useful for browsing hierarchical structures (e.g. the file system, widget or namespace hierarchies, etc.) [http://mini.net/files/LemonTree.gif] LemonTree is a weekend fun project to explore its possibilities - "very pretty", but some fruits first were sour for me :) One quirk was that each node has to have a unique name, which better not contains "::" - but a simple solution is to just count up an integer, ''uniqueID''. } package require BWidget namespace eval LemonTree {variable uniqueID 0} if 0 {The [Tree] widget allows a -data item for each node, which I use for a [dict]-like list that contains the node's type and "real name" (as opposed to the "display name" - for instance, a dir node would display only its [[file tail]], but the real name is the full path). This routine adds a node to the LemonTree: } proc LemonTree::add {w parent type name {text ""}} { variable uniqueID; variable icon if {$text eq ""} {set text $name} set id n[incr uniqueID] set data [list type $type name $name] set fill [expr {[string match (* $text]? "blue": "black"}] set drawcross [expr {[info proc ::LemonTree::kids($type)] eq ""? "never": "allways"}] $w insert end $parent $id -text $text -data $data \ -drawcross $drawcross -fill $fill if [info exists icon($type)] { $w itemconfigure $id -image $icon($type) } } if 0 {For speed, a Tree isn't drawn fully expanded at the beginning. Instead, nodes are opened on demand, when the user clicks on the [[+]] icon. I use the -drawcross "allways" mode (shudder - should be fixed to "always", but then older code might break) to indicate that the node hasn't been opened before - after the first opening, the mode is set to "auto", meaning to draw a cross only if the node has children. } proc LemonTree::open {w node} { if {[$w itemcget $node -drawcross] eq "allways"} { set data [$w itemcget $node -data] set type [dict'get $data type] foreach {ktype kids} [kids($type) $w $node] { foreach kid $kids {add $w $node $ktype $kid} } $w itemconfigure $node -drawcross auto } } if 0 {So far for the generic LemonTree - the rest is already customization for specific item types. The ''kids($type)'' call above looks like an array element - in fact it's a way of dispatching the generic operation of providing the list of children of an entity of given type, which of course depends on the type. For instance, the children of a directory are its subdirectories, and then its files (with special-casing for [Windows], so that drive letters are the children of "/"): } proc LemonTree::kids(dir) {w node} { set name [dict'get [$w itemcget $node -data] name] if {$::tcl_platform(platform) eq "windows" && $name eq "/"} { return [list dir [file volumes]] } set dirs [lsort [glob -nocomplain -type d $name/*]] set files [lsort [glob -nocomplain -type f $name/*]] list dir $dirs file $files } if 0 {Namespaces have a hierarchy, but contain collections of commands and variables as well. So I introduced an intermediate layer (parens around the display name make these "meta-children" come displayed in blue):} proc LemonTree::kids(namespace) {w node} { list ns-commands (Commands) ns-vars (Variables) ns-children (Children) } proc LemonTree::kids(ns-children) {w node} { set ns [dict'get [$w itemcget [$w parent $node] -data] name] list namespace [lsort [namespace children $ns]] } proc LemonTree::kids(ns-commands) {w node} { set ns [dict'get [$w itemcget [$w parent $node] -data] name] list command [lsort [info commands ${ns}::*]] } proc LemonTree::kids(ns-vars) {w node} { set ns [dict'get [$w itemcget [$w parent $node] -data] name] set res "" foreach var [lsort [info vars ${ns}::*]] { lappend res [expr {[array exists $var]? "array": "variable"}] $var } set res } #-- Arrays can also be seen as a one-level subtree: proc LemonTree::kids(array) {w node} { set name [dict'get [$w itemcget $node -data] name] list variable [lsort [array names $name]] } proc LemonTree::kids(widget) {w node} { set name [dict'get [$w itemcget $node -data] name] list widget [winfo children $name] } if 0 {A Tree looks prettier if nodes have icons, so I'm using some of those that BWidget comes with:} set path $BWIDGET::LIBRARY/images foreach {type name} {dir folder file file array copy} { set LemonTree::icon($type) [image create photo -file $path/$name.gif] } # Some more icons come from [adavis]'s [Icons] package: set LemonTree::icon(widget) [image create photo -data { R0lGODlhEAAQAIUAAFxaXGRmZFRWVGQmhFwmfFxeXOTm5MTCxLyWzLySzKyC vKSCvJxyrJRmrIxipIxWpNze3AQCBMTGxJRWtJRatIxOrIRCpHw+pHw6nHQ2 lGwulOzu7Pz+/Pz+9Ozu5Pz+7NzexPz+5Pz+hPz+3NzevPz+BMTCBNzetMTC DPz+xNze1NzezPwCBAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACwALAAAAAAQABAAAAaV QEBAMCAUj0aCYFkwHBAJhWLBYDQcD8ghIjhIJhRKxXLBZDQaiYQLABDe8PiS u+HY7/dOh+PhQvB4eh8fIH6Adh2DHyGFAn+BiQAiISMkhnmSIQAlI5KXHIkf AiUmpCUnhoKLISgpIikmAlwqtCArkiUlIhwiuSKyEcHCESausMEsycrJEaal y9ARIizN1NPQ0dfJfkEAIf5oQ3JlYXRlZCBieSBCTVBUb0dJRiBQcm8gdmVy c2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4LiBBbGwgcmlnaHRzIHJl c2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw==}] set LemonTree::icon(namespace) [image create photo -data { R0lGODlhEAAQAIIAAPwCBAQCBPz+xERCBMTCBISCBDQyNAAAACH5BAEAAAAA LAAAAAAQABAAAANPCLoR+7AJ0SALYkxd79za12FgOTlAQBDhRxUFqrKEG8Py OqwEfMeKwGDI8zVGul0vFsAFdaxB43ecKZfUKm1lZD6ERZgBZWn0OpYvGeJP AAAh/mhDcmVhdGVkIGJ5IEJNUFRvR0lGIFBybyB2ZXJzaW9uIDIuNQ0KqSBE ZXZlbENvciAxOTk3LDE5OTguIEFsbCByaWdodHMgcmVzZXJ2ZWQuDQpodHRw Oi8vd3d3LmRldmVsY29yLmNvbQA7}] set LemonTree::icon(command) [image create photo -data { R0lGODlhEAAQAIIAAPwCBAQCBISChMTCxDQyNFxaXKSipPz+/CH5BAEAAAAA LAAAAAAQABAAAANdCLobwbAFMciLwBFSihBEFHSG8QnmpQQEBX6loI5G5QTl cMgrZSmEmsGxKqRWNV3hMrFlBtDoA1eTEaKHJdMYhR6+gxkF++UMGbiDzvDV ioyHAJSHcchuGLQq4k8AACH+aENyZWF0ZWQgYnkgQk1QVG9HSUYgUHJvIHZl cnNpb24gMi41DQqpIERldmVsQ29yIDE5OTcsMTk5OC4gQWxsIHJpZ2h0cyBy ZXNlcnZlZC4NCmh0dHA6Ly93d3cuZGV2ZWxjb3IuY29tADs=}] set LemonTree::icon(variable) [image create photo -data { R0lGODlhEAAQAIYAAPwCBFxaVMR+RPzKjNze3AQCBMR6RPzGjPyODPz+/MzO zPyKDPyKBPz29OTWzPyGDPyGBOx6BOza1OR2BKROBNSOXKRKBBwOBOzu7PTW xPzizOySZPyCDFxaXOy2lNRyRMxmJCQOBPTm1OzStPTKrMR+XIRWLFxGNCQS BDQyNIRSNDQuJERGRLyqlNzSvIx6ZKRuVEw6LLSyrLymhKSShBwaFFROTJyW jMS+vNzW1OTazNzKrHRqXOzezOTOpPTq3OzWvOTStLyedMS+rLy2pMSynMSu lAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAA LAAAAAAQABAAAAewgAAAAYSFhoQCA4IBBI2OjgUGBwiLBAmXlpcKkgsMlZcJ BA0JDpIPEBGVjwkSBgOnExSfmBIVBxAMExYXswkYGRobHLq8gh2PHhoeHyAW IYKzIiMkJSYnKCnQg5YNHtQqKywtK9qMBC4vMDEBMjIz2dCMDTQ1Njc4OToz 5PEEOzw3ZPToMcLHO23HfogQ0QMIkCA+hPBbhAPHECJFjMyYIUQIvEUpUqwQ OXKkSEF+AgEAIf5oQ3JlYXRlZCBieSBCTVBUb0dJRiBQcm8gdmVyc2lvbiAy LjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4LiBBbGwgcmlnaHRzIHJlc2VydmVk Lg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw==}] if 0 {This thing is more useful if you can get more information about an item by clicking on it - for a file, its size and date; for a variable, its value; for a proc, its full specification, etc. As a small first shot, I selected a "balloon" for that purpose. } proc LemonTree::Info {w node} { set type [dict'get [$w itemcget $node -data] type] if {[info proc ::LemonTree::info($type)] ne ""} { balloon $w [info($type) $w $node] } } #-- type-specific info providers: proc LemonTree::info(array) {w node} { set name [dict'get [$w itemcget $node -data] name] return "$name: array, [array size $name] elements" } proc LemonTree::info(command) {w node} { set name [dict'get [$w itemcget $node -data] name] if {[info procs $name] ne ""} { return [procinfo $name] } else {return "$name: compiled command"} } proc LemonTree::info(dir) {w node} { set name [dict'get [$w itemcget $node -data] name] set mtime [clock format [file mtime $name] -format %y-%m-%d,%H:%M:%S] set nfiles [llength [glob -nocomplain $name/*]] return "$name\n$nfiles files\nModified: $mtime" } proc LemonTree::info(file) {w node} { set name [dict'get [$w itemcget $node -data] name] set mtime [clock format [file mtime $name] -format %y-%m-%d,%H:%M:%S] return "$name\n[file size $name] bytes\nModified: $mtime" } proc LemonTree::info(namespace) {w node} { set ns [dict'get [$w itemcget $node -data] name] return "namespace $ns\n[llength [info commands ${ns}::*]] commands,\ [llength [info vars ${ns}::*]] variables,\ [llength [namespace children $ns]] child(ren)" } proc LemonTree::info(variable) {w node} { set name [dict'get [$w itemcget $node -data] name] if [info exists $name] { list $name = [set $name] } else { #-- array element set arr [dict'get [$w itemcget [$w parent $node] -data] name] list ${arr}($name) = [set ${arr}($name)] } } proc LemonTree::info(widget) {w node} { set name [dict'get [$w itemcget $node -data] name] return "[winfo class $name] $name [winfo geometry $name]" } #-- A simple ballon, modified from [Bag of Tk algorithms]: proc balloon {w text} { set top .balloon catch {destroy $top} toplevel $top -bd 1 pack [message $top.txt -aspect 10000 -bg lightyellow \ -borderwidth 0 -text $text -font {Helvetica 9}] wm overrideredirect $top 1 wm geometry $top +[winfo pointerx $w]+[winfo pointery $w] bind $top <1> [list destroy $top] raise $top } if 0 {From Tcl 8.5, one would use a real [dict], but it's easy to make a replacement that works roughly the same in 8.4 (it returns "" for non- existing keys instead of throwing an error), and might be slower, but I won't notice on dicts with two elements ;-} proc dict'get {dict key} { foreach {k value} $dict {if {$k eq $key} {return $value}} } #-- reconstruct a proc's definition as a string: proc procinfo name { set args "" foreach arg [info args $name] { if [info default $name $arg def] {lappend arg $def} lappend args $arg } return "proc $name {$args} {[info body $name]}" } #-- Now to demonstrate and test the whole thing: Tree .t -background white -opencmd {LemonTree::open .t} \ -width 40 -height 30 -yscrollcommand {.y set} .t bindText <1> {LemonTree::Info .t} .t bindImage <1> {LemonTree::Info .t} LemonTree::add .t root dir / "(Files /)" LemonTree::add .t root namespace :: "(Namespace ::)" LemonTree::add .t root widget . "(Widget .)" pack [scrollbar .y -command {.t yview}] -side right -fill y pack .t -fill both -expand 1 -side left #-- Little development helpers: bind . {exec wish $argv0 &; exit} bind . {console show} if 0 {See also [stardom]. ---- [TV] ''(Oct 25 2004)'' Cool. ---- [Arts and crafts of Tcl-Tk programming] }