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