1# treeutil.tcl --- 2# 3# Collection of various utility procedures for treectrl. 4# 5# Copyright (c) 2005 6# 7# This source file is distributed under BSD-style license. 8# 9# $Id: treeutil.tcl,v 1.18 2007-11-04 13:54:50 matben Exp $ 10 11# USAGE: 12# 13# ::treeutil::bind widgetPath item ?type? ?script? 14# 15# where 'type' is <Enter> , <Leave> or <ButtonPress-1>. 16# Substitutions in script: 17# %T treectrl widget path 18# %C column index 19# %I item id 20# %x widget x coordinate 21# %y widget y coordinate 22# %E element name 23# 24# ::treeutil::setdboptions widgetPath classWidget prefix 25 26package provide treeutil 1.0 27 28namespace eval ::treeutil { 29 30 variable events {<Enter> <Leave> <ButtonPress-1>} 31} 32 33# treeutil::bind -- 34# 35# Public interface. 36 37proc treeutil::bind {w item args} { 38 variable state 39 variable events 40 41 if {[winfo class $w] ne "TreeCtrl"} { 42 return -code error "window must be a treectrl" 43 } 44 set len [llength $args] 45 if {$len > 2} { 46 return -code error "usage: ::treeutil::bind w item ?type? ?script?" 47 } 48 set ans [list] 49 set item [$w item id $item] 50 if {$len == 0} { 51 foreach e $events { 52 if {[info exists state($w,$item,$e)]} { 53 lappend ans $e 54 } 55 } 56 } elseif {$len == 1} { 57 set type [lindex $args 0] 58 if {[info exists state($w,$item,$type)]} { 59 set ans $state($w,$item,$type) 60 } 61 } else { 62 set type [lindex $args 0] 63 set cmd [lindex $args 1] 64 if {$cmd eq ""} { 65 unset -nocomplain state($w,$item,$type) 66 } elseif {[string index $cmd 0] eq "+"} { 67 lappend state($w,$item,$type) [string trimleft $cmd "+"] 68 } else { 69 set state($w,$item,$type) [list $cmd] 70 } 71 if {![info exists state($w,init)]} { 72 Init $w 73 set state($w,init) 1 74 } 75 } 76 return $ans 77} 78 79proc treeutil::Init {w} { 80 variable state 81 82 set btags [bindtags $w] 83 if {[lsearch $btags TreeUtil] < 0} { 84 bindtags $w [linsert $btags 1 TreeUtil] 85 } 86 ::bind TreeUtil <Motion> { ::treeutil::Track %W %x %y } 87 ::bind TreeUtil <Enter> { ::treeutil::Track %W %x %y } 88 ::bind TreeUtil <Leave> { ::treeutil::Track %W %x %y } 89 ::bind TreeUtil <ButtonPress-1> { ::treeutil::OnButtonPress1 %W %x %y } 90 ::bind TreeUtil <Destroy> { ::treeutil::OnDestroy %W } 91 92 # We could think of a <FocusOut> event also but the macs floating window 93 # takes focus which makes this useless for tooltip windows. 94 95 # Scrolling may move items without moving the mouse. 96 # @@@ Many more things affect this! 97 $w notify bind $w <Scroll-x> {+::treeutil::Generic %T } 98 $w notify bind $w <Scroll-y> {+::treeutil::Generic %T } 99 $w notify bind $w <Expand-after> {+::treeutil::Generic %T } 100 $w notify bind $w <Collapse-after> {+::treeutil::Generic %T } 101 $w notify bind $w <ItemDelete> {+::treeutil::Generic %T } 102 103 $w notify bind $w <ItemDelete> {+::treeutil::OnItemDelete %T %i } 104 105 set state($w,item) -1 106 set state($w,x) -1 107 set state($w,y) -1 108} 109 110proc treeutil::Track {w x y} { 111 variable state 112 113 set id [$w identify $x $y] 114 set prev $state($w,item) 115 116 if {[lindex $id 0] eq "item"} { 117 set item [lindex $id 1] 118 if {$item != $prev} { 119 if {$prev != -1} { 120 Generate $w $x $y $prev <Leave> $id 121 } 122 Generate $w $x $y $item <Enter> $id 123 set state($w,item) $item 124 } 125 } elseif {([lindex $id 0] eq "header") || ($id eq "")} { 126 if {$prev != -1} { 127 Generate $w $x $y $prev <Leave> 128 } 129 set state($w,item) -1 130 } 131 set state($w,x) $x 132 set state($w,y) $y 133} 134 135proc treeutil::Generic {w} { 136 variable state 137 138 Track $w $state($w,x) $state($w,y) 139} 140 141proc treeutil::Generate {w x y item type {id ""}} { 142 variable state 143 144 if {[info exists state($w,$item,$type)]} { 145 array set aid {column "" elem "" line "" button ""} 146 if {[llength $id] == 6} { 147 array set aid $id 148 } 149 set map [list %T $w %x $x %y $y %I $item %C $aid(column) %E $aid(elem)] 150 foreach cmd $state($w,$item,$type) { 151 uplevel #0 [string map $map $cmd] 152 } 153 } 154} 155 156proc treeutil::OnButtonPress1 {w x y} { 157 variable state 158 159 set id [$w identify $x $y] 160 if {[lindex $id 0] eq "item"} { 161 set item [lindex $id 1] 162 if {[llength $id] == 6} { 163 Generate $w $x $y $item <ButtonPress-1> 164 } 165 } 166} 167 168proc treeutil::OnItemDelete {w items} { 169 variable state 170 171 foreach item $items { 172 array unset state $w,$item,* 173 } 174} 175 176proc treeutil::OnDestroy {w} { 177 variable state 178 179 array unset state $w,* 180} 181 182# treeutil::setdboptions -- 183# 184# Configure elements and styles from option database. 185# We use a specific format for the database resource names: 186# 187# element options: prefix:elementName-option 188# style options: prefix:styleName:elementName-option 189# 190# Arguments: 191# w treectrl widgetPath 192# wclass widgetPath 193# prefix 194# 195# Results: 196# configures treectrl elements and layouts 197 198 199proc treeutil::setdboptions {w wclass prefix} { 200 201 # Element options: 202 foreach ename [$w element names] { 203 set eopts [list] 204 foreach ospec [$w element configure $ename] { 205 set oname [lindex $ospec 0] 206 set dvalue [lindex $ospec 3] 207 set value [lindex $ospec 4] 208 set dbname ${prefix}:${ename}${oname} 209 set dbvalue [option get $wclass $dbname {}] 210 if {($dbvalue ne "") && ($value ne $dbvalue)} { 211 lappend eopts $oname $dbvalue 212 } 213 } 214 eval {$w element configure $ename} $eopts 215 } 216 217 # Style layout options: 218 foreach style [$w style names] { 219 foreach ename [$w style elements $style] { 220 set sopts [list] 221 foreach {key value} [$w style layout $style $ename] { 222 set dbname ${prefix}:${style}:${ename}${key} 223 set dbvalue [option get $wclass $dbname {}] 224 if {($dbvalue ne "") && ($value ne $dbvalue)} { 225 lappend sopts $key $dbvalue 226 } 227 } 228 eval {$w style layout $style $ename} $sopts 229 } 230 } 231} 232 233# treeutil::configurecolumns -- 234# 235# Configure all columns. 236 237proc treeutil::configurecolumns {w args} { 238 foreach C [$w column list -visible] { 239 eval {$w column configure $C} $args 240 } 241} 242 243# treeutil::configureelements -- 244# 245# Configure all elements. 246# -elementName-option value ... 247 248proc treeutil::configureelements {w args} { 249 foreach {key value} $args { 250 set idx [string first "-" $key 1] 251 set E [string range $key 1 [expr {$idx-1}]] 252 set option [string range $key $idx end] 253 $w element configure $E $option $value 254 } 255} 256 257# treeutil::configurestyles -- 258# 259# Configure all styles. 260# -styleName:elementName-option value 261 262proc treeutil::configurestyles {w args} { 263 foreach {key value} $args { 264 set idx1 [string first ":" $key 1] 265 set idx2 [string first "-" $key 2] 266 set S [string range $key 1 [expr {$idx1-1}]] 267 set E [string range $key [expr {$idx1+1}] [expr {$idx2-1}]] 268 set option [string range $key $idx2 end] 269 $w style layout $S $E $option $value 270 } 271} 272 273# treeutil::configureelementtype -- 274# 275# Simplified way of configuring a certain element type. 276 277proc treeutil::configureelementtype {w type args} { 278 foreach E [$w element names] { 279 if {[$w element type $E] eq $type} { 280 eval {$w element configure $E} $args 281 } 282 } 283} 284 285proc treeutil::copycolumns {src dst} { 286 287 foreach C [$src column list] { 288 set opts [list] 289 foreach spec [$src column configure $C] { 290 lappend opts [lindex $spec 4] 291 } 292 eval {$dst column create} $opts 293 } 294} 295 296proc treeutil::copyelements {src dst} { 297 298 foreach E [$src element names] { 299 set opts [list] 300 foreach spec [$src element configure $E] { 301 lappend opts [lindex $spec 4] 302 } 303 set type [$src element type $E] 304 eval {$dst element create $E $type} $opts 305 } 306} 307 308proc treeutil::copystyles {src dst} { 309 310 foreach S [$src style names] { 311 foreach E [$src style elements $S] { 312 set opts [$src style layout $S $E] 313 $dst style create $S 314 eval {$dst style layout $S $W} $opts 315 } 316 } 317} 318 319# treeutil::protect, deprotect -- 320# 321# A tag is just a string of characters, and it may take any form, 322# including that of an integer, although the characters 323# '(', ')', '&', '|', '^' and '!' should be avoided. 324# Tags must therefore be protected if they contain any of these specials. 325 326# BUG: this wont work for "!" 327 328proc treeutil::protect {tags} { 329 regsub -all {([()&|^!])} $tags {\\\1} tags 330 return $tags 331} 332proc treeutil::protect {tags} { 333 # Not foolproof!!! 334 set tags [string map {_ ___ ! _} $tags] 335 regsub -all {([()&|^])} $tags {\\\1} tags 336 return $tags 337} 338 339proc treeutil::deprotect {tags} { 340 # Inverse of protect. 341 regsub -all {\\([()&|^!])} $tags {\1} tags 342 return $tags 343} 344proc treeutil::deprotect {tags} { 345 # Inverse of protect. 346 regsub -all {\\([()&|^])} $tags {\1} tags 347 set tags [string map {! _ ___ _} $tags] 348 return $tags 349} 350 351 352