1#  utils.tcl ---
2#
3#      This file is part of The Coccinella application. We collect some handy
4#      small utility procedures here.
5#
6#  Copyright (c) 2005  Mats Bengtsson
7#
8#  This file is distributed under BSD style license.
9#
10# $Id: utils.tcl,v 1.15 2008-07-30 13:23:59 matben Exp $
11
12package provide utils 1.0
13
14# InvertArray ---
15#
16#    Inverts an array so that ...
17#    No spaces allowed; no error checking made that the inverse is unique.
18
19proc InvertArray {arrName invArrName} {
20
21    # Pretty tricky to make it work. Perhaps the new array should be unset?
22    upvar $arrName locArr
23    upvar $invArrName locInvArr
24    foreach name [array names locArr] {
25	set locInvArr($locArr($name)) $name
26    }
27}
28
29# max, min ---
30#
31#    Finds max and min of numerical values. From the WikiWiki page.
32
33proc max {args} {
34    lindex [lsort -real $args] end
35}
36
37proc min {args} {
38    lindex [lsort -real $args] 0
39}
40
41# lapply --
42#
43#       Applies a command to each list element.
44#       NB: See mstack for a more general!
45
46proc lapply {cmd alist} {
47    set applied [list]
48    foreach e $alist {
49	lappend applied [uplevel $cmd [list $e]]
50    }
51    return $applied
52}
53
54# lprune --
55#
56#       Removes element from list, silently.
57
58proc lprune {listName elem} {
59    upvar $listName listValue
60    set idx [lsearch $listValue $elem]
61    if {$idx >= 0} {
62	uplevel [list set $listName [lreplace $listValue $idx $idx]]
63    }
64    return
65}
66
67# lrevert --
68#
69#       Revert the order of the list elements.
70
71proc lrevert {args} {
72    set tmp [list]
73    set args [lindex $args 0]
74    for {set i [expr {[llength $args] - 1}]} {$i >= 0} {incr i -1} {
75	lappend tmp [lindex $args $i]
76    }
77    return $tmp
78}
79
80if {![llength [info commands lreverse]]} {
81    interp alias {} lreverse {} lrevert
82}
83
84# listintersect --
85#
86#       Intersections of two lists.
87
88proc listintersect {alist blist} {
89    set tmp {}
90    foreach a $alist {
91	if {[lsearch $blist $a] >= 0} {
92	    lappend tmp $a
93	}
94    }
95    return $tmp
96}
97
98# listintersectnonempty --
99#
100#       Is intersection of two lists non empty.
101
102proc listintersectnonempty {alist blist} {
103    foreach a $alist {
104	if {[lsearch $blist $a] >= 0} {
105	    return 1
106	}
107    }
108    return 0
109}
110
111# A few routines:
112# Copyright (c) 1997-1999 Jeffrey Hobbs
113#
114# lintersect --
115#   returns list of items that exist only in all lists
116# Arguments:
117#   args        lists
118# Returns:
119#   The list of common items, uniq'ed, order independent
120#
121proc lintersect {args} {
122    set len [llength $args]
123    if {$len <= 1} {
124	return [lindex $args 0]
125    }
126    array set a {}
127    foreach l [lindex $args 0] {
128	set a($l) 1
129    }
130    foreach list [lrange $args 1 end] {
131	foreach l $list {
132	    if {[info exists a($l)]} {
133		incr a($l)
134	    }
135	}
136    }
137    set retval {}
138    foreach l [array names a] {
139	if {$a($l) == $len} {
140	    lappend retval $l
141	}
142    }
143    return $retval
144}
145
146# lunique --
147#   order independent list unique proc.  most efficient, but requires
148#   __LIST never be an element of the input list
149# Arguments:
150#   __LIST      list of items to make unique
151# Returns:
152#   list of only unique items, order not defined
153#
154proc lunique {__LIST} {
155    if {[llength $__LIST]} {
156	foreach $__LIST $__LIST break
157	unset __LIST
158	return [info locals]
159    }
160}
161
162# luniqueo --
163#   order dependent list unique proc
164# Arguments:
165#   ls          list of items to make unique
166# Returns:
167#   list of only unique items in same order as input
168#
169proc luniqueo {ls} {
170    set rs {}
171    foreach l $ls {
172	if {[info exist ($l)]} { continue }
173	lappend rs $l
174	set ($l) {}
175    }
176    return $rs
177}
178
179# lsearchsublists --
180#
181#       Search sublists instead. Very incomplete!
182#       Note: returns empty if non found.
183#
184# @@@ OBSOLETE in 8.5!
185
186proc lsearchsublists {args} {
187
188    if {[llength $args] < 2} {
189	return -code error "Usage: lsearchsublists ?options? list pattern"
190    }
191    set pattern [lindex $args end]
192    set list    [lindex $args end-1]
193    set options [lrange $args 0 end-2]
194
195    set idx0 0
196    set idx1 -1
197    foreach elem $list {
198	set idx1 [eval [concat lsearch $options [list $elem $pattern]]]
199	if {$idx1 >= 0} {
200	    break
201	} else {
202	    incr idx0
203	}
204    }
205    if {$idx1 < 0} {
206	return
207    } else {
208	return [list $idx0 $idx1]
209    }
210}
211
212# @@@ TODO: advanced list logic
213#
214# type = {{user | wb} & available & junk}
215# compare with an arbitrary list where at least one of the element
216# must fulfill the logic implied by 'type', say {user unavailable} (=0)
217
218# ESCglobs --
219#
220#	array get and array unset accepts glob characters. These need to be
221#	escaped if they occur as part of a variable.
222
223proc ESCglobs {s} {
224    return [string map {* \\* ? \\? [ \\[ ] \\] \\ \\\\} $s]
225}
226
227# arraysequal --
228#
229#       Compare two arrays.
230
231proc arraysequal {arrName1 arrName2} {
232    upvar 1 $arrName1 arr1 $arrName2 arr2
233
234    if {![array exists arr1]} {
235	return -code error "$arrName1 is not an array"
236    }
237    if {![array exists arr2]} {
238	return -code error "$arrName2 is not an array"
239    }
240    if {[array size arr1] != [array size arr2]} {
241	return 0
242    }
243    if {[array size arr1] == 0} {
244	return 1
245    }
246    foreach {key value} [array get arr1] {
247	if {![info exists arr2($key)]} {
248	    return 0
249	}
250	if {![string equal $arr1($key) $arr2($key)]} {
251	    return 0
252	}
253    }
254    return 1
255}
256
257# arraysequalnames --
258#
259#       Checked named array indexes only.
260
261proc arraysequalnames {arrName1 arrName2 names} {
262    upvar 1 $arrName1 arr1 $arrName2 arr2
263
264    foreach name $names {
265	set ex1 [info exists arr1($name)]
266	set ex2 [info exists arr2($name)]
267	if {$ex1 && $ex2} {
268	    if {$arr1($name) != $arr2($name)} {
269		return 0
270	    }
271	} elseif {($ex1 && !$ex2) || (!$ex1 && $ex2)} {
272	    return 0
273	}
274    }
275    return 1
276}
277
278# arraygetsublist --
279#
280#       Extracts a flat array from another array that matches 'prefix',
281#       and strips off all prefix. Use dict instead when that comes.
282
283proc arraygetsublist {arrName prefix} {
284    upvar 1 $arrName arr
285    set subL [list]
286    set len [string length $prefix]
287    foreach {name value} [array get arr $prefix*] {
288	set key [string range $name $len end]
289	lappend subL $key $value
290    }
291    return $subL
292}
293
294if {![llength [info commands lassign]]} {
295    proc lassign {vals args} {uplevel 1 [list foreach $args $vals break] }
296}
297
298# getdirname ---
299#
300#       Returns the path from 'filePath' thus stripping of any file name.
301#       This is a workaround for the strange [file dirname ...] which strips
302#       off "the last thing."
303#       We need actual files here, not fake ones.
304#
305# Arguments:
306#       filePath       the path.
307
308proc getdirname {filePath} {
309
310    if {[file isfile $filePath]} {
311	return [file dirname $filePath]
312    } else {
313	return $filePath
314    }
315}
316
317proc dumpwidgethierarchy {{win .} {tabs "\t"}} {
318    set tab "\t"
319    foreach w [winfo children $win] {
320	array unset opts
321	set geo ""
322	set manager [winfo manager $w]
323	if {$manager eq "pack"} {
324	    array set opts [pack info $w]
325	    set geo "-side $opts(-side)"
326	} elseif {$manager eq "grid"} {
327	    array set opts [grid info $w]
328	    set geo "-sticky $opts(-sticky)"
329	}
330	#puts "$tabs$w$tab$manager: $geo"
331	puts "$tabs$w$tab[winfo class $w]"
332	dumpwidgethierarchy $w "$tabs\t"
333    }
334}
335
336