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