mirror of
https://github.com/envmodules/modules.git
synced 2026-06-10 00:56:30 +08:00
329 lines
9.7 KiB
Tcl
329 lines
9.7 KiB
Tcl
##########################################################################
|
|
|
|
# UTIL.TCL, utility procedures
|
|
# Copyright (C) 2002-2004 Mark Lakata
|
|
# Copyright (C) 2004-2017 Kent Mein
|
|
# Copyright (C) 2016-2022 Xavier Delaruelle
|
|
#
|
|
# This program is free software: you can redistribute it and/or modify
|
|
# it under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation, either version 2 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# This program is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
##########################################################################
|
|
|
|
proc charEscaped {str {charlist { \\\t\{\}|<>!;#^$&*?"'`()}}} {
|
|
return [regsub -all "\(\[$charlist\]\)" $str {\\\1}]
|
|
}
|
|
|
|
proc charUnescaped {str {charlist { \\\t\{\}|<>!;#^$&*?"'`()}}} {
|
|
return [regsub -all "\\\\\(\[$charlist\]\)" $str {\1}]
|
|
}
|
|
|
|
proc strTo {lang str {esc 1}} {
|
|
switch -- $lang {
|
|
tcl { set enco \{; set encc \}}
|
|
shell { set enco '; set encc '}
|
|
}
|
|
# escape all special characters
|
|
if {$esc} {
|
|
set str [charEscaped $str]
|
|
}
|
|
# enclose if empty or if contain a space character unless already escaped
|
|
if {$str eq {} || (!$esc && [regexp {\s} $str])} {
|
|
set str "$enco$str$encc"
|
|
}
|
|
return $str
|
|
}
|
|
|
|
proc listTo {lang lst {esc 1}} {
|
|
set lout [list]
|
|
# transform each list element
|
|
foreach str $lst {
|
|
lappend lout [strTo $lang $str $esc]
|
|
}
|
|
return [join $lout { }]
|
|
}
|
|
|
|
# find command path and remember it
|
|
proc getCommandPath {cmd} {
|
|
return [lindex [auto_execok $cmd] 0]
|
|
}
|
|
|
|
# find then run command or raise error if command not found
|
|
proc runCommand {cmd args} {
|
|
set cmdpath [getCommandPath $cmd]
|
|
if {$cmdpath eq {}} {
|
|
knerror "Command '$cmd' cannot be found" MODULES_ERR_GLOBAL
|
|
} else {
|
|
return [exec $cmdpath {*}$args]
|
|
}
|
|
}
|
|
|
|
proc getAbsolutePath {path} {
|
|
# currently executing a modulefile or rc, so get the directory of this file
|
|
if {[currentState modulefile] ne {}} {
|
|
set curdir [file dirname [currentState modulefile]]
|
|
# elsewhere get module command current working directory
|
|
} else {
|
|
# register pwd at first call
|
|
if {![isStateDefined cwd]} {
|
|
# raise a global known error if cwd cannot be retrieved (especially
|
|
# when this directory has been removed)
|
|
if {[catch {setState cwd [pwd]} errorMsg]} {
|
|
knerror $errorMsg
|
|
}
|
|
}
|
|
set curdir [getState cwd]
|
|
}
|
|
|
|
# empty result if empty path
|
|
if {$path eq {}} {
|
|
set abspath {}
|
|
# consider path absolute if it starts with a variable ref
|
|
} elseif {[string index $path 0] eq {$}} {
|
|
set abspath $path
|
|
} else {
|
|
set abslist {}
|
|
# get a first version of the absolute path by joining the current
|
|
# working directory to the given path. if given path is already absolute
|
|
# 'file join' will not break it as $curdir will be ignored as soon a
|
|
# beginning '/' character is found on $path. this first pass also clean
|
|
# extra '/' character. then each element of the path is analyzed to
|
|
# clear "." and ".." components.
|
|
foreach elt [file split [file join $curdir $path]] {
|
|
if {$elt eq {..}} {
|
|
# skip ".." element if it comes after root element, remove last
|
|
# element elsewhere
|
|
if {[llength $abslist] > 1} {
|
|
set abslist [lreplace $abslist end end]
|
|
}
|
|
# skip any "." element
|
|
} elseif {$elt ne {.}} {
|
|
lappend abslist $elt
|
|
}
|
|
}
|
|
set abspath [file join {*}$abslist]
|
|
}
|
|
|
|
# return cleaned absolute path
|
|
return $abspath
|
|
}
|
|
|
|
# if no exact match found but icase mode is enabled then search if an icase
|
|
# match exists among all array key elements, select dictionary highest version
|
|
# if multiple icase matches are returned
|
|
proc getArrayKey {arrname name icase} {
|
|
if {$icase} {
|
|
upvar $arrname arr
|
|
if {![info exists arr($name)]} {
|
|
foreach elt [lsort -dictionary -decreasing [array names arr]] {
|
|
if {[string equal -nocase $name $elt]} {
|
|
reportDebug "key '$elt' in array '$arrname' matches '$name'"
|
|
set name $elt
|
|
break
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return $name
|
|
}
|
|
|
|
# split string while ignore any separator character that is escaped
|
|
proc psplit {str sep} {
|
|
# use standard split if no sep character found
|
|
if {[string first \\$sep $str] == -1} {
|
|
set res [split $str $sep]
|
|
} else {
|
|
set previdx -1
|
|
set idx [string first $sep $str]
|
|
while {$idx != -1} {
|
|
# look ahead if found separator is escaped
|
|
if {[string index $str [expr {$idx-1}]] ne "\\"} {
|
|
# unescape any separator character when adding to list
|
|
lappend res [charUnescaped [string range $str [expr {$previdx+1}]\
|
|
[expr {$idx-1}]] $sep]
|
|
set previdx $idx
|
|
}
|
|
set idx [string first $sep $str [expr {$idx+1}]]
|
|
}
|
|
|
|
lappend res [charUnescaped [string range $str [expr {$previdx+1}] end]\
|
|
$sep]
|
|
}
|
|
|
|
return $res
|
|
}
|
|
|
|
# join list while escape any character equal to separator
|
|
proc pjoin {lst sep} {
|
|
# use standard join if no sep character found
|
|
if {[string first $sep $lst] == -1} {
|
|
set res [join $lst $sep]
|
|
} else {
|
|
set res {}
|
|
foreach elt $lst {
|
|
# preserve empty entries
|
|
if {[info exists not_first]} {
|
|
append res $sep
|
|
} else {
|
|
set not_first 1
|
|
}
|
|
# escape any separator character when adding to string
|
|
append res [charEscaped $elt $sep]
|
|
}
|
|
}
|
|
|
|
return $res
|
|
}
|
|
|
|
# Is provided string a version number: consider first element of string if
|
|
# '.' character used in it. [0-9af] on this first part is considered valid
|
|
# anything else could be used in latter elements
|
|
proc isVersion {str} {
|
|
return [string is xdigit -strict [lindex [split $str .] 0]]
|
|
}
|
|
|
|
# Return number of occurrences of passed character in passed string
|
|
proc countChar {str char} {
|
|
return [expr {[string length $str] - [string length [string map [list\
|
|
$char {}] $str]]}]
|
|
}
|
|
|
|
proc appendNoDupToList {lstname args} {
|
|
set ret 0
|
|
upvar $lstname lst
|
|
foreach elt $args {
|
|
if {![info exists lst] || $elt ni $lst} {
|
|
lappend lst $elt
|
|
set ret 1
|
|
}
|
|
}
|
|
return $ret
|
|
}
|
|
|
|
proc replaceFromList {list1 item {item2 {}}} {
|
|
while {[set xi [lsearch -exact $list1 $item]] >= 0} {
|
|
##nagelfar ignore #2 Badly formed if statement
|
|
set list1 [if {[string length $item2] == 0} {lreplace $list1 $xi $xi}\
|
|
{lreplace $list1 $xi $xi $item2}]
|
|
}
|
|
|
|
return $list1
|
|
}
|
|
|
|
# test if 2 lists have at least one element in common
|
|
proc isIntBetweenList {list1 list2} {
|
|
foreach elt $list1 {
|
|
if {$elt in $list2} {
|
|
return 1
|
|
}
|
|
}
|
|
return 0
|
|
}
|
|
|
|
# test if 2 lists have at least one element in diff
|
|
proc isDiffBetweenList {list1 list2} {
|
|
foreach elt $list1 {
|
|
if {$elt ni $list2} {
|
|
return 1
|
|
}
|
|
}
|
|
return 0
|
|
}
|
|
|
|
# returns elements from list1 not part of list2 and elements from list2 not
|
|
# part of list1
|
|
proc getDiffBetweenList {list1 list2} {
|
|
set res1 [list]
|
|
set res2 [list]
|
|
|
|
foreach elt $list1 {
|
|
if {$elt ni $list2} {
|
|
lappend res1 $elt
|
|
}
|
|
}
|
|
foreach elt $list2 {
|
|
if {$elt ni $list1} {
|
|
lappend res2 $elt
|
|
}
|
|
}
|
|
|
|
return [list $res1 $res2]
|
|
}
|
|
|
|
# return elements from arr1 not in arr2, elements from arr1 in arr2 but with a
|
|
# different value and elements from arr2 not in arr1.
|
|
# if notset_equals_empty is enabled, not-set element in array is equivalent to
|
|
# element set to an empty value.
|
|
# if unordered_lists_compared is enabled, value of array element is considered
|
|
# a list and difference between list entries is made (order insensitive)
|
|
proc getDiffBetweenArray {arrname1 arrname2 {notset_equals_empty 0}\
|
|
{unordered_lists_compared 0}} {
|
|
upvar $arrname1 arr1
|
|
upvar $arrname2 arr2
|
|
set notin2 [list]
|
|
set diff [list]
|
|
set notin1 [list]
|
|
|
|
foreach name [array names arr1] {
|
|
# element in arr1 not in arr2
|
|
if {![info exists arr2($name)]} {
|
|
if {!$notset_equals_empty} {
|
|
lappend notin2 $name
|
|
# if we consider a not-set entry equal to an empty value, there is a
|
|
# difference only if entry in the other array is not empty
|
|
} elseif {$arr1($name) ne {}} {
|
|
lappend diff $name
|
|
}
|
|
# element present in both arrays but with a different value
|
|
} elseif {!$unordered_lists_compared} {
|
|
# but with a different value
|
|
if {$arr1($name) ne $arr2($name)} {
|
|
lappend diff $name
|
|
}
|
|
} else {
|
|
# with a different value, not considering order
|
|
lassign [getDiffBetweenList $arr1($name) $arr2($name)] notin2 notin1
|
|
if {([llength $notin2] + [llength $notin1]) > 0} {
|
|
lappend diff $name
|
|
}
|
|
}
|
|
}
|
|
|
|
foreach name [array names arr2] {
|
|
# element in arr2 not in arr1
|
|
if {![info exists arr1($name)]} {
|
|
if {!$notset_equals_empty} {
|
|
lappend notin1 $name
|
|
} elseif {$arr2($name) ne {}} {
|
|
lappend diff $name
|
|
}
|
|
}
|
|
}
|
|
|
|
return [list $notin2 $diff $notin1]
|
|
}
|
|
|
|
proc getCallingProcName {} {
|
|
if {[info level] > 2} {
|
|
set caller [lindex [info level -2] 0]
|
|
} else {
|
|
set caller {}
|
|
}
|
|
return $caller
|
|
}
|
|
|
|
# ;;; Local Variables: ***
|
|
# ;;; mode:tcl ***
|
|
# ;;; End: ***
|
|
# vim:set tabstop=3 shiftwidth=3 expandtab autoindent:
|