Preview: modulecmd
Size: 654.01 KB
//usr/bin/modulecmd
#!/usr/bin/tclsh
# MODULECMD.TCL, a pure TCL implementation of the module command
# 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/>.
##########################################################################
# Runtime state properties (default value, proc to call to initialize state
# value?)
##nagelfar ignore +31 Found constant
array set g_state_defs [list\
autoinit {0}\
clock_seconds {<undef> initStateClockSeconds}\
domainname {<undef> {runCommand domainname}}\
error_count {0}\
extra_siteconfig_loaded {0}\
false_rendered {0}\
force {0}\
hiding_threshold {0}\
inhibit_errreport {0}\
inhibit_interp {0}\
init_error_report {0}\
is_stderr_tty {<undef> initStateIsStderrTty}\
is_win {<undef> initStateIsWin}\
kernelversion {<undef> {runCommand uname -v}}\
lm_info_cached {0}\
machine [list $::tcl_platform(machine)]\
nodename {<undef> {runCommand uname -n}}\
os [list $::tcl_platform(os)]\
osversion [list $::tcl_platform(osVersion)]\
paginate {<undef> initStatePaginate}\
path_separator {<undef> initStatePathSeparator}\
report_format {regular}\
reportfd {stderr initStateReportfd}\
return_false {0}\
siteconfig_loaded {0}\
shelltype {<undef> initStateShellType}\
sub1_separator {&}\
sub2_separator {|}\
tcl_ext_lib_loaded {0}\
tcl_version [list [info patchlevel]]\
term_columns {<undef> initStateTermColumns}\
timer {0}\
usergroups {<undef> initStateUsergroups}\
username {<undef> initStateUsername}\
]
# Configuration option properties (superseding environment variable, default
# value, is configuration lockable to default value, value kind, valid value
# list?, internal value representation?, proc to call to initialize option
# value, valid value list kind
##nagelfar ignore #73 Too long line
array set g_config_defs [list\
contact {MODULECONTACT root@localhost 0 s}\
auto_handling {MODULES_AUTO_HANDLING 1 0 b {0 1}}\
avail_indepth {MODULES_AVAIL_INDEPTH 1 0 b {0 1}}\
avail_output {MODULES_AVAIL_OUTPUT {modulepath:alias:dirwsym:sym:tag:variantifspec:key} 0 l {modulepath alias\
dirwsym sym tag key variant variantifspec} {} {} eltlist}\
avail_terse_output {MODULES_AVAIL_TERSE_OUTPUT {modulepath:alias:dirwsym:sym:tag:variantifspec} 0 l\
{modulepath alias dirwsym sym tag key variant variantifspec} {} {}\
eltlist}\
cache_buffer_bytes {MODULES_CACHE_BUFFER_BYTES 32768 0 i {4096 1000000} {}\
{} intbe}\
cache_expiry_secs {MODULES_CACHE_EXPIRY_SECS 0 0 i {0 31536000} {} {}\
intbe}\
collection_pin_version {MODULES_COLLECTION_PIN_VERSION 0 0 b {0 1}}\
collection_pin_tag {MODULES_COLLECTION_PIN_TAG 0 0 b {0 1}}\
collection_target {MODULES_COLLECTION_TARGET <undef> 0 s}\
color {MODULES_COLOR auto 0 s {never auto always} {0 1 2}\
initConfColor}\
colors {MODULES_COLORS {} 0 l {} {} initConfColors}\
csh_limit {{} 4000 0 i}\
extra_siteconfig {MODULES_SITECONFIG <undef> 1 s {}}\
editor {MODULES_EDITOR {vi} 0 s {} {} initConfEditor}\
home {MODULESHOME {/usr/share/Modules} 0 s}\
icase {MODULES_ICASE search 0 s {never search always}}\
ignore_cache {MODULES_IGNORE_CACHE 0 0 b {0 1}}\
ignore_user_rc {MODULES_IGNORE_USER_RC 0 0 b {0 1}}\
ignored_dirs {{} {CVS RCS SCCS .svn .git .SYNC .sos} 0 o}\
implicit_requirement {MODULES_IMPLICIT_REQUIREMENT 1 0\
b {0 1}}\
list_output {MODULES_LIST_OUTPUT {header:idx:variant:sym:tag:key} 0 l {header idx variant\
sym tag key} {} {} eltlist}\
list_terse_output {MODULES_LIST_TERSE_OUTPUT {header} 0 l\
{header idx variant sym tag key} {} {} eltlist}\
locked_configs {{} {} 0 o}\
mcookie_check {MODULES_MCOOKIE_CHECK always 0 s {eval always}}\
mcookie_version_check {MODULES_MCOOKIE_VERSION_CHECK\
1 0 b {0 1}}\
ml {MODULES_ML 1 0 b {0 1}}\
nearly_forbidden_days {MODULES_NEARLY_FORBIDDEN_DAYS 14\
0 i {0 365} {} {} intbe}\
pager {MODULES_PAGER {/usr/bin/less -eFKRX} 0 s}\
protected_envvars {MODULES_PROTECTED_ENVVARS <undef> 0 l}\
rcfile {MODULERCFILE <undef> 0 s}\
redirect_output {MODULES_REDIRECT_OUTPUT 1 0 b {0 1}}\
reset_target_state {MODULES_RESET_TARGET_STATE __init__ 0 s}\
quarantine_support {MODULES_QUARANTINE_SUPPORT 0 0 b {0\
1}}\
run_quarantine {MODULES_RUN_QUARANTINE <undef> 0 o}\
shells_with_ksh_fpath {MODULES_SHELLS_WITH_KSH_FPATH {} 0 l {sh bash csh\
tcsh fish} {} {} eltlist}\
silent_shell_debug {MODULES_SILENT_SHELL_DEBUG 0 0 b {0\
1}}\
siteconfig {{} {/etc/environment-modules/siteconfig.tcl} 0 s}\
tag_abbrev {MODULES_TAG_ABBREV {auto-loaded=aL:loaded=L:hidden=H:hidden-loaded=H:forbidden=F:nearly-forbidden=nF:sticky=S:super-sticky=sS:keep-loaded=kL} 0 l {} {} initConfTagAbbrev}\
tag_color_name {MODULES_TAG_COLOR_NAME {} 0 l {} {}\
initConfTagColorName}\
tcl_ext_lib {{} {} 0 s {} {} initConfTclExtLib}\
tcl_linter {MODULES_TCL_LINTER {nagelfar.tcl} 0 s}\
term_background {MODULES_TERM_BACKGROUND dark 0 s {dark light}}\
term_width {MODULES_TERM_WIDTH 0 0 i {0 1000} {} {} intbe}\
unload_match_order {MODULES_UNLOAD_MATCH_ORDER returnlast 0 s\
{returnlast returnfirst}}\
implicit_default {MODULES_IMPLICIT_DEFAULT 1 1 b {0 1}}\
extended_default {MODULES_EXTENDED_DEFAULT 1 0 b {0 1}}\
advanced_version_spec {MODULES_ADVANCED_VERSION_SPEC 1 0 b {0\
1}}\
search_match {MODULES_SEARCH_MATCH starts_with 0 s {starts_with\
contains}}\
set_shell_startup {MODULES_SET_SHELL_STARTUP 0 0 b {0 1}}\
variant_shortcut {MODULES_VARIANT_SHORTCUT {} 0 l {} {}\
initConfVariantShortcut}\
verbosity {MODULES_VERBOSITY normal 0 s {silent concise normal\
verbose verbose2 trace debug debug2}}\
wa_277 {MODULES_WA_277 0 0 b {0 1}}\
]
# Get state value
proc getState {state {valifundef {}} {catchinitproc 0}} {
if {![info exists ::g_states($state)]} {
# fetch state properties (including its default value) if defined
if {[info exists ::g_state_defs($state)]} {
lassign $::g_state_defs($state) value initproclist
} else {
set value <undef>
set initproclist {}
}
# call specific proc to initialize state if any
if {$initproclist ne {}} {
# catch init procedure error and report it as warning, so default
# value will get set for state
if {$catchinitproc} {
if {[catch {set value [{*}$initproclist]} errMsg]} {
reportWarning $errMsg
}
} else {
set value [{*}$initproclist]
}
# overridden value coming the command-line
##nagelfar ignore Suspicious variable
} elseif {[info exists ::asked_$state]} {
set value [set ::asked_$state]
}
# return passed value if undefined and no value record
if {$value eq {<undef>}} {
set value $valifundef
} else {
setState $state $value
}
return $value
} else {
return $::g_states($state)
}
}
# Clear state
proc unsetState {state} {
if {[isStateDefined $state]} {
unset ::g_states($state)
reportDebug "$state unset"
}
}
# Set state value
proc setState {state value} {
set ::g_states($state) $value
reportDebug "$state set to '$value'"
}
# Append each passed value to the existing state value list
proc lappendState {state args} {
if {$state eq {-nodup}} {
set state [lindex $args 0]
# retrieve current val through getState to initialize it if still undef
set value [getState $state]
##nagelfar ignore Found constant
appendNoDupToList value {*}[lrange $args 1 end]
setState $state $value
} else {
lappend ::g_states($state) {*}$args
reportDebug "$state appended with '$args'"
}
}
# Remove last element from state value list
proc lpopState {state} {
setState $state [lrange [getState $state] 0 end-1]
}
# Return first element from state value list
proc topState {state} {
return [lindex [getState $state] 0]
}
# Return last element from state value list
proc currentState {state} {
return [lindex [getState $state] end]
}
# Get number of element from state value list
proc depthState {state} {
return [llength [getState $state]]
}
# Check if state has been defined
proc isStateDefined {state} {
return [info exists ::g_states($state)]
}
# Check if state equals passed value
proc isStateEqual {state value} {
return [expr {[getState $state] eq $value}]
}
proc isConfigLocked {option} {
return [expr {[lsearch -exact [getConf locked_configs] $option] != -1}]
}
# Get configuration option value
proc getConf {option {valifundef {}}} {
if {![info exists ::g_configs($option)]} {
# fetch option properties (including its default value)
lassign $::g_config_defs($option) envvar value islockable valuekind\
validvallist intvallist initproc validvallistkind
# ensure option is not locked before superseding its default value
if {!$islockable || ![isConfigLocked $option]} {
# call specific proc to initialize config option if any
if {$initproc ne {}} {
set value [$initproc $envvar $value $validvallist $intvallist]
} else {
# overridden value coming from environment
if {$envvar ne {} && [info exists ::env($envvar)]} {
switch -- $validvallistkind {
eltlist {
# ignore non-valid values
if {![isDiffBetweenList [split $::env($envvar) :]\
$validvallist]} {
set value $::env($envvar)
}
}
intbe {
# ignore non-valid values
if {[string is integer -strict $::env($envvar)] &&\
$::env($envvar) >= [lindex $validvallist 0] &&\
$::env($envvar) <= [lindex $validvallist 1]} {
set value $::env($envvar)
}
}
{} {
# ignore non-valid values
##nagelfar ignore +3 Non static subcommand
if {[switch -- [llength $validvallist] {
0 {expr {1 == 1}}
1 {string is $validvallist -strict $::env($envvar)}
default {expr {$::env($envvar) in $validvallist}}
}]} {
set value $::env($envvar)
}
}
}
}
# overridden value coming the command-line (already validated)
##nagelfar ignore Suspicious variable
if {[info exists ::asked_$option]} {
set askedval [set ::asked_$option]
# append or subtract value to existing configuration value if
# new value starts with '+' or '-' (for colon-separated list
# option only)
if {$valuekind eq {l} && [string index $askedval 0] in {+ -}} {
set curvaluelist [split $value :]
switch -- [string index $askedval 0] {
+ {
##nagelfar ignore Found constant
appendNoDupToList curvaluelist {*}[split [string\
range $askedval 1 end] :]
}
- {
lassign [getDiffBetweenList $curvaluelist [split\
[string range $askedval 1 end] :]] curvaluelist
}
}
set value [join $curvaluelist :]
} else {
set value $askedval
}
}
# convert value to its internal representation
if {[llength $intvallist] > 0} {
set value [lindex $intvallist [lsearch -exact $validvallist\
$value]]
}
}
}
# return passed value if undefined and no value record
if {$value eq {<undef>}} {
set value $valifundef
} else {
setConf $option $value
}
return $value
} else {
return $::g_configs($option)
}
}
# Set configuration option value
proc setConf {option value} {
set ::g_configs($option) $value
reportDebug "$option set to '$value'"
}
# Unset configuration option value if it is set
proc unsetConf {option} {
if {[info exists ::g_configs($option)]} {
unset ::g_configs($option)
reportDebug "$option unset"
}
}
# Append each passed value to the existing config option value list
proc lappendConf {option args} {
# retrieve current value through getConf to initialize it if still undef
set value [getConf $option]
##nagelfar ignore Found constant
appendNoDupToList value {*}$args
setConf $option $value
}
# Source site config which can be used to define global procedures or
# settings. We first look for the global siteconfig, then if an extra
# siteconfig is defined and allowed, source that file if it exists
proc sourceSiteConfig {} {
lappend siteconfiglist [getConf siteconfig]
for {set i 0} {$i < [llength $siteconfiglist]} {incr i} {
set siteconfig [lindex $siteconfiglist $i]
if {[file readable $siteconfig]} {
reportDebug "Source site configuration ($siteconfig)"
if {[catch {uplevel 1 source "{$siteconfig}"} errMsg]} {
set errMsg "Site configuration source failed\n"
# issue line number is lost due to uplevel use
append errMsg [formatErrStackTrace $::errorInfo $siteconfig {}]
reportErrorAndExit $errMsg
}
##nagelfar ignore Found constant
if {$siteconfig eq [getConf siteconfig]} {
setState siteconfig_loaded 1
} else {
setState extra_siteconfig_loaded 1
}
}
# check on extra_siteconfig after initial siteconfig loaded in case
# it inhibits this extra load
##nagelfar ignore Found constant
if {$siteconfig eq [getConf siteconfig] && [getConf\
extra_siteconfig] ne {}} {
lappend siteconfiglist [getConf extra_siteconfig]
}
}
}
# Used to tell if a machine is running Windows or not
proc initStateIsWin {} {
return [expr {$::tcl_platform(platform) eq {windows}}]
}
# Get default path separator
proc initStatePathSeparator {} {
return [expr {[getState is_win] ? {;} : {:}}]
}
# Detect if terminal is attached to stderr message channel
proc initStateIsStderrTty {} {
return [expr {![catch {fconfigure stderr -mode}]}]
}
# Determine if pagination need to be started
proc initStatePaginate {} {
set pager [getConf pager]
# empty or 'cat' pager command means no-pager
set no_cmds [list {} cat]
# default pager enablement depends on pager command value
set paginate [expr {[file tail [lindex $pager 0]] ni $no_cmds}]
# asked enablement could only nullify a previous asked disablement as it
# requires a valid pager command configuration, which by default enables
# pagination; some module command may also turn off pager; also if error
# stream is not attached to a terminal
set no_subcmds [list clear edit]
if {$paginate && (([info exists ::asked_paginate] && !$::asked_paginate)\
|| [getState subcmd] in $no_subcmds || ([getState subcmd] eq {ml} &&\
[lindex [getState subcmd_args] 0] in $no_subcmds) || ![getState\
is_stderr_tty])} {
set paginate 0
}
return $paginate
}
# start pager pipe process with defined configuration
proc initStateReportfd {} {
# get default value
lassign $::g_state_defs(reportfd) reportfd
# start pager at first call and only if enabled
if {[getState paginate]} {
if {[catch {
set reportfd [open "|[getConf pager] >@stderr 2>@stderr" w]
fconfigure $reportfd -buffering line -blocking 1 -buffersize 65536
} errMsg]} {
# silently set reportfd to its fallback value to process warn msg
set ::g_states(reportfd) $reportfd
reportWarning $errMsg
}
}
# startup content in case of structured output format (puts here rather
# calling report proc to avoid infinite reportfd init loop
if {[isStateEqual report_format json]} {
puts -nonewline $reportfd \{
}
return $reportfd
}
# Provide columns number for output formatting
proc initStateTermColumns {} {
set cols [getConf term_width]
if {$cols == 0} {
# determine col number from tty capabilities
# tty info query depends on running OS
switch -- $::tcl_platform(os) {
SunOS {
catch {regexp {columns = (\d+);} [exec stty] match cols} errMsg
}
{Windows NT} {
catch {regexp {Columns:\s+(\d+)} [exec mode] match cols} errMsg
}
default {
catch {set cols [lindex [exec stty size] 1]} errMsg
}
}
# default size if tty cols cannot be found
set cols [expr {![info exists cols] || $cols eq {0} ? 80 : $cols}]
}
return $cols
}
# Deduce shelltype value from shell state value
proc initStateShellType {} {
switch -- [getState shell] {
sh - bash - ksh - zsh {
set shelltype sh
}
csh - tcsh {
set shelltype csh
}
default {
set shelltype [getState shell]
}
}
return $shelltype
}
# Get all groups of user running modulecmd.tcl process
proc __initStateUsergroups {} {
# ensure groups including space in their name (found on Cygwin/MSYS
# platforms) are correctly set as list element
if {[catch {
return [split [string range [runCommand id -G -n -z] 0 end-1] \0]
} errMsg]} {
# fallback if '-z' option is not supported
return [runCommand id -G -n]
}
}
# Get name of user running modulecmd.tcl process
proc __initStateUsername {} {
return [runCommand id -u -n]
}
# Get Epoch time (number of seconds elapsed since Unix epoch)
proc __initStateClockSeconds {} {
return [clock seconds]
}
# Initialize Select Graphic Rendition table
proc initConfColors {envvar value validvallist intvallist} {
# overridden value coming from environment
if {[info exists ::env($envvar)]} {
set colors_list $::env($envvar)
if {[catch {
# test overridden value could be set to a dummy array variable
array set test_colors [split $colors_list {:=}]
} errMsg ]} {
# report issue as a debug message rather warning to avoid
# disturbing user with a warning message in the middle of a
# useful output as this table will be initialized at first use
reportDebug "Ignore invalid value set in $envvar ($colors_list)"
unset colors_list
}
}
# if no valid override set use default color theme for terminal
# background color kind (light or dark)
if {![info exists colors_list]} {
if {[getConf term_background] eq {light}} {
##nagelfar ignore Too long line
set colors_list {hi=1:db=2:tr=2:se=2:er=31:wa=33:me=35:in=34:mp=1;34:di=34:al=36:va=33:sy=35:de=4:cm=32:aL=107:L=47:H=2:F=101:nF=103:S=106:sS=104:kL=48;5;109}
} else {
##nagelfar ignore Too long line
set colors_list {hi=1:db=2:tr=2:se=2:er=91:wa=93:me=95:in=94:mp=1;94:di=94:al=96:va=93:sy=95:de=4:cm=92:aL=100:L=90;47:H=2:F=41:nF=43:S=46:sS=44:kL=30;48;5;109}
}
if {[catch {
array set test_colors [split $colors_list {:=}]
} errMsg ]} {
reportDebug "Ignore invalid default [getConf term_background]\
background colors ($colors_list)"
# define an empty list if no valid value set
set colors_list {}
}
}
# check each color defined and unset invalid codes
set value {}
foreach {elt col} [split $colors_list {:=}] {
if {![regexp {^[\d;]+$} $col]} {
reportDebug "Ignore invalid color code for '$elt' ($col)"
} else {
lappend value $elt=$col
}
}
set value [join $value :]
# set SGR table as an array to easily access rendition for each key
array unset ::g_colors
array set ::g_colors [split $value {:=}]
return $value
}
# Initialize color configuration value
proc initConfColor {envvar value validvallist intvallist} {
# overridden value coming from environment via standard variable
# https://no-color.org/ and https://bixense.com/clicolors/
if {[info exists ::env(NO_COLOR)]} {
set value never
} elseif {[info exists ::env(CLICOLOR)]} {
if {$::env(CLICOLOR) eq {0}} {
set value never
} else {
set value auto
}
} elseif {[info exists ::env(CLICOLOR_FORCE)] && $::env(CLICOLOR_FORCE)\
ne {0}} {
set value always
}
# overridden value coming from environment via Modules-specific variable
if {$envvar ne {} && [info exists ::env($envvar)]} {
# ignore non-valid values
if {[llength $validvallist] == 0 || $::env($envvar) in $validvallist} {
set value $::env($envvar)
}
}
# overridden value coming the command-line
if {[info exists ::asked_color]} {
set value [set ::asked_color]
}
# convert value to its internal representation
if {[llength $intvallist] > 0} {
set value [lindex $intvallist [lsearch -exact $validvallist $value]]
}
# disable color mode if no terminal attached except if 'always' asked
if {$value != 0 && (![getState is_stderr_tty] || $value == 2)} {
incr value -1
}
# initialize color theme if color mode enabled
getConf colors
return $value
}
# Initialize tcl_ext_lib configuration value
proc initConfTclExtLib {envvar value validvallist intvallist} {
set libfile libtclenvmodules.so
# determine lib directory
##nagelfar ignore +13 Too long line
#set libdir {@libdir@}
switch -- [getState machine] {
x86_64 - aarch64 - ppc64le - s390x {
set libdirmain {/usr/lib64}
set libdiralt {/usr/lib}
}
default {
set libdirmain {/usr/lib}
set libdiralt {/usr/lib64}
}
}
# use alternative arch lib if available and not main one
if {![file exists [file join $libdirmain $libfile]] && [file exists [file\
join $libdiralt $libfile]]} {
set libdir $libdiralt
} else {
set libdir $libdirmain
}
return [file join $libdir $libfile]
}
# Initialize module tag abbreviation table
proc initConfTagAbbrev {envvar value validvallist intvallist} {
# overridden value coming from environment
if {[info exists ::env($envvar)]} {
if {[catch {
# try to set the tag-abbreviation mapping table
array set ::g_tagAbbrev [split $::env($envvar) {:=}]
set value $::env($envvar)
} errMsg ]} {
reportWarning "Ignore invalid value set in $envvar ($::env($envvar))"
array unset ::g_tagAbbrev
}
}
# test default value
if {![array exists ::g_tagAbbrev]} {
if {[catch {
array set ::g_tagAbbrev [split $value {:=}]
} errMsg ]} {
reportWarning "Ignore invalid default value for 'tag_abbrev' config\
($value)"
array unset ::g_tagAbbrev
# define an empty list if no valid value set
set value {}
}
}
# build abbrev:tagname array
foreach {tag abbrev} [array get ::g_tagAbbrev] {
# skip tags not relevant for current command, that share their
# abbreviation with another tag
switch -- $tag {
hidden-loaded {
set setabbrevtag [expr {[currentState commandname] eq {list}}]
}
hidden {
set setabbrevtag [expr {[currentState commandname] eq {avail}}]
}
default {
set setabbrevtag 1
}
}
if {$setabbrevtag} {
set ::g_abbrevTag($abbrev) $tag
}
}
return $value
}
# Initialize module tag color name table
proc initConfTagColorName {envvar value validvallist intvallist} {
# overridden value coming from environment
if {[info exists ::env($envvar)]} {
set value $::env($envvar)
}
# set table for efficient search
foreach tag [split $value :] {
set ::g_tagColorName($tag) 1
}
return $value
}
# Initialize interactive editor command
proc initConfEditor {envvar value validvallist intvallist} {
# overridden value coming from environment via Modules-specific variable
if {$envvar ne {} && [info exists ::env($envvar)]} {
set value $::env($envvar)
# overridden value coming from environment via standard variable
} elseif {[info exists ::env(VISUAL)]} {
set value $::env(VISUAL)
} elseif {[info exists ::env(EDITOR)]} {
set value $::env(EDITOR)
}
return $value
}
# Initialize variant shortcut table
proc initConfVariantShortcut {envvar value validvallist intvallist} {
# overridden value coming from environment
if {[info exists ::env($envvar)]} {
if {[catch {
# try to set the variant-shortcut mapping table
array set testarr [split $::env($envvar) {:=}]
set value $::env($envvar)
set setfromenv 1
} errMsg ]} {
reportWarning "Ignore invalid value set in $envvar ($::env($envvar))"
}
}
# test default value
if {![info exists setfromenv]} {
if {[catch {
array set testarr [split $value {:=}]
} errMsg ]} {
reportWarning "Ignore invalid default value for 'variant_shortcut'\
config ($value)"
# define an empty list if no valid value set
set value {}
}
}
# ignore shortcut if not equal to one character or if set on alphanum char
# or on char with special meaning
foreach {vr sc} [split $value {:=}] {
if {[string length $sc] == 1 && ![string match {[a-zA-Z0-9+~/@=-]}\
$sc]} {
# remove duplicate shortcut or variant definition
if {[info exists ::g_variantShortcut($vr)]} {
unset ::g_shortcutVariant($::g_variantShortcut($vr))
}
if {[info exists ::g_shortcutVariant($sc)]} {
unset ::g_variantShortcut($::g_shortcutVariant($sc))
}
set ::g_variantShortcut($vr) $sc
set ::g_shortcutVariant($sc) $vr
}
}
# update value after above filtering step
set value {}
foreach vr [array names ::g_variantShortcut] {
if {[string length $value] > 0} {
append value :
}
append value $vr=$::g_variantShortcut($vr)
}
return $value
}
# Is currently set verbosity level is equal or higher than level passed as arg
proc isVerbosityLevel {name} {
return [expr {[lsearch -exact [lindex $::g_config_defs(verbosity) 4]\
[getConf verbosity]] >= [lsearch -exact [lindex\
$::g_config_defs(verbosity) 4] $name]}]
}
# Is match performed in a case sensitive or insensitive manner
proc isIcase {} {
# depending on current sub-command, list values that equal to a case
# insensitive match enablement
lappend enabledValList always
if {[currentState commandname] in [list avail list whatis search paths\
savelist]} {
lappend enabledValList search
}
return [expr {[getConf icase] in $enabledValList}]
}
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 $idx-1] ne "\\"} {
# unescape any separator character when adding to list
lappend res [charUnescaped [string range $str $previdx+1 $idx-1]\
$sep]
set previdx $idx
}
set idx [string first $sep $str $idx+1]
}
lappend res [charUnescaped [string range $str $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 intersection of all lists: elements present in every list
proc getIntersectBetweenList {args} {
foreach lst $args {
if {![info exists res]} {
set cur_res $lst
} else {
set cur_res [list]
foreach elt $res {
if {$elt in $lst} {
lappend cur_res $elt
}
}
}
set res $cur_res
# stop when intersection result becomes empty
if {[llength $res] == 0} {
break
}
}
return $res
}
# 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
}
proc raiseErrorCount {} {
setState error_count [expr {[getState error_count] + 1}]
}
proc renderFalse {} {
if {[isStateDefined false_rendered]} {
reportDebug {false already rendered}
# no shell code to render false if shell not set
} elseif {[isStateDefined shell]} {
# setup flag to render only once
setState false_rendered 1
# render a false value most of the time through a variable assignment
# that will be looked at in the shell module function calling
# modulecmd.tcl to return in turns a boolean status. Except for python
# and cmake, the value assigned to variable is also returned as the
# entire rendering status
switch -- [getState shelltype] {
sh - csh - fish {
# no need to set a variable on real shells as last statement
# result can easily be checked
lappend ::g_shcode_out {test 0 = 1;}
}
tcl {
lappend ::g_shcode_out {set _mlstatus 0;}
}
cmd {
lappend ::g_shcode_out {set errorlevel=1}
}
perl {
lappend ::g_shcode_out {{ no strict 'vars'; $_mlstatus = 0; }}
}
python {
lappend ::g_shcode_out {_mlstatus = False}
}
ruby {
lappend ::g_shcode_out {_mlstatus = false}
}
lisp {
lappend ::g_shcode_out {nil}
}
cmake {
lappend ::g_shcode_out {set(_mlstatus FALSE)}
}
r {
lappend ::g_shcode_out {mlstatus <- FALSE}
}
}
}
}
proc renderTrue {} {
# render a true value most of the time through a variable assignment that
# will be looked at in the shell module function calling modulecmd.tcl to
# return in turns a boolean status. Except for python and cmake, the
# value assigned to variable is also returned as the full rendering status
switch -- [getState shelltype] {
sh - csh - fish {
# no need to set a variable on real shells as last statement
# result can easily be checked
lappend ::g_shcode_out {test 0;}
}
tcl {
lappend ::g_shcode_out {set _mlstatus 1;}
}
cmd {
lappend ::g_shcode_out {set errorlevel=0}
}
perl {
lappend ::g_shcode_out {{ no strict 'vars'; $_mlstatus = 1; }}
}
python {
lappend ::g_shcode_out {_mlstatus = True}
}
ruby {
lappend ::g_shcode_out {_mlstatus = true}
}
lisp {
lappend ::g_shcode_out {t}
}
cmake {
lappend ::g_shcode_out {set(_mlstatus TRUE)}
}
r {
lappend ::g_shcode_out {mlstatus <- TRUE}
}
}
}
proc renderText {text} {
# render a text value most of the time through a variable assignment that
# will be looked at in the shell module function calling modulecmd.tcl to
# return in turns a string value.
switch -- [getState shelltype] {
sh - csh - fish {
foreach word $text {
# no need to set a variable on real shells, echoing text will make
# it available as result
lappend ::g_shcode_out "echo '$word';"
}
}
tcl {
lappend ::g_shcode_out "set _mlstatus \"$text\";"
}
cmd {
foreach word $text {
lappend ::g_shcode_out "echo $word"
}
}
perl {
lappend ::g_shcode_out "{ no strict 'vars'; \$_mlstatus = '$text'; }"
}
python {
lappend ::g_shcode_out "_mlstatus = '$text'"
}
ruby {
lappend ::g_shcode_out "_mlstatus = '$text'"
}
lisp {
lappend ::g_shcode_out "(message \"$text\")"
}
cmake {
lappend ::g_shcode_out "set(_mlstatus \"$text\")"
}
r {
lappend ::g_shcode_out "mlstatus <- '$text'"
}
}
}
proc renderSettings {} {
global g_stateEnvVars g_stateAliases g_stateFunctions g_stateCompletes\
g_newXResources g_delXResources g_shcode_out
# preliminaries if there is stuff to render
if {[getState autoinit] || [array size g_stateEnvVars] > 0 ||\
[array size g_stateAliases] > 0 || [array size g_newXResources] > 0 ||\
[array size g_stateFunctions] > 0 || [array size g_stateCompletes] > 0\
|| [array size g_delXResources] > 0 || [info exists ::g_changeDir] ||\
[info exists ::g_stdoutPuts] || [info exists ::g_prestdoutPuts] ||\
[info exists ::g_return_text]} {
switch -- [getState shelltype] {
python {
lappend g_shcode_out {import os}
}
}
set has_rendered 1
} else {
set has_rendered 0
}
# send pre content deferred during modulefile interpretation
if {[info exists ::g_prestdoutPuts]} {
foreach {newline msg} $::g_prestdoutPuts {
append outmsg $msg
if {$newline} {
lappend g_shcode_out $outmsg
unset outmsg
}
}
# add last remaining message
if {[info exists outmsg]} {
lappend g_shcode_out $outmsg
}
}
if {[getState autoinit]} {
renderAutoinit
}
# filter Modules-specific environment variables for mod-to-sh subcmd
if {[getState modtosh_real_shell] ne {}} {
foreach globvar [getModulesEnvVarGlobList 1] {
foreach var [array names g_stateEnvVars -glob $globvar] {
unset g_stateEnvVars($var)
}
}
}
# new environment variables
foreach var [array names g_stateEnvVars] {
switch -- $g_stateEnvVars($var) {
new {
switch -- [getState shelltype] {
csh {
set val [charEscaped $::env($var)]
# csh barfs on long env vars
if {[getState shell] eq {csh} && [string length $val] >\
[getConf csh_limit]} {
if {$var eq {PATH}} {
reportWarning "PATH exceeds [getConf csh_limit]\
characters, truncating and appending\
/usr/bin:/bin ..."
set val [string range $val 0 [getConf\
csh_limit]-1]:/usr/bin:/bin
} else {
reportWarning "$var exceeds [getConf csh_limit]\
characters, truncating..."
set val [string range $val 0 [getConf csh_limit]-1]
}
}
lappend g_shcode_out "setenv $var $val;"
}
sh {
lappend g_shcode_out "$var=[charEscaped $::env($var)];\
export $var;"
}
fish {
set val [charEscaped $::env($var)]
# fish shell has special treatment for PATH variable
# so its value should be provided as a list separated
# by spaces not by semi-colons
if {$var eq {PATH}} {
regsub -all : $val { } val
}
lappend g_shcode_out "set -xg $var $val;"
}
tcl {
set val $::env($var)
lappend g_shcode_out "set ::env($var) {$val};"
}
cmd {
set val $::env($var)
lappend g_shcode_out "set $var=$val"
}
perl {
set val [charEscaped $::env($var) \']
lappend g_shcode_out "\$ENV{'$var'} = '$val';"
}
python {
set val [charEscaped $::env($var) \']
lappend g_shcode_out "os.environ\['$var'\] = '$val'"
}
ruby {
set val [charEscaped $::env($var) \']
lappend g_shcode_out "ENV\['$var'\] = '$val'"
}
lisp {
set val [charEscaped $::env($var) \"]
lappend g_shcode_out "(setenv \"$var\" \"$val\")"
}
cmake {
set val [charEscaped $::env($var) \"]
lappend g_shcode_out "set(ENV{$var} \"$val\")"
}
r {
set val [charEscaped $::env($var) {\\'}]
lappend g_shcode_out "Sys.setenv('$var'='$val')"
}
}
}
del {
switch -- [getState shelltype] {
csh {
lappend g_shcode_out "unsetenv $var;"
}
sh {
lappend g_shcode_out "unset $var;"
}
fish {
lappend g_shcode_out "set -e $var;"
}
tcl {
lappend g_shcode_out "catch {unset ::env($var)};"
}
cmd {
lappend g_shcode_out "set $var="
}
perl {
lappend g_shcode_out "delete \$ENV{'$var'};"
}
python {
lappend g_shcode_out "os.environ\['$var'\] = ''"
lappend g_shcode_out "del os.environ\['$var'\]"
}
ruby {
lappend g_shcode_out "ENV\['$var'\] = nil"
}
lisp {
lappend g_shcode_out "(setenv \"$var\" nil)"
}
cmake {
lappend g_shcode_out "unset(ENV{$var})"
}
r {
lappend g_shcode_out "Sys.unsetenv('$var')"
}
}
}
}
}
foreach var [array names g_stateAliases] {
switch -- $g_stateAliases($var) {
new {
set val $::g_Aliases($var)
# convert $n in !!:n and $* in !* on csh (like on compat version)
if {[getState shelltype] eq {csh}} {
regsub -all {([^\\]|^)\$([0-9]+)} $val {\1!!:\2} val
regsub -all {([^\\]|^)\$\*} $val {\1!*} val
}
# unescape \$ after now csh-specific conversion is over
regsub -all {\\\$} $val {$} val
switch -- [getState shelltype] {
csh {
set val [charEscaped $val]
lappend g_shcode_out "alias $var $val;"
}
sh {
set val [charEscaped $val]
lappend g_shcode_out "alias $var=$val;"
}
fish {
set val [charEscaped $val]
lappend g_shcode_out "alias $var $val;"
}
cmd {
lappend g_shcode_out "doskey $var=$val"
}
}
}
del {
switch -- [getState shelltype] {
csh {
lappend g_shcode_out "unalias $var;"
}
sh {
lappend g_shcode_out "unalias $var;"
}
fish {
lappend g_shcode_out "functions -e $var;"
}
cmd {
lappend g_shcode_out "doskey $var="
}
}
}
}
}
foreach funcname [array names g_stateFunctions] {
switch -- $g_stateFunctions($funcname) {
new {
# trim function body to smoothly add a finishing ;
set val [string trim $::g_Functions($funcname) "; \t\n\r"]
switch -- [getState shell] {
sh - ksh - zsh {
lappend g_shcode_out "$funcname () { $val; };"
}
bash {
lappend g_shcode_out "$funcname () { $val; }; export -f\
$funcname;"
}
fish {
lappend g_shcode_out "function $funcname; $val; end;"
}
}
}
del {
switch -- [getState shelltype] {
sh {
lappend g_shcode_out "unset -f $funcname;"
}
fish {
lappend g_shcode_out "functions -e $funcname;"
}
}
}
}
}
foreach compname [array names g_stateCompletes] {
switch -- $g_stateCompletes($compname) {
new {
foreach {compshell body} $::g_Completes($compname) {
# skip definition not made for current shell
if {$compshell eq [getState shell]} {
switch -- [getState shell] {
bash {
lappend g_shcode_out "complete $body $compname;"
}
tcsh {
lappend g_shcode_out "complete $compname $body;"
}
fish {
# ensure pre-existing fish completion is cleared
if {![info exists fishcompclear($compname)]} {
lappend g_shcode_out "complete -e -c $compname;"
set fishcompclear($compname) 1
}
lappend g_shcode_out "complete -c $compname $body;"
}
}
}
}
}
del {
switch -- [getState shell] {
bash {
lappend g_shcode_out "complete -r $compname;"
}
tcsh {
lappend g_shcode_out "uncomplete $compname;"
}
fish {
lappend g_shcode_out "complete -e -c $compname;"
}
}
}
}
}
# preliminaries for x-resources stuff
if {[array size g_newXResources] > 0 || [array size g_delXResources] > 0} {
switch -- [getState shelltype] {
python {
lappend g_shcode_out {import subprocess}
}
ruby {
lappend g_shcode_out {require 'open3'}
}
}
}
# new x resources
if {[array size g_newXResources] > 0} {
# xrdb executable has already be verified in x-resource
set xrdb [getCommandPath xrdb]
foreach var [array names g_newXResources] {
set val $g_newXResources($var)
# empty val means that var is a file to parse
if {$val eq {}} {
switch -- [getState shelltype] {
sh - csh - fish {
lappend g_shcode_out "$xrdb -merge $var;"
}
tcl {
lappend g_shcode_out "exec $xrdb -merge $var;"
}
perl {
lappend g_shcode_out "system(\"$xrdb -merge $var\");"
}
python {
set var [charEscaped $var \']
lappend g_shcode_out "subprocess.Popen(\['$xrdb',\
'-merge', '$var'\])"
}
ruby {
set var [charEscaped $var \']
lappend g_shcode_out "Open3.popen2('$xrdb -merge $var')"
}
lisp {
lappend g_shcode_out "(shell-command-to-string \"$xrdb\
-merge $var\")"
}
cmake {
lappend g_shcode_out "execute_process(COMMAND $xrdb -merge\
$var)"
}
r {
set var [charEscaped $var {\\'}]
lappend g_shcode_out "system('$xrdb -merge $var')"
}
}
} else {
switch -- [getState shelltype] {
sh - csh - fish {
set var [charEscaped $var \"]
set val [charEscaped $val \"]
lappend g_shcode_out "echo \"$var: $val\" | $xrdb -merge;"
}
tcl {
lappend g_shcode_out "set XRDBPIPE \[open \"|$xrdb -merge\"\
r+\];"
set var [charEscaped $var \"]
set val [charEscaped $val \"]
lappend g_shcode_out "puts \$XRDBPIPE \"$var: $val\";"
lappend g_shcode_out {close $XRDBPIPE;}
lappend g_shcode_out {unset XRDBPIPE;}
}
perl {
lappend g_shcode_out "open(XRDBPIPE, \"|$xrdb -merge\");"
set var [charEscaped $var \"]
set val [charEscaped $val \"]
lappend g_shcode_out "print XRDBPIPE \"$var: $val\\n\";"
lappend g_shcode_out {close XRDBPIPE;}
}
python {
set var [charEscaped $var \']
set val [charEscaped $val \']
lappend g_shcode_out "subprocess.Popen(\['$xrdb',\
'-merge'\],\
stdin=subprocess.PIPE).communicate(input='$var:\
$val\\n')"
}
ruby {
set var [charEscaped $var \']
set val [charEscaped $val \']
lappend g_shcode_out "Open3.popen2('$xrdb -merge') {|i,o,t|\
i.puts '$var: $val'}"
}
lisp {
lappend g_shcode_out "(shell-command-to-string \"echo $var:\
$val | $xrdb -merge\")"
}
cmake {
set var [charEscaped $var \"]
set val [charEscaped $val \"]
lappend g_shcode_out "execute_process(COMMAND echo \"$var:\
$val\" COMMAND $xrdb -merge)"
}
r {
set var [charEscaped $var {\\'}]
set val [charEscaped $val {\\'}]
lappend g_shcode_out "system('$xrdb -merge', input='$var:\
$val')"
}
}
}
}
}
if {[array size g_delXResources] > 0} {
##nagelfar ignore Found constant
set xrdb [getCommandPath xrdb]
set xres_to_del {}
foreach var [array names g_delXResources] {
# empty val means that var is a file to parse
if {$g_delXResources($var) eq {}} {
# xresource file has to be parsed to find what resources
# are declared there and need to be unset
foreach fline [split [exec $xrdb -n load $var] \n] {
lappend xres_to_del [lindex [split $fline :] 0]
}
} else {
lappend xres_to_del $var
}
}
# xresource strings are unset by emptying their value since there
# is no command of xrdb that can properly remove one property
switch -- [getState shelltype] {
sh - csh - fish {
foreach var $xres_to_del {
lappend g_shcode_out "echo \"$var:\" | $xrdb -merge;"
}
}
tcl {
foreach var $xres_to_del {
lappend g_shcode_out "set XRDBPIPE \[open \"|$xrdb -merge\"\
r+\];"
set var [charEscaped $var \"]
lappend g_shcode_out "puts \$XRDBPIPE \"$var:\";"
lappend g_shcode_out {close $XRDBPIPE;}
lappend g_shcode_out {unset XRDBPIPE;}
}
}
perl {
foreach var $xres_to_del {
lappend g_shcode_out "open(XRDBPIPE, \"|$xrdb -merge\");"
set var [charEscaped $var \"]
lappend g_shcode_out "print XRDBPIPE \"$var:\\n\";"
lappend g_shcode_out {close XRDBPIPE;}
}
}
python {
foreach var $xres_to_del {
set var [charEscaped $var \']
lappend g_shcode_out "subprocess.Popen(\['$xrdb', '-merge'\],\
stdin=subprocess.PIPE).communicate(input='$var:\\n')"
}
}
ruby {
foreach var $xres_to_del {
set var [charEscaped $var \']
lappend g_shcode_out "Open3.popen2('$xrdb -merge') {|i,o,t|\
i.puts '$var:'}"
}
}
lisp {
foreach var $xres_to_del {
lappend g_shcode_out "(shell-command-to-string \"echo $var: |\
$xrdb -merge\")"
}
}
cmake {
foreach var $xres_to_del {
set var [charEscaped $var \"]
lappend g_shcode_out "execute_process(COMMAND echo \"$var:\"\
COMMAND $xrdb -merge)"
}
}
r {
foreach var $xres_to_del {
set var [charEscaped $var {\\'}]
lappend g_shcode_out "system('$xrdb -merge', input='$var:')"
}
}
}
}
if {[info exists ::g_changeDir]} {
switch -- [getState shelltype] {
sh - csh - fish {
lappend g_shcode_out "cd '$::g_changeDir';"
}
tcl {
lappend g_shcode_out "cd \"$::g_changeDir\";"
}
cmd {
lappend g_shcode_out "cd $::g_changeDir"
}
perl {
lappend g_shcode_out "chdir '$::g_changeDir';"
}
python {
lappend g_shcode_out "os.chdir('$::g_changeDir')"
}
ruby {
lappend g_shcode_out "Dir.chdir('$::g_changeDir')"
}
lisp {
lappend g_shcode_out "(shell-command-to-string \"cd\
'$::g_changeDir'\")"
}
r {
lappend g_shcode_out "setwd('$::g_changeDir')"
}
}
# cannot change current directory of cmake "shell"
}
# send content deferred during modulefile interpretation
if {[info exists ::g_stdoutPuts]} {
foreach {newline msg} $::g_stdoutPuts {
append outmsg $msg
if {$newline} {
lappend g_shcode_out $outmsg
unset outmsg
}
}
# add last remaining message
if {[info exists outmsg]} {
lappend g_shcode_out $outmsg
}
}
# if currently processing mod-to-sh subcmd, send shell code to the message
# channel then reset code and shell state to get evaluation result shell
# code on stdout channel
if {[getState modtosh_real_shell] ne {}} {
if {[info exists g_shcode_out]} {
report [join $::g_shcode_out \n]
unset g_shcode_out
}
setState shell [getState modtosh_real_shell]
unsetState shelltype
}
# return text value if defined even if error happened
if {[info exists ::g_return_text]} {
reportDebug {text value should be returned.}
renderText $::g_return_text
} elseif {[getState error_count] > 0} {
reportDebug "[getState error_count] error(s) detected."
renderFalse
} elseif {[getState return_false]} {
reportDebug {false value should be returned.}
renderFalse
} elseif {$has_rendered} {
# finish with true statement if something has been put
renderTrue
}
}
# Output all gathered shell code to stdout. This is a separate proc rather the
# final code of renderSettings as such output is also done when exiting after
# an error. Stdout is flushed from flushAndExit proc
proc renderFlush {} {
if {[info exists ::g_shcode_out]} {
# required to work on cygwin, shouldn't hurt real linux
fconfigure stdout -translation lf
puts stdout [join $::g_shcode_out \n]
}
}
proc renderAutoinit {} {
# automatically detect which tclsh should be used for
# future module commands
set tclshbin [info nameofexecutable]
# ensure script path is absolute
set ::argv0 [getAbsolutePath $::argv0]
##nagelfar ignore #462 Close brace not aligned with line
switch -- [getState shelltype] {
csh {
set pre_hi {set _histchars = $histchars; unset histchars;}
set post_hi {set histchars = $_histchars; unset _histchars;}
set pre_pr {set _prompt=$prompt:q; set prompt="";}
set post_pr {set prompt=$_prompt:q; unset _prompt;}
# apply workaround for Tcsh history if set
set eval_cmd [expr {[getConf wa_277] ? "eval `$tclshbin\
'\"'\"'$::argv0'\"'\"' [getState shell] \\!*`;" : "eval\
\"`$tclshbin '\"'\"'$::argv0'\"'\"' [getState shell] \\!*:q`\";"}]
set pre_ex {set _exit="$status";}
set post_ex {test 0 = $_exit}
set fdef "if ( \$?histchars && \$?prompt )\
alias module '$pre_hi $pre_pr $eval_cmd $pre_ex $post_hi $post_pr $post_ex' ;
if ( \$?histchars && ! \$?prompt )\
alias module '$pre_hi $eval_cmd $pre_ex $post_hi $post_ex' ;
if ( ! \$?histchars && \$?prompt )\
alias module '$pre_pr $eval_cmd $pre_ex $post_pr $post_ex' ;
if ( ! \$?histchars && ! \$?prompt ) alias module '$eval_cmd' ;"
if {[getConf ml]} {
append fdef {
alias ml 'module ml \!*' ;}
}
}
sh {
# Considering the diversity of ways local variables are handled
# through the sh-variants ('local' known everywhere except on ksh,
# 'typeset' known everywhere except on pure-sh, and on some systems
# the pure-sh is in fact a 'ksh'), no local variables are defined and
# these variables that should have been local are unset at the end
# on zsh, word splitting should be enabled explicitly
set wsplit [expr {[getState shell] eq {zsh} ? {^^=} : {}}]
# build quarantine mechanism in module function
# an empty runtime variable is set even if no corresponding
# MODULES_RUNENV_* variable found, as var cannot be unset on
# modified environment command-line
set fdef "_module_raw() {"
if {[getConf silent_shell_debug]} {
append fdef {
unset _mlshdbg;
if [ "${MODULES_SILENT_SHELL_DEBUG:-0}" = '1' ]; then
case "$-" in
*v*x*) set +vx; _mlshdbg='vx' ;;
*v*) set +v; _mlshdbg='v' ;;
*x*) set +x; _mlshdbg='x' ;;
*) _mlshdbg='' ;;
esac;
fi;}
}
if {[getConf quarantine_support]} {
append fdef "
unset _mlre _mlIFS;
if \[ -n \"\${IFS+x}\" \]; then
_mlIFS=\$IFS;
fi;
IFS=' ';
for _mlv in \${${wsplit}MODULES_RUN_QUARANTINE:-}; do"
##nagelfar ignore #4 Too long line
append fdef {
if [ "${_mlv}" = "${_mlv##*[!A-Za-z0-9_]}" ] && [ "${_mlv}" = "${_mlv#[0-9]}" ]; then
if [ -n "$(eval 'echo ${'"$_mlv"'+x}')" ]; then
_mlre="${_mlre:-}__MODULES_QUAR_${_mlv}='$(eval 'echo ${'"$_mlv"'}')' ";
fi;
_mlrv="MODULES_RUNENV_${_mlv}";
_mlre="${_mlre:-}${_mlv}='$(eval 'echo ${'"$_mlrv"':-}')' ";
fi;
done;
if [ -n "${_mlre:-}" ]; then
_mlre="${_mlre:-}__MODULES_QUARANTINE_SET=1 ";}
append fdef "\n eval \"\$(eval \${${wsplit}_mlre} $tclshbin\
'$::argv0' [getState shell] '\"\$@\"')\";
else
eval \"\$($tclshbin '$::argv0' [getState shell] \"\$@\")\";
fi;"
} else {
append fdef "
eval \"\$($tclshbin '$::argv0' [getState shell] \"\$@\")\";"
}
append fdef {
_mlstatus=$?;}
if {[getConf quarantine_support]} {
append fdef {
if [ -n "${_mlIFS+x}" ]; then
IFS=$_mlIFS;
else
unset IFS;
fi;
unset _mlre _mlv _mlrv _mlIFS;}
}
if {[getConf silent_shell_debug]} {
append fdef {
if [ -n "${_mlshdbg:-}" ]; then
set -"$_mlshdbg";
fi;
unset _mlshdbg;}
}
append fdef {
return $_mlstatus;}
# define both _module_raw and module functions in any cases to allow
# content redirection when command-line switch is used (--redirect or
# --no-redirect)
# content is redirected by default when shell session is attached to
# a terminal (non-terminal session are not redirected to avoid
# breaking things like scp or sftp transfer)
# use local/typeset variable in this context as we cannot unset it
# afterward (since _module_raw should be the cmd to return status)
set localcmd [expr {[getState shell] eq {ksh} ? {typeset} : {local}}]
##nagelfar ignore Unescaped close brace
append fdef "\n};\nmodule() {
$localcmd _mlredir=[getState is_stderr_tty];\n"
append fdef { if [ -n "${MODULES_REDIRECT_OUTPUT+x}" ]; then
if [ "$MODULES_REDIRECT_OUTPUT" = '0' ]; then
_mlredir=0;
elif [ "$MODULES_REDIRECT_OUTPUT" = '1' ]; then
_mlredir=1;
fi;
fi;
case " $@ " in
*' --no-redirect '*) _mlredir=0 ;;
*' --redirect '*) _mlredir=1 ;;
esac;
if [ $_mlredir -eq 0 ]; then
_module_raw "$@";
else
_module_raw "$@" 2>&1;
fi;}
append fdef "\n};"
if {[getState shell] eq {bash}} {
append fdef {
export -f _module_raw;
export -f module;}
}
if {[getConf ml]} {
append fdef {
ml() { module ml "$@"; };}
if {[getState shell] eq {bash}} {
append fdef {
export -f ml;}
}
}
}
fish {
set fdef "function _module_raw\n"
if {[getConf quarantine_support]} {
append fdef { set -l _mlre ''; set -l _mlv; set -l _mlrv;
for _mlv in (string split ' ' $MODULES_RUN_QUARANTINE)
if string match -r '^[A-Za-z_][A-Za-z0-9_]*$' $_mlv >/dev/null
if set -q $_mlv
set _mlre $_mlre"__MODULES_QUAR_"$_mlv"='$$_mlv' "
end
set _mlrv "MODULES_RUNENV_$_mlv"
set _mlre "$_mlre$_mlv='$$_mlrv' "
end
end
if [ -n "$_mlre" ]
set _mlre "env $_mlre __MODULES_QUARANTINE_SET=1"
end}
# use "| source -" rather than "eval" to be able
# to redirect stderr after stdout being evaluated
append fdef "\n eval \$_mlre $tclshbin \\'$::argv0\\' [getState\
shell] (string escape -- \$argv) | source -\n"
} else {
append fdef " eval $tclshbin \\'$::argv0\\' [getState shell]\
(string escape -- \$argv) | source -\n"
}
append fdef "end
function module
set _mlredir [getState is_stderr_tty]
if set -q MODULES_REDIRECT_OUTPUT
if \[ \"\$MODULES_REDIRECT_OUTPUT\" = '0' \]
set _mlredir 0
else if \[ \"\$MODULES_REDIRECT_OUTPUT\" = '1' \]
set _mlredir 1
end
end
if contains -- --no-redirect \$argv; or begin ; \[ \$_mlredir -eq 0\
\]; and not contains -- --redirect \$argv ; end
_module_raw \$argv
else
_module_raw \$argv 2>&1
end
end"
if {[getConf ml]} {
append fdef {
function ml
module ml $argv
end}
}
}
tcl {
set fdef "proc module {args} {"
if {[getConf quarantine_support]} {
append fdef {
set _mlre {};
if {[info exists ::env(MODULES_RUN_QUARANTINE)]} {
foreach _mlv [split $::env(MODULES_RUN_QUARANTINE) " "] {
if {[regexp {^[A-Za-z_][A-Za-z0-9_]*$} $_mlv]} {
if {[info exists ::env($_mlv)]} {
lappend _mlre "__MODULES_QUAR_${_mlv}=$::env($_mlv)"
}
set _mlrv "MODULES_RUNENV_${_mlv}"
lappend _mlre [expr {[info exists ::env($_mlrv)] ?\
"${_mlv}=$::env($_mlrv)" : "${_mlv}="}]
}
}
if {[llength $_mlre] > 0} {
lappend _mlre "__MODULES_QUARANTINE_SET=1"
set _mlre [linsert $_mlre 0 "env"]
}
}}
}
append fdef {
set _mlstatus 1;}
if {[getConf quarantine_support]} {
append fdef "\n catch {exec {*}\$_mlre \"$tclshbin\"\
\"$::argv0\" \"[getState shell]\" {*}\$args 2>@stderr}\
script\n"
} else {
append fdef "\n catch {exec \"$tclshbin\" \"$::argv0\"\
\"[getState shell]\" {*}\$args 2>@stderr} script\n"
}
append fdef { eval $script;
return $_mlstatus}
append fdef "\n}"
if {[getConf ml]} {
append fdef {
proc ml {args} {
return [module ml {*}$args]
}}
}
}
cmd {
reportErrorAndExit {No autoinit mode available for 'cmd' shell}
}
perl {
set fdef "sub module {"
if {[getConf quarantine_support]} {
append fdef {
my $_mlre = '';
if (defined $ENV{'MODULES_RUN_QUARANTINE'}) {
foreach my $_mlv (split(' ', $ENV{'MODULES_RUN_QUARANTINE'})) {
if ($_mlv =~ /^[A-Za-z_][A-Za-z0-9_]*$/) {
if (defined $ENV{$_mlv}) {
$_mlre .= "__MODULES_QUAR_${_mlv}='$ENV{$_mlv}' ";
}
my $_mlrv = "MODULES_RUNENV_$_mlv";
$_mlre .= "$_mlv='$ENV{$_mlrv}' ";
}
}
if ($_mlre ne "") {
$_mlre = "env ${_mlre}__MODULES_QUARANTINE_SET=1 ";
}
}}
}
append fdef {
my $args = '';
if (@_ > 0) {
$args = '"' . join('" "', @_) . '"';
}
my $_mlstatus = 1;}
if {[getConf quarantine_support]} {
append fdef "\n eval `\${_mlre}$tclshbin '$::argv0' perl\
\$args`;\n"
} else {
append fdef "\n eval `$tclshbin '$::argv0' perl \$args`;\n"
}
append fdef { return $_mlstatus;}
append fdef "\n}"
if {[getConf ml]} {
append fdef {
sub ml {
return module('ml', @_);
}}
}
}
python {
set fdef {import sys, re, subprocess
def module(*arguments):}
if {[getConf quarantine_support]} {
append fdef {
_mlre = os.environ.copy()
if 'MODULES_RUN_QUARANTINE' in os.environ:
for _mlv in os.environ['MODULES_RUN_QUARANTINE'].split():
if re.match('^[A-Za-z_][A-Za-z0-9_]*$', _mlv):
if _mlv in os.environ:
_mlre['__MODULES_QUAR_' + _mlv] = os.environ[_mlv]
_mlrv = 'MODULES_RUNENV_' + _mlv
if _mlrv in os.environ:
_mlre[_mlv] = os.environ[_mlrv]
else:
_mlre[_mlv] = ''
_mlre['__MODULES_QUARANTINE_SET'] = '1'}
}
append fdef {
ns = {}}
if {[getConf quarantine_support]} {
append fdef "\n out, err = subprocess.Popen(\['$tclshbin',\
'$::argv0', 'python'\] + list(arguments),\
stdout=subprocess.PIPE, stderr=subprocess.PIPE,\
env=_mlre).communicate()\n"
} else {
append fdef "\n out, err = subprocess.Popen(\['$tclshbin',\
'$::argv0', 'python'\] + list(arguments),\
stdout=subprocess.PIPE,\
stderr=subprocess.PIPE).communicate()\n"
}
append fdef { exec(out, ns)
if '_mlstatus' in ns:
_mlstatus = ns['_mlstatus']
else:
_mlstatus = True
if err.decode():
print(err.decode(), end='', file=sys.stderr)
return _mlstatus}
if {[getConf ml]} {
append fdef {
def ml(*arguments):
return module('ml', *arguments)
}
}
}
ruby {
set fdef {class ENVModule
def ENVModule.module(*args)}
if {[getConf quarantine_support]} {
##nagelfar ignore +7 Too long line
append fdef {
_mlre = ''
if ENV.has_key?('MODULES_RUN_QUARANTINE') then
ENV['MODULES_RUN_QUARANTINE'].split(' ').each do |_mlv|
if _mlv =~ /^[A-Za-z_][A-Za-z0-9_]*$/ then
if ENV.has_key?(_mlv) then
_mlre << "__MODULES_QUAR_" + _mlv + "='" + ENV[_mlv].to_s + "' "
end
_mlrv = 'MODULES_RUNENV_' + _mlv
_mlre << _mlv + "='" + ENV[_mlrv].to_s + "' "
end
end
unless _mlre.empty?
_mlre = 'env ' + _mlre + '__MODULES_QUARANTINE_SET=1 '
end
end}
}
append fdef {
if args[0].kind_of?(Array) then
args = args[0]
end
if args.length == 0 then
args = ''
else
args = "\"#{args.join('" "')}\""
end
_mlstatus = true}
if {[getConf quarantine_support]} {
##nagelfar ignore +2 Suspicious # char
append fdef "\n eval `#{_mlre}$tclshbin '$::argv0' ruby\
#{args}`\n"
} else {
append fdef "\n eval `$tclshbin '$::argv0' ruby #{args}`\n"
}
append fdef { return _mlstatus
end}
if {[getConf ml]} {
append fdef {
def ENVModule.ml(*args)
return ENVModule.module('ml', *args)
end}
}
append fdef {
end}
}
lisp {
reportErrorAndExit {lisp mode autoinit not yet implemented}
}
cmake {
if {[getConf quarantine_support]} {
set pre_exec "\n execute_process(COMMAND \${_mlre} $tclshbin\
\"$::argv0\" cmake "
} else {
set pre_exec "\n execute_process(COMMAND $tclshbin\
\"$::argv0\" cmake "
}
set post_exec "\n OUTPUT_FILE \${tempfile_name})\n"
set fdef {function(module)
cmake_policy(SET CMP0007 NEW)}
if {[getConf quarantine_support]} {
append fdef {
set(_mlre "")
if(DEFINED ENV{MODULES_RUN_QUARANTINE})
string(REPLACE " " ";" _mlv_list "$ENV{MODULES_RUN_QUARANTINE}")
foreach(_mlv ${_mlv_list})
if(${_mlv} MATCHES "^[A-Za-z_][A-Za-z0-9_]*$")
if(DEFINED ENV{${_mlv}})
set(_mlre "${_mlre}__MODULES_QUAR_${_mlv}=$ENV{${_mlv}};")
endif()
set(_mlrv "MODULES_RUNENV_${_mlv}")
set(_mlre "${_mlre}${_mlv}=$ENV{${_mlrv}};")
endif()
endforeach()
if (NOT "${_mlre}" STREQUAL "")
set(_mlre "env;${_mlre}__MODULES_QUARANTINE_SET=1;")
endif()
endif()}
}
append fdef {
set(_mlstatus TRUE)
execute_process(COMMAND mktemp -t moduleinit.cmake.XXXXXXXXXXXX
OUTPUT_VARIABLE tempfile_name
OUTPUT_STRIP_TRAILING_WHITESPACE)
if(${ARGC} EQUAL 1)}
# adapt command definition depending on the number of args to be
# able to pass to some extend (<5 args) empty string element to
# modulecmd (no other way as empty element in ${ARGV} are skipped
append fdef "$pre_exec\"\${ARGV0}\"$post_exec"
append fdef { elseif(${ARGC} EQUAL 2)}
append fdef "$pre_exec\"\${ARGV0}\" \"\${ARGV1}\"$post_exec"
append fdef { elseif(${ARGC} EQUAL 3)}
append fdef "$pre_exec\"\${ARGV0}\" \"\${ARGV1}\"\
\"\${ARGV2}\"$post_exec"
append fdef { elseif(${ARGC} EQUAL 4)}
append fdef "$pre_exec\"\${ARGV0}\" \"\${ARGV1}\"\
\"\${ARGV2}\" \"\${ARGV3}\"$post_exec"
append fdef { else()}
append fdef "$pre_exec\${ARGV}$post_exec"
append fdef { endif()
if(EXISTS ${tempfile_name})
include(${tempfile_name})
file(REMOVE ${tempfile_name})
endif()
set(module_result ${_mlstatus} PARENT_SCOPE)
endfunction(module)}
if {[getConf ml]} {
append fdef {
function(ml)
module(ml ${ARGV})
set(module_result ${module_result} PARENT_SCOPE)
endfunction(ml)}
}
}
r {
set fdef "module <- function(...){"
if {[getConf quarantine_support]} {
##nagelfar ignore +7 Too long line
append fdef {
mlre <- ''
if (!is.na(Sys.getenv('MODULES_RUN_QUARANTINE', unset=NA))) {
for (mlv in strsplit(Sys.getenv('MODULES_RUN_QUARANTINE'), ' ')[[1]]) {
if (grepl('^[A-Za-z_][A-Za-z0-9_]*$', mlv)) {
if (!is.na(Sys.getenv(mlv, unset=NA))) {
mlre <- paste0(mlre, "__MODULES_QUAR_", mlv, "='", Sys.getenv(mlv), "' ")
}
mlrv <- paste0('MODULES_RUNENV_', mlv)
mlre <- paste0(mlre, mlv, "='", Sys.getenv(mlrv), "' ")
}
}
if (mlre != '') {
mlre <- paste0('env ', mlre, '__MODULES_QUARANTINE_SET=1 ')
}
}}
}
append fdef {
arglist <- as.list(match.call())
arglist[1] <- 'r'
args <- paste0('"', paste0(arglist, collapse='" "'), '"')}
if {[getConf quarantine_support]} {
append fdef "\n cmd <- paste(mlre, '$tclshbin', '\"$::argv0\"',\
args, sep=' ')\n"
} else {
append fdef "\n cmd <- paste('$tclshbin', '\"$::argv0\"', args,\
sep=' ')\n"
}
append fdef { mlstatus <- TRUE
hndl <- pipe(cmd)
eval(expr = parse(file=hndl))
close(hndl)
invisible(mlstatus)}
append fdef "\n}"
if {[getConf ml]} {
append fdef {
ml <- function(...){
module('ml', ...)
}}
}
}
}
# output function definition
lappend ::g_shcode_out $fdef
}
proc get-env {var {valifunset {}}} {
# return current value if exists and not cleared
if {[info exists ::env($var)] && ![info exists ::g_clearedEnvVars($var)]} {
return $::env($var)
} else {
return $valifunset
}
}
proc isProtectedEnvVar {var} {
# return if var is protected by protected_envvars config
return [expr {$var in [split [getConf protected_envvars] :]}]
}
proc set-env {var val} {
set mode [currentState mode]
reportDebug "$var=$val"
if {![isProtectedEnvVar $var]} {
# an empty string value means unsetting variable on Windows platform, so
# call unset-env to ensure variable will not be seen defined yet raising
# an error when trying to access it
if {[getState is_win] && $val eq {}} {
unset-env $var
} else {
interp-sync-env set $var $val
# variable is not cleared anymore if set again
if {[info exists ::g_clearedEnvVars($var)]} {
unset ::g_clearedEnvVars($var)
}
# propagate variable setup to shell environment on load and unload
# mode
if {$mode eq {load} || $mode eq {unload}} {
set ::g_stateEnvVars($var) new
}
}
} else {
reportWarning "Modification of protected environment variable $var\
ignored"
}
}
proc reset-to-unset-env {var {val {}}} {
interp-sync-env set $var $val
# set var as cleared if val is empty
if {$val eq {}} {
set ::g_clearedEnvVars($var) 1
}
}
proc unset-env {var {internal 0} {val {}}} {
set mode [currentState mode]
reportDebug "$var (internal=$internal, val=$val)"
if {![isProtectedEnvVar $var]} {
# clear value instead of unset it not to break variable later reference
# in modulefile. clear whether variable set or not to get a later usage
# consistent behavior whatever env is setup
if {!$internal} {
reset-to-unset-env $var $val
# internal variables (like ref counter var) are purely unset if they
# exists
} elseif {[info exists ::env($var)]} {
interp-sync-env unset $var
set intwasset 1
}
# propagate deletion in any case if variable is public and for internal
# one only if variable was set
if {($mode eq {load} || $mode eq {unload}) && (!$internal ||\
[info exists intwasset])} {
set ::g_stateEnvVars($var) del
}
} else {
reportWarning "Modification of protected environment variable $var\
ignored"
}
}
proc getPushenvVarName {var} {
return __MODULES_PUSHENV_${var}
}
proc getModshareVarName {var} {
# no modshare variable for Modules-specific path variables as each entry
# should be unique (no reference counting mechanism for these variables
# expect for MODULEPATH)
if {$var in {_LMFILES_ LOADEDMODULES} || [string equal -length 10\
__MODULES_ $var] || [string equal -length 8 MODULES_ $var]} {
return {}
# specific modshare variable use a Modules-specific prefix (rather suffix
# that may lead to warning message for instance for DYLD-related variables)
} else {
return __MODULES_SHARE_${var}
}
}
# path fiddling
proc getReferenceCountArray {var separator} {
# get reference counter set in environment
set sharevar [getModshareVarName $var]
array set refcount {}
if {[info exists ::env($sharevar)]} {
set modsharelist [psplit $::env($sharevar) [getState path_separator]]
# ignore environment ref count variable if malformed
if {([llength $modsharelist] % 2) == 0} {
array set refcount $modsharelist
} else {
reportDebug "Reference counter value in '$sharevar' is malformed\
($modsharelist)"
}
}
array set countarr {}
if {[info exists ::env($var)]} {
# do not skip a bare empty path entry that can also be found in
# reference counter array (sometimes var is cleared by setting it
# empty not unsetting it, ignore var in this case)
if {$::env($var) eq {} && [info exists refcount()]} {
lappend eltlist {}
} else {
set eltlist [split $::env($var) $separator]
}
# just go thought the elements of the variable, which means additional
# elements part of the reference counter variable will be ignored
foreach elt $eltlist {
# no reference counter, means value has been set once
if {![info exists refcount($elt)]} {
set count 1
# bad reference counter value is ignored
} elseif {![string is digit -strict $refcount($elt)] ||\
$refcount($elt) < 1} {
reportDebug "Reference counter value for '$elt' in '$sharevar' is\
erroneous ($refcount($elt))"
set count 1
} else {
set count $refcount($elt)
}
set countarr($elt) $count
}
}
set count_list [array get countarr]
reportDebug "(var=$var, delim=$separator) got '$count_list'"
return $count_list
}
# generate reference count value to export in user environment
proc setReferenceCountRecordValue {sharevar countlist} {
foreach {elt refcount} $countlist {
# do not export elements with a reference count of 1 as no reference
# count entry means a reference count of 1
# exception made for empty string which is recorded even for a single
# reference count to be able to distinguish between an empty path
# variable and a path variable with an empty string as unique element
if {$refcount > 1 || $elt eq {}} {
lappend reclist $elt $refcount
}
}
if {[info exists reclist]} {
set-env $sharevar [pjoin $reclist [getState path_separator]]
# unset ref count var if found set whereas no counter should be recorded
} elseif {[info exists ::env($sharevar)]} {
unset-env $sharevar 1
}
}
proc unload-path {cmd mode dflbhv args} {
reportDebug "($args) cmd=$cmd, mode=$mode, dflbhv=$dflbhv"
lassign [parsePathCommandArgs $cmd $mode $dflbhv {*}$args] separator\
allow_dup idx_val ign_refcount bhv var path_list
switch -- $bhv {
noop {
return [list $bhv $var]
}
append - prepend {
# set paths instead of removing them
add-path unload-path load $bhv $cmd $separator $var {*}$path_list
return [list $bhv $var]
}
}
# clean any previously defined pushenv stack
unset-env [getPushenvVarName $var] 1
# no reference count management when no share variable is returned
set isrefcount [expr {[set sharevar [getModshareVarName $var]] ne {}}]
if {$isrefcount} {
array set countarr [getReferenceCountArray $var $separator]
}
# Don't worry about dealing with this variable if it is already scheduled
# for deletion
if {[info exists ::g_stateEnvVars($var)] && $::g_stateEnvVars($var) eq\
{del}} {
return [list $bhv $var]
}
# save initial variable content to match index arguments
set dir_list [split [get-env $var] $separator]
# detect if empty env value means empty path entry
if {[llength $dir_list] == 0 && [info exists countarr()]} {
lappend dir_list {}
}
# build list of index to remove from variable
set del_idx_list [list]
foreach dir $path_list {
# retrieve dir value if working on an index list
if {$idx_val} {
set idx $dir
# go to next index if this one is not part of the existing range
# needed to distinguish an empty value to an out-of-bound value
if {$idx < 0 || $idx >= [llength $dir_list]} {
continue
} else {
set dir [lindex $dir_list $idx]
}
}
# update reference counter array
if {[info exists countarr($dir)]} {
# unload value in any case if counter ignored (--ignore-refcount set)
if {$ign_refcount} {
set countarr($dir) 0
} else {
incr countarr($dir) -1
}
if {$countarr($dir) <= 0} {
unset countarr($dir)
set newcount 0
} else {
set newcount $countarr($dir)
}
} else {
set newcount 0
}
# get all entry indexes corresponding to dir
set found_idx_list [lsearch -all -exact $dir_list $dir]
# remove all found entries
if {$newcount <= 0} {
# only remove passed position in --index mode
if {$idx_val} {
lappend del_idx_list $idx
} else {
lappend del_idx_list {*}$found_idx_list
}
# if multiple entries found remove the extra entries compared to new
# reference counter
} elseif {[llength $found_idx_list] > $newcount} {
# only remove passed position in --index mode
if {$idx_val} {
lappend del_idx_list $idx
} else {
# delete extra entries, starting from end of the list (on a path
# variable, entries at the end have less priority than those at
# the start)
lappend del_idx_list {*}[lrange $found_idx_list $newcount end]
}
}
}
# update variable if some element need to be removed
if {[llength $del_idx_list] > 0} {
set del_idx_list [lsort -integer -unique $del_idx_list]
set newpath [list]
set nbelem [llength $dir_list]
# rebuild list of element without indexes set for deletion
for {set i 0} {$i < $nbelem} {incr i} {
if {$i ni $del_idx_list} {
lappend newpath [lindex $dir_list $i]
}
}
} else {
set newpath $dir_list
}
# set env variable and corresponding reference counter in any case
if {[llength $newpath] == 0} {
unset-env $var
} else {
set-env $var [join $newpath $separator]
}
if {$isrefcount} {
setReferenceCountRecordValue $sharevar [array get countarr]
}
return [list $bhv $var]
}
proc add-path {cmd mode dflbhv args} {
reportDebug "($args) cmd=$cmd, mode=$mode, dflbhv=$dflbhv"
# may be called from unload-path where argument parsing was already done
if {$cmd eq {unload-path}} {
set path_list [lassign $args cmd separator var]
set allow_dup 0
set ign_refcount 0
set bhv $dflbhv
} else {
lassign [parsePathCommandArgs $cmd $mode $dflbhv {*}$args] separator\
allow_dup idx_val ign_refcount bhv var path_list
}
# clean any previously defined pushenv stack
unset-env [getPushenvVarName $var] 1
# no reference count management when no share variable is returned
set isrefcount [expr {[set sharevar [getModshareVarName $var]] ne {}}]
if {$isrefcount} {
array set countarr [getReferenceCountArray $var $separator]
}
if {$bhv eq {prepend}} {
set path_list [lreverse $path_list]
}
set val [get-env $var]
foreach dir $path_list {
if {![info exists countarr($dir)] || $allow_dup} {
# ignore env var set empty if no empty entry found in reference
# counter array (sometimes var is cleared by setting it empty not
# unsetting it)
if {$val ne {} || [info exists countarr()]} {
set val [expr {$bhv eq {prepend} ? "$dir$separator$val" :\
"$val$separator$dir"}]
} else {
set val $dir
}
}
if {[info exists countarr($dir)]} {
# do not increase counter if it is ignored (--ignore-refcount set)
# unless if duplicate mode is enabled (--duplicates set)
if {!$ign_refcount || $allow_dup} {
incr countarr($dir)
}
} else {
set countarr($dir) 1
}
}
set-env $var $val
if {$isrefcount} {
setReferenceCountRecordValue $sharevar [array get countarr]
}
return {}
}
# analyze argument list passed to a path command to set default value or raise
# error in case some attributes are missing
proc parsePathCommandArgs {cmd mode dflbhv args} {
# parse argument list
set next_is_delim 0
set next_is_ignored 0
set next_is_reset 0
set allow_dup 0
set idx_val 0
set ign_refcount 0
set bhv $dflbhv
foreach arg $args {
# everything passed after variable name is considered a value
if {[info exists var]} {
switch -- $arg {
--append-on-unload - --prepend-on-unload {
if {$cmd ne {remove-path}} {
knerror "invalid option '$arg' for $cmd"
} elseif {$mode ne {unload}} {
# ignore value set after this argument if not unloading
# unless if no list is already set for load mode
if {[info exists val_raw_list]} {
set next_is_ignored 1
}
} else {
set bhv [expr {$arg eq {--append-on-unload} ? {append} :\
{prepend}}]
# if another argument is set, current value list will be
# withdrawn to start from new list set after this argument
set next_is_reset 1
}
set bhvopt $arg
}
--remove-on-unload - --noop-on-unload {
if {$cmd ne {remove-path}} {
knerror "invalid option '$arg' for $cmd"
} elseif {$mode eq {unload}} {
set bhv [expr {$arg eq {--remove-on-unload} ? {remove} :\
{noop}}]
}
set bhvopt $arg
}
default {
if {$next_is_reset} {
set next_is_reset 0
set val_raw_list [list $arg]
} elseif {!$next_is_ignored} {
# set multiple passed values in a list
lappend val_raw_list $arg
}
}
}
} else {
switch -glob -- $arg {
--index {
if {$cmd ne {remove-path}} {
reportWarning "--index option has no effect on $cmd"
} else {
set idx_val 1
}
}
--duplicates {
# raise warning when option is used by remove-path
if {$cmd eq {remove-path}} {
reportWarning "--duplicates option has no effect on $cmd"
} else {
set allow_dup 1
}
}
-d - -delim - --delim {
set next_is_delim 1
}
--delim=* {
set delim [string range $arg 8 end]
}
--ignore-refcount {
set ign_refcount 1
}
--append-on-unload - --prepend-on-unload - --remove-on-unload -\
--noop-on-unload {
if {$cmd ne {remove-path}} {
knerror "invalid option '$arg' for $cmd"
} elseif {$mode eq {unload}} {
switch -- [string range $arg 2 5] {
noop { set bhv noop }
remo { set bhv remove }
appe { set bhv append }
prep { set bhv prepend }
}
}
set bhvopt $arg
}
-* {
knerror "invalid option '$arg' for $cmd"
}
default {
if {$next_is_delim} {
set delim $arg
set next_is_delim 0
} else {
set var $arg
}
}
}
}
}
# adapt with default value or raise error if some arguments are missing
if {![info exists delim]} {
set delim [getState path_separator]
} elseif {$delim eq {}} {
knerror "$cmd should get a non-empty path delimiter"
}
if {![info exists var]} {
knerror "$cmd should get an environment variable name"
} elseif {$var eq {}} {
knerror "$cmd should get a valid environment variable name"
}
if {![info exists val_raw_list]} {
knerror "$cmd should get a value for environment variable $var"
}
# some options cannot be mixed
if {$idx_val != 0 && ([info exists bhvopt] && $bhvopt !=\
{--noop-on-unload})} {
knerror "--index and $bhvopt options cannot be simultaneously set"
}
# set list of value to add
set val_list [list]
foreach val $val_raw_list {
# check passed indexes are numbers
if {$idx_val && ![string is integer -strict $val]} {
knerror "$cmd should get valid number as index value"
}
switch -- $val \
{} {
# add empty entry in list
lappend val_list {}
} \
$delim {
knerror "$cmd cannot handle path equals to separator string"
} \
default {
# split passed value with delimiter
lappend val_list {*}[split $val $delim]
}
}
reportDebug "(delim=$delim, allow_dup=$allow_dup, idx_val=$idx_val,\
ign_refcount=$ign_refcount, bhv=$bhv, var=$var, val=$val_list,\
nbval=[llength $val_list])"
return [list $delim $allow_dup $idx_val $ign_refcount $bhv $var $val_list]
}
# get list of Modules-specific environment variable in glob form
proc getModulesEnvVarGlobList {{loaded_ctx 0}} {
set envvar_glob_list [list LOADEDMODULES _LMFILES_]
# only return list of variables related to module loaded context
if {$loaded_ctx} {
lappend envvar_glob_list __MODULES_*
} else {
lappend envvar_glob_list MODULE* __MODULES_* *_module*
}
return $envvar_glob_list
}
#
# Debug, Info, Warnings and Error message handling.
#
# save message when report is not currently initialized as we do not
# know yet if debug mode is enabled or not
proc reportDebug {message {showcaller 1} {caller _undef_}} {
# get caller name
if {$caller eq {_undef_} && $showcaller} {
set caller [getCallingProcName]
}
lappend ::errreport_buffer [list reportDebug $message $showcaller $caller]
}
# regular procedure to use once error report is initialized
proc __reportDebug {message {showcaller 1} {caller _undef_}} {
# display active interp details if not the main one
set prefix [currentState debug_msg_prefix]
if {$caller eq {_undef_} && $showcaller} {
set caller [getCallingProcName]
}
# display caller name as prefix
if {$showcaller && $caller ne {}} {
append prefix "$caller: "
}
report [sgr db "DEBUG $prefix$message"] 0 1
}
# alternative procedure used when debug is disabled
proc __reportDebugNop {args} {}
proc reportWarning {message {recordtop 0}} {
reportError $message $recordtop WARNING wa 0
}
proc reportError {message {recordtop 0} {severity ERROR} {sgrkey er}\
{raisecnt 1}} {
lappend ::errreport_buffer [list reportError $message $recordtop $severity\
$sgrkey $raisecnt]
}
proc __reportError {message {recordtop 0} {severity ERROR} {sgrkey er}\
{raisecnt 1}} {
# if report disabled, also disable error raise to get a coherent
# behavior (if no message printed, no error code change)
if {![getState inhibit_errreport]} {
if {$raisecnt} {
raiseErrorCount
}
set msgsgr "[sgr $sgrkey $severity]: $message"
# record message to report it later on if a record id is found
if {[currentState msgrecordid] ne {}} {
recordMessage $msgsgr $recordtop
# skip message report if silent
} elseif {[isVerbosityLevel concise]} {
# save error messages to render them all together in JSON format
if {[isStateEqual report_format json]} {
lappend ::g_report_erralist $severity $message
} else {
report $msgsgr 0 0 1
}
}
}
}
# throw known error (call error with 'known error' code)
proc knerror {message {code MODULES_ERR_KNOWN}} {
error $message {} $code
}
# save message if report is not yet initialized
proc reportErrorAndExit {message} {
lappend ::errreport_buffer [list reportErrorAndExit $message]
}
# regular procedure to use once error report is initialized
proc __reportErrorAndExit {message} {
raiseErrorCount
renderFalse
error $message {} MODULES_ERR_RENDERED
}
proc reportInternalBug {message {modfile {}} {title {Module ERROR}}} {
if {$modfile ne {}} {
append message "\nIn '$modfile'"
}
append message "\nPlease contact <[getConf contact]>"
reportError $message 0 $title me
}
proc reportInfo {message {title INFO}} {
if {[isVerbosityLevel normal]} {
# use reportError for convenience but there is no error here
reportError $message 0 $title in 0
}
}
proc reportTrace {message {title TRACE}} {
if {[isVerbosityLevel trace]} {
# use reportError for convenience but there is no error here
reportError [sgr tr $message] 0 $title tr 0
}
}
proc reportTimer {message timestr start_us stop_us} {
set elapsed_ms [expr {($stop_us - $start_us) / 1000.0}]
report [sgr db "TIMER $message [format $timestr $elapsed_ms]"] 0 1
}
# trace procedure execution start
proc reportTraceExecEnter {cmdstring op} {
reportDebug $cmdstring 1 [getCallingProcName]
}
# time procedure execution duration
proc reportTimerExecEnter {cmdstring op} {
uplevel 1 set proc_timer_start [clock microseconds]
}
proc reportTimerExecLeave {cmdstring code result op} {
reportTimer $cmdstring {(%.3f ms)} [uplevel 1 set proc_timer_start]\
[clock microseconds]
}
# is currently active message record id at top level
proc isMsgRecordIdTop {} {
return [expr {[depthState msgrecordid] eq 1}]
}
# record messages on the eventual additional module evaluations that have
# occurred during the current evaluation
proc reportModuleEval {} {
set evalid [currentState evalid]
array set contexttitle {conun {Unloading conflict} reqlo {Loading\
requirement} depre {Reloading dependent} depun {Unloading dependent}\
urequn {Unloading useless requirement}}
if {[info exists ::g_moduleEval($evalid)]} {
foreach contextevallist $::g_moduleEval($evalid) {
set msgrecidlist [lassign $contextevallist context]
# skip context with no description title
if {[info exists contexttitle($context)]} {
# exclude hidden modules from report unless an high level of
# verbosity is set
if {[info exists ::g_moduleHiddenEval($evalid:$context)] &&\
![isVerbosityLevel verbose2]} {
lassign [getDiffBetweenList $msgrecidlist\
$::g_moduleHiddenEval($evalid:$context)] msgrecidlist
}
if {[llength $msgrecidlist] > 0} {
set moddesiglist {}
foreach msgrecid $msgrecidlist {
lappend moddesiglist [getModuleDesignation $msgrecid]
}
reportInfo [join $moddesiglist] $contexttitle($context)
}
}
}
# purge list in case same evaluation is re-done afterward
unset ::g_moduleEval($evalid)
}
}
# render messages related to current record id under an header block
proc reportMsgRecord {header {hidden 0}} {
set recid [currentState msgrecordid]
if {[info exists ::g_msgRecord($recid)]} {
# skip message report if silent (report even if hidden as soon as msgs
# are associated to hidden module evaluation)
if {[isVerbosityLevel concise]} {
set tty_cols [getState term_columns]
set padding { }
set dispmsg $header
foreach msg $::g_msgRecord($recid) {
# split lines if too large for terminal
set first 1
set max_idx [tcl::mathfunc::max [expr {$tty_cols - [string length\
$padding]}] 1]
set linelist [list]
foreach line [split $msg \n] {
set lineadd {}
while {$lineadd ne $line} {
set line_max_idx $max_idx
# sgr tags consume no length
set eidx 0
while {[set sidx [string first "\033\[" $line $eidx]] !=\
-1} {
set eidx [string first m $line $sidx]
incr line_max_idx [expr {1 + $eidx - $sidx}]
}
# no split if no whitespace found to slice
if {[string length $line] > $line_max_idx && [set cut_idx\
[string last { } $line $line_max_idx]] != -1} {
set lineadd [string range $line 0 $cut_idx-1]
set line [string range $line $cut_idx+1 end]
} else {
set lineadd $line
}
# skip empty line
if {[string trim $lineadd] ne {}} {
lappend linelist $lineadd
}
if {$first} {
set first 0
incr max_idx -[string length $padding]
if {$max_idx < 1} {set max_idx 1}
}
}
}
# display each line
set first 1
foreach line $linelist {
append dispmsg \n
if {$first} {
set first 0
} else {
append dispmsg $padding
}
append dispmsg $padding$line
}
}
reportSeparateNextContent
report $dispmsg
reportSeparateNextContent
}
# purge message list in case same evaluation is re-done afterward
unset ::g_msgRecord($recid)
# report header if no other specific msg to output in verbose mode or in
# normal verbosity mode if currently processing a cmd which triggers
# multiple module evaluations that cannot be guessed by the user (excluding
# dependency evaluations which are reported by triggering top evaluation)
# if hidden flag is enabled report only if verbosity >= verbose2
} elseif {(!$hidden && ([isVerbosityLevel verbose] || ([isVerbosityLevel\
normal] && ([ongoingCommandName restore] || [ongoingCommandName source]\
|| [ongoingCommandName reset] || [ongoingCommandName stash] ||\
[ongoingCommandName stashpop] || [ongoingCommandName cacheclear] ||\
[ongoingCommandName cachebuild]) && $recid eq [topState msgrecordid])))\
|| ($hidden && [isVerbosityLevel verbose2])} {
report $header
}
}
# separate next content produced if any
proc reportSeparateNextContent {} {
lappend ::errreport_buffer [list reportSeparateNextContent]
}
# regular procedure to use once error report is initialized
proc __reportSeparateNextContent {} {
# hold or apply
if {[depthState reportholdid] > 0} {
lappend ::g_holdReport([currentState reportholdid]) [list\
reportSeparateNextContent]
} else {
setState report_sep_next 1
}
}
# save message for block rendering
proc recordMessage {message {recordtop 0}} {
lappend ::g_msgRecord([expr {$recordtop ? [topState msgrecordid] :\
[currentState msgrecordid]}]) $message
}
# check if some msg have been recorded for current evaluation
proc isMsgRecorded {} {
return [info exists ::g_msgRecord([currentState msgrecordid])]
}
# filter and format error stack trace to only report useful content
proc formatErrStackTrace {errmsg loc {cmdlist {}}} {
set headstr "\n while executing\n"
set splitstr "\n invoked from within\n"
set splitstrlen [string length $splitstr]
set aftheadidx [string first $headstr $errmsg]
if {$aftheadidx != -1} {
incr aftheadidx [string length $headstr]
}
# get name of invalid command name to maintain it in error stack trace
if {[string equal -length 22 {invalid command name "} $errmsg]} {
set unkcmd [lindex [split [string range $errmsg 0 $aftheadidx] {"}] 1]
} else {
set unkcmd {}
}
# get list of modulecmd.tcl internal procedure to filter out from stack
# skip this when no interp command list is provided
if {[llength $cmdlist] > 0} {
lassign [getDiffBetweenList [list {*}[info commands] {*}[info procs]]\
$cmdlist] filtercmdlist keepcmdlist
} else {
set filtercmdlist {}
}
# define commands to filter out from bottom of stack
set filtercmdendlist [list {eval $modcontent} "source $loc" {uplevel 1\
source $siteconfig} {eval $cachecontent}]
# filter out modulecmd internal references at beginning of stack
set internals 1
while {$internals && $aftheadidx != -1} {
# fetch erroneous command and its caller
set stackelt [string range $errmsg $aftheadidx [string first\
$splitstr $errmsg $aftheadidx]]
lassign [split [lindex [split $stackelt {"}] 1]] cmd1 cmd2
set cmdcaller [lindex [split [string range $stackelt [string last\
{(procedure } $stackelt] end] {"}] 1]
if {$cmd1 eq {eval}} {
set cmd1 $cmd2
}
# filter out stack element referring to or called by an unknown
# procedure (ie. a modulecmd.tcl internal procedure)
if {$cmd1 ne $unkcmd && ($cmdcaller in $filtercmdlist || $cmd1 in\
$filtercmdlist)} {
set errmsg [string replace $errmsg $aftheadidx [expr {[string first\
$splitstr $errmsg] + $splitstrlen - 1}]]
} else {
set internals 0
}
}
# filter out modulecmd internal references at end of stack
set internals 1
while {$internals} {
set beffootidx [string last $splitstr $errmsg]
set stackelt [string range $errmsg $beffootidx end]
set cmd [lindex [split $stackelt {"}] 1]
if {$cmd in $filtercmdendlist} {
set errmsg [string replace $errmsg $beffootidx end]
} else {
set internals 0
}
}
# replace error location at end of stack
set lastnl [string last \n $errmsg]
set lastline [string range $errmsg $lastnl+1 end]
if {[string match { ("eval" body line*} $lastline]} {
set errmsg [string replace $errmsg $lastnl $lastnl+[string length\
" (\"eval\" body line"] "\n (file \"$loc\" line"]
} elseif {![string match { (file *} $lastline]} {
# add error location at end of stack
append errmsg "\n (file \"$loc\")"
}
return $errmsg
}
# Test if color is enabled and passed sgrkey is defined and not null
proc isSgrkeyColored {sgrkey} {
return [expr {[getConf color] && [info exists ::g_colors($sgrkey)] &&\
$::g_colors($sgrkey) ne {}}]
}
# Select Graphic Rendition of a string with passed sgr keys (if color enabled)
proc sgr {keylist str {himatchmap {}} {othkeylist {}}} {
if {[getConf color]} {
set sgrreset 22
foreach sgrkey $keylist {
if {[info exists ::g_colors($sgrkey)]} {
# track color key that have been used
if {![info exists ::g_used_colors($sgrkey)]} {
set ::g_used_colors($sgrkey) 1
}
if {[info exists sgrset]} {
append sgrset {;}
}
append sgrset $::g_colors($sgrkey)
# if render bold or faint just reset that attribute, not all
if {$sgrreset != 0 && $sgrset != 1 && $sgrset != 2} {
set sgrreset 0
}
}
}
if {[llength $othkeylist] == 0} {
# highlight matching substring
if {[llength $himatchmap] > 0} {
set str [string map $himatchmap $str]
}
if {[info exists sgrset]} {
set str "\033\[${sgrset}m$str\033\[${sgrreset}m"
}
} else {
if {![info exists sgrset]} {
set sgrset {}
} else {
append sgrset {;}
}
# determine each chunk where the other sgr keys apply
set tagsgrlen [expr {int(ceil([string length $str]/[llength\
$othkeylist]))}]
for {set i 0} {$i < [llength $othkeylist]} {incr i} {
set idx [expr {$i*$tagsgrlen}]
set sgrkey [lindex $othkeylist $i]
lappend sgridxlist $idx $::g_colors($sgrkey)
# track color key that have been used
if {![info exists ::g_used_colors($sgrkey)]} {
set ::g_used_colors($sgrkey) 1
}
}
# determine each chunk where the highlight applies
set hiidxlist {}
foreach {mstr sgrmstr} $himatchmap {
set idx 0
while {$idx != -1} {
if {[set idx [string first $mstr $str $idx]] != -1} {
lappend hiidxlist $idx
incr idx [string length $mstr]
# add highlight end index unless if end of string
if {$idx < [string length $str]} {
lappend hiidxlist $idx
}
}
}
# no need to look at next match string if this one was found
if {[llength $hiidxlist] > 0} {
break
}
}
# mix other sgr chunks with highlighted chunks to define sgr codes
set i 0
set j 0
set sgridx [lindex $sgridxlist 0]
set hiidx [lindex $hiidxlist 0]
set hicur 0
set sgrcur {}
set sgrrst {0;}
while {$i < [llength $sgridxlist] || $j < [llength $hiidxlist]} {
set sgrcode {}
set cursgridx $sgridx
# sgr chunk change
if {$sgridx ne {} && ($hiidx eq {} || $sgridx <= $hiidx)} {
incr i
set sgrcur $sgrset[lindex $sgridxlist $i]
set idx $sgridx
if {$idx != 0} {
append sgrcode $sgrrst
}
append sgrcode $sgrcur
incr i
set sgridx [lindex $sgridxlist $i]
}
# highlight change
if {$hiidx ne {} && ($cursgridx eq {} || $hiidx <= $cursgridx)} {
set idx $hiidx
set hicur [expr {!$hicur}]
if {$hicur} {
if {$sgrcode ne {}} {
append sgrcode {;}
}
append sgrcode $::g_colors(hi)
# restore current sgr set to only clear highlight
} elseif {$sgrcode eq {}} {
append sgrcode $sgrrst $sgrcur
}
incr j
set hiidx [lindex $hiidxlist $j]
} elseif {$hicur} {
append sgrcode {;} $::g_colors(hi)
}
lappend fullsgridxlist $idx $sgrcode
}
# reset sgr at end of string
lappend fullsgridxlist [string length $str] 0
# apply defined sgr codes to the string
set stridx 0
foreach {sgridx sgrcode} $fullsgridxlist {
if {$sgridx != 0} {
append sgrstr [string range $str $stridx $sgridx-1]
}
append sgrstr "\033\[${sgrcode}m"
set stridx $sgridx
}
set str $sgrstr
}
}
return $str
}
# Sort tags to return those matching defined sgr keys in a list up to a given
# maxnb number and if tag not set to be displayed by its name. Other elements
# are returned in a separate list
proc getTagSgrForModname {keylist maxnb} {
set sgrkeylist {}
if {[getConf color]} {
set otherlist {}
foreach key $keylist {
if {[info exists ::g_colors($key)] && ![info exists\
::g_tagColorName($key)] && [llength $sgrkeylist] < $maxnb} {
lappend sgrkeylist $key
} else {
lappend otherlist $key
}
}
} else {
set otherlist $keylist
}
return [list $sgrkeylist $otherlist]
}
# save message if report is not yet initialized
proc report {message {nonewline 0} {immed 0} {padnl 0}} {
lappend ::errreport_buffer [list report $message $nonewline $immed $padnl]
}
# regular procedure to use once error report is initialized
proc __report {message {nonewline 0} {immed 0} {padnl 0}} {
# hold or print output
if {!$immed && [depthState reportholdid] > 0} {
lappend ::g_holdReport([currentState reportholdid]) [list report\
$message $nonewline $immed $padnl]
} else {
# produce blank line prior message if asked to
if {[isStateDefined reportfd] && [isStateDefined report_sep_next]} {
unsetState report_sep_next
report [expr {[isStateEqual report_format json] ? {,} : {}}]
}
# prefix msg lines after first one with 2 spaces
if {$padnl} {
set first 1
foreach line [split $message \n] {
if {$first} {
set first 0
} else {
append padmsg "\n "
}
append padmsg $line
}
set message $padmsg
}
# protect from issue with fd, just ignore it
catch {
if {$nonewline} {
puts -nonewline [getState reportfd] $message
} else {
puts [getState reportfd] $message
}
}
}
}
# report error the correct way depending of its type
proc reportIssue {issuetype issuemsg {issuefile {}}} {
switch -- $issuetype {
invalid {
reportInternalBug $issuemsg $issuefile
}
default {
reportError $issuemsg
}
}
}
# report defined command (used in display evaluation mode)
proc reportCmd {cmd args} {
# use Tcl native string representation of list
if {$cmd eq {-nativeargrep}} {
set cmd [lindex $args 0]
set cmdargs [lrange $args 1 end]
} else {
set cmdargs [listTo tcl $args 0]
}
set extratab [expr {[string length $cmd] < 8 ? "\t" : {}}]
report [sgr cm $cmd]$extratab\t$cmdargs
# empty string returns if command result is another command input
return {}
}
# report defined command (called as an execution trace)
proc reportCmdTrace {cmdstring args} {
reportCmd {*}$cmdstring
}
proc reportVersion {} {
report {Modules Release 5.3.0\
(2023-05-14)}
}
# disable error reporting (non-critical report only) unless debug enabled
proc inhibitErrorReport {} {
if {![isVerbosityLevel trace]} {
setState inhibit_errreport 1
}
}
proc initProcReportTrace {type prc} {
##nagelfar ignore #7 Non static subcommand
if {[isVerbosityLevel debug] && [getState timer]} {
# time execution of procedure instead of regular debug report
trace $type execution $prc enter reportTimerExecEnter
trace $type execution $prc leave reportTimerExecLeave
} elseif {[isVerbosityLevel debug2]} {
# trace each procedure call
trace $type execution $prc enter reportTraceExecEnter
}
}
# init error report and output buffered messages
proc initErrorReport {} {
# ensure init is done only once
if {![isStateDefined init_error_report]} {
setState init_error_report 1
# ask for color init now as debug mode has already fire lines to render
# and we want them to be reported first (not the color init lines)
if {[isVerbosityLevel debug]} {
getConf color
}
# trigger pager start if something needs to be printed, to guaranty
# reportDebug calls during pager start are processed in buffer mode
if {[isVerbosityLevel debug]} {
getState reportfd
}
# only report timing information in debug mode if timer mode is enabled
if {[isVerbosityLevel debug] && ![getState timer]} {
# replace report procedures used to buffer messages until error
# report being initialized by regular report procedures
# delete initial reportDebug proc after getState which needs it
rename ::reportDebug {}
rename ::__reportDebug ::reportDebug
} else {
rename ::reportDebug {}
# set a disabled version if debug is disabled
rename ::__reportDebugNop ::reportDebug
}
rename ::reportError {}
rename ::__reportError ::reportError
rename ::reportErrorAndExit {}
rename ::__reportErrorAndExit ::reportErrorAndExit
rename ::reportSeparateNextContent {}
rename ::__reportSeparateNextContent ::reportSeparateNextContent
rename ::report {}
rename ::__report ::report
# setup traces for either debug or timer reports
if {[isVerbosityLevel debug] && [getState timer] || [isVerbosityLevel\
debug2]} {
# list of core procedures to exclude from tracing
set excl_prc_list [list report reportDebug reportFlush reportTimer\
reportTraceExecEnter reportTimerExecEnter reportTimerExecLeave\
initProcReportTrace isVerbosityLevel reportSeparateNextContent\
getState setState unsetState lappendState lpopState currentState\
depthState isStateDefined isStateEqual sgr getConf setConf\
unsetConf lappendConf getCallingProcName]
foreach prc [info procs] {
if {$prc ni $excl_prc_list} {
initProcReportTrace add $prc
}
}
}
# now error report is init output every message saved in buffer; first
# message will trigger message paging configuration and startup unless
# already done if debug mode enabled
foreach errreport $::errreport_buffer {
{*}$errreport
}
}
}
# drop or report held messages
proc releaseHeldReport {args} {
foreach {holdid action} $args {
if {[info exists ::g_holdReport($holdid)]} {
if {$action eq {report}} {
foreach repcall $::g_holdReport($holdid) {
{*}$repcall
}
}
unset ::g_holdReport($holdid)
}
}
}
# final message output and reportfd flush and close
proc reportFlush {} {
# report execution time if asked
if {[getState timer]} {
reportSeparateNextContent
reportTimer {Total execution took} {%.3f ms} $::timer_start [clock\
microseconds]
}
# finish output document if json format enabled
if {[isStateEqual report_format json]} {
# render error messages all together
if {[info exists ::g_report_erralist]} {
# ignite report first to get eventual error message from report
# initialization in order 'foreach' got all messages prior firing
report "\"errors\": \[" 1
foreach {sev msg} $::g_report_erralist {
# split message in lines
lappend dispmsglist "\n{ \"severity\": \"$sev\", \"message\": \[\
\"[join [split [charEscaped $msg \"] \n] {", "}]\" \] }"
}
report "[join $dispmsglist ,] \]"
}
# inhibit next content separator if output is ending
unsetState report_sep_next
report \}
}
# close pager if enabled
if {[isStateDefined reportfd] && ![isStateEqual reportfd stderr]} {
catch {flush [getState reportfd]}
catch {close [getState reportfd]}
}
}
# check if element passed as argument (corresponding to a kind of information)
# should be part of output content
proc isEltInReport {elt {retifnotdef 1}} {
# get config name relative to current sub-command and output format
set conf [currentState commandname]
if {[getState report_format] ne {regular}} {
append conf _[getState report_format]
}
append conf _output
set arrname ::g_$conf
##nagelfar vartype arrname varName
if {[info exists ::g_config_defs($conf)]} {
# build value cache if it does not exist yet
if {![array exists $arrname]} {
array set $arrname {}
foreach confelt [split [getConf $conf] :] {
##nagelfar ignore Suspicious variable name
set ${arrname}($confelt) 1
}
}
# check if elt is marked to be included in output
##nagelfar ignore Suspicious variable name
set ret [info exists ${arrname}($elt)]
} else {
# return $retifnotdef (ok by default) in case no config option
# corresponds to the current module sub-command and output format
set ret $retifnotdef
}
return $ret
}
proc registerModuleDesignation {evalid mod vrlist taglist} {
set ::g_moduleDesgination($evalid) [list $mod $vrlist $taglist]
}
proc getModuleDesignation {from {mod {}} {sgr 1}} {
# fetch module name version and variants from specified context
switch -- $from {
spec {
set moddesig [getModuleNameAndVersFromVersSpec $mod]
set vrlist [getVariantList $mod 7 0 1]
set taglist {}
}
loaded {
set moddesig $mod
set vrlist [getVariantList $mod 7]
set taglist {}
}
default {
# fetch information from passed evaluation id
if {[info exists ::g_moduleDesgination($from)]} {
lassign $::g_moduleDesgination($from) moddesig vrlist taglist
# if not found, use passed spec to compute designation
} else {
set moddesig [getModuleNameAndVersFromVersSpec $mod]
set vrlist [getVariantList $mod 7 0 1]
set taglist [getExportTagList $mod]
}
}
}
# build module designation
switch -- $sgr {
2 {
set vrsgr va
set himatchmap [prepareMapToHightlightSubstr $moddesig]
set showtags 1
# prepare list of tag abbreviations that can be substituted and list
# of tags whose name should be colored
getConf tag_abbrev
getConf tag_color_name
# abbreviate tags
set taglist [abbrevTagList $taglist]
}
1 {
set vrsgr {se va}
set himatchmap {}
set showtags 0
}
0 {
set vrsgr {}
set himatchmap {}
set showtags 0
}
}
lassign [formatListEltToDisplay $moddesig {} {} {} {} 0 0 $taglist\
$showtags $vrlist $vrsgr 1 $himatchmap] disp dispsgr displen
return $dispsgr
}
#
# Helper procedures to format various messages
#
proc getHintUnFirstMsg {modlist} {
return "HINT: Might try \"module unload [join $modlist]\" first."
}
proc getHintLoFirstMsg {modlist} {
if {[llength $modlist] > 1} {
set oneof {at least one of }
set mod modules
} else {
set oneof {}
set mod module
}
return "HINT: ${oneof}the following $mod must be loaded first: [join\
$modlist]"
}
proc getErrConflictMsg {conlist} {
return "Module cannot be loaded due to a conflict.\n[getHintUnFirstMsg\
$conlist]"
}
proc getErrPrereqMsg {prelist {load 1}} {
if {$load} {
foreach pre $prelist {
lappend predesiglist [getModuleDesignation spec $pre]
}
lassign [list {} missing [getHintLoFirstMsg $predesiglist]] un mis\
hintmsg
} else {
##nagelfar ignore Found constant
lassign [list un a [getHintUnFirstMsg $prelist]] un mis hintmsg
}
return "Module cannot be ${un}loaded due to $mis prereq.\n$hintmsg"
}
proc getErrReqLoMsg {prelist} {
foreach pre $prelist {
lappend predesiglist [getModuleDesignation spec $pre]
}
return "Load of requirement [join $predesiglist { or }] failed"
}
proc getReqNotLoadedMsg {prelist} {
foreach pre $prelist {
lappend predesiglist [getModuleDesignation spec $pre]
}
return "Requirement [join $predesiglist { or }] is not loaded"
}
proc getDepLoadedMsg {prelist} {
set is [expr {[llength $prelist] > 1 ? {are} : {is}}]
foreach pre $prelist {
lappend predesiglist [getModuleDesignation loaded $pre]
}
return "Dependent [join $predesiglist { and }] $is loaded"
}
proc getErrConUnMsg {conlist} {
set condesiglist {}
foreach con $conlist {
lappend condesiglist [getModuleDesignation spec $con]
}
return "Unload of conflicting [join $condesiglist { and }] failed"
}
proc getConIsLoadedMsg {conlist {loading 0}} {
set is [expr {[llength $conlist] > 1 ? {are} : {is}}]
set loaded [expr {$loading ? {loading} : {loaded}}]
set condesiglist {}
foreach con $conlist {
lappend condesiglist [getModuleDesignation spec $con]
}
return "Conflicting [join $condesiglist { and }] $is $loaded"
}
proc getForbiddenMsg {mod} {
set msg "Access to module [getModuleDesignation spec $mod 2] is denied"
set extramsg [getModuleTagProp $mod forbidden message]
if {$extramsg ne {}} {
append msg \n$extramsg
}
return $msg
}
proc getNearlyForbiddenMsg {mod} {
set after [getModuleTagProp $mod nearly-forbidden after]
set msg "Access to module will be denied starting '$after'"
set extramsg [getModuleTagProp $mod nearly-forbidden message]
if {$extramsg ne {}} {
append msg \n$extramsg
}
return $msg
}
proc getStickyUnloadMsg {{tag sticky}} {
return "Unload of $tag module skipped"
}
proc getStickyForcedUnloadMsg {} {
return {Unload of sticky module forced}
}
proc getModWithAltVrIsLoadedMsg {mod} {
set vrdesiglist {}
foreach vr [getVariantList $mod 1] {
lappend vrdesiglist [sgr va $vr]
}
return "Variant [sgr se "\{"][join $vrdesiglist [sgr se :]][sgr se "\}"]\
is already loaded"
}
proc getEmptyNameMsg {type} {
return "Invalid empty $type name"
}
#
# Stack of message recording/eval unique identifiers
#
proc pushMsgRecordId {recid {setmsgid 1}} {
lappendState evalid $recid
if {$setmsgid} {
lappendState msgrecordid $recid
}
}
proc popMsgRecordId {{setmsgid 1}} {
lpopState evalid
if {$setmsgid} {
lpopState msgrecordid
}
}
proc clearAllMsgRecordId {} {
unsetState evalid
unsetState msgrecordid
}
#
# Format output text
#
# format an element with its syms for display in a list
proc formatListEltToDisplay {elt eltsgr eltsuffix sym_list symsgr show_syms\
sgrdef tag_list show_tags vr_list vrsgr show_vrs {himatchmap {}}\
{himatcharrvrmap {}} {himatcharrvrvalmap {}}} {
# fetch sgr codes from tags to apply directly on main element
if {$show_tags && [llength $tag_list] > 0} {
# if more codes than character in elt, additional codes apply to the
# side tag list
lassign [getTagSgrForModname $tag_list [string length $elt]] tagsgrlist\
tag_list
} else {
set tagsgrlist {}
}
# display default sym graphically over element name
if {$show_syms} {
if {[set defidx [lsearch -exact $sym_list default]] != -1 && $sgrdef} {
set sym_list [lreplace $sym_list $defidx $defidx]
lappend eltsgrlist de
}
}
set displen 0
set disp $elt
lappend eltsgrlist $eltsgr
set dispsgr [sgr $eltsgrlist $elt $himatchmap $tagsgrlist]
# enclose name between quotes if a space is found
if {[string first { } $elt] != -1} {
incr displen 2
set dispsgr '$dispsgr'
}
# append suffix
append disp $eltsuffix
append dispsgr $eltsuffix
# format variant list if any
if {$show_vrs && [llength $vr_list] > 0} {
array set himatchvrvalarr $himatcharrvrvalmap
array set himatchvrarr $himatcharrvrmap
set commasgr [sgr se ,]
set vrssgr "[sgr se \{]"
set vrs \{
foreach vrspec $vr_list {
lassign $vrspec vrname vrnameset vrvalues vrdflidx vrloadedidx\
loadedsgrkey
array unset vrvalsgridx
# apply sgr to default and loaded variant value
if {$vrdflidx != -1} {
lappend vrvalsgridx($vrdflidx) de
}
if {$vrloadedidx != -1} {
lappend vrvalsgridx($vrloadedidx) $loadedsgrkey
}
set vrsgrvalues $vrvalues
foreach vrvalidx [array names vrvalsgridx] {
lset vrsgrvalues $vrvalidx [sgr $vrvalsgridx($vrvalidx) [lindex\
$vrvalues $vrvalidx]]
}
if {[info exists notfirstvr]} {
set colonsgr [sgr se :]
append vrssgr $colonsgr
append vrs :
} else {
set notfirstvr 1
}
# highlight variant if corresponds to one set in query
if {[info exists himatchvrarr($vrname)]} {
set hivrmap $himatchvrarr($vrname)
set hivrvalmap $himatchvrvalarr($vrname)
} else {
set hivrmap {}
set hivrvalmap {}
}
if {[string length $vrnameset] > 0} {
append vrssgr [sgr $vrsgr $vrnameset $hivrmap]
}
append vrssgr [sgr $vrsgr [lindex $vrsgrvalues 0] $hivrvalmap]
foreach vrvalue [lrange $vrsgrvalues 1 end] {
append vrssgr $commasgr[sgr $vrsgr $vrvalue $hivrvalmap]
}
append vrs $vrnameset[join $vrvalues :]
}
append vrssgr [sgr se \}]
append vrs \}
append dispsgr $vrssgr
append disp $vrs
}
# format remaining sym list
if {$show_syms && [llength $sym_list] > 0} {
# track if a symbol has been reported excluding sym for alias '@'
if {![info exists ::g_used_sym_nocolor] && ([llength $sym_list] > 1 ||
[lindex $sym_list 0] ne {@})} {
set ::g_used_sym_nocolor 1
}
append disp "([join $sym_list :])"
set symssgr [sgr se (]
foreach sym $sym_list {
if {[info exists notfirstsym]} {
if {![info exists colonsgr]} {
set colonsgr [sgr se :]
}
append symssgr $colonsgr
} else {
set notfirstsym 1
}
append symssgr [sgr $symsgr $sym]
}
append symssgr [sgr se )]
append dispsgr $symssgr
}
# format tag list if any remaining
if {$show_tags && [llength $tag_list] > 0} {
append disp " <[join $tag_list :]>"
set tagssgr " [sgr se <]"
foreach tag $tag_list {
# track tag name or abbreviation that have been used
if {![info exists ::g_used_tags($tag)]} {
set ::g_used_tags($tag) 1
}
if {[info exists notfirsttag]} {
if {![info exists colonsgr]} {
set colonsgr [sgr se :]
}
append tagssgr $colonsgr
} else {
set notfirsttag 1
}
# try to sgr in case a code apply to the tag
append tagssgr [sgr $tag $tag]
}
append tagssgr [sgr se >]
append dispsgr $tagssgr
}
# compute length
incr displen [string length $disp]
return [list $disp $dispsgr $displen]
}
# format an element with its syms for a long/detailed display in a list
proc formatListEltToLongDisplay {elt eltsgr eltsuffix sym_list symsgr mtime\
sgrdef {himatchmap {}}} {
# display default sym graphically over element name
if {[set defidx [lsearch -exact $sym_list default]] != -1 && $sgrdef} {
set sym_list [lreplace $sym_list $defidx $defidx]
lappend eltsgrlist de
}
lappend eltsgrlist $eltsgr
set displen 0
set disp $elt
set dispsgr [sgr $eltsgrlist $elt $himatchmap]
# enclose name between quotes if a space is found
if {[string first { } $elt] != -1} {
incr displen 2
set dispsgr '$dispsgr'
}
# append suffix
append disp $eltsuffix
append dispsgr $eltsuffix
# compute length
incr displen [string length $disp]
# format remaining sym list
if {[llength $sym_list] > 0} {
set symslen [string length [join $sym_list :]]
foreach sym $sym_list {
if {![info exists colonsgr]} {
set colonsgr [sgr se :]
} else {
append symssgr $colonsgr
}
append symssgr [sgr $symsgr $sym]
}
} else {
set symssgr {}
set symslen 0
}
set nbws1 [expr {40 - $displen}]
set nbws2 [expr {$nbws1 < 0 ? 20 - $symslen + $nbws1 : 20 - $symslen}]
return [list $disp $dispsgr[string repeat { } $nbws1]$symssgr[string\
repeat { } $nbws2]$mtime $displen]
}
proc formatArrayValToJson {vallist} {
return [expr {[llength $vallist] > 0 ? "\[ \"[join $vallist {", "}]\" \]"\
: {[]}}]
}
proc formatObjectValToJson {objlist} {
foreach {key val isbool} $objlist {
if {[info exists disp]} {
append disp {, }
}
append disp "\"$key\": "
if {$isbool} {
append disp [expr {$val ? {true} : {false}}]
} else {
append disp "\"$val\""
}
}
##nagelfar ignore Bad expression
return [expr {[info exists disp] ? "{ $disp }" : "{}"}]
}
# format an element with its syms for a json display in a list
proc formatListEltToJsonDisplay {elt args} {
set disp "\"$elt\": \{ \"name\": \"$elt\""
foreach {key vtype val show} $args {
if {!$show} {
continue
}
append disp ", \"$key\": "
switch -- $vtype {
a {append disp [formatArrayValToJson $val]}
o {append disp [formatObjectValToJson $val]}
s {append disp "\"$val\""}
}
}
append disp "\}"
return $disp
}
# Prepare a map list to translate later on a substring in its highlighted
# counterpart. Translate substring into all module it specifies in case of an
# advanced version specification. Each string obtained is right trimmed from
# wildcard. No highlight is set for strings still containing wildcard chars
# after right trim operation. No highlist map is returned at all if highlight
# rendering is disabled.
proc prepareMapToHightlightSubstr {args} {
set maplist {}
if {[sgr hi {}] ne {}} {
foreach substr $args {
foreach m [getAllModulesFromVersSpec $substr] {
set m [string trimright $m {*?}]
if {$m ne {} && [string first * $m] == -1 && [string first ? $m]\
== -1} {
lappend maplist $m [sgr hi $m]
}
}
}
}
return $maplist
}
# Specific highlight translation map for variant name and value
proc prepareMapToHightlightVariant {args} {
set vrname_maplist {}
set vrval_maplist {}
if {[sgr hi {}] ne {}} {
foreach modspec $args {
foreach vrspec [getVariantListFromVersSpec $modspec] {
lassign $vrspec vrname vrvalue vrisbool
set maplist [list $vrname [sgr hi $vrname]]
# also highlight shortcut if any
if {[info exists ::g_variantShortcut($vrname)]} {
lappend maplist $::g_variantShortcut($vrname) [sgr hi\
$::g_variantShortcut($vrname)]
}
lappend vrname_maplist $vrname $maplist
# adapt variant value to highlight if boolean
set maplist {}
if {$vrisbool} {
set vrshort [expr {$vrvalue ? {+} : {-}}]$vrname
lappend maplist $vrshort [sgr hi $vrshort]
set vrvalue [expr {$vrvalue ? {on} : {off}}]
}
lappend maplist $vrvalue [sgr hi $vrvalue]
lappend vrval_maplist $vrname $maplist
}
}
}
return [list $vrname_maplist $vrval_maplist]
}
# Format list of modules obtained from a getModules call in upper context
proc reportModules {search_queries header hsgrkey hstyle show_mtime show_idx\
one_per_line theader_cols excluded_tag {mod_list_order {}}} {
# link to the result module list obtained in caller context
upvar mod_list mod_list
# output is JSON format
set json [isStateEqual report_format json]
# is some module variant specified in search query
set variant_spec_in_query 0
foreach modspec $search_queries {
if {[llength [getVariantListFromVersSpec $modspec]] > 0} {
set variant_spec_in_query 1
break
}
}
# elements to include in output
set report_sym [isEltInReport sym]
set report_tag [isEltInReport tag]
set report_alias [isEltInReport alias]
# enable variant report if variantifspec configured and some variant is
# specified in query or variant configured for report or list sub-command
# json output
set report_variant [expr {($variant_spec_in_query && [isEltInReport\
variantifspec 0]) || [isEltInReport variant [expr {[currentState\
commandname] eq {list} && $json}]]}]
set collect_variant_from [expr {[currentState commandname] eq {avail} ?\
{2} : {0}}]
# prepare list of tag abbreviations that can be substituted and list of
# tags whose name should be colored
getConf tag_abbrev
getConf tag_color_name
# prepare results for display
set alias_colored [isSgrkeyColored al]
set default_colored [isSgrkeyColored de]
set himatchmap [prepareMapToHightlightSubstr {*}$search_queries]
lassign [prepareMapToHightlightVariant {*}$search_queries]\
himatcharrvrmap himatcharrvrvalmap
set clean_list {}
set vr_list {}
# treat elements in specified order if any
##nagelfar ignore #2 Badly formed if statement
foreach elt [if {[llength $mod_list_order] == 0} {array names mod_list}\
{set mod_list_order}] {
if {$report_variant} {
set vr_list [getVariantList $elt [expr {$json ? 4 : 7}] 0\
$collect_variant_from]
}
set sym_list [getVersAliasList $elt]
# fetch tags but clear excluded tag
set tag_list [replaceFromList [getTagList $elt] $excluded_tag]
# abbreviate tags unless for json output
if {!$json} {
set tag_list [abbrevTagList $tag_list]
}
set dispsgr {}
# ignore "version" entries as symbolic version are treated
# along to their relative modulefile not independently
switch -- [lindex $mod_list($elt) 0] {
directory {
if {$json} {
set dispsgr [formatListEltToJsonDisplay $elt type s directory\
1 symbols a $sym_list 1]
} elseif {$show_mtime} {
# append / char after name to clearly indicate this is a dir
lassign [formatListEltToLongDisplay $elt di / $sym_list sy {}\
$default_colored $himatchmap] disp dispsgr displen
} else {
lassign [formatListEltToDisplay $elt di / $sym_list sy\
$report_sym $default_colored {} 0 {} {} 0 $himatchmap] disp\
dispsgr displen
}
}
modulefile - virtual {
if {$json} {
set dispsgr [formatListEltToJsonDisplay $elt type s modulefile\
1 variants o $vr_list $report_variant symbols a $sym_list 1\
tags a $tag_list 1 pathname s [lindex $mod_list($elt) 2] 1]
} elseif {$show_mtime} {
set clock_mtime [expr {[lindex $mod_list($elt) 1] ne {} ?\
[clock format [lindex $mod_list($elt) 1] -format {%Y/%m/%d\
%H:%M:%S}] : {}}]
# add to display file modification time in addition
# to potential syms
lassign [formatListEltToLongDisplay $elt {} {} $sym_list sy\
$clock_mtime $default_colored $himatchmap] disp dispsgr\
displen
} else {
lassign [formatListEltToDisplay $elt {} {} $sym_list sy\
$report_sym $default_colored $tag_list $report_tag $vr_list\
va $report_variant $himatchmap $himatcharrvrmap\
$himatcharrvrvalmap] disp dispsgr displen
}
}
alias {
if {$json} {
set dispsgr [formatListEltToJsonDisplay $elt type s alias 1\
symbols a $sym_list 1 tags a $tag_list 1 target s [lindex\
$mod_list($elt) 1] 1]
} elseif {$show_mtime} {
lassign [formatListEltToLongDisplay $elt al " -> [lindex\
$mod_list($elt) 1]" $sym_list sy {} $default_colored\
$himatchmap] disp dispsgr displen
} elseif {$report_alias} {
# add a '@' sym to indicate elt is an alias if not colored
if {!$alias_colored} {
lappend sym_list @
# track use of '@' sym to add it to the output key
if {![info exists ::g_used_alias_nocolor]} {
set ::g_used_alias_nocolor 1
}
}
lassign [formatListEltToDisplay $elt al {} $sym_list sy\
$report_sym $default_colored $tag_list $report_tag {} {} 0\
$himatchmap] disp dispsgr displen
}
}
}
if {$dispsgr ne {}} {
if {$json} {
lappend clean_list $dispsgr
} else {
lappend clean_list $disp
set sgrmap($disp) $dispsgr
set lenmap($disp) $displen
}
}
}
set len_list {}
set max_len 0
if {$json} {
##nagelfar ignore Found constant
upvar 0 clean_list display_list
if {![info exists display_list]} {
set display_list {}
}
} else {
set display_list {}
# dictionary-sort results unless if output order is specified
if {[llength $mod_list_order] == 0} {
set clean_list [lsort -dictionary $clean_list]
}
foreach disp $clean_list {
# compute display element length list on sorted result
lappend display_list $sgrmap($disp)
lappend len_list $lenmap($disp)
if {$lenmap($disp) > $max_len} {
set max_len $lenmap($disp)
}
}
}
# output table header if needed and not yet done
if {[llength $display_list] > 0 && $show_mtime && ![isStateDefined\
theader_shown]} {
setState theader_shown 1
displayTableHeader {*}$theader_cols
}
# output formatted elements
displayElementList $header $hsgrkey $hstyle $one_per_line $show_idx 1\
$display_list $len_list $max_len
}
proc showModulePath {} {
set modpathlist [getModulePathList]
if {[llength $modpathlist] > 0} {
report {Search path for module files (in search order):}
foreach path $modpathlist {
report " [sgr mp $path]"
}
} else {
reportWarning {No directories on module search path}
}
}
proc displayTableHeader {sgrkey args} {
foreach {title col_len} $args {
set col "- [sgr $sgrkey $title] "
append col [string repeat - [expr {$col_len - [string length $title] -\
3}]]
lappend col_list $col
}
report [join $col_list .]
}
proc displaySeparatorLine {{title {}} {sgrkey {}}} {
set tty_cols [getState term_columns]
if {$title eq {}} {
# adapt length if screen width is very small
set max_rep 67
set rep [expr {$tty_cols > $max_rep ? $max_rep : $tty_cols}]
report [string repeat - $rep]
} else {
set len [string length $title]
set lrep [tcl::mathfunc::max [expr {($tty_cols - $len - 2)/2}] 1]
set rrep [tcl::mathfunc::max [expr {$tty_cols - $len - 2 - $lrep}] 1]
report "[string repeat - $lrep] [sgr $sgrkey $title] [string repeat -\
$rrep]"
}
}
# get a list of elements and print them in a column or in a
# one-per-line fashion
proc displayElementList {header sgrkey hstyle one_per_line display_idx\
start_idx display_list {len_list {}} {max_len 0}} {
set elt_cnt [llength $display_list]
reportDebug "header=$header, sgrkey=$sgrkey, hstyle=$hstyle,\
elt_cnt=$elt_cnt, max_len=$max_len, one_per_line=$one_per_line,\
display_idx=$display_idx, start_idx=$start_idx"
# end proc if no element are to print
if {$elt_cnt == 0} {
return
}
# output is JSON format
set json [isStateEqual report_format json]
# display header if any provided
if {$header ne {noheader}} {
if {$json} {
report "\"$header\": \{"
} elseif {$hstyle eq {sepline}} {
displaySeparatorLine $header $sgrkey
} else {
report [sgr $sgrkey $header]:
}
}
if {$json} {
set displist [join $display_list ,\n]
# display one element per line
} elseif {$one_per_line} {
if {$display_idx} {
set idx $start_idx
foreach elt $display_list {
append displist [format {%2d) %s } $idx $elt] \n
incr idx
}
} else {
append displist [join $display_list \n] \n
}
# elsewhere display elements in columns
} else {
if {$display_idx} {
# save room for numbers and spacing: 2 digits + ) + space
set elt_prefix_len 4
} else {
set elt_prefix_len 0
}
# save room for two spaces after element
set elt_suffix_len 2
# compute rows*cols grid size with optimized column number
# the size of each column is computed to display as much column
# as possible on each line
incr max_len $elt_suffix_len
foreach len $len_list {
lappend elt_len [incr len $elt_suffix_len]
}
set tty_cols [getState term_columns]
# find valid grid by starting with non-optimized solution where each
# column length is equal to the length of the biggest element to display
set cur_cols [tcl::mathfunc::max [expr {int(($tty_cols - \
$elt_prefix_len) / $max_len)}] 0]
# when display is found too short to display even one column
if {$cur_cols == 0} {
set cols 1
set rows $elt_cnt
array set col_width [list 0 $max_len]
} else {
set cols 0
set rows 0
}
set last_round 0
set restart_loop 0
while {$cur_cols > $cols} {
if {!$restart_loop} {
if {$last_round} {
incr cur_rows
} else {
set cur_rows [expr {int(ceil(double($elt_cnt) / $cur_cols))}]
}
for {set i 0} {$i < $cur_cols} {incr i} {
set cur_col_width($i) 0
}
for {set i 0} {$i < $cur_rows} {incr i} {
set row_width($i) 0
}
set istart 0
} else {
##nagelfar ignore Unknown variable
set istart [expr {$col * $cur_rows}]
# only remove width of elements from current col
for {set row 0} {$row < ($i % $cur_rows)} {incr row} {
##nagelfar ignore Unknown variable
incr row_width($row) -[expr {$pre_col_width + $elt_prefix_len}]
}
}
set restart_loop 0
for {set i $istart} {$i < $elt_cnt} {incr i} {
set col [expr {int($i / $cur_rows)}]
set row [expr {$i % $cur_rows}]
# restart loop if a column width change
if {[lindex $elt_len $i] > $cur_col_width($col)} {
set pre_col_width $cur_col_width($col)
set cur_col_width($col) [lindex $elt_len $i]
set restart_loop 1
break
}
# end search of maximum number of columns if computed row width
# is larger than terminal width
if {[incr row_width($row) +[expr {$cur_col_width($col) \
+ $elt_prefix_len}]] > $tty_cols} {
# start last optimization pass by increasing row number until
# reaching number used for previous column number, by doing so
# this number of column may pass in terminal width, if not
# fallback to previous number of column
if {$last_round && $cur_rows == $rows} {
incr cur_cols -1
} else {
set last_round 1
}
break
}
}
# went through all elements without reaching terminal width limit so
# this number of column solution is valid, try next with a greater
# column number
if {$i == $elt_cnt} {
set cols $cur_cols
set rows $cur_rows
array set col_width [array get cur_col_width]
# number of column is fixed if last optimization round has started
# reach end also if there is only one row of results
if {!$last_round && $rows > 1} {
incr cur_cols
}
}
}
reportDebug list=$display_list
reportDebug "rows/cols=$rows/$cols,\
lastcol_item_cnt=[expr {int($elt_cnt % $rows)}]"
for {set row 0} {$row < $rows} {incr row} {
for {set col 0} {$col < $cols} {incr col} {
set index [expr {$col * $rows + $row}]
if {$index < $elt_cnt} {
if {$display_idx} {
append displist [format "%2d) " [expr {$index +$start_idx}]]
}
# cannot use 'format' as strings may contain SGR codes
append displist [lindex $display_list $index][string repeat\
{ } [expr {$col_width($col) - [lindex $len_list $index]}]]
}
}
append displist \n
}
}
if {$json && $header ne {noheader}} {
append displist "\n\}"
}
report $displist 1
reportSeparateNextContent
}
# Report an output key to help understand what the SGR used on this output
# correspond to
proc displayKey {} {
array set skipsgr [list hi 1 db 1 tr 1 se 1 er 1 wa 1 me 1 in 1 cm 1 va 1]
array set typesgr [list mp modulepath di [list directory <SGR>/ 10] al\
module-alias sy [list {symbolic-version} [sgr se (]<SGR>[sgr se )] 18]\
de [list {default-version}]]
set display_list {}
set len_list {}
foreach key [array names ::g_used_colors] {
# sgr key matches a basic modulefile type
if {[info exists typesgr($key)]} {
# the way to describe key is already defined
if {[llength $typesgr($key)] > 1} {
lassign $typesgr($key) desc desctmp len
set desc [string map [list <SGR> [sgr $key $desc]] $desctmp]
} else {
set desc [lindex $typesgr($key) 0]
}
if {$key eq {sy} && [info exists ::g_used_sym_nocolor]} {
unset ::g_used_sym_nocolor
}
# key is a tag abbreviation
} elseif {[info exists ::g_abbrevTag($key)]} {
set desc $::g_abbrevTag($key)
# if not part of the ignored list, this key corresponds to a tag name
} elseif {![info exists skipsgr($key)]} {
set desc $key
}
if {[info exists desc]} {
# define key description
if {![info exists len]} {
set len [string length $desc]
set desc [sgr $key $desc]
}
lappend display_list $desc
lappend len_list $len
unset desc
unset len
}
}
# include var=val key if any other variant form is present in report
if {![info exists ::g_used_va(val)] && [array exists ::g_used_va]} {
set ::g_used_va(val) 1
}
# add key for variant reports
if {[info exists ::g_used_va(on)]} {
lappend display_list "[sgr se \{][sgr va +variant][sgr se\
\}]=[sgr se \{][sgr va variant=on][sgr se \}]"
lappend len_list 23
}
if {[info exists ::g_used_va(off)]} {
lappend display_list "[sgr se \{][sgr va -variant][sgr se\
\}]=[sgr se \{][sgr va variant=off][sgr se \}]"
lappend len_list 24
}
foreach sc [array names ::g_used_va] {
if {$sc ni {on off val}} {
lappend display_list "[sgr se \{][sgr va ${sc}value][sgr se\
\}]=[sgr se \{][sgr va $::g_used_va($sc)=value][sgr se \}]"
lappend len_list [expr {17 + [string length $::g_used_va($sc)]}]
}
}
# finish with variant=value entry as it is referred by other variant keys
if {[info exists ::g_used_va(val)]} {
lappend display_list "[sgr se \{][sgr va variant=value][sgr se \}]"
lappend len_list 15
}
# add key for alias if '@' put in parentheses
if {[info exists ::g_used_alias_nocolor]} {
lappend display_list "[sgr se (]@[sgr se )]=module-alias"
lappend len_list 9
}
# add key for symbolic version if any put in parentheses but no color
if {[info exists ::g_used_sym_nocolor]} {
lappend display_list "[sgr se (]symbolic-version[sgr se )]"
lappend len_list 18
}
# add key for module tag if any put in angle brackets
if {[array exists ::g_used_tags]} {
lappend display_list "[sgr se <]module-tag[sgr se >]"
lappend len_list 12
}
# report translation of each uncolored tag abbreviation that have been used
foreach tag [array names ::g_used_tags] {
if {![info exists ::g_used_colors($tag)] && [info exists\
::g_abbrevTag($tag)]} {
lappend display_list [sgr se <]$tag[sgr se >]=$::g_abbrevTag($tag)
lappend len_list [expr {[string length $tag] + [string length\
$::g_abbrevTag($tag)] + 3}]
}
}
# find largest element
set max_len 0
foreach len $len_list {
if {$len > $max_len} {
set max_len $len
}
}
if {[llength $display_list] > 0} {
# display header
report Key:
# display key content
displayElementList noheader {} {} 0 0 0 $display_list $len_list $max_len
}
}
# Return conf value and from where an eventual def value has been overridden
proc displayConfig {val env_var {asked 0} {trans {}} {locked 0}} {
array set transarr $trans
# get overridden value and know what has overridden it
if {$asked} {
set defby " (cmd-line)"
} elseif {$env_var ne {} && !$locked && [info exists ::env($env_var)]} {
set defby " (env-var)"
} elseif {$locked} {
set defby " (locked)"
} else {
set defby {}
}
# translate fetched value if translation table exists
if {[info exists transarr($val)]} {
set val $transarr($val)
}
return $val$defby
}
# report linter output as error/warning messages
proc displayLinterOutput {linter output} {
switch -- $linter {
nagelfar {
# parsing linter output
set report_list {}
foreach line [split $output \n] {
set firstword [string range $line 0 [string first { } $line]-1]
switch -- $firstword {
Checking - Parsing {}
Line {
# add message of previous line if any
if {[info exists msg]} {
lappend report_list $msg
}
# extract information from message line
set colidx [string first : $line]
set linenum [string trimleft [string range $line 5\
$colidx-1]]
set severity [string index $line $colidx+2]
switch -- $severity {
W {
set severity WARNING
set sgrkey wa
set raisecnt 0
}
E {
set severity ERROR
set sgrkey er
set raisecnt 1
}
default {
set severity NOTICE
set sgrkey in
set raisecnt 0
}
}
set msg [string range $line $colidx+4 end]
# start recorded message properties
lappend report_list $linenum $severity $sgrkey $raisecnt
}
default {
# this line is continuing message started previously
append msg \n[string trimleft $line]
}
}
}
# add message of last line if any
if {[info exists msg]} {
lappend report_list $msg
unset msg
}
# report messages
foreach {linenum severity sgrkey raisecnt mesg} $report_list {
reportError $mesg 0 "[format %-7s $severity] line $linenum"\
$sgrkey $raisecnt
}
}
default {
reportError $output
}
}
}
proc reportMlUsage {} {
reportVersion
report {Usage: ml [options] [command] [args ...]
ml [options] [[-]modulefile ...]
Examples:
ml equivalent to: module list
ml foo bar equivalent to: module load foo bar
ml -foo -bar baz equivalent to: module unload foo bar; module load baz
ml avail -t equivalent to: module avail -t
See 'module --help' to get available commands and options.}
}
proc reportUsage {} {
reportVersion
##nagelfar ignore #111 Too long line
report {Usage: module [options] [command] [args ...]
Loading / Unloading commands:
add | load modulefile [...] Load modulefile(s)
try-add | try-load modfile [...] Load modfile(s), no complain if not found
add-any | load-any modfile [...] Load first available modulefile in list
rm | unload modulefile [...] Remove modulefile(s)
purge Unload all loaded modulefiles
reload Unload then load all loaded modulefiles
switch | swap [mod1] mod2 Unload mod1 and load mod2
refresh Refresh loaded module volatile components
reset Restore initial environment
Listing / Searching commands:
list [-a] [-t|-l|-j] [-S|-C] [mod ...]
List all or matching loaded modules
avail [-a] [-t|-l|-j] [-S|-C] [-d|-L] [--indepth|--no-indepth] [mod ...]
List all or matching available modules
aliases [-a] List all module aliases
whatis [-a] [-j] [modulefile ...] Print whatis information of modulefile(s)
apropos | keyword | search [-a] [-j] str
Search all name and whatis containing str
is-loaded [modulefile ...] Test if any of the modulefile(s) are loaded
is-avail modulefile [...] Is any of the modulefile(s) available
info-loaded modulefile Get full name of matching loaded module(s)
Collection of modules handling commands:
save [collection|file] Save current module list to collection
restore [collection|file] Restore module list from collection or file
saverm [collection] Remove saved collection
saveshow [collection|file] Display information about collection
savelist [-a] [-t|-l|-j] [-S|-C] [collection ...]
List all or matching saved collections
is-saved [collection ...] Test if any of the collection(s) exists
stash Save current environment and reset
stashpop [stash] Restore then remove stash collection
stashrm [stash] Remove stash collection
stashshow [stash] Display information about stash collection
stashclear Remove all stash collections
stashlist List all stash collections
Environment direct handling commands:
prepend-path [-d c] var val [...] Prepend value to environment variable
append-path [-d c] var val [...] Append value to environment variable
remove-path [-d c] var val [...] Remove value from environment variable
Module cache handling commands:
cachebuild [modulepath ...] Create cache file for modulepath(s)
cacheclear Delete cache file in enabled modulepath(s)
Other commands:
help [modulefile ...] Print this or modulefile(s) help info
display | show modulefile [...] Display information about modulefile(s)
test [modulefile ...] Test modulefile(s)
use [-a|-p] dir [...] Add dir(s) to MODULEPATH variable
unuse dir [...] Remove dir(s) from MODULEPATH variable
is-used [dir ...] Is any of the dir(s) enabled in MODULEPATH
path modulefile Print modulefile path
paths modulefile Print path of matching available modules
clear [-f] Reset Modules-specific runtime information
source scriptfile [...] Execute scriptfile(s)
config [--dump-state|name [val]] Display or set Modules configuration
state [name] Display Modules state
sh-to-mod shell shellscript [arg ...]
Make modulefile from script env changes
mod-to-sh shell modulefile [...]
Make shell code from modulefile env changes
edit modulefile Open modulefile in editor
lint [-a] [modulefile ...] Check syntax of modulefile
Switches:
-t | --terse Display output in terse format
-l | --long Display output in long format
-j | --json Display output in JSON format
-o LIST | --output=LIST
Define elements to output on 'avail' or 'list' sub-commands
in addition to module names (LIST is made of items like
'sym', 'tag', 'variant' or 'key' separated by ':')
-a | --all Include hidden modules in search
-d | --default Only show default versions available
-L | --latest Only show latest versions available
-S | --starts-with
Search modules whose name begins with query string
-C | --contains Search modules whose name contains query string
-i | --icase Case insensitive match
-a | --append Append directory to MODULEPATH (on 'use' sub-command)
-p | --prepend Prepend directory to MODULEPATH
--auto Enable automated module handling mode
--no-auto Disable automated module handling mode
-f | --force By-pass dependency consistency or confirmation dialog
--tag=LIST Apply tag to loading module on 'load', 'try-load', 'load-any'
or 'switch' sub-commands (LIST is made of tag names
separated by ':')
--ignore-cache Ignore module cache
--ignore-user-rc
Skip evaluation of user-specific module rc file
Options:
-h | --help This usage info
-V | --version Module version
-D | --debug Enable debug messages
-T | --trace Enable trace messages
-v | --verbose Enable verbose messages
-s | --silent Turn off error, warning and informational messages
--timer Report execution times
--paginate Pipe mesg output into a pager if stream attached to terminal
--no-pager Do not pipe message output into a pager
--redirect Send output to stdout (only for sh, bash, ksh, zsh and fish)
--no-redirect Send output to stderr
--color[=WHEN] Colorize the output; WHEN can be 'always' (default if
omitted), 'auto' or 'never'
-w COLS | --width=COLS
Set output width to COLS columns.}
}
# create appropriate message and kind of report when a requirement is not
# satisfied
proc reportMissingPrereqError {curmodnamevr args} {
set retisreqlo [isModuleEvaluated reqlo $curmodnamevr {*}$args]
# report message on currently evaluated module message block
if {![set retiseval [isModuleEvaluated any $curmodnamevr {*}$args]] ||\
[currentState msgrecordid] ne [topState msgrecordid] || !$retisreqlo} {
# more appropriate msg if an evaluation was attempted or is by-passed
set msg [expr {$retiseval || [getState force] ? [getReqNotLoadedMsg\
$args] : [getErrPrereqMsg $args]}]
# still proceed if force mode enabled
if {[getState force]} {
reportWarning $msg
# no error raise if done later
} elseif {$retisreqlo} {
reportError $msg
} else {
knerror $msg MODULES_ERR_GLOBAL
}
}
# raise reqlo-specific msg to top level if attempted
if {$retisreqlo} {
set msg [getErrReqLoMsg $args]
if {[getState force]} {
reportWarning $msg 1
} else {
knerror $msg MODULES_ERR_GLOBALTOP
}
}
}
# create appropriate message and kind of report when a conflict is detected
proc reportPresentConflictError {curmodnamevr mod isloading} {
set retisconun [isModuleEvaluated conun $curmodnamevr $mod]
# report message on currently evaluated module message block
if {![set retiseval [isModuleEvaluated any $curmodnamevr $mod]] ||\
[currentState msgrecordid] ne [topState msgrecordid] || !$retisconun} {
# more appropriate msg if an eval was attempted or is by-passed
set msg [expr {$retiseval || [getState force] ? [getConIsLoadedMsg\
[list $mod] $isloading] : [getErrConflictMsg $mod]}]
# still proceed if force mode enabled
if {[getState force]} {
reportWarning $msg
# indicate message has already been reported
lappend ::report_conflict([currentState evalid]) $mod
} else {
knerror $msg MODULES_ERR_GLOBAL
}
}
}
#
# Tcl sub-interpreter management
#
# dummy proc to disable modulefile commands on some evaluation modes
proc nop {args} {}
# dummy proc for commands available on other Modules flavor but not here
proc nimp {cmd args} {
reportWarning "'$cmd' command not implemented"
}
# Get identifier name of current Tcl modulefile interpreter. An interp is
# dedicated to each mode/auto_handling option value/depth level of modulefile
# interpretation
proc getCurrentModfileInterpName {} {
return __modfile_[currentState mode]_[getConf auto_handling]_[depthState\
modulename]
}
# synchronize environment variable change over all started sub interpreters
proc interp-sync-env {op var {val {}}} {
set envvar ::env($var)
##nagelfar vartype envvar varName
# apply operation to main interpreter
switch -- $op {
set { set $envvar $val }
unset { unset $envvar }
}
# apply operation to each sub-interpreters if not found autosynced
if {[llength [interp slaves]] > 0} {
reportDebug "$op var='$envvar', val='$val' on interp(s) [interp slaves]"
foreach itrp [interp slaves] {
switch -- $op {
set {
# no value pre-check on Windows platform as an empty value set
# means unsetting variable which lead querying value to error
if {[getState is_win] || ![interp eval $itrp [list info exists\
$envvar]] || [interp eval $itrp [list set $envvar]] ne\
$val} {
interp eval $itrp [list set $envvar $val]
}
}
unset {
if {[interp eval $itrp [list info exists $envvar]]} {
interp eval $itrp [list unset $envvar]
}
}
}
}
}
}
# Initialize list of interp alias commands to define for given evaluation mode
# and auto_handling enablement
proc initModfileModeAliases {mode auto aliasesVN aliasesPassArgVN\
tracesVN} {
global g_modfilePerModeAliases
upvar #0 $aliasesVN aliases
upvar #0 $aliasesPassArgVN aliasesPassArg
upvar #0 $tracesVN traces
if {![info exists g_modfilePerModeAliases]} {
set ::g_modfileBaseAliases [list versioncmp versioncmp getenv getenv\
getvariant getvariant is-loaded is-loaded is-saved is-saved is-used\
is-used is-avail is-avail uname uname module-info module-info exit\
exitModfileCmd reportCmdTrace reportCmdTrace reportInternalBug\
reportInternalBug reportWarning reportWarning reportError\
reportError raiseErrorCount raiseErrorCount report report\
isVerbosityLevel isVerbosityLevel isWin initStateIsWin puts\
putsModfileCmd readModuleContent readModuleContent\
formatErrStackTrace formatErrStackTrace]
# list of alias commands whose target procedure is adapted according to
# the evaluation mode
set ::g_modfileEvalModes {load unload display help test whatis refresh\
scan}
##nagelfar ignore #41 Too long line
array set g_modfilePerModeAliases {
add-property {nop nop nop nop nop nop nop nop }
always-load {always-load nop reportCmd nop nop nop nop always-load-sc}
append-path {append-path append-path-un append-path append-path append-path edit-path-wh nop edit-path-sc}
chdir {chdir nop reportCmd nop nop nop nop chdir-sc }
complete {complete complete-un reportCmd nop nop nop complete complete-sc }
conflict {conflict nop reportCmd nop nop nop nop conflict-sc }
depends-on {prereqAllModfileCmd nop reportCmd nop nop nop nop prereq-all-sc}
extensions {nop nop nop nop nop nop nop nop }
family {family family-un reportCmd nop nop nop nop family-sc }
module {module module reportCmd nop nop nop nop module-sc }
module-alias {module-alias module-alias module-alias module-alias module-alias module-alias nop nop }
module-log {nimp nimp reportCmd nop nop nop nop nop }
module-trace {nimp nimp reportCmd nop nop nop nop nop }
module-user {nimp nimp reportCmd nop nop nop nop nop }
module-verbosity {nimp nimp reportCmd nop nop nop nop nop }
module-version {module-version module-version module-version module-version module-version module-version nop nop }
module-virtual {module-virtual module-virtual module-virtual module-virtual module-virtual module-virtual nop nop }
module-forbid {module-forbid module-forbid module-forbid module-forbid module-forbid module-forbid nop nop }
module-hide {module-hide module-hide module-hide module-hide module-hide module-hide nop nop }
module-tag {module-tag module-tag module-tag module-tag module-tag module-tag nop nop }
module-whatis {nop nop reportCmd nop nop module-whatis nop nop }
prepend-path {prepend-path prepend-path-un prepend-path prepend-path prepend-path edit-path-wh nop edit-path-sc}
prereq-all {prereqAllModfileCmd nop reportCmd nop nop nop nop prereq-all-sc}
prereq-any {prereqAnyModfileCmd nop reportCmd nop nop nop nop prereq-sc }
prereq {prereqAnyModfileCmd nop reportCmd nop nop nop nop prereq-sc }
pushenv {pushenv pushenv-un pushenv pushenv pushenv pushenv-wh nop pushenv-sc }
remove-path {remove-path remove-path-un remove-path remove-path remove-path edit-path-wh nop edit-path-sc}
remove-property {nop nop nop nop nop nop nop nop }
require-fullname {require-fullname nop reportCmd nop nop nop nop nop }
set-alias {set-alias set-alias-un reportCmd nop nop nop set-alias set-alias-sc}
set-function {set-function set-function-un reportCmd nop nop nop set-function set-function-sc}
setenv {setenv setenv-un setenv setenv setenv setenv-wh nop setenv-sc }
source-sh {source-sh source-sh-un source-sh-di nop nop nop source-sh source-sh }
system {system system reportCmd nop nop nop nop nop }
uncomplete {uncomplete nop reportCmd nop nop nop nop uncomplete-sc}
unset-alias {unset-alias nop reportCmd nop nop nop nop unset-alias-sc}
unset-function {unset-function nop reportCmd nop nop nop nop unset-function-sc}
unsetenv {unsetenv unsetenv-un unsetenv unsetenv unsetenv unsetenv-wh nop unsetenv-sc }
variant {variant variant variant variant variant variant-wh variant variant-sc }
x-resource {x-resource x-resource reportCmd nop nop nop nop nop }
}
}
# alias commands where interpreter ref should be passed as argument
array set aliasesPassArg [list getvariant [list __itrp__] puts [list\
__itrp__] variant [list __itrp__]]
# initialize list with all commands not dependent of the evaluation mode
array set aliases $::g_modfileBaseAliases
# add site-specific command aliases for modulefile interp
if {[info exists ::modulefile_extra_cmds]} {
if {[catch {array set aliases $::modulefile_extra_cmds} errorMsg]} {
knerror "Invalid value '$::modulefile_extra_cmds' ($errorMsg)\nfor\
siteconfig variable 'modulefile_extra_cmds'"
}
}
# add alias commands whose target command vary depending on the eval mode
set modeidx [lsearch -exact $::g_modfileEvalModes $mode]
foreach alias [array names g_modfilePerModeAliases] {
set aliastarget [set aliases($alias) [lindex\
$g_modfilePerModeAliases($alias) $modeidx]]
# some target procedures need command name as first arg
if {$aliastarget in {reportCmd nimp edit-path-wh edit-path-sc}} {
set aliasesPassArg($alias) [list $alias]
# prereq commands need auto_handling state as first arg
} elseif {$mode eq {load} && $alias in {prereq prereq-any prereq-all\
depends-on}} {
set aliasesPassArg($alias) [list 0 $auto]
# associate a trace command if per-mode alias command is not reportCmd
# in display mode (except for source-sh)
} elseif {$mode eq {display} && $alias ne {source-sh}} {
set traces($alias) reportCmdTrace
}
}
}
proc execute-modulefile {modfile modname modnamevrvar modspec {up_namevr 1}\
{fetch_tags 1}} {
# link to modnamevr variable name from calling ctx if content update asked
if {$up_namevr} {
upvar $modnamevrvar modnamevr
} else {
set modnamevr $modnamevrvar
}
lappendState modulefile $modfile
lappendState modulename $modname
lappendState modulenamevr $modnamevr
lappendState specifiedname $modspec
set mode [currentState mode]
lappendState debug_msg_prefix\
"\[#[depthState modulename]:$mode:$modname\] "
# skip modulefile if interpretation has been inhibited
if {[getState inhibit_interp]} {
reportDebug "skipping $modfile"
return 1
}
reportTrace "'$modfile' as '$modname'" {Evaluate modulefile}
# gather all tags of evaluated modulefile
if {$fetch_tags} {
cacheCurrentModules 0
collectModuleTags $modnamevr
}
# inform that access to module will be soon denied
if {$mode ne {unload} && [isModuleTagged $modnamevr nearly-forbidden 1]} {
reportWarning [getNearlyForbiddenMsg $modnamevr]
set nearlyforbidwarn 1
# fail unload attempt if module is sticky, unless if forced or reloading
# also fail unload if mod is super-sticky even if forced, unless reloading
} elseif {$mode eq {unload}} {
# when loaded, tags applies to mod name and version (not with variant)
if {[isModuleTagged $modname super-sticky 1] && [currentState\
reloading_supersticky] ne $modname} {
# restore changed states prior raising error
lpopState debug_msg_prefix
lpopState specifiedname
lpopState modulename
lpopState modulenamevr
lpopState modulefile
knerror [getStickyUnloadMsg super-sticky]
} elseif {[isModuleTagged $modname sticky 1] && [currentState\
reloading_sticky] ne $modname && [currentState unloading_sticky] ne\
$modname} {
if {[getState force]} {
reportWarning [getStickyForcedUnloadMsg]
} else {
# restore changed states prior raising error
lpopState debug_msg_prefix
lpopState specifiedname
lpopState modulename
lpopState modulenamevr
lpopState modulefile
knerror [getStickyUnloadMsg]
}
}
}
if {![info exists ::g_modfileUntrackVars]} {
# list variable that should not be tracked for saving
array set ::g_modfileUntrackVars [list ModulesCurrentModulefile 1\
modcontent 1 env 1]
# commands that should be renamed before aliases setup
array set ::g_modfileRenameCmds [list puts _puts]
}
# dedicate an interpreter per mode and per level of interpretation to have
# a dedicated interpreter in case of cascaded multi-mode interpretations
set itrp [getCurrentModfileInterpName]
# evaluation mode-specific configuration
set autosuf [expr {[getConf auto_handling] ? {AH} : {}}]
set dumpCommandsVN g_modfile${mode}${autosuf}Commands
set aliasesVN g_modfile${mode}${autosuf}Aliases
set aliasesPassArgVN g_modfile${mode}${autosuf}AliasesPassArg
set tracesVN g_modfile${mode}${autosuf}Traces
##nagelfar ignore Suspicious variable name
if {![info exists ::$aliasesVN]} {
##nagelfar vartype aliasesVN varName
##nagelfar vartype aliasesPassArgVN varName
##nagelfar vartype tracesVN varName
initModfileModeAliases $mode [getConf auto_handling] $aliasesVN\
$aliasesPassArgVN $tracesVN
}
# variable to define in modulefile interp
if {![info exists ::g_modfileBaseVars]} {
# record module tool properties
set ::g_modfileBaseVars [list ModuleTool Modules ModuleToolVersion\
{5.3.0}]
if {[info exists ::modulefile_extra_vars]} {
if {([llength $::modulefile_extra_vars] % 2) != 0} {
knerror "Invalid value '$::modulefile_extra_vars' (list must have\
an even number of elements)\nfor siteconfig variable\
'modulefile_extra_vars'"
}
foreach {var val} $::modulefile_extra_vars {
if {[string first { } $var] != -1} {
knerror "Invalid variable name '$var'\ndefined in siteconfig\
variable 'modulefile_extra_vars'"
}
}
lappend ::g_modfileBaseVars {*}$::modulefile_extra_vars
}
}
# create modulefile interpreter at first interpretation
if {![interp exists $itrp]} {
reportDebug "creating interp $itrp"
interp create $itrp
# initialize global static variables for modulefile interp
foreach {var val} $::g_modfileBaseVars {
interp eval $itrp set ::$var "{$val}"
}
# dump initial interpreter state to restore it before each modulefile
# interpretation. use same dump state for all modes/levels
if {![info exists ::g_modfileVars]} {
dumpInterpState $itrp g_modfileVars g_modfileArrayVars\
g_modfileUntrackVars g_modfileProcs
}
# interp has just been created
set fresh 1
} else {
set fresh 0
}
# reset interp state command before each interpretation
resetInterpState $itrp $fresh g_modfileVars g_modfileArrayVars\
g_modfileUntrackVars g_modfileProcs $aliasesVN $aliasesPassArgVN\
$tracesVN g_modfileRenameCmds $dumpCommandsVN
# reset modulefile-specific variable before each interpretation
interp eval $itrp set ::ModulesCurrentModulefile "{$modfile}"
interp eval $itrp set vrspeclist "{[getVariantListFromVersSpec\
$modnamevr]}"
##nagelfar ignore +7 Suspicious # char
set errorVal [interp eval $itrp {
set modcontent [readModuleContent $::ModulesCurrentModulefile 1]
if {$modcontent eq {}} {
return 1
}
info script $::ModulesCurrentModulefile
# eval then call for specific proc depending mode under same catch
set sourceFailed [catch {
eval $modcontent
# raise error if a variant specified is not defined in modulefile
set vrerrlist {}
foreach vrspec $vrspeclist {
set vrname [lindex $vrspec 0]
if {![info exists ::ModuleVariant($vrname)]} {
lappend vrerrlist "Unknown variant '$vrname' specified"
}
}
# report all unknown variants specified, raise error on last report
# take caution with vrerrlist variable as we are in modfile eval ctx
if {[info exists vrerrlist] && [llength $vrerrlist] > 0} {
for {set i 0} {$i < ([llength $vrerrlist] - 1)} {incr i} {
reportError [lindex $vrerrlist $i]
}
error [lindex $vrerrlist $i] {} MODULES_ERR_GLOBAL
}
switch -- [module-info mode] {
help {
if {[info procs ModulesHelp] eq {ModulesHelp}} {
ModulesHelp
} else {
reportWarning "Unable to find ModulesHelp in\
$::ModulesCurrentModulefile."
}
}
display {
if {[info procs ModulesDisplay] eq {ModulesDisplay}} {
ModulesDisplay
}
}
test {
if {[info procs ModulesTest] eq {ModulesTest}} {
if {[string is true -strict [ModulesTest]]} {
report {Test result: PASS}
} else {
report {Test result: FAIL}
raiseErrorCount
}
} else {
reportWarning "Unable to find ModulesTest in\
$::ModulesCurrentModulefile."
}
}
}
} errorMsg]
if {$sourceFailed} {
# no error in case of "continue" command
# catch continue even if called outside of a loop
if {$errorMsg eq {invoked "continue" outside of a loop}\
|| $sourceFailed == 4} {
unset errorMsg
return 0
# catch break even if called outside of a loop
# on Darwin, error is different: no errorCode & return code set to 3
} elseif {$errorMsg eq {invoked "break" outside of a loop}\
|| ($errorMsg eq {} && (![info exists ::errorInfo]\
|| $::errorInfo eq {})) || (![info exists ::errorCode] &&\
$sourceFailed == 3)} {
unset errorMsg
# report load/unload/refresh evaluation break if verbosity level
# >= normal, no error count raise during scan evaluation
set mode [module-info mode]
if {$mode in {load unload refresh} && [isVerbosityLevel normal]} {
reportError {Module evaluation aborted}
} elseif {$mode ne {scan}} {
raiseErrorCount
}
return 1
} elseif {$errorCode eq {MODULES_ERR_SUBFAILED}} {
# error counter and message already handled, just return error
return 1
} elseif {$errorCode eq {MODULES_ERR_GLOBALTOP}} {
reportError $errorMsg 1
return 1
} elseif {$errorCode eq {MODULES_ERR_GLOBAL}} {
reportError $errorMsg
return 1
} else {
# format stack trace to report modulefile information only
reportInternalBug [formatErrStackTrace $::errorInfo\
$::ModulesCurrentModulefile [list {*}[info procs] {*}[info\
commands]]]
return 1
}
} else {
unset errorMsg
return 0
}
}]
# check if mod name version and variant has changed (default variant set)
# update modnamevr if so and collect tags applying to new name
if {$up_namevr} {
set newmodnamevr "{$modname}"
if {[set vr [getVariantList $modname 1]] ne {}} {
append newmodnamevr " $vr"
}
if {$modnamevr ne $newmodnamevr} {
set modnamevr_tag_list [getTagList $modnamevr]
set modnamevr_extratag_list [getExtraTagList $modnamevr]
lassign [parseModuleSpecification 0 0 0 0 {*}$newmodnamevr] modnamevr
if {$fetch_tags} {
collectModuleTags $modnamevr
# set tags applying to previous name (without default variant set)
# not to forget extra defined tags
setModuleTag $modnamevr {*}$modnamevr_tag_list
setModuleExtraTag $modnamevr {*}$modnamevr_extratag_list
}
}
}
# check if special tags now applies and require to raise an error
if {$mode ne {unload}} {
if {[isModuleTagged $modnamevr forbidden 1]} {
set errorVal 1
reportError [getForbiddenMsg $modnamevr]
} elseif {![info exists nearlyforbidwarn] && [isModuleTagged $modnamevr\
nearly-forbidden 1]} {
reportWarning [getNearlyForbiddenMsg $modnamevr]
}
}
reportDebug "exiting $modfile"
lpopState debug_msg_prefix
lpopState specifiedname
lpopState modulename
lpopState modulenamevr
lpopState modulefile
return $errorVal
}
# Smaller subset than main module load... This function runs modulerc and
# .version files
proc execute-modulerc {modfile modname modspec} {
lappendState modulefile $modfile
# push name to be found by module-alias and version
lappendState modulename $modname
lappendState specifiedname $modspec
set ::ModulesVersion {}
lappendState debug_msg_prefix "\[#[depthState modulename]:$modname\] "
if {![info exists ::g_modrcUntrackVars]} {
# list variable that should not be tracked for saving
array set ::g_modrcUntrackVars [list ModulesCurrentModulefile 1\
ModulesVersion 1 modcontent 1 env 1]
# commands that should be renamed before aliases setup
array set ::g_modrcRenameCmds [list]
# list interpreter alias commands to define
array set ::g_modrcAliases [list uname uname system system versioncmp\
versioncmp is-loaded is-loaded is-used is-used module-version\
module-version module-alias module-alias module-virtual\
module-virtual module-forbid module-forbid module-hide module-hide\
module-tag module-tag module-info module-info\
reportInternalBug reportInternalBug setModulesVersion\
setModulesVersion readModuleContent readModuleContent\
formatErrStackTrace formatErrStackTrace]
# add site-specific command aliases for modulerc interp
if {[info exists ::modulerc_extra_cmds]} {
if {[catch {array set ::g_modrcAliases $::modulerc_extra_cmds}\
errorMsg]} {
knerror "Invalid value '$::modulerc_extra_cmds' ($errorMsg)\nfor\
siteconfig variable 'modulerc_extra_cmds'"
}
}
# alias commands where an argument should be passed
array set ::g_modrcAliasesPassArg [list]
# trace commands that should be associated to aliases
array set ::g_modrcAliasesTraces [list]
# variable to define in modulerc interp
set ::g_modrcBaseVars [list ModuleTool Modules ModuleToolVersion\
{5.3.0}]
if {[info exists ::modulerc_extra_vars]} {
if {([llength $::modulerc_extra_vars] % 2) != 0} {
knerror "Invalid value '$::modulerc_extra_vars' (list must have\
an even number of elements)\nfor siteconfig variable\
'modulerc_extra_vars'"
}
foreach {var val} $::modulerc_extra_vars {
if {[string first { } $var] != -1} {
knerror "Invalid variable name '$var'\ndefined in siteconfig\
variable 'modulerc_extra_vars'"
}
}
lappend ::g_modrcBaseVars {*}$::modulerc_extra_vars
}
}
# dedicate an interpreter per level of interpretation to have in case of
# cascaded interpretations a specific interpreter per level
set itrp __modrc_[depthState modulename]
reportTrace '$modfile' {Evaluate modulerc}
# create modulerc interpreter at first interpretation
if {![interp exists $itrp]} {
reportDebug "creating interp $itrp"
interp create $itrp
# initialize global static variables for modulerc interp
foreach {var val} $::g_modrcBaseVars {
interp eval $itrp set ::$var "{$val}"
}
# dump initial interpreter state to restore it before each modulerc
# interpretation. use same dump state for all levels
if {![info exists ::g_modrcVars]} {
dumpInterpState $itrp g_modrcVars g_modrcArrayVars\
g_modrcUntrackVars g_modrcProcs
}
# interp has just been created
set fresh 1
} else {
set fresh 0
}
# reset interp state command before each interpretation
resetInterpState $itrp $fresh g_modrcVars g_modrcArrayVars\
g_modrcUntrackVars g_modrcProcs g_modrcAliases g_modrcAliasesPassArg\
g_modrcAliasesTraces g_modrcRenameCmds g_modrcCommands
interp eval $itrp set ::ModulesCurrentModulefile "{$modfile}"
interp eval $itrp {set ::ModulesVersion {}}
# create an alias ModuleVersion on ModulesVersion
interp eval $itrp {upvar 0 ::ModulesVersion ::ModuleVersion}
##nagelfar ignore +4 Suspicious # char
set errorVal [interp eval $itrp {
set modcontent [readModuleContent $::ModulesCurrentModulefile]
if {$modcontent eq {}} {
# simply skip rc file, no exit on error here
return 1
}
info script $::ModulesCurrentModulefile
if [catch {eval $modcontent} errorMsg] {
# format stack trace to report modulerc information only
reportInternalBug [formatErrStackTrace $::errorInfo\
$::ModulesCurrentModulefile [list {*}[info procs] {*}[info\
commands]]]
return 1
} else {
# pass ModulesVersion value to main interp
if {[info exists ::ModulesVersion]} {
setModulesVersion $::ModulesVersion
}
return 0
}
}]
# default version set via ModulesVersion variable in .version file
# override previously defined default version for modname
lassign [getModuleNameVersion] mod modname modversion
if {$modversion eq {.version} && $::ModulesVersion ne {}} {
# ModulesVersion should target an element in current directory
if {[string first / $::ModulesVersion] == -1} {
setModuleResolution $modname/default $modname/$::ModulesVersion\
default
} else {
reportError "Invalid ModulesVersion '$::ModulesVersion' defined"
}
}
lpopState debug_msg_prefix
lpopState specifiedname
lpopState modulename
lpopState modulefile
return $::ModulesVersion
}
# Save list of the defined procedure and the global variables with their
# associated values set in sub interpreter passed as argument. Global
# structures are used to save these information and the name of these
# structures are provided as argument.
proc dumpInterpState {itrp dumpVarsVN dumpArrayVarsVN untrackVarsVN\
dumpProcsVN} {
upvar #0 $dumpVarsVN dumpVars
upvar #0 $dumpArrayVarsVN dumpArrayVars
upvar #0 $untrackVarsVN untrackVars
upvar #0 $dumpProcsVN dumpProcs
regexp {^__[a-z]+} $itrp itrpkind
# save name and value for any other global variables
foreach var [$itrp eval {info globals}] {
if {![info exists untrackVars($var)]} {
reportDebug "saving for $itrpkind var $var"
if {[$itrp eval array exists ::$var]} {
set dumpVars($var) [$itrp eval array get ::$var]
set dumpArrayVars($var) 1
} else {
set dumpVars($var) [$itrp eval set ::$var]
}
}
}
# save name of every defined procedures
foreach var [$itrp eval {info procs}] {
set dumpProcs($var) 1
}
reportDebug "saving for $itrpkind proc list [array names dumpProcs]"
}
# Define commands to be known by sub interpreter.
proc initInterpCommands {itrp fresh aliasesVN aliasesPassArgVN tracesVN\
renameCmdsVN} {
upvar #0 $aliasesVN aliases
upvar #0 $aliasesPassArgVN aliasesPassArg
upvar #0 $tracesVN traces
upvar #0 $renameCmdsVN renameCmds
# rename some commands on freshly created interp before aliases defined
# below overwrite them
if {$fresh} {
foreach cmd [array names renameCmds] {
$itrp eval rename $cmd $renameCmds($cmd)
}
}
# set interpreter alias commands each time to guaranty them being
# defined and not overridden by modulefile or modulerc content
foreach alias [array names aliases] {
if {[info exists aliasesPassArg($alias)]} {
set aliasargs $aliasesPassArg($alias)
# pass current itrp reference on special keyword
if {[lindex $aliasargs 0] eq {__itrp__}} {
lset aliasargs 0 $itrp
}
interp alias $itrp $alias {} $aliases($alias) {*}$aliasargs
} else {
interp alias $itrp $alias {} $aliases($alias)
}
}
if {$fresh} {
# trace each modulefile command call if verbosity is set to debug (when
# higher verbosity level is set all cmds are already traced) and timer
# mode is disabled
if {[getConf verbosity] eq {debug} && ![getState timer]} {
interp alias $itrp reportTraceExecEnter {} reportTraceExecEnter
foreach alias [array names aliases] {
# exclude internal commands expoxed to modulerc/file interpreter
# exclude cachefile commands
if {$alias ni {report reportDebug reportError reportWarning\
reportCmdTrace raiseErrorCount reportInternalBug\
formatErrStackTrace isVerbosityLevel modulefile-content\
modulerc-content modulefile-invalid limited-access-file\
limited-access-directory}} {
interp eval $itrp [list trace add execution $alias enter\
reportTraceExecEnter]
}
}
}
}
foreach alias [array names traces] {
interp eval $itrp [list trace add execution $alias leave\
$traces($alias)]
}
}
# Restore initial setup of sub interpreter passed as argument based on
# global structure previously filled with initial list of defined procedure
# and values of global variable.
proc resetInterpState {itrp fresh dumpVarsVN dumpArrayVarsVN untrackVarsVN\
dumpProcsVN aliasesVN aliasesPassArgVN tracesVN renameCmdsVN\
dumpCommandsVN} {
upvar #0 $dumpVarsVN dumpVars
upvar #0 $dumpArrayVarsVN dumpArrayVars
upvar #0 $untrackVarsVN untrackVars
upvar #0 $dumpProcsVN dumpProcs
upvar #0 $dumpCommandsVN dumpCommands
# look at list of defined procedures and delete those not part of the
# initial state list. do not check if they have been altered as no vital
# procedures lied there. note that if a Tcl command has been overridden
# by a proc, it will be removed here and command will also disappear
foreach var [$itrp eval {info procs}] {
if {![info exists dumpProcs($var)]} {
reportDebug "removing on $itrp proc $var"
$itrp eval [list rename $var {}]
}
}
##nagelfar vartype aliasesVN varName
##nagelfar vartype aliasesPassArgVN varName
##nagelfar vartype tracesVN varName
##nagelfar vartype renameCmdsVN varName
# rename some commands and set aliases on interpreter
initInterpCommands $itrp $fresh $aliasesVN $aliasesPassArgVN $tracesVN\
$renameCmdsVN
# dump interpreter command list here on first time as aliases should be
# set prior to be found on this list for correct match
if {![info exists dumpCommands]} {
set dumpCommands [$itrp eval {info commands}]
reportDebug "saving for $itrp command list $dumpCommands"
# if current interpreter command list does not match initial list it
# means that at least one command has been altered so we need to recreate
# interpreter to guaranty proper functioning
} elseif {$dumpCommands ne [$itrp eval {info commands}]} {
reportDebug "missing command(s), recreating interp $itrp"
interp delete $itrp
interp create $itrp
initInterpCommands $itrp 1 $aliasesVN $aliasesPassArgVN $tracesVN\
$renameCmdsVN
}
# check every global variables currently set and correct them to restore
# initial interpreter state. work on variables at the very end to ensure
# procedures and commands are correctly defined
foreach var [$itrp eval {info globals}] {
if {![info exists untrackVars($var)]} {
if {![info exists dumpVars($var)]} {
reportDebug "removing on $itrp var $var"
$itrp eval unset ::$var
} elseif {![info exists dumpArrayVars($var)]} {
if {$dumpVars($var) ne [$itrp eval set ::$var]} {
reportDebug "restoring on $itrp var $var"
if {[llength $dumpVars($var)] > 1} {
# restore value as list
$itrp eval set ::$var [list $dumpVars($var)]
} else {
# brace value to be able to restore empty string
$itrp eval set ::$var "{$dumpVars($var)}"
}
}
} else {
if {$dumpVars($var) ne [$itrp eval array get ::$var]} {
reportDebug "restoring on $itrp var $var"
$itrp eval array set ::$var [list $dumpVars($var)]
}
}
}
}
}
#
# Modulefile Tcl commands
#
# Dictionary-style string comparison
# Use dictionary sort of lsort proc to compare two strings in the "string
# compare" fashion (returning -1, 0 or 1). Tcl dictionary-style comparison
# enables to compare software versions (ex: "1.10" is greater than "1.8")
proc versioncmp {str1 str2} {
if {$str1 eq $str2} {
return 0
# put both strings in a list, then lsort it and get first element
} elseif {[lindex [lsort -dictionary [list $str1 $str2]] 0] eq $str1} {
return -1
} else {
return 1
}
}
proc module-info {what {more {}}} {
set mode [currentState mode]
switch -- $what {
mode {
if {$more ne {}} {
set command [currentState commandname]
return [expr {$mode eq $more || ($more eq {remove} && $mode eq \
{unload}) || ($more eq {switch} && $command eq {switch}) ||\
($more eq {nonpersist} && $mode eq {refresh})}]
} else {
return $mode
}
}
command {
set command [currentState commandname]
if {$more eq {}} {
return $command
} else {
return [expr {$command eq $more}]
}
}
name {
return [currentState modulename]
}
specified {
return [currentState specifiedname]
}
shell {
if {$more ne {}} {
return [expr {[getState shell] eq $more}]
} else {
return [getState shell]
}
}
flags {
# C-version specific option, not relevant for Tcl-version but return
# a zero integer value to avoid breaking modulefiles using it
return 0
}
shelltype {
if {$more ne {}} {
return [expr {[getState shelltype] eq $more}]
} else {
return [getState shelltype]
}
}
user {
# C-version specific option, not relevant for Tcl-version but return
# an empty value or false to avoid breaking modulefiles using it
if {$more ne {}} {
return 0
} else {
return {}
}
}
alias {
set ret [resolveModuleVersionOrAlias $more [isIcase]]
if {$ret ne $more} {
return $ret
} else {
return {}
}
}
trace {
return {}
}
tracepat {
return {}
}
type {
return Tcl
}
symbols {
lassign [getModuleNameVersion $more 1] mod modname modversion
set sym_list [getVersAliasList $mod]
# if querying special symbol "default" but nothing found registered
# on it, look at symbol registered on bare module name in case there
# are symbols registered on it but no default symbol set yet to link
# to them
if {[llength $sym_list] == 0 && $modversion eq {default}} {
set sym_list [getVersAliasList $modname]
}
return [join $sym_list :]
}
tags {
# refresh mod name version and variant to correctly get all matching
# tags (in case tags apply to specific module variant)
set modname [currentState modulename]
set vrlist [getVariantList $modname 1]
if {[llength $vrlist] > 0} {
lassign [parseModuleSpecification 0 0 0 0 $modname {*}$vrlist]\
modnamevr
} else {
set modnamevr $modname
}
collectModuleTags $modnamevr
if {$more ne {}} {
return [expr {$more in [getTagList $modnamevr]}]
} else {
return [getTagList $modnamevr]
}
}
version {
lassign [getModuleNameVersion $more 1] mod
return [resolveModuleVersionOrAlias $mod [isIcase]]
}
loaded {
lassign [getModuleNameVersion $more 1] mod
return [getLoadedMatchingName $mod returnall]
}
usergroups {
if {[getState is_win]} {
knerror "module-info usergroups not supported on Windows platform"
} else {
if {$more ne {}} {
return [expr {$more in [getState usergroups]}]
} else {
return [getState usergroups]
}
}
}
username {
if {[getState is_win]} {
knerror "module-info username not supported on Windows platform"
} else {
if {$more ne {}} {
return [expr {[getState username] eq $more}]
} else {
return [getState username]
}
}
}
default {
knerror "module-info $what not supported"
return {}
}
}
}
proc module-whatis {args} {
lappend ::g_whatis [join $args]
return {}
}
# Specifies a default or alias version for a module that points to an
# existing module version Note that aliases defaults are stored by the
# short module name (not the full path) so aliases and defaults from one
# directory will apply to modules of the same name found in other
# directories.
proc module-version {args} {
lassign [getModuleNameVersion [lindex $args 0] 1] mod modname modversion
# go for registration only if valid modulename
if {$mod ne {}} {
foreach version [lrange $args 1 end] {
set aliasversion $modname/$version
# do not alter a previously defined alias version
if {![info exists ::g_moduleVersion($aliasversion)]} {
setModuleResolution $aliasversion $mod $version
} else {
reportWarning "Symbolic version '$aliasversion' already defined"
}
}
}
return {}
}
proc module-alias {args} {
lassign [getModuleNameVersion [lindex $args 0]] alias
lassign [getModuleNameVersion [lindex $args 1] 1] mod
reportDebug "$alias = $mod"
if {[setModuleResolution $alias $mod]} {
set ::g_moduleAlias($alias) $mod
set ::g_sourceAlias($alias) [currentState modulefile]
}
return {}
}
proc module-virtual {args} {
lassign [getModuleNameVersion [lindex $args 0]] mod
set modfile [getAbsolutePath [lindex $args 1]]
reportDebug "$mod = $modfile"
set ::g_moduleVirtual($mod) $modfile
set ::g_sourceVirtual($mod) [currentState modulefile]
return {}
}
# Parse date time argument value and translate it into epoch time
proc __parseDateTimeArg {opt datetime} {
if {[regexp {^\d{4}-\d{2}-\d{2}(T\d{2}:\d{2})?$} $datetime match\
timespec]} {
# time specification is optional
if {$timespec eq {}} {
append datetime T00:00
}
# return corresponding epoch time
return [clock scan $datetime -format %Y-%m-%dT%H:%M]
} else {
knerror "Incorrect $opt value '$datetime' (valid date time format is\
'YYYY-MM-DD\[THH:MM\]')"
}
}
# parse application criteria arguments and determine if command applies
proc parseApplicationCriteriaArgs {aftbef nearsec args} {
set otherargs {}
# parse argument list
foreach arg $args {
if {[info exists nextargisval]} {
##nagelfar vartype nextargisval varName
set $nextargisval $arg
unset nextargisval
} elseif {[info exists nextargisdatetime]} {
##nagelfar ignore Suspicious variable name
set ${nextargisdatetime}raw $arg
# get epoch time from date time argument value
##nagelfar vartype nextargisdatetime varName
##nagelfar ignore Unknown variable
set $nextargisdatetime [parseDateTimeArg $prevarg $arg]
unset nextargisdatetime
} else {
switch -- $arg {
--after - --before {
# treat --after/--before as regular content if disabled
if {!$aftbef} {
lappend otherargs $arg
} else {
set nextargisdatetime [string trimleft $arg -]
}
}
--not-group - --not-user {
if {[getState is_win]} {
knerror "Option '$arg' not supported on Windows platform"
} else {
set nextargisval not[string range $arg 6 end]list
}
}
default {
lappend otherargs $arg
}
}
set prevarg $arg
}
}
if {[info exists nextargisval] || [info exists nextargisdatetime]} {
knerror "Missing value for '$prevarg' option"
}
# does it apply to current user?
set notuser [expr {[info exists notuserlist] && [getState username] in\
$notuserlist}]
set notgroup [expr {[info exists notgrouplist] && [isIntBetweenList\
$notgrouplist [getState usergroups]]}]
# does it apply currently?
set isbefore [expr {[info exists before] && [getState clock_seconds] <\
$before}]
set isafter [expr {[info exists after] && [getState clock_seconds] >=\
$after}]
# are criteria met
set apply [expr {!$notuser && !$notgroup && ($isbefore || $isafter ||\
(![info exists before] && ![info exists after]))}]
# is end limit near ?
set isnearly [expr {!$apply && !$notuser && !$notgroup && [info exists\
after] && !$isafter && [getState clock_seconds] >= ($after - $nearsec)}]
if {![info exists afterraw]} {
set afterraw {}
}
return [list $apply $isnearly $afterraw $otherargs]
}
proc setModspecTag {modspec tag {props {}}} {
reportDebug "Set tag '$tag' with properties '$props' on module\
specification '$modspec'"
# record tag list for mod root to optimize search
set modroot [getModuleRootFromVersSpec $modspec]
if {![info exists ::g_moduleTagRoot($modroot)]} {
lappend ::g_moduleTagRoot($modroot) $tag
set idx 0
set new 1
} else {
set idx [lsearch -exact $::g_moduleTagRoot($modroot) $tag]
if {$idx == -1} {
set idx [llength $::g_moduleTagRoot($modroot)]
lappend ::g_moduleTagRoot($modroot) $tag
set new 1
}
}
# then record mod spec and props at idx defined for tag. new spec are
# appended and firstly matching spec is returned with its props on search
if {[info exists new]} {
lappend ::g_moduleTagRootSpec($modroot) [list $modspec $props]
} else {
set tagrootlist [lindex $::g_moduleTagRootSpec($modroot) $idx]
lappend tagrootlist $modspec $props
lset ::g_moduleTagRootSpec($modroot) $idx $tagrootlist
}
}
proc module-forbid {args} {
# parse application criteria arguments to determine if command apply
lassign [parseApplicationCriteriaArgs 1 [expr {[getConf\
nearly_forbidden_days] * 86400}] {*}$args] apply isnearly after\
otherargs
# parse remaining argument list, do it even if command does not apply to
# raise any command specification error
foreach arg $otherargs {
if {[info exists nextargisval]} {
##nagelfar vartype nextargisval varName
set $nextargisval $arg
unset nextargisval
} else {
switch -glob -- $arg {
--nearly-message {
set nextargisval nearlymessage
}
--message {
set nextargisval message
}
-* {
knerror "Invalid option '$arg'"
}
default {
lappend modarglist $arg
}
}
set prevarg $arg
}
}
if {[info exists nextargisval]} {
knerror "Missing value for '$prevarg' option"
}
if {![info exists modarglist]} {
knerror {No module specified in argument}
}
# skip record if application criteria are not met
if {$apply} {
set proplist {}
if {[info exists message]} {
##nagelfar ignore Found constant
lappend proplist message $message
}
# record each forbid spec after parsing them
foreach modarg [parseModuleSpecification 0 0 0 0 {*}$modarglist] {
setModspecTag $modarg forbidden $proplist
}
} elseif {$isnearly} {
##nagelfar ignore Found constant
lappend proplist after $after
if {[info exists nearlymessage]} {
##nagelfar ignore Found constant
lappend proplist message $nearlymessage
}
# record each nearly forbid spec after parsing them
foreach modarg [parseModuleSpecification 0 0 0 0 {*}$modarglist] {
setModspecTag $modarg nearly-forbidden $proplist
}
}
}
proc module-hide {args} {
set hidinglvl 1
set hiddenloaded 0
# parse application criteria arguments to determine if command apply
lassign [parseApplicationCriteriaArgs 1 0 {*}$args] apply isnearly after\
otherargs
# parse remaining argument list, do it even if command does not apply to
# raise any command specification error
foreach arg $otherargs {
switch -glob -- $arg {
--hard {
# hardened stealth
set hidinglvl 2
}
--soft {
# soften level of camouflage
set hidinglvl 0
}
--hidden-loaded {
# module should stay hidden once being loaded
set hiddenloaded 1
}
-* {
knerror "Invalid option '$arg'"
}
default {
lappend modarglist $arg
}
}
}
if {![info exists modarglist]} {
knerror {No module specified in argument}
}
# skip hide spec record if application criteria are not met
if {$apply} {
# record each hide spec after parsing them
foreach modarg [parseModuleSpecification 0 0 0 0 {*}$modarglist] {
setModspecHidingLevel $modarg $hidinglvl
if {$hiddenloaded} {
setModspecTag $modarg hidden-loaded
}
}
}
}
proc module-tag {args} {
# parse application criteria arguments to determine if command apply
lassign [parseApplicationCriteriaArgs 0 0 {*}$args] apply isnearly after\
otherargs
# parse remaining argument list, do it even if command does not apply to
# raise any command specification error
foreach arg $otherargs {
switch -glob -- $arg {
-* {
knerror "Invalid option '$arg'"
}
default {
if {![info exists tag]} {
set tag $arg
} else {
lappend modarglist $arg
}
}
}
}
if {![info exists tag]} {
knerror {No tag specified in argument}
}
if {![info exists modarglist]} {
knerror {No module specified in argument}
}
if {$tag in [list loaded auto-loaded forbidden nearly-forbidden hidden\
hidden-loaded]} {
knerror "'$tag' is a reserved tag name and cannot be set"
}
# skip tag record if application criteria are not met
if {$apply} {
# record each hide spec after parsing them
foreach modarg [parseModuleSpecification 0 0 0 0 {*}$modarglist] {
setModspecTag $modarg $tag
}
}
}
# parse arguments sent to the unsetenv modulefile command
proc parseSetenvCommandArgs {mode dflbhv args} {
set bhv $dflbhv
foreach arg $args {
switch -- $arg {
--set-if-undef {
if {$mode eq {load}} {
set setifundef 1
}
}
default {
if {![info exists var]} {
set var $arg
} elseif {![info exists val]} {
set val $arg
} else {
# too much argument
set wrongargnum 1
}
}
}
}
if {[info exists wrongargnum] || ![info exists var] || ![info exists\
val]} {
knerror {wrong # args: should be "setenv ?--set-if-undef? var val"}
}
if {[info exists setifundef] && [info exists ::env($var)]} {
set bhv noop
}
reportDebug "bhv=$bhv, var=$var, val=$val"
return [list $bhv $var $val]
}
proc setenv {args} {
lassign [parseSetenvCommandArgs load set {*}$args] bhv var val
if {$bhv eq {set}} {
# clean any previously defined reference counter array
unset-env [getModshareVarName $var] 1
# clean any previously defined pushenv stack
unset-env [getPushenvVarName $var] 1
# Set the variable for later use during the modulefile evaluation
set-env $var $val
}
return {}
}
# undo setenv in unload mode
proc setenv-un {args} {
lassign [parseSetenvCommandArgs unload unset {*}$args] bhv var val
# clean any existing reference counter array
unset-env [getModshareVarName $var] 1
# clean any previously defined pushenv stack
unset-env [getPushenvVarName $var] 1
# Add variable to the list of variable to unset in shell output code but
# set it in interp context as done on load mode for later use during the
# modulefile evaluation
unset-env $var 0 $val
return {}
}
# optimized setenv for whatis mode: init env variable with an empty
# value if undefined. do not care about value, just avoid variable to be
# undefined for later use during the modulefile evaluation
proc setenv-wh {args} {
lassign [parseSetenvCommandArgs load set {*}$args] bhv var val
if {![info exists ::env($var)]} {
set ::env($var) {}
}
return {}
}
# parse arguments sent to the getenv modulefile command
proc parseGetenvCommandArgs {cmd args} {
set returnval 0
set valifundef {}
switch -- [llength $args] {
1 {
set var [lindex $args 0]
}
2 {
switch -- [lindex $args 0] {
--return-value {
set returnval 1
set var [lindex $args 1]
}
default {
set var [lindex $args 0]
set valifundef [lindex $args 1]
}
}
}
3 {
if {[lindex $args 0] ne {--return-value}} {
set wrongargs 1
} else {
set returnval 1
set var [lindex $args 1]
set valifundef [lindex $args 2]
}
}
default {
set wrongargs 1
}
}
set argname [expr {$cmd eq {getenv} ? {variable} : {name}}]
if {[info exists wrongargs]} {
knerror "wrong # args: should be \"$cmd ?--return-value? $argname\
?valifundef?\""
}
reportDebug "$argname='$var', valifundef='$valifundef',\
returnval='$returnval'"
return [list $var $valifundef $returnval]
}
proc getenv {args} {
# parse args
lassign [parseGetenvCommandArgs getenv {*}$args] var valifundef returnval
if {[currentState mode] ne {display} || $returnval} {
return [get-env $var $valifundef]
} else {
return "\$$var"
}
}
# parse arguments sent to the unsetenv modulefile command
proc parseUnsetenvCommandArgs {mode dflbhv args} {
foreach arg $args {
switch -- $arg {
--unset-on-unload {
if {$mode eq {unload}} {
set bhv unset
}
}
--noop-on-unload {
if {$mode eq {unload}} {
set bhv noop
}
}
default {
if {![info exists var]} {
set var $arg
} elseif {![info exists val]} {
set val $arg
if {$mode eq {unload} && ![info exists bhv]} {
set bhv set
}
} else {
# too much argument
set wrongargnum 1
}
}
}
}
if {[info exists wrongargnum] || ![info exists var]} {
knerror {wrong # args: should be "unsetenv ?--noop-on-unload?\
?--unset-on-unload? var ?val?"}
}
if {![info exists bhv]} {
set bhv $dflbhv
}
# initialize val to always return same structure, val is only used if bhv
# equals 'set'
if {![info exists val]} {
set val {}
}
reportDebug "bhv=$bhv, var=$var, val=$val"
return [list $bhv $var $val]
}
proc unsetenv {args} {
lassign [parseUnsetenvCommandArgs load unset {*}$args] bhv var val
# clean any existing reference counter array
unset-env [getModshareVarName $var] 1
# clean any previously defined pushenv stack
unset-env [getPushenvVarName $var] 1
# Set the variable for later use during the modulefile evaluation
unset-env $var
return {}
}
# undo unsetenv in unload mode
proc unsetenv-un {args} {
lassign [parseUnsetenvCommandArgs unload noop {*}$args] bhv var val
switch -- $bhv {
set {
# apply value specified for set on unload
return [setenv $var $val]
}
unset {
return [unsetenv $var]
}
noop {
# otherwise just clear variable if it does not exist on unload mode
# for later use during the modulefile evaluation
if {![info exists ::env($var)]} {
reset-to-unset-env $var
}
}
}
return {}
}
# optimized unsetenv for whatis mode: init env variable with an empty
# value if undefined. do not care about value, just avoid variable to be
# undefined for later use during the modulefile evaluation
proc unsetenv-wh {args} {
lassign [parseUnsetenvCommandArgs load noop {*}$args] bhv var val
if {![info exists ::env($var)]} {
set ::env($var) {}
}
return {}
}
proc chdir {dir} {
if {[file exists $dir] && [file isdirectory $dir]} {
set ::g_changeDir $dir
} else {
# report issue but does not treat it as an error to have the
# same behavior as C-version
reportWarning "Cannot chdir to '$dir' for '[currentState modulename]'"
}
return {}
}
# supersede exit command to handle it if called within a modulefile
# rather than exiting the whole process
proc exitModfileCmd {{code 0}} {
if {[currentState mode] in {load refresh}} {
setState inhibit_interp 1
}
# break to gently end interpretation of current modulefile
return -code break
}
# enables sub interp to return ModulesVersion value to the main interp
proc setModulesVersion {val} {
set ::ModulesVersion $val
}
# supersede puts command to catch content sent to stdout/stderr within
# modulefile in order to correctly send stderr content (if a pager has been
# enabled) or postpone content channel send after rendering on stdout the
# relative environment changes required by the modulefile
proc putsModfileCmd {itrp args} {
# determine if puts call targets the stdout or stderr channel
switch -- [llength $args] {
1 {
# create struct with newline status and message to output
set deferPuts [list 1 [lindex $args 0]]
}
2 {
switch -- [lindex $args 0] {
-nonewline {
set deferPuts [list 0 [lindex $args 1]]
}
stdout {
set deferPuts [list 1 [lindex $args 1]]
}
prestdout {
set deferPrePuts [list 1 [lindex $args 1]]
}
stderr {
set reportArgs [list [lindex $args 1]]
}
}
}
3 {
if {[lindex $args 0] eq {-nonewline}} {
switch -- [lindex $args 1] {
stdout {
set deferPuts [list 0 [lindex $args 2]]
}
prestdout {
set deferPrePuts [list 0 [lindex $args 2]]
}
stderr {
set reportArgs [list [lindex $args 2] 1]
}
}
} else {
set wrongNumArgs 1
}
}
default {
set wrongNumArgs 1
}
}
# raise error if bad argument number detected, do this here rather in _puts
# not to confuse people with an error reported by an internal name (_puts)
if {[info exists wrongNumArgs]} {
knerror {wrong # args: should be "puts ?-nonewline? ?channelId? string"}
# defer puts if it targets stdout (see renderSettings)
} elseif {[info exists deferPuts]} {
# current module is qualified for refresh evaluation
lappendState -nodup refresh_qualified [currentState modulename]
lappend ::g_stdoutPuts {*}$deferPuts
} elseif {[info exists deferPrePuts]} {
lappendState -nodup refresh_qualified [currentState modulename]
lappend ::g_prestdoutPuts {*}$deferPrePuts
# if it targets stderr call report, which knows what channel to use
} elseif {[info exists reportArgs]} {
# report message only if not silent
if {[isVerbosityLevel concise]} {
report {*}$reportArgs
}
# pass to real puts command if not related to stdout and do that in modfile
# interpreter context to get access to eventual specific channel
} else {
# re-throw error as a known error for accurate stack trace print
if {[catch {$itrp eval _puts $args} errMsg]} {
knerror $errMsg MODULES_ERR_CUSTOM
}
}
}
proc prepend-path {args} {
# Set the variable for later use during the modulefile evaluation
add-path prepend-path load prepend {*}$args
return {}
}
proc prepend-path-un {args} {
# Set the variable for later use during the modulefile evaluation
unload-path prepend-path unload remove {*}$args
return {}
}
proc append-path {args} {
# Set the variable for later use during the modulefile evaluation
add-path append-path load append {*}$args
return {}
}
proc append-path-un {args} {
# Set the variable for later use during the modulefile evaluation
unload-path append-path unload remove {*}$args
return {}
}
proc remove-path {args} {
# Set the variable for later use during the modulefile evaluation
unload-path remove-path load remove {*}$args
return {}
}
# undo remove-path in unload mode
proc remove-path-un {args} {
lassign [unload-path remove-path unload noop {*}$args] bhv var
# clean any previously defined pushenv stack
unset-env [getPushenvVarName $var] 1
# clear variable if it does not exist on unload mode for later use
# during the modulefile evaluation
if {![info exists ::env($var)]} {
reset-to-unset-env $var
}
}
# optimized *-path for whatis mode: init env variable with an empty value if
# undefined. do not care about value, just avoid variable to be undefined for
# later use during the modulefile evaluation
proc edit-path-wh {cmd args} {
# get variable name
lassign [parsePathCommandArgs $cmd load noop {*}$args] separator allow_dup\
idx_val ign_refcount bhv var path_list
if {![info exists ::env($var)]} {
set ::env($var) {}
}
return {}
}
proc set-alias {alias what} {
set ::g_Aliases($alias) $what
set ::g_stateAliases($alias) new
# current module is qualified for refresh evaluation
lappendState -nodup refresh_qualified [currentState modulename]
return {}
}
# undo set-alias in unload mode
proc set-alias-un {alias what} {
return [unset-alias $alias]
}
proc unset-alias {alias} {
set ::g_Aliases($alias) {}
set ::g_stateAliases($alias) del
return {}
}
proc set-function {function what} {
set ::g_Functions($function) $what
set ::g_stateFunctions($function) new
# current module is qualified for refresh evaluation
lappendState -nodup refresh_qualified [currentState modulename]
return {}
}
# undo set-function in unload mode
proc set-function-un {function what} {
return [unset-function $function]
}
proc unset-function {function} {
set ::g_Functions($function) {}
set ::g_stateFunctions($function) del
return {}
}
proc is-loaded {args} {
# parse module version specification
set args [parseModuleSpecification 0 0 0 0 {*}$args]
foreach mod $args {
if {[getLoadedMatchingName $mod returnfirst] ne {}} {
return 1
}
}
# is something loaded whatever it is?
return [expr {[llength $args] == 0 && [llength\
[getLoadedModulePropertyList name]] > 0}]
}
proc is-loading {args} {
foreach mod $args {
if {[getLoadedMatchingName $mod returnfirst 1] ne {}} {
return 1
}
}
# is something else loading whatever it is?
return [expr {[llength $args] == 0 && [llength [getLoadingModuleList]] >1}]
}
proc conflict {args} {
set currentModule [currentState modulename]
set curmodnamevr [currentState modulenamevr]
# get module short name if loaded by its full pathname
if {[set isfullpath [isModuleFullPath $currentModule]]} {
set currentSModule [findModuleNameFromModulefile $currentModule]
}
defineModEqProc [isIcase] [getConf extended_default]
# parse module version specification
set args [parseModuleSpecification 0 0 0 0 {*}$args]
# register conflict list unless record inhibited for current iterp context
if {[currentState inhibit_req_record] != [currentState evalid]} {
setLoadedConflict $currentModule {*}$args
}
foreach mod $args {
# if the conflict module is loading and it does not correspond to
# currently evaluated module, we cannot proceed
set isloading [expr {![modEq $mod $currentModule eqstart 1 2 1] &&\
(!$isfullpath || ![modEq $mod $currentSModule eqstart 1 2 1]) &&\
[is-loading $mod]}]
# if the conflicting module is loaded, we cannot either
if {[is-loaded $mod] || $isloading} {
reportPresentConflictError $curmodnamevr $mod $isloading
}
}
return {}
}
proc parsePrereqCommandArgs {cmd args} {
set tag_list {}
set optional 0
set opt_list {}
set prereq_list {}
# parse options defined
set i 0
foreach arg $args {
if {[info exists nextargistaglist]} {
set tag_list [split $arg :]
lappend opt_list $arg
unset nextargistaglist
} else {
switch -glob -- $arg {
--optional {
set optional 1
lappend opt_list $arg
}
--tag=* {
set tag_list [split [string range $arg 6 end] :]
lappend opt_list $arg
if {[llength $tag_list] == 0} {
knerror "Missing value for '--tag' option"
}
}
--tag {
set nextargistaglist 1
lappend opt_list $arg
}
-* {
knerror "Invalid option '$arg'"
}
default {
set prereq_list [lrange $args $i end]
# end option parsing: remaining elts are list of prereqs
break
}
}
}
incr i
}
foreach tag $tag_list {
if {$tag in [list loaded auto-loaded forbidden nearly-forbidden\
hidden]} {
knerror "Tag '$tag' cannot be manually set"
}
}
if {[llength $prereq_list] == 0} {
knerror "wrong # args: should be \"$cmd ?--optional? ?--tag? ?taglist?\
modulefile ?...?\""
} elseif {[set mispopt [lsearch -inline -glob $prereq_list --*]] ne {}} {
knerror "Misplaced option '$mispopt'"
}
return [list $tag_list $optional $opt_list $prereq_list]
}
proc prereqAnyModfileCmd {tryload auto args} {
lassign [parsePrereqCommandArgs prereq {*}$args] tag_list optional\
opt_list args
set currentModule [currentState modulename]
set curmodnamevr [currentState modulenamevr]
# parse module version specification
set args [parseModuleSpecification 0 0 0 0 {*}$args]
# register prereq list (sets of optional prereq are registered as list)
# unless record inhibited for current iterp context
if {[currentState inhibit_req_record] != [currentState evalid]} {
# if requirement is optional, add current module to the recorded prereq
# list to make the requirement rule satisfied even if none loaded, as
# current module will be loaded
if {$optional} {
lappend record_list $currentModule
}
lappend record_list {*}$args
setLoadedPrereq $currentModule $record_list
}
if {$auto} {
# try to load prereq as dependency resolving is enabled
lassign [loadRequirementModuleList $tryload $optional $tag_list\
{*}$args] retlo prereqloaded
} else {
set loadedmod_list {}
foreach mod $args {
# get all loaded or loading mod in args list
if {[set loadedmod [getLoadedMatchingName $mod returnfirst]] ne {}\
|| [set loadedmod [getLoadedMatchingName $mod returnfirst 1]] ne\
{}} {
lappend loadedmod_list $loadedmod
}
}
set prereqloaded [expr {[llength $loadedmod_list] > 0}]
}
if {!$prereqloaded} {
if {!$optional} {
# error if requirement is not satisfied unless if optional
reportMissingPrereqError $curmodnamevr {*}$args
}
} elseif {!$auto} {
# apply missing tag to all loaded module found (already done when
# dependency resolving is enabled)
cmdModuleTag 0 0 $tag_list {*}$loadedmod_list
}
return {}
}
proc x-resource {resource {value {}}} {
# sometimes x-resource value may be provided within resource name
# as the "x-resource {Ileaf.popup.saveUnder: True}" example provided
# in manpage. so here is an attempt to extract real resource name and
# value from resource argument
if {[string length $value] == 0 && ![file exists $resource]} {
# look first for a space character as delimiter, then for a colon
set sepapos [string first { } $resource]
if { $sepapos == -1 } {
set sepapos [string first : $resource]
}
if { $sepapos > -1 } {
set value [string range $resource $sepapos+1 end]
set resource [string range $resource 0 $sepapos-1]
reportDebug "corrected ($resource, $value)"
} else {
# if not a file and no value provided x-resource cannot be
# recorded as it will produce an error when passed to xrdb
reportWarning "x-resource $resource is not a valid string or file"
return {}
}
}
# check current environment can handle X11 resource edition elsewhere exit
if {[catch {runCommand xrdb -query} errMsg]} {
knerror "X11 resources cannot be edited, issue spotted\n[sgr er\
ERROR]: $errMsg" MODULES_ERR_GLOBAL
}
# if a resource does hold an empty value in g_newXResources or
# g_delXResources arrays, it means this is a resource file to parse
if {[currentState mode] eq {load}} {
set ::g_newXResources($resource) $value
} else {
set ::g_delXResources($resource) $value
}
return {}
}
proc uname {what} {
return [switch -- $what {
sysname {getState os}
machine {getState machine}
nodename - node {getState nodename}
release {getState osversion}
domain {getState domainname}
version {getState kernelversion}
default {knerror "uname $what not supported"}
}]
}
# run shell command
proc system {args} {
# run through the appropriate shell
if {[getState is_win]} {
set shell cmd.exe
set shellarg /c
} else {
set shell /bin/sh
set shellarg -c
}
if {[catch {exec >&@stderr $shell $shellarg [join $args]}]} {
# non-zero exit status, get it:
set status [lindex $::errorCode 2]
} else {
# exit status was 0
set status 0
}
return $status
}
# test at least one of the collections passed as argument exists
proc is-saved {args} {
foreach coll $args {
lassign [findCollections $coll exact] collfile colldesc
if {[string length $collfile] > 0} {
return 1
}
}
# is something saved whatever it is?
return [expr {[llength $args] == 0 && [llength [findCollections]] > 0}]
}
# test at least one of the directories passed as argument is set in MODULEPATH
proc is-used {args} {
set modpathlist [getModulePathList]
foreach path $args {
# transform given path in an absolute path to compare with dirs
# registered in the MODULEPATH env var which are returned absolute.
set abspath [getAbsolutePath $path]
if {$abspath in $modpathlist} {
return 1
}
}
# is something used whatever it is?
return [expr {[llength $args] == 0 && [llength $modpathlist] > 0}]
}
# test at least one of the modulefiles passed as argument exists
proc is-avail {args} {
# parse module version specification
# a module name is mandatory
set args [parseModuleSpecification 0 0 0 0 {*}$args]
set ret 0
# disable error reporting to avoid modulefile errors
# to pollute result. Only if not already inhibited
set alreadyinhibit [getState inhibit_errreport]
if {!$alreadyinhibit} {
inhibitErrorReport
}
foreach mod $args {
lassign [getPathToModule $mod] modfile modname modnamevr
if {$modfile ne {}} {
set ret 1
break
}
}
# re-enable only is it was disabled from this procedure
if {!$alreadyinhibit} {
setState inhibit_errreport 0
}
return $ret
}
proc execShAndGetEnv {shell script args} {
set sep {%ModulesShToMod%}
set subsep {%ModulesSubShToMod%}
set shdesc [list $script {*}$args]
set sherr 0
set shellopts [list]
upvar ignvarlist ignvarlist
set ignvarlist [list OLDPWD PWD _ _AST_FEATURES PS1 _LMFILES_\
LOADEDMODULES]
# define shell command to run to source script and analyze the environment
# changes it performs
switch -- [file tail $shell] {
dash - sh {
# declare is not supported by dash but functions cannot be retrieved
# anyway, so keep using declare and throw errors out to avoid overall
# execution error. dash does not pass arguments to sourced script but
# it does not raise error if arguments are set
##nagelfar ignore +3 Found constant
set command "export -p; echo $sep; declare -f 2>/dev/null; echo\
$sep; alias; echo $sep; echo $sep; pwd; echo $sep; . [listTo\
shell $shdesc] 2>&1; echo $sep; export -p; echo $sep; declare -f\
2>/dev/null; echo $sep; alias; echo $sep; echo $sep; pwd"
set varre {export (\S+?)=["']?(.*?)["']?$}
set funcre {(\S+?) \(\)\s?\n?{\s?\n(.+?)\n}$}
set aliasre {(\S+?)='(.*?)'$}
set varvalmap [list {\"} {"} \\\\ \\]
set alvalmap [list {'\''} ' {'"'"'} ']
}
bash {
##nagelfar ignore +2 Found constant
set command "export -p; echo $sep; declare -f; echo $sep; alias;\
echo $sep; complete; echo $sep; pwd; echo $sep; . [listTo shell\
$shdesc] 2>&1; echo $sep; export -p; echo $sep; declare -f; echo\
$sep; alias; echo $sep; complete; echo $sep; pwd"
set varre {declare -x (\S+?)="(.*?)"$}
set funcre {(\S+?) \(\)\s?\n{\s?\n(.+?)\n}$}
set aliasre {alias (\S+?)='(.*?)'$}
set compre {complete (.+?) (\S+?)$}
set comprevar [list match value name]
set varvalmap [list {\"} {"} \\\\ \\]
set alvalmap [list {'\''} ']
lappend shellopts --noprofile --norc
}
ksh - ksh93 {
##nagelfar ignore +3 Found constant
set command "typeset -x; echo $sep; typeset +f | while read f; do\
typeset -f \${f%\\(\\)}; echo; done; echo $sep; alias; echo $sep;\
echo $sep; pwd; echo $sep; . [listTo shell $shdesc] 2>&1; echo\
$sep; typeset -x; echo $sep; typeset +f | while read f; do\
typeset -f \${f%\\(\\)}; echo; done; echo $sep; alias; echo $sep;\
echo $sep; pwd"
set varre {(\S+?)=\$?'?(.*?)'?$}
set funcre {(\S+?)\(\) {\n?(.+?)}[;\n]?$}
set aliasre {(\S+?)=\$?'?(.*?)'?$}
set varvalmap [list {\'} ']
set alvalmap [list {\"} {"} {\\'} ' {\'} ' {\\\\} {\\}]
}
zsh {
##nagelfar ignore +2 Found constant
set command "typeset -x; echo $sep; declare -f; echo $sep; alias;\
echo $sep; echo $sep; pwd; echo $sep; . [listTo shell $shdesc]\
2>&1; echo $sep; typeset -x; echo $sep; declare -f; echo $sep;\
alias; echo $sep; echo $sep; pwd"
set varre {(\S+?)=\$?'?(.*?)'?$}
set funcre {(\S+?) \(\) {\n(.+?)\n}$}
set aliasre {(\S+?)=\$?'?(.*?)'?$}
set varvalmap [list {'\''} ']
set alvalmap [list {'\''} ']
}
csh {
##nagelfar ignore +2 Found constant
set command "setenv; echo $sep; echo $sep; alias; echo $sep; echo\
$sep; pwd; echo $sep; source [listTo shell $shdesc] >&\
/dev/stdout; echo $sep; setenv; echo $sep; echo $sep; alias; echo\
$sep; echo $sep; pwd"
set varre {(\S+?)=(.*?)$}
set aliasre {(\S+?)\t(.*?)$}
set varvalmap [list]
set alvalmap [list]
lappend shellopts -f
}
tcsh {
##nagelfar ignore +2 Found constant
set command "setenv; echo $sep; echo $sep; alias; echo $sep;\
complete; echo $sep; pwd; echo $sep; source [listTo shell\
$shdesc] >& /dev/stdout; echo $sep; setenv; echo $sep; echo $sep;\
alias; echo $sep; complete; echo $sep; pwd"
set varre {(\S+?)=(.*?)$}
set aliasre {(\S+?)\t\(?(.*?)\)?$}
set compre {(\S+?)\t(.*?)$}
set comprevar [list match name value]
set varvalmap [list]
set alvalmap [list]
lappend shellopts -f
}
fish {
# exclude from search builtins, fish-specific functions and private
# functions defined prior script evaluation: reduce this way the
# the number of functions to parse.
set getfunc "set funcout (string match -r -v \$funcfilter (functions\
-a -n) | while read f; functions \$f; echo '$subsep'; end)"
##nagelfar ignore +9 Found constant
set command "set -xgL; echo '$sep'; status test-feature\
regex-easyesc 2>/dev/null; and set escrepl '\\\\\\\\\$1'; or set\
escrepl '\\\\\\\\\\\\\\\$1'; set funcfilter \\^\\((string\
join '|' (string replace -r '(\\\[|\\.)' \$escrepl\
(builtin -n; functions -a -n | string split ', ' | string match\
-e -r '^_')))\\|fish\\.\\*\\)\\\$; $getfunc; $getfunc; string\
split \$funcout; echo '$sep'; string split \$funcout; echo\
'$sep'; complete; echo '$sep'; pwd; echo '$sep'; source [listTo\
shell $shdesc] 2>&1; or exit \$status; echo '$sep'; set -xgL;\
echo '$sep'; $getfunc; string split \$funcout; echo '$sep';\
string split \$funcout; echo '$sep'; complete; echo '$sep'; pwd"
set varre {^(\S+?\M) ?'?(.*?)'?$}
# exclude alias from function list
set funcre "^function (\\S+?)(?: \[^\\n\]*?--description\
(?!'?alias)\[^\\n\]+)?\\n(.+?)?\\s*\\nend\\n$subsep\$"
# fetch aliases from available functions
set aliasre "^function (\\S+?) \[^\\n\]*?--description\
'?alias\[^\\n\]+\\n\\s*(.+?)(?: \\\$argv)?\\s*\\nend\\n$subsep\$"
set compre {complete ((?:-\S+? )*?)(?:(?:-c|--command)\
)?([^-]\S+)(.*?)$}
set comprevar [list match valpart1 name valpart2]
# translate back fish-specific code
set varvalmap [list {' '} : {\'} ' {\"} \" \\\\ \\]
set alvalmap [list { $argv;} {}]
# fish builtins change LS_COLORS variable
lappend ignvarlist LS_COLORS
}
default {
knerror "Shell '$shell' not supported"
}
}
if {![file exists $script]} {
knerror "Script '$script' cannot be found"
}
set shellpath [getCommandPath $shell]
if {$shellpath eq {}} {
knerror "Shell '$shell' cannot be found"
}
set shellexec [list $shellpath {*}$shellopts -c $command]
reportDebug "running '$shellexec'"
if {[catch {set output [exec {*}$shellexec]} output]} {
set sherr 1
}
# link result variables to calling context
upvar cwdbefout cwdbefout cwdaftout cwdaftout
# extract each output sections
set idx 0
foreach varout {varbefout funcbefout aliasbefout compbefout cwdbefout\
scriptout varaftout funcaftout aliasaftout compaftout cwdaftout} {
##nagelfar vartype varout varName
if {[set sepidx [string first $sep $output $idx]] == -1} {
set $varout [string trimright [string range $output $idx end] \n]
if {$varout ne {cwdaftout} && !$sherr} {
knerror "Unexpected output when sourcing '$shdesc' in shell\
'$shell'"
}
} else {
set $varout [string trimright [string range $output $idx $sepidx-1]\
\n]
set idx [expr {$sepidx + [string length $sep] + 1}]
}
# remove expected Tcl error message
if {$sherr && $varout eq {scriptout} && [set erridx [string\
last {child process exited abnormally} [set $varout]]] != -1} {
set $varout [string range [set $varout] 0 $erridx-2]
}
}
if {$sepidx != -1 && !$sherr} {
knerror "Unexpected output when sourcing '$shdesc' in shell '$shell'"
}
reportDebug "script output is '$scriptout'"
if {$sherr} {
# throw error if script had an issue, send script output along if any
set errmsg "Script '$script' exited abnormally"
if {$scriptout ne {}} {
append errmsg "\n with following output\n$scriptout"
}
knerror $errmsg
}
# link result variables to calling context
upvar varbef varbef varaft varaft
upvar funcbef funcbef funcaft funcaft
upvar aliasbef aliasbef aliasaft aliasaft
upvar compbef compbef compaft compaft
# extract environment variable information
##nagelfar ignore Found constant
foreach {out arr} [list varbefout varbef varaftout varaft] {
##nagelfar vartype out varName
foreach {match name value} [regexp -all -inline -lineanchor $varre [set\
$out]] {
# convert shell-specific escaping
##nagelfar ignore Suspicious variable name
set ${arr}($name) [string map $varvalmap $value]
}
}
# extract function information if function supported by shell
if {[info exists funcre]} {
##nagelfar ignore Found constant
foreach {out arr} [list funcbefout funcbef funcaftout funcaft] {
foreach {match name value} [regexp -all -inline -lineanchor $funcre\
[set $out]] {
# no specific escaping to convert for functions
##nagelfar ignore Suspicious variable name
set ${arr}($name) $value
}
}
}
# extract alias information
##nagelfar ignore Found constant
foreach {out arr} [list aliasbefout aliasbef aliasaftout aliasaft] {
foreach {match name value} [regexp -all -inline -lineanchor $aliasre\
[set $out]] {
##nagelfar ignore Suspicious variable name
set ${arr}($name) [string map $alvalmap $value]
}
}
# extract complete information if supported by shell
if {[info exists compre]} {
##nagelfar ignore Found constant
foreach {out arr} [list compbefout compbef compaftout compaft] {
##nagelfar ignore Non constant variable list to foreach statement
foreach $comprevar [regexp -all -inline -lineanchor $compre [set\
$out]] {
if {[info exists valpart1]} {
##nagelfar ignore Unknown variable
set value [concat $valpart1 $valpart2]
}
# no specific escaping to convert for completes
##nagelfar ignore Suspicious variable name
lappend ${arr}($name) $value
}
}
}
}
# execute script with args through shell and convert environment changes into
# corresponding modulefile commands
proc sh-to-mod {args} {
set modcontent [list]
set pathsep [getState path_separator]
set shell [lindex $args 0]
# evaluate script and retrieve environment before and after evaluation
# procedure will set result variables in current context
##nagelfar implicitvarcmd {execShAndGetEnv *} ignvarlist cwdbefout\
cwdaftout varbef varaft funcbef funcaft aliasbef aliasaft compbef\
compaft
execShAndGetEnv {*}$args
# check environment variable change
lassign [getDiffBetweenArray varbef varaft] notaft diff notbef
foreach name $notaft {
# also ignore Modules variables intended for internal use
if {$name ni $ignvarlist && ![string equal -length 10 $name\
__MODULES_]} {
lappend modcontent [list unsetenv $name]
}
}
foreach name $diff {
if {$name ni $ignvarlist && ![string equal -length 10 $name\
__MODULES_]} {
# new value is totally different (also consider a bare ':' as a
# totally different value to avoid erroneous matches)
if {$varbef($name) eq $pathsep || [set idx [string first\
$varbef($name) $varaft($name)]] == -1} {
lappend modcontent [list setenv $name $varaft($name)]
} else {
# content should be prepended
if {$idx > 0} {
set modcmd [list prepend-path]
# check from the end to get the largest chunk to prepend
set idx [string last $varbef($name) $varaft($name)]
# get delimiter from char found between new and existing value
set delim [string index $varaft($name) $idx-1]
if {$delim ne $pathsep} {
lappend modcmd -d $delim
}
lappend modcmd $name
# split value and remove duplicate entries
set vallist [list]
appendNoDupToList vallist {*}[split [string range\
$varaft($name) 0 $idx-2] $delim]
# an empty element is added
if {[llength $vallist] == 0} {
lappend vallist {}
}
lappend modcontent [list {*}$modcmd {*}$vallist]
}
# content should be appended
if {($idx + [string length $varbef($name)]) < [string length\
$varaft($name)]} {
set modcmd [list append-path]
set delim [string index $varaft($name) $idx+[string length\
$varbef($name)]]
if {$delim ne $pathsep} {
lappend modcmd -d $delim
}
lappend modcmd $name
set vallist [list]
appendNoDupToList vallist {*}[split [string range\
$varaft($name) [expr {$idx + [string length $varbef($name)]\
+ 1}] end] $delim]
if {[llength $vallist] == 0} {
lappend vallist {}
}
lappend modcontent [list {*}$modcmd {*}$vallist]
}
}
}
}
foreach name $notbef {
if {$name ni $ignvarlist && ![string equal -length 10 $name\
__MODULES_]} {
if {[string first $pathsep $varaft($name)] == -1} {
lappend modcontent [list setenv $name $varaft($name)]
} else {
# define a path-like variable if path separator found in it
# split value and remove duplicate entries
set vallist [list]
appendNoDupToList vallist {*}[split $varaft($name) $pathsep]
lappend modcontent [list prepend-path $name {*}$vallist]
}
}
}
# check function change
lassign [getDiffBetweenArray funcbef funcaft] notaft diff notbef
foreach name $notaft {
lappend modcontent [list unset-function $name]
}
foreach name [list {*}$diff {*}$notbef] {
lappend modcontent [list set-function $name \n$funcaft($name)]
}
# check alias change
lassign [getDiffBetweenArray aliasbef aliasaft] notaft diff notbef
foreach name $notaft {
lappend modcontent [list unset-alias $name]
}
foreach name [list {*}$diff {*}$notbef] {
lappend modcontent [list set-alias $name $aliasaft($name)]
}
# check complete change
lassign [getDiffBetweenArray compbef compaft] notaft diff notbef
foreach name $notaft {
lappend modcontent [list uncomplete $name]
}
foreach name [list {*}$diff {*}$notbef] {
foreach body $compaft($name) {
lappend modcontent [list complete $shell $name $body]
}
}
# check current working directory change
if {$cwdbefout ne $cwdaftout} {
lappend modcontent [list chdir $cwdaftout]
}
# sort result to ensure consistent output whatever the evaluation shell
set modcontent [lsort -dictionary $modcontent]
reportDebug "resulting env changes '$modcontent'"
return $modcontent
}
proc source-sh {shell script args} {
# evaluate script and get the environment changes it performs translated
# into modulefile commands
set shtomodargs [list $shell $script {*}$args]
set modcontent [sh-to-mod {*}$shtomodargs]
# register resulting modulefile commands
setLoadedSourceSh [currentState modulename] [list $shtomodargs\
{*}$modcontent]
# get name of current module Tcl interp
set itrp [getCurrentModfileInterpName]
# evaluate resulting modulefile commands through current Tcl interp
foreach modcmd $modcontent {
interp eval $itrp $modcmd
}
}
# undo source-sh in unload mode
proc source-sh-un {shell script args} {
set shtomodargs [list $shell $script {*}$args]
set modsrcsh [getLoadedSourceSh [currentState modulename]]
# find commands resulting from source-sh evaluation recorded in env
if {[set idx [lsearch -exact $modsrcsh $shtomodargs]] != -1 } {
set modcontent [lindex $modsrcsh $idx+1]
} else {
set modcontent {}
}
# get name of current module unload Tcl interp
set itrp [getCurrentModfileInterpName]
# evaluate each recorded command in unload Tcl interp to get them reversed
foreach modcmd $modcontent {
interp eval $itrp $modcmd
}
}
# report underlying modulefile cmds in display mode
proc source-sh-di {shell script args} {
set shtomodargs [list $shell $script {*}$args]
# if module loaded, get as much content from environment as possible
if {[is-loaded [currentState modulename]]} {
set modsrcsh [getLoadedSourceSh [currentState modulename]]
# find commands resulting from source-sh evaluation recorded in env
if {[set idx [lsearch -exact $modsrcsh $shtomodargs]] != -1 } {
set reccontent [lindex $modsrcsh $idx+1]
} else {
set reccontent {}
}
# need to evaluate script to get alias/function/complete definition
execShAndGetEnv {*}$shtomodargs
set modcontent {}
foreach cmd $reccontent {
# build modulefile content to show with recorded elements in env and
# alias/function/complete definition obtained by reevaluating script
switch -- [lindex $cmd 0] {
complete {
set cpname [lindex $cmd 2]
if {[info exists compaft($cpname)]} {
set cpbodylist $compaft($cpname)
} else {
set cpbodylist [list {}]
}
foreach cpbody $cpbodylist {
lappend modcontent [list complete $shell $cpname $cpbody]
}
}
set-alias {
set alname [lindex $cmd 1]
if {[info exists aliasaft($alname)]} {
set albody $aliasaft($alname)
} else {
set albody {}
}
lappend modcontent [list set-alias $alname $albody]
}
set-function {
set fnname [lindex $cmd 1]
if {[info exists funcaft($fnname)]} {
set fnbody \n$funcaft($fnname)
} else {
set fnbody {}
}
lappend modcontent [list set-function $fnname $fnbody]
}
default {
lappend modcontent $cmd
}
}
}
# not loaded, so get full content from script evaluation
} else {
set modcontent [sh-to-mod {*}$shtomodargs]
}
# get name of current module unload Tcl interp
set itrp [getCurrentModfileInterpName]
# evaluate each recorded command in display Tcl interp to get them printed
foreach modcmd $modcontent {
interp eval $itrp $modcmd
}
}
# parse arguments set on a variant modulefile command
proc parseVariantCommandArgs {args} {
set dflvalue {}
set defdflvalue 0
set isboolean 0
set i 0
foreach arg $args {
incr i
if {[info exists nextargisval]} {
##nagelfar vartype nextargisval varName
set $nextargisval $arg
unset nextargisval
} else {
switch -glob -- $arg {
--default {
##nagelfar ignore Found constant
set nextargisval dflvalue
set defdflvalue 1
}
--boolean {
set isboolean 1
}
-* {
knerror "Invalid option '$arg'"
}
default {
set name $arg
# end option parsing: remaining elts are allowed values
break
}
}
set prevarg $arg
}
}
if {[info exists nextargisval]} {
knerror "Missing value for '$prevarg' option"
}
# check variant name and allowed values
if {![info exists name]} {
knerror {No variant name specified}
}
if {![string match {[A-Za-z0-9_]} [string index $name 0]]} {
knerror "Invalid variant name '$name'"
}
set values [lrange $args $i end]
if {$isboolean} {
if {[llength $values] > 0} {
knerror "No value should be defined for boolean variant '$name'"
} else {
set values {1 0 yes no true false on off}
}
} else {
foreach val $values {
if {[string is boolean -strict $val] && ![string is integer\
-strict $val]} {
knerror "Boolean value defined on non-boolean variant '$name'"
}
}
}
if {$defdflvalue && $isboolean} {
# default value should be bool if variant is boolean
if {![string is boolean -strict $dflvalue]} {
knerror "Boolean value is expected as default value for variant\
'$name'"
# translate default value in boolean canonical form (0 or 1)
} else {
set dflvalue [string is true -strict $dflvalue]
}
}
return [list $name $values $defdflvalue $dflvalue $isboolean]
}
proc variant {itrp args} {
# parse args
lassign [parseVariantCommandArgs {*}$args] name values defdflvalue\
dflvalue isboolean
# version variant is forbidden until specific implementation
if {$name eq {version}} {
knerror "'version' is a restricted variant name" MODULES_ERR_GLOBAL
}
# get variant list defined on command line
set vrlist [getVariantListFromVersSpec [currentState modulenamevr]]
# search for variant specification (most right-positionned value wins)
for {set i [expr {[llength $vrlist]-1}]} {$i >= 0} {incr i -1} {
lassign [lindex $vrlist $i] vrname vrvalue
if {$vrname eq $name} {
# translate value in boolean canonical form (0/1) if variant is bool
if {$isboolean && [string is boolean -strict $vrvalue]} {
set value [string is true -strict $vrvalue]
} else {
set value $vrvalue
}
set isdflval [expr {$defdflvalue && $dflvalue eq $value}]
break
}
}
# error if variant has not been specified unless a default is defined
if {![info exists isdflval]} {
if {$defdflvalue} {
set value $dflvalue
# 2 means default value automatically set
set isdflval 2
# no error if variant is undefined on display mode, return here not to
# set any variant-specific variable
} elseif {[currentState mode] eq {display}} {
return
} else {
set allowedmsg [expr {[llength $values] == 0 ? {} : "\nAllowed\
values are: $values"}]
knerror "No value specified for variant '$name'$allowedmsg"\
MODULES_ERR_GLOBAL
}
}
# check defined value
if {($isboolean && ![string is boolean -strict $value]) || (!$isboolean &&\
[llength $values] > 0 && $value ni $values)} {
# invalid value error is not a modulefile error
knerror "Invalid value '$value' for variant '$name'\nAllowed values\
are: $values" MODULES_ERR_GLOBAL
} else {
# instantiate variant in modulefile context
reportDebug "Set variant on $itrp: ModuleVariant($name) = '$value'"
$itrp eval set "{::ModuleVariant($name)}" "{$value}"
# after modfile interp ModuleVariant is unset by resetInterpState
# record variant for persistency (name value is-boolean is-default)
# unless module is currently unloading
if {[currentState mode] ne {unload}} {
setLoadedVariant [currentState modulename] [list $name $value\
$isboolean $isdflval]
}
}
}
# optimized variant command for whatis mode: init entry in ModuleVariant array
# to avoid variable being undefined when accessed during modulefile evaluation
proc variant-wh {itrp args} {
# parse args
lassign [parseVariantCommandArgs {*}$args] name values defdflvalue\
dflvalue isboolean
# instantiate variant in modulefile context to an empty value
reportDebug "Set variant on $itrp: ModuleVariant($name) = ''"
$itrp eval set "{::ModuleVariant($name)}" "{}"
}
proc getvariant {itrp args} {
# parse args
lassign [parseGetenvCommandArgs getvariant {*}$args] name valifundef\
returnval
if {[currentState mode] ne {display} || $returnval} {
if {[$itrp eval info exists "{::ModuleVariant($name)}"]} {
return [$itrp eval set "{::ModuleVariant($name)}"]
} else {
return $valifundef
}
} else {
return [sgr va "{$name}"]
}
}
proc require-fullname {} {
# test specified name is any alternative name of currently evaluating mod
# expect the default and parent dir name (which are considered unqualified)
if {![modEq [currentState specifiedname] [currentState modulename] eqspec\
1 4]} {
knerror {Module version must be specified to load module}\
MODULES_ERR_GLOBAL
}
}
proc prereqAllModfileCmd {tryload auto args} {
lassign [parsePrereqCommandArgs prereq-all {*}$args] tag_list optional\
opt_list args
# call prereq over each arg independently to emulate a prereq-all
foreach arg $args {
prereqAnyModfileCmd $tryload $auto {*}$opt_list $arg
}
}
proc always-load {args} {
lassign [parsePrereqCommandArgs always-load {*}$args] tag_list optional\
opt_list args
# append keep-loaded tag to the list, second tag list in opt_list will take
# over the initial list defined
lappend tag_list keep-loaded
lappend opt_list --tag [join $tag_list :]
# auto load is inhibited if currently in DepRe context
set auto [expr {[currentModuleEvalContext] eq {depre} ? {0} : {1}}]
# load all module specified
prereqAllModfileCmd 0 $auto {*}$opt_list {*}$args
}
proc family {name} {
# ensure name is valid to be part of the name of an environment variable
if {[string length $name] == 0 || ![regexp {^[A-Za-z0-9_]*$} $name]} {
knerror "Invalid family name '$name'"
}
# only one loaded module could provide a given family
conflict $name
# set name as an alias for currently loading module
setLoadedAltname [currentState modulename] al|$name
# set variable in environment to know what module name provides family
set upname [string toupper $name]
lassign [getModuleNameVersion] mod modname modversion
if {$modname eq {.}} {
set modname [currentState modulename]
}
setenv MODULES_FAMILY_$upname $modname
# also set Lmod-specific variable for compatibility
setenv LMOD_FAMILY_$upname $modname
}
proc family-un {name} {
# ensure name is valid to be part of the name of an environment variable
if {[string length $name] == 0 || ![regexp {^[A-Za-z0-9_]*$} $name]} {
knerror "Invalid family name '$name'"
}
# unset family-related environment variable
set upname [string toupper $name]
unsetenv MODULES_FAMILY_$upname
unsetenv LMOD_FAMILY_$upname
}
proc complete {shell name body} {
if {[string length $name] == 0} {
knerror "Invalid command name '$name'"
}
# append definition retaining for which shell they are made
# also some shells may set multiple definitions for a single name
lappend ::g_Completes($name) $shell $body
set ::g_stateCompletes($name) new
# current module is qualified for refresh evaluation
lappendState -nodup refresh_qualified [currentState modulename]
}
# undo complete in unload mode
proc complete-un {shell name body} {
return [uncomplete $name]
}
proc uncomplete {name} {
if {[string length $name] == 0} {
knerror "Invalid command name '$name'"
}
set ::g_Completes($name) {}
set ::g_stateCompletes($name) del
}
proc pushenv {var val} {
# save initial value in pushenv value stack
set pushvar [getPushenvVarName $var]
if {![info exists ::env($pushvar)] && [info exists ::env($var)]} {
prepend-path $pushvar &$::env($var)
}
# clean any previously defined reference counter array
unset-env [getModshareVarName $var] 1
# Set the variable for later use during the modulefile evaluation
set-env $var $val
# add this value to the stack associated to current module name in order to
# know what element to remove from stack when unloading
prepend-path $pushvar [currentState modulename]&$val
return {}
}
# undo pushenv in unload mode
proc pushenv-un {var val} {
# clean any existing reference counter array
unset-env [getModshareVarName $var] 1
# update value stack
set pushvar [getPushenvVarName $var]
if {[info exists ::env($pushvar)]} {
set pushlist [split $::env($pushvar) :]
# find value pushed by currently evaluated module and remove it
set popidx [lsearch -exact $pushlist [currentState modulename]&$val]
if {$popidx != -1} {
set pushlist [lreplace $pushlist $popidx $popidx]
remove-path --index $pushvar $popidx
}
if {[llength $pushlist] > 0} {
# fetch value on top of the stack
set validx [expr {[string first & [lindex $pushlist 0]] + 1}]
set popval [string range [lindex $pushlist 0] $validx end]
# restore top value if different from current one
# env array is used instead of get-env to know if envvar is undefined
if {![info exists ::env($var)] || $::env($var) ne $popval} {
set-env $var $popval
}
# if last element remaining in stack is the initial value prior first
# pushenv, then clear the stack totally
if {$validx == 1} {
remove-path --index $pushvar 0
}
} else {
unset-env $var 0 $val
}
} else {
# Add variable to the list of variable to unset in shell output code but
# set it in interp context as done on load mode for later use during the
# modulefile evaluation
unset-env $var 0 $val
}
return {}
}
# optimized pushenv for whatis mode (same approach than setenv-wh)
proc pushenv-wh {var val} {
if {![info exists ::env($var)]} {
set ::env($var) {}
}
return {}
}
# optimized variant command for scan mode: init entry in ModuleVariant array
# to avoid variable being undefined when accessed during modulefile evaluation
# record variant definition in structure for extra match search or report
proc variant-sc {itrp args} {
# parse args
lassign [parseVariantCommandArgs {*}$args] name values defdflvalue\
dflvalue isboolean
# remove duplicate possible values for boolean variant
if {$isboolean} {
set values {on off}
if {$defdflvalue} {
set dflvalue [expr {$dflvalue ? {on} : {off}}]
}
}
recordScanModuleElt [currentState modulename] $name variant
lappend ::g_scanModuleVariant([currentState modulename]) [list $name\
$values $defdflvalue $dflvalue $isboolean]
# instantiate variant in modulefile context to an empty value
reportDebug "Set variant on $itrp: ModuleVariant($name) = ''"
$itrp eval set "{::ModuleVariant($name)}" "{}"
}
proc setenv-sc {args} {
lassign [parseSetenvCommandArgs load set {*}$args] bhv var val
recordScanModuleElt [currentState modulename] $var setenv envvar
if {![info exists ::env($var)]} {
set ::env($var) {}
}
return {}
}
proc edit-path-sc {cmd args} {
lassign [parsePathCommandArgs $cmd load noop {*}$args] separator allow_dup\
idx_val ign_refcount bhv var path_list
recordScanModuleElt [currentState modulename] $var $cmd envvar
if {![info exists ::env($var)]} {
set ::env($var) {}
}
return {}
}
proc pushenv-sc {var val} {
recordScanModuleElt [currentState modulename] $var pushenv envvar
if {![info exists ::env($var)]} {
set ::env($var) {}
}
return {}
}
proc unsetenv-sc {args} {
lassign [parseUnsetenvCommandArgs load noop {*}$args] bhv var val
recordScanModuleElt [currentState modulename] $var unsetenv envvar
if {![info exists ::env($var)]} {
set ::env($var) {}
}
return {}
}
proc complete-sc {shell name body} {
if {[string length $name] == 0} {
knerror "Invalid command name '$name'"
}
recordScanModuleElt [currentState modulename] $name complete
}
proc uncomplete-sc {name} {
if {[string length $name] == 0} {
knerror "Invalid command name '$name'"
}
recordScanModuleElt [currentState modulename] $name uncomplete
}
proc set-alias-sc {alias what} {
recordScanModuleElt [currentState modulename] $alias set-alias
}
proc unset-alias-sc {alias} {
recordScanModuleElt [currentState modulename] $alias unset-alias
}
proc set-function-sc {function what} {
recordScanModuleElt [currentState modulename] $function set-function
}
proc unset-function-sc {function} {
recordScanModuleElt [currentState modulename] $function unset-function
}
proc chdir-sc {dir} {
recordScanModuleElt [currentState modulename] $dir chdir
}
proc family-sc {name} {
if {[string length $name] == 0 || ![regexp {^[A-Za-z0-9_]*$} $name]} {
knerror "Invalid family name '$name'"
}
recordScanModuleElt [currentState modulename] $name family
}
proc prereq-sc {args} {
lassign [parsePrereqCommandArgs prereq {*}$args] tag_list optional\
opt_list args
foreach modspec [parseModuleSpecification 0 0 0 0 {*}$args] {
recordScanModuleElt [currentState modulename] $modspec prereq\
prereq-any require
}
}
proc prereq-all-sc {args} {
lassign [parsePrereqCommandArgs prereq-all {*}$args] tag_list optional\
opt_list args
foreach modspec [parseModuleSpecification 0 0 0 0 {*}$args] {
recordScanModuleElt [currentState modulename] $modspec prereq-all\
depends-on require
}
}
proc always-load-sc {args} {
lassign [parsePrereqCommandArgs always-load {*}$args] tag_list optional\
opt_list args
foreach modspec [parseModuleSpecification 0 0 0 0 {*}$args] {
recordScanModuleElt [currentState modulename] $modspec always-load\
require
}
}
proc conflict-sc {args} {
foreach modspec [parseModuleSpecification 0 0 0 0 {*}$args] {
recordScanModuleElt [currentState modulename] $modspec conflict incompat
}
}
proc module-sc {command args} {
lassign [parseModuleCommandName $command help] command cmdvalid cmdempty
# ignore sub-commands that do not either load or unload
if {$command in {load load-any switch try-load unload}} {
# parse options to distinguish them from module version spec
lassign [parseModuleCommandArgs 0 $command 0 {*}$args] show_oneperline\
show_mtime show_filter search_filter search_match dump_state\
addpath_pos not_req tag_list args
set modspeclist [parseModuleSpecification 0 0 0 0 {*}$args]
if {$command eq {switch}} {
# distinguish switched-off module spec from switched-on
# ignore command without or with too much argument
switch -- [llength $modspeclist] {
{1} {
# no switched-off module with one-arg form
recordScanModuleElt [currentState modulename] $modspeclist\
switch switch-on require
}
{2} {
lassign $modspeclist swoffarg swonarg
recordScanModuleElt [currentState modulename] $swoffarg switch\
switch-off incompat
recordScanModuleElt [currentState modulename] $swonarg switch\
switch-on require
}
}
} else {
set xtalias [expr {$command eq {unload} ? {incompat} : {require}}]
# record each module spec
foreach modspec $modspeclist {
recordScanModuleElt [currentState modulename] $modspec $command\
$xtalias
}
}
}
}
proc recordScanModuleElt {mod name args} {
if {![info exists ::g_scanModuleElt]} {
set ::g_scanModuleElt [dict create]
}
foreach elt $args {
if {![dict exists $::g_scanModuleElt $elt]} {
dict set ::g_scanModuleElt $elt {}
}
if {![dict exists $::g_scanModuleElt $elt $name]} {
dict set ::g_scanModuleElt $elt $name [list $mod]
} else {
##nagelfar ignore Suspicious variable name
dict with ::g_scanModuleElt $elt {lappend $name $mod}
}
reportDebug "Module $mod defines $elt:$name"
}
}
# test given variant specification matches what scanned module defines
proc doesModVariantMatch {mod pvrlist} {
set ret 1
if {[info exists ::g_scanModuleVariant($mod)]} {
foreach availvr $::g_scanModuleVariant($mod) {
set availvrarr([lindex $availvr 0]) [lindex $availvr 1]
set availvrisbool([lindex $availvr 0]) [lindex $availvr 4]
}
foreach pvr $pvrlist {
set pvrarr([lindex $pvr 0]) [lindex $pvr 1]
set pvrisbool([lindex $pvr 0]) [lindex $pvr 2]
}
# no match if a specified variant is not found among module variants or
# if the value is not available
foreach vrname [array names pvrarr] {
# if variant is a boolean, specified value should be a boolean too
# any value accepted for free-value variant
if {![info exists availvrarr($vrname)] || ($availvrisbool($vrname)\
&& !$pvrisbool($vrname)) || (!$availvrisbool($vrname) && [llength\
$availvrarr($vrname)] > 0 && $pvrarr($vrname) ni\
$availvrarr($vrname))} {
set ret 0
break
}
}
} else {
set ret 0
}
return $ret
}
# collect list of modules matching all extra specifier criteria
proc getModMatchingExtraSpec {pxtlist} {
set res [list]
if {[info exists ::g_scanModuleElt]} {
foreach pxt $pxtlist {
lassign $pxt elt name
set one_crit_res [list]
if {$elt in {require incompat load unload prereq conflict prereq-all\
prereq-any depends-on always-load load-any try-load switch\
switch-on switch-off}} {
if {[dict exists $::g_scanModuleElt $elt]} {
foreach modspec [dict get $::g_scanModuleElt $elt] {
# modEq proc has been initialized in getModules phase #2
if {[modEq $modspec $name eqstart 1 5 1]} {
# possible duplicate module entry in result list
lappend one_crit_res {*}[dict get $::g_scanModuleElt\
$elt $modspec]
}
}
}
} else {
# get modules matching one simple extra specifier criterion
if {[dict exists $::g_scanModuleElt $elt $name]} {
set one_crit_res [dict get $::g_scanModuleElt $elt $name]
}
}
lappend all_crit_res $one_crit_res
# no match on one criterion means no match globally, no need to test
# further criteria
if {[llength $one_crit_res] == 0} {
break
}
}
# matching modules are those found in every criteria result
set res [getIntersectBetweenList {*}$all_crit_res]
}
return $res
}
# determine if current module search requires an extra match search
proc isExtraMatchSearchRequired {mod} {
# an extra match search is required if not currently inhibited and:
# * variant should be reported in output
# * mod specification contains variant during avail/paths/whatis
# * mod specification contains extra specifier during avail/paths/whatis
return [expr {![getState inhibit_ems 0] && ([isEltInReport variant 0] ||\
(([llength [getVariantListFromVersSpec $mod]] + [llength\
[getExtraListFromVersSpec $mod]]) > 0 && [currentState commandname] in\
{avail paths whatis}))}]
}
# perform extra match search on currently being built module search result
proc filterExtraMatchSearch {mod res_arrname versmod_arrname} {
# link to variables/arrays from upper context
upvar $res_arrname found_list
upvar $versmod_arrname versmod_list
# get extra match query properties
set spec_vr_list [getVariantListFromVersSpec $mod]
set check_variant [expr {[llength $spec_vr_list] > 0}]
set spec_xt_list [getExtraListFromVersSpec $mod]
set check_extra [expr {[llength $spec_xt_list] > 0}]
set filter_res [expr {$check_variant || $check_extra}]
# disable error reporting to avoid modulefile errors (not coping with scan
# evaluation for instance) to pollute result
set alreadyinhibit [getState inhibit_errreport]
if {!$alreadyinhibit} {
inhibitErrorReport
}
set unset_list {}
set keep_list {}
# evaluate all modules found in scan mode to gather content information
lappendState mode scan
foreach elt [array names found_list] {
switch -- [lindex $found_list($elt) 0] {
modulefile - virtual {
# skip evaluation of fully forbidden modulefile
if {![isModuleTagged $elt forbidden 0]} {
##nagelfar ignore Suspicious variable name
execute-modulefile [lindex $found_list($elt) 2] $elt $elt $elt\
0 0
}
}
}
# unset elements that do not match extra query
if {$filter_res} {
switch -- [lindex $found_list($elt) 0] {
alias {
# module alias does not hold properties to match extra query
lappend unset_list $elt
}
modulefile - virtual {
if {$check_variant && ![doesModVariantMatch $elt\
$spec_vr_list]} {
lappend unset_list $elt
} elseif {$check_extra} {
# know currently retained modules to later compute those
# to withdrawn
lappend keep_list $elt
}
}
}
}
}
lpopState mode
# get list of modules matching extra specifiers to determine those to not
# matching that need to be withdrawn from result
if {$check_extra} {
set extra_keep_list [getModMatchingExtraSpec $spec_xt_list]
lassign [getDiffBetweenList $keep_list $extra_keep_list]\
extra_unset_list
set unset_list [list {*}$unset_list {*}$extra_unset_list]
}
# unset marked elements
foreach elt $unset_list {
unset found_list($elt)
# also unset any symbolic version pointing to unset elt
if {[info exists versmod_list($elt)]} {
foreach eltsym $versmod_list($elt) {
# getModules phase #2 may have already withdrawn symbol
if {[info exists found_list($eltsym)]} {
unset found_list($eltsym)
}
}
}
}
# re-enable error report only is it was disabled from this procedure
if {!$alreadyinhibit} {
setState inhibit_errreport 0
}
}
# convert environment variable references in string to their values
# every local variable is prefixed by '0' to ensure they will not be
# overwritten through variable reference resolution process
proc resolvStringWithEnv {0str} {
# fetch variable references in string
set 0match_list [regexp -all -inline {\$[{]?([A-Za-z_][A-Za-z0-9_]*)[}]?}\
${0str}]
if {[llength ${0match_list}] > 0} {
# put in local scope every environment variable referred in string
for {set 0i 1} {${0i} < [llength ${0match_list}]} {incr 0i 2} {
set 0varname [lindex ${0match_list} ${0i}]
##nagelfar vartype 0varname varName
if {![info exists ${0varname}]} {
set ${0varname} [get-env ${0varname}]
}
}
# resolve variable reference with values (now in local scope)
set 0res [subst -nobackslashes -nocommands ${0str}]
} else {
set 0res ${0str}
}
reportDebug "'${0str}' resolved to '${0res}'"
return ${0res}
}
# deduce modulepath from modulefile and module name
proc getModulepathFromModuleName {modfile modname} {
return [string range $modfile 0 end-[string length /$modname]]
}
# deduce module name from modulefile and modulepath
proc getModuleNameFromModulepath {modfile modpath} {
return [string range $modfile [string length $modpath/] end]
}
# extract module name from modulefile and currently enabled modulepaths
proc findModuleNameFromModulefile {modfile} {
set ret {}
foreach modpath [getModulePathList] {
if {[string first $modpath/ $modfile/] == 0} {
set ret [getModuleNameFromModulepath $modfile $modpath]
break
}
}
return $ret
}
# extract modulepath from modulefile and currently enabled modulepaths
proc findModulepathFromModulefile {modfile} {
set ret {}
foreach modpath [getModulePathList] {
if {[string first $modpath/ $modfile/] == 0} {
set ret $modpath
break
}
}
return $ret
}
# Determine with a name provided as argument the corresponding module name,
# version and name/version. Module name is guessed from current module name
# when shorthand version notation is used. Both name and version are guessed
# from current module if name provided is empty. If 'name_relative_tocur' is
# enabled then name argument may be interpreted as a name relative to the
# current modulefile directory (useful for module-version and module-alias
# for instance).
proc getModuleNameVersion {{name {}} {name_relative_tocur 0}} {
set curmod [currentState modulename]
set curmodname [file dirname $curmod]
set curmodversion [file tail $curmod]
if {$name eq {}} {
set name $curmodname
set version $curmodversion
# check for shorthand version notation like "/version" or "./version"
# only if we are currently interpreting a modulefile or modulerc
} elseif {$curmod ne {} && [regexp {^\.?\/(.*)$} $name match version]} {
# if we cannot distinguish a module name, raise error when shorthand
# version notation is used
if {[currentState modulefile] ne $curmod && $curmod ne {.modulerc}} {
# name is the name of current module directory
set name $curmodname
} else {
reportError "Invalid modulename '$name' found"
return {}
}
} else {
set name [string trimright $name /]
set version [file tail $name]
if {$name eq $version} {
set version {}
} else {
set name [file dirname $name]
}
# name may correspond to last part of current module
# if so name is replaced by current module name
if {$name_relative_tocur && [file tail $curmodname] eq $name} {
set name $curmodname
}
}
if {$version eq {}} {
set mod $name
} else {
set mod $name/$version
}
return [list $mod $name $version]
}
# Register alias or symbolic version deep resolution in a global array that
# can be used thereafter to get in one query the actual modulefile behind
# a virtual name. Also consolidate a global array that in the same manner
# list all the symbols held by modulefiles.
proc setModuleResolution {mod target {symver {}} {override_res_path 1}\
{auto_symver 0}} {
global g_moduleResolved g_resolvedHash g_resolvedPath g_symbolHash
# find end-point module and register step-by-step path to get to it
set res $target
lappend res_path $res
while {$mod ne $res && [info exists g_resolvedPath($res)]} {
set res $g_resolvedPath($res)
lappend res_path $res
}
# error if resolution end on initial module
if {$mod eq $res} {
reportError "Resolution loop on '$res' detected"
return 0
}
# module name will be useful when registering symbol
if {$symver ne {}} {
lassign [getModuleNameVersion $mod] modfull modname
}
# change default symbol owner if previously given; auto symbol are defined
# only if no default is pre-existing
if {$symver eq {default} && !$auto_symver} {
# alternative name "modname" is set when mod = "modname/default" both
# names will be registered to be known for queries and resolution defs
set modalt $modname
if {[info exists g_moduleResolved($mod)]} {
set prev $g_moduleResolved($mod)
# there may not be a default in case of auto symbol
if {[info exists g_symbolHash($prev)] && [set idx [lsearch -exact\
$g_symbolHash($prev) default]] != -1} {
reportDebug "remove symbol 'default' from '$prev'"
set g_symbolHash($prev) [lreplace $g_symbolHash($prev) $idx $idx]
}
}
}
# register end-point resolution
reportDebug "$mod resolved to $res"
set g_moduleResolved($mod) $res
# set first element of resolution path only if not already set or
# scratching enabled, no change when propagating symbol along res path
if {$override_res_path || ![info exists g_resolvedPath($mod)]} {
set g_resolvedPath($mod) $target
}
lappend g_resolvedHash($res) $mod
# also register resolution on alternative name if any
if {[info exists modalt]} {
reportDebug "$modalt resolved to $res"
set g_moduleResolved($modalt) $res
if {$override_res_path || ![info exists g_resolvedPath($modalt)]} {
set g_resolvedPath($modalt) $target
}
lappend g_resolvedHash($res) $modalt
# register name alternative to know their existence
set ::g_moduleAltName($modalt) $mod
set ::g_moduleAltName($mod) $modalt
}
# if other modules were pointing to this one, adapt resolution end-point
set relmod_list {}
if {[info exists g_resolvedHash($mod)]} {
set relmod_list $g_resolvedHash($mod)
unset g_resolvedHash($mod)
}
# also adapt resolution for modules pointing to the alternative name
if {[info exists modalt] && [info exists g_resolvedHash($modalt)]} {
lappend relmod_list {*}$g_resolvedHash($modalt)
unset g_resolvedHash($modalt)
}
foreach relmod $relmod_list {
set g_moduleResolved($relmod) $res
reportDebug "$relmod now resolved to $res"
lappend g_resolvedHash($res) $relmod
}
# register and propagate symbols to the resolution path, exception made for
# auto symbol which are stored separately and not propagated
if {[info exists g_symbolHash($mod)]} {
set sym_list $g_symbolHash($mod)
} else {
set sym_list {}
}
if {$symver ne {} && $auto_symver} {
reportDebug "define auto symbolic version '$mod' targeting $target"
set ::g_autoSymbol($mod) $target
} elseif {$symver ne {} && !$auto_symver} {
# merge symbol definitions in case of alternative name
if {[info exists modalt] && [info exists g_symbolHash($modalt)]} {
set sym_list [lsort -dictionary -unique [list {*}$sym_list\
{*}$g_symbolHash($modalt)]]
reportDebug "set symbols '$sym_list' to $mod and $modalt"
set g_symbolHash($mod) $sym_list
set g_symbolHash($modalt) $sym_list
}
# dictionary-sort symbols and remove eventual duplicates
set sym_list [lsort -dictionary -unique [list {*}$sym_list $symver]]
# propagate symbols in g_symbolHash and g_moduleVersion toward the
# resolution path, handle that locally if we still work on same
# modulename, call for a proper resolution as soon as we change of
# module to get this new resolution registered
foreach modres $res_path {
lassign [getModuleNameVersion $modres] modfull modresname
if {$modname eq $modresname} {
if {[info exists g_symbolHash($modres)]} {
set modres_sym_list [lsort -dictionary -unique [list\
{*}$g_symbolHash($modres) {*}$sym_list]]
} else {
set modres_sym_list $sym_list
}
# sync symbols of alternative name if any
if {[info exists ::g_moduleAltName($modres)]} {
set altmodres $::g_moduleAltName($modres)
reportDebug "set symbols '$modres_sym_list' to $modres and\
$altmodres"
set g_symbolHash($altmodres) $modres_sym_list
} else {
reportDebug "set symbols '$modres_sym_list' to $modres"
}
set g_symbolHash($modres) $modres_sym_list
# register symbolic version for querying in g_moduleVersion
foreach symelt $sym_list {
set modvers $modresname/$symelt
reportDebug "module-version $modvers = $modres"
set ::g_moduleVersion($modvers) $modres
set ::g_sourceVersion($modvers) [currentState modulefile]
# record eventual missing resolution
if {![info exists g_moduleResolved($modvers)]} {
set g_moduleResolved($modvers) $modres
reportDebug "$modvers resolved to $modres"
lappend g_resolvedHash($modres) $modvers
}
}
# as we change of module name a proper resolution call should be
# made (see below) and will handle the rest of the resolution path
} else {
set need_set_res 1
break
}
}
# when registering an alias, existing symbols on alias source name should
# be broadcast along the resolution path with a proper resolution call
# (see below)
} else {
lassign [getModuleNameVersion $target] modres modresname
set need_set_res 1
}
# resolution needed to broadcast symbols along resolution path without
# altering initial path already set for these symbols
if {[info exists need_set_res]} {
foreach symelt $sym_list {
set modvers $modresname/$symelt
reportDebug "set resolution for $modvers"
setModuleResolution $modvers $modres $symelt 0
}
}
return 1
}
# retrieve all names that resolve to passed mod
proc getAllModuleResolvedName {mod {flag_type 0} {modspec {}} {filter_default\
0}} {
set namelist {}
set resmodlist {}
set icase [isIcase]
defineModEqProc $icase [getConf extended_default]
# get parent directories of mod
foreach modelt [split $mod /] {
if {[info exists modroot]} {
append modroot /
}
append modroot $modelt
lappend resmodlist $modroot
}
set modpar [file dirname $mod]
set moddfl $modpar/default
# add additionally all the altnames set on directories, parents of mod
# or on distant directories whose default version resolves to mod
for {set i 0} {$i < [llength $resmodlist]} {incr i 1} {
set modelt [getArrayKey ::g_resolvedHash [lindex $resmodlist $i] $icase]
if {[info exists ::g_resolvedHash($modelt)]} {
foreach resmod $::g_resolvedHash($modelt) {
# if alternative name corresponds to one root name test if default
# symbol is hidden
set resmoddfl [expr {[lsearch -exact $resmodlist $resmod] != -1 ?\
"$resmod/default" : {}}]
# if alternative name corresponds to default symbol and is hidden
# test if query matches bare module name
set resmodpar [expr {[file tail $resmod] eq {default} ? [file\
dirname $resmod] : {}}]
# if modelt is not a parent directory of mod, check its resolution
# points to mod (directly for alias/sym or indirectly for dir
# whose default version bridge resolution toward mod)
# if modspec arg is set, exclude hidden entries not explicitly
# matching modspec. auto symbols cannot be hidden
# if filter_default is asked, skip parent module name and /default
# symbol name from result list
if {($modspec eq {} || ([info exists ::g_autoSymbol($resmod)] &&\
$::g_autoSymbol($resmod) eq $mod) || (![isModuleHidden $resmod\
$modspec] && ($resmoddfl eq {} || ![isModuleHidden $resmoddfl\
$modspec])) || [modEq $modspec $resmod eqspec] || ($resmodpar\
ne {} && [modEq $modspec $resmodpar eqspec])) && ([modEq\
$modelt $mod eqstart] || $::g_moduleResolved($resmod) eq $mod\
|| $mod eq [lindex [getPathToModule\
$::g_moduleResolved($resmod) {} 0] 1]) && (!$filter_default ||\
(![modEq $resmod $modpar] && ![modEq $resmod $moddfl]))} {
# prefix automatically generated syms with type flag if asked
if {$flag_type && [info exists ::g_moduleAlias($resmod)]} {
appendNoDupToList namelist al|$resmod
} elseif {$flag_type && [info exists\
::g_autoSymbol($resmod)]} {
appendNoDupToList namelist as|$resmod
} else {
appendNoDupToList namelist $resmod
}
unset modroot
foreach reselt [split [file dirname $resmod] /] {
if {[info exists modroot]} {
append modroot /
}
append modroot $reselt
appendNoDupToList resmodlist $modroot
}
}
}
}
}
return $namelist
}
# build list for a given loaded module of its alternative names plus its
# simplified names (name minus version or any subdir if this version or subdir
# are the implicit default for module)
proc getLoadedAltAndSimplifiedName {mod} {
if {[isModuleFullPath $mod]} {
set namelist [list $mod]
# use already computed name list if any
} elseif {[info exists ::g_loadedAltAndSimplifiedName($mod)]} {
set namelist $::g_loadedAltAndSimplifiedName($mod)
} else {
# get recorded alternative name
set namelist [getLoadedAltname $mod]
# also look through modpaths for simplified mod name
set modpathlist [getModulePathList]
if {[llength $modpathlist] > 0} {
set modfile [getModulefileFromLoadedModule $mod]
set parentmod [file dirname $mod]
# simplify to parent name as long as it resolves to current mod
while {$parentmod ne {.}} {
lassign [getPathToModule $parentmod $modpathlist 0] parentfile
if {$parentfile eq $modfile} {
lappend namelist $parentmod
set parentmod [file dirname $parentmod]
} else {
set parentmod .
}
}
}
# recorded computed name list for later use
set ::g_loadedAltAndSimplifiedName($mod) $namelist
}
return $namelist
}
# return value list of a loaded module property by parsing corresponding
# environment variable
proc getLoadedModulePropertyList {prop {filter_empty 1}} {
switch -- $prop {
name {
set envvar LOADEDMODULES
set subsplit 0
}
file {
set envvar _LMFILES_
set subsplit 0
}
modulepath {
set envvar MODULEPATH
set subsplit 0
}
default {
set envvar __MODULES_LM[string toupper $prop]
set subsplit [expr {$prop ni {init refresh}}]
if {$prop in {altname conflict}} {
set nosubsubsplit 1
}
}
}
switch -- $prop {
conflict - prereq - init {
set unserialize_map {< :}
}
sourcesh {
set unserialize_submap [list <EnvModEscPS> [getState path_separator]\
<EnvModEscS1> [getState sub1_separator]\
<EnvModEscS2> [getState sub2_separator]]
}
}
set res_list [list]
foreach elt [split [get-env $envvar] [getState path_separator]] {
if {$subsplit} {
set sub1sep [getState sub1_separator]
set sub2sep [getState sub2_separator]
# unserialize content of environment variable if map translation set
if {[info exists unserialize_map]} {
set elt [string map $unserialize_map $elt]
}
set subelt_list [split $elt $sub1sep]
# ignore empty element (1 is meaningless as first elt is loaded mod)
if {[llength $subelt_list] > 1 || !$filter_empty} {
set subres_list {}
foreach subelt $subelt_list {
# keep first arg as string and other args as lists (unless if
# subelt should not be split)
if {[llength $subres_list] > 0 && ![info exists\
nosubsubsplit]} {
set subelt [split $subelt $sub2sep]
# skip empty value element
if {[llength $subelt] == 0 && $filter_empty} {
continue
}
}
if {[info exists unserialize_submap]} {
set subelt [string map $unserialize_submap $subelt]
}
lappend subres_list $subelt
}
lappend res_list $subres_list
}
} else {
# ignore empty element
if {$elt ne {} || !$filter_empty} {
# unserialize content of env variable if map translation set
if {[info exists unserialize_map]} {
set elt [string map $unserialize_map $elt]
}
lappend res_list $elt
}
}
}
return $res_list
}
# return list of module paths by parsing MODULEPATH env variable
# behavior param enables to exit in error when no MODULEPATH env variable
# is set. by default an empty list is returned if no MODULEPATH set
# resolv_var param tells if environment variable references in path elements
# should be resolved or passed as-is in result list
# set_abs param applies an absolute path name conversion to path elements
# if enabled
proc getModulePathList {{behavior returnempty} {resolv_var 1} {set_abs 1}} {
if {![info exists ::env(MODULEPATH)] && $behavior eq {exiterronundef}} {
reportErrorAndExit {No module path defined}
}
set modpath_list [list]
foreach modpath [getLoadedModulePropertyList modulepath] {
if {$resolv_var} {
set modpath [resolvStringWithEnv $modpath]
}
if {$set_abs} {
set modpath [getAbsolutePath $modpath]
}
appendNoDupToList modpath_list $modpath
}
return $modpath_list
}
# return list of the configured and existing global RC files
proc getGlobalRcFileList {} {
set rclist {}
if {[set rcfile [getConf rcfile]] ne {}} {
# if MODULERCFILE is a dir, look at a modulerc file in it
if {[file isdirectory $rcfile] && [file isfile $rcfile/modulerc]} {
lappend rclist $rcfile/modulerc
} elseif {[file isfile $rcfile]} {
lappend rclist $rcfile
}
}
if {[file isfile {/etc/environment-modules/rc}]} {
lappend rclist {/etc/environment-modules/rc}
}
# ignore user rc if relative configuration is enabled
if {![getConf ignore_user_rc] && [info exists ::env(HOME)] && [file isfile\
$::env(HOME)/.modulerc]} {
lappend rclist $::env(HOME)/.modulerc
}
set readable_rclist {}
foreach rc $rclist {
if {[file readable $rc]} {
lappend readable_rclist $rc
}
}
return $readable_rclist
}
proc getModuleTag {mod tag {cmp eqstart} {return_rule 0}} {
set modroot [getModuleRootFromVersSpec $mod]
# look if mod matches one of the module specs applying to mod root
if {[info exists ::g_moduleTagRoot($modroot)]} {
set idx [lsearch -exact $::g_moduleTagRoot($modroot) $tag]
if {$idx == -1} {
return {}
} else {
foreach {tmodspec tprops} [lindex $::g_moduleTagRootSpec($modroot)\
$idx] {
# first matching module spec wins with its properties
if {[modEq $tmodspec $mod $cmp 1 0 1]} {
if {$return_rule} {
return $tmodspec
} else {
return [list $tag $tprops]
}
}
}
}
}
return {}
}
proc isModuleTagged {mod tag {collected 0}} {
# retrieve tag information from collected tags or raw info
if {$collected} {
return [expr {$tag in [getTagList $mod]}]
} else {
return [expr {[llength [getModuleTag $mod $tag]] != 0}]
}
}
proc getTaggedLoadedModuleList {tag} {
set modlist [list]
foreach mod [getLoadedModulePropertyList name] {
if {[isModuleTagged $mod $tag 1]} {
lappend modlist $mod
}
}
return $modlist
}
proc getModuleTagProp {mod tag prop} {
set ret {}
array set tags [getModuleTag $mod $tag]
if {[info exists tags($tag)]} {
array set props $tags($tag)
if {[info exists props($prop)]} {
set ret $props($prop)
}
}
return $ret
}
# Gather all tags applying to a given module
proc collectModuleTags {mod} {
set modroot [getModuleRootFromVersSpec $mod]
# look if mod matches one of the module specs applying to mod root
if {[info exists ::g_moduleTagRoot($modroot)]} {
for {set i 0} {$i < [llength $::g_moduleTagRoot($modroot)]} {incr i} {
set tag [lindex $::g_moduleTagRoot($modroot) $i]
# skip already known tag
if {![info exists ::g_tagHash($mod)] || $tag ni $::g_tagHash($mod)} {
foreach {tmodspec tprops} [lindex\
$::g_moduleTagRootSpec($modroot) $i] {
# add tag if one modspec matches mod
if {[modEq $tmodspec $mod eqstart 1 0 1]} {
setModuleTag $mod $tag
break
}
}
}
}
}
}
proc setModuleTag {mod args} {
appendNoDupToList ::g_tagHash($mod) {*}$args
}
proc setModuleExtraTag {mod args} {
appendNoDupToList ::g_extraTagHash($mod) {*}$args
}
proc unsetModuleTag {mod args} {
if {[info exists ::g_tagHash($mod)]} {
lassign [getDiffBetweenList $::g_tagHash($mod) $args] diff_list
if {[llength $diff_list] > 0} {
set ::g_tagHash($mod) $diff_list
} else {
unset ::g_tagHash($mod)
}
}
}
proc unsetModuleExtraTag {mod args} {
if {[info exists ::g_extraTagHash($mod)]} {
lassign [getDiffBetweenList $::g_extraTagHash($mod) $args] diff_list
if {[llength $diff_list] > 0} {
set ::g_extraTagHash($mod) $diff_list
} else {
unset ::g_extraTagHash($mod)
}
}
}
proc getTagList {mod {sort 1}} {
if {[info exists ::g_tagHash($mod)]} {
if {$sort} {
set ret [lsort -dictionary $::g_tagHash($mod)]
} else {
set ret $::g_tagHash($mod)
}
reportDebug "'$mod' has tag list '$ret'"
} else {
set ret {}
}
return $ret
}
# return tags applying to mod that can be exported
proc getExportTagList {mod {serialized 0}} {
# remove loaded/hidden tags from the list to register
lassign [getDiffBetweenList [getTagList $mod 0] [list loaded hidden]] ret
if {$serialized && [llength $ret] > 0} {
# extract mod name and version from full spec with variants
set ret [join [list [getModuleNameAndVersFromVersSpec $mod] {*}$ret]\
[getState sub1_separator]]
}
return $ret
}
# return extra tags set on mod
proc getExtraTagList {mod {serialized 0}} {
if {[info exists ::g_extraTagHash($mod)]} {
if {$serialized} {
# extract mod name and version from full spec with variants
set ret [join [list [getModuleNameAndVersFromVersSpec $mod]\
{*}$::g_extraTagHash($mod)] [getState sub1_separator]]
} else {
set ret $::g_extraTagHash($mod)
}
} else {
set ret {}
}
return $ret
}
# return tags set on mod to record in collection
proc getSaveTagList {mod} {
# return all tags if pin tag is enabled, except nearly-forbidden that is
# not intended for save
if {[getConf collection_pin_tag]} {
lassign [getDiffBetweenList [getExportTagList $mod] [list\
nearly-forbidden]] ret
} else {
set ret [getExtraTagList $mod]
# in addition to those set with --tag option, add tags obtained by the
# way mod has been loaded
if {[isModuleTagged $mod auto-loaded 1]} {
lappend ret auto-loaded
}
if {[isModuleTagged $mod keep-loaded 1]} {
lappend ret keep-loaded
}
}
return $ret
}
proc abbrevTagList {taglist} {
set ret [list]
foreach tag $taglist {
if {[info exists ::g_tagAbbrev($tag)]} {
# empty string abbrev means no tag report
if {$::g_tagAbbrev($tag) ne {}} {
lappend ret $::g_tagAbbrev($tag)
}
} else {
lappend ret $tag
}
}
return [lsort -dictionary $ret]
}
proc getVariantList {mod {report 0} {excl_dflval 0} {from 0}} {
set vrspeclist {}
set loadedsgrkey {}
# fetch variant information from
switch -- $from {
0 {
# variant set after module being loaded
if {[info exists ::g_loadedModuleVariant($mod)]} {
set vrspeclist $::g_loadedModuleVariant($mod)
}
}
1 {
# module specification
set vrspeclist [getVariantListFromVersSpec $mod]
}
2 {
# variant definition collected during scan evaluation
if {[info exists ::g_scanModuleVariant($mod)]} {
set vrspeclist $::g_scanModuleVariant($mod)
}
# if module is currently loaded, gather its variant values
if {[info exists ::g_loadedModuleVariant($mod)]} {
foreach lovrspec $::g_loadedModuleVariant($mod) {
lassign $lovrspec lovrname lovrvalue lovrvalisbool lovrvalisdfl
if {$lovrvalisbool} {
set lovrvalue [expr {$lovrvalue ? {on} : {off}}]
}
set lovrarr($lovrname) $lovrvalue
}
# get sgr key corresponding to loaded tag (if tag reported)
if {$report == 7 && [isEltInReport tag]} {
set loadedkind [expr {[isModuleTagged $mod auto-loaded 1] ?\
{auto-loaded} : {loaded}}]
lassign [abbrevTagList [list $loadedkind]] loadedsgrkey
}
}
}
}
# use array to make variant unique
foreach vrspec $vrspeclist {
if {$from == 2} {
# report all available variant values on avail
lassign $vrspec vrname vrvalues vrdefdflval vrdflval
set vrvalisbool 0
set vrvalisdfl 0
# build value list to output for free-variant value
if {[llength $vrvalues] == 0} {
# if module is loaded, add loaded variant value
if {[info exists lovrarr($vrname)]} {
lappend vrvalues $lovrarr($vrname)
}
# if a default value is defined, add it to possible value list
if {$vrdefdflval && $vrdflval ni $vrvalues} {
lappend vrvalues $vrdflval
}
# indicate on free-value variant that all values are possible
lappend vrvalues *
}
} else {
lassign $vrspec vrname vrvalue vrvalisbool vrvalisdfl
set vrvalues [list $vrvalue]
}
# correct is-default value if invalid
if {![string is integer -strict $vrvalisdfl]} {
set vrvalisdfl 0
}
# correct is-boolean value if invalid
if {![string is boolean -strict $vrvalisbool]} {
set vrvalisbool 0
}
set vrisbool($vrname) $vrvalisbool
# correct boolean value if invalid
if {$vrvalisbool && ![string is boolean -strict $vrvalue]} {
set vrvalue 0
}
# do not return variant if value is default, unless if variant was
# specifically set to default value (isdfl=1) and we only want to
# exclude the automatically set default value (excl_dflval=2)
if {$excl_dflval > 0} {
if {$vrvalisdfl == 0 || ($excl_dflval == 2 && $vrvalisdfl == 1)} {
set vrarr($vrname) $vrvalue
# nullify previous duplicate definition if this one is default
} elseif {[info exists vrarr($vrname)]} {
unset vrarr($vrname)
}
} else {
if {$report == 7} {
# indicate what value in the list is the default one
if {[info exists vrdefdflval]} {
set vrdflidxarr($vrname) [expr {$vrdefdflval ? [lsearch -exact\
$vrvalues $vrdflval] : {-1}}]
} else {
set vrdflidxarr($vrname) [expr {$vrvalisdfl ? {0} : {-1}}]
}
# indicate what value in the list is the loaded one
set vrloidxarr($vrname) [expr {[info exists lovrarr($vrname)] ?\
[lsearch -exact $vrvalues $lovrarr($vrname)] : {-1}}]
if {$vrvalisbool} {
set vrarr($vrname) $vrvalue
} else {
set vrarr($vrname) $vrvalues
}
# is-default hint has to be transmitted on report mode '3'
} elseif {$report == 3} {
set vrarr($vrname) [list $vrvalue [expr {$vrvalisdfl > 0 &&\
$vrvalisdfl < 3}]]
} else {
set vrarr($vrname) $vrvalue
}
}
}
# sort variant to report
set ret {}
foreach vrname [lsort -dictionary [array names vrarr]] {
switch -- $report {
4 {lappend ret $vrname $vrarr($vrname) $vrisbool($vrname)}
3 {lappend ret $vrname [lindex $vrarr($vrname) 0] [lindex\
$vrarr($vrname) 1]}
2 {lappend ret [list $vrname $vrarr($vrname) $vrisbool($vrname)]}
1 - 5 - 6 {
if {$vrisbool($vrname)} {
if {$vrarr($vrname)} {
lappend ret +$vrname
# track if +var variant has been reported to build key
# unless if key should not be updated (report mode '6')
if {$report != 6 && ![info exists ::g_used_va(on)]} {
set ::g_used_va(on) 1
}
} else {
lappend ret -$vrname
# track if -var variant has been reported to build key
# unless if key should not be updated (report mode '6')
if {$report != 6 && ![info exists ::g_used_va(off)]} {
set ::g_used_va(off) 1
}
}
# use defined shortcut to report if any set for this variant
# ignore shortcut if report=5 (when saving collection)
} elseif {$report != 5 && [info exists\
::g_variantShortcut($vrname)]} {
set sc $::g_variantShortcut($vrname)
lappend ret $sc$vrarr($vrname)
# track if variant shortcut has been reported to build key
# unless if key should not be updated (report mode '6')
if {$report != 6 && ![info exists ::g_used_va($sc)]} {
set ::g_used_va($sc) $vrname
}
} else {
lappend ret $vrname=$vrarr($vrname)
# track if var=val variant has been reported to build key
# unless if key should not be updated (report mode '6')
if {$report != 6 && ![info exists ::g_used_va(val)]} {
set ::g_used_va(val) 1
}
}
}
7 {
if {$vrisbool($vrname)} {
if {$vrarr($vrname)} {
lappend ret [list $vrname {} [list +$vrname]\
$vrdflidxarr($vrname) $vrloidxarr($vrname) $loadedsgrkey]
# track if +var variant has been reported to build key
if {![info exists ::g_used_va(on)]} {
set ::g_used_va(on) 1
}
} else {
lappend ret [list $vrname {} [list -$vrname]\
$vrdflidxarr($vrname) $vrloidxarr($vrname) $loadedsgrkey]
# track if -var variant has been reported to build key
if {![info exists ::g_used_va(off)]} {
set ::g_used_va(off) 1
}
}
# use defined shortcut to report if any set for this variant
# ignore shortcut if report=5 (when saving collection)
} elseif {$report != 5 && [info exists\
::g_variantShortcut($vrname)]} {
set sc $::g_variantShortcut($vrname)
lappend ret [list $vrname $sc $vrarr($vrname)\
$vrdflidxarr($vrname) $vrloidxarr($vrname) $loadedsgrkey]
# track if variant shortcut has been reported to build key
# unless if key should not be updated (report mode '6')
if {$report != 6 && ![info exists ::g_used_va($sc)]} {
set ::g_used_va($sc) $vrname
}
} else {
lappend ret [list $vrname $vrname= $vrarr($vrname)\
$vrdflidxarr($vrname) $vrloidxarr($vrname) $loadedsgrkey]
# track if var=val variant has been reported to build key
# unless if key should not be updated (report mode '6')
if {$report != 6 && ![info exists ::g_used_va(val)]} {
set ::g_used_va(val) 1
}
}
}
0 {lappend ret $vrname $vrarr($vrname)}
}
}
return $ret
}
proc isModuleDotHidden {mod} {
foreach elt [split $mod /] {
if {[string index $elt 0] eq {.}} {
return 1
}
}
return 0
}
proc getModuleHidingLevel {mod} {
set modroot [lindex [file split $mod] 0]
# look if mod matches one of the hidden module specs applying to mod root
if {[info exists ::g_moduleHideRoot($modroot)]} {
for {set lvl 2} {$lvl > -1} {incr lvl -1} {
foreach hmodspec [lindex $::g_moduleHideRoot($modroot) $lvl] {
if {[modEq $hmodspec $mod eqstart 1 0 1 {}]} {
return $lvl
}
}
}
}
return -1
}
proc setModspecHidingLevel {modspec lvl} {
# skip record if an higher hiding level is already set
if {![info exists ::g_moduleHide($modspec)] || $lvl >\
$::g_moduleHide($modspec)} {
reportDebug "Record hidden module specification '$modspec' (lvl=$lvl)"
set ::g_moduleHide($modspec) $lvl
# record hidden mod spec for mod root to optimize search
set modroot [getModuleRootFromVersSpec $modspec]
if {![info exists ::g_moduleHideRoot($modroot)]} {
set ::g_moduleHideRoot($modroot) [list [list] [list] [list]]
}
# record in list corresponding to hidden level to search from strongest
# to weakest hidden level
set hiderootlvllist [lindex $::g_moduleHideRoot($modroot) $lvl]
lappend hiderootlvllist $modspec
lset ::g_moduleHideRoot($modroot) $lvl $hiderootlvllist
}
}
# test if mod is declared hidden or has one element in its name starting with
# dot character. mod is considered hidden depending on their hiding level,
# current search query and hiding threshold. when retdetails option is
# enabled, mod hiding level and query match hind are also returned
proc isModuleHidden {mod {modspec {}} {retdetails 0}} {
set defhidlvl [set hidlvl [getModuleHidingLevel $mod]]
if {$hidlvl >= [getState hiding_threshold]} {
# soft hidden mods are considered matched if their root name matches
# search query, other kind of hidden mods must fully matches query
set hidmatch [expr {$hidlvl == 0 ? [modStartNb $mod $modspec] > 0 :\
[modEq $modspec $mod eqspec]}]
} else {
set hidlvl -1
set hidmatch 0
}
if {$hidlvl < 1 && [set isdot [isModuleDotHidden $mod]] && [getState\
hiding_threshold] < 1} {
set hidlvl 1
# dot hidden are considered matched if remaining string part after
# search query is not dot hidden
set hidmatch [expr {[set i [modStartNb $mod $modspec]] > 0 &&\
![isModuleDotHidden [join [lrange [file split $mod] $i end] /]]}]
}
# hidden if hiding level greater or equal hiding threshold and not
# matched or if matched hard hiding level are kept hidden
set ishid [expr {$hidlvl != -1 && (!$hidmatch || $hidlvl > 1)}]
# is module hidden by definition (whatever hiding threshold or match)
set hidbydef [expr {$defhidlvl > 0 || ([info exists isdot] && $isdot)}]
set ret [expr {$retdetails ? [list $hidlvl $hidmatch $hidbydef $ishid]\
: $ishid}]
return $ret
}
# check if module name is specified as a full pathname (not a name relative
# to a modulepath)
proc isModuleFullPath {mod} {
return [regexp {^(|\.|\.\.)/} $mod]
}
# check if a module corresponds to a virtual module (module name
# does not corresponds to end of the modulefile name)
proc isModuleVirtual {mod modfile} {
return [expr {[string first $mod $modfile end-[string length $mod]] == -1}]
}
# Return the full pathname and modulename to the module.
# Resolve aliases and default versions if the module name is something like
# "name/version" or just "name" (find default version).
proc getPathToModule {mod {indir {}} {report_issue 1} {look_loaded no}\
{excdir {}}} {
reportDebug "finding '$mod' in '$indir' (report_issue=$report_issue,\
look_loaded=$look_loaded, excdir='$excdir')"
set vrlist [getVariantList $mod 1 0 1]
if {$mod eq {}} {
set retlist [list {} {} {} none [getEmptyNameMsg module]]
# try first to look at loaded modules if enabled to find matching module
# or to find a closest match (used when switching with single name arg)
} elseif {$look_loaded ne {no}} {
switch -- $look_loaded {
match {set getLoadedNameProc getLoadedMatchingName}
close {set getLoadedNameProc getLoadedWithClosestName}
}
if {[set lm [$getLoadedNameProc $mod]] ne {}} {
set vrlist [getVariantList $lm 1]
set retlist [list [getModulefileFromLoadedModule $lm] $lm]
} else {
set retlist [list {} [getModuleNameAndVersFromVersSpec $mod]\
$mod notloaded]
}
# Check for $mod specified as a full pathname
} elseif {[isModuleFullPath $mod]} {
set mod [getAbsolutePath $mod]
# note that a raw filename as an argument returns the full
# path as the module name
lassign [checkValidModule $mod] check_valid check_msg
switch -- $check_valid {
true {
set retlist [list $mod $mod]
}
invalid - accesserr {
set retlist [list {} $mod $mod $check_valid $check_msg $mod]
}
}
} else {
set dir_list [expr {$indir ne {} ? $indir : [getModulePathList\
exiterronundef]}]
# remove excluded directories (already searched)
foreach dir $excdir {
set dir_list [replaceFromList $dir_list $dir]
}
set icase [isIcase]
defineGetEqArrayKeyProc $icase [getConf extended_default] [getConf\
implicit_default]
# Now search for $mod in module paths
set modspec $mod
foreach dir $dir_list {
# get list of modules corresponding to searched query
array unset mod_list
array set mod_list [getModules $dir $mod 0 [list rc_defs_included\
resolve]]
set prevmod {}
set mod_res {}
# loop to resolve correct modulefile in case specified mod is a
# directory that should be analyzed to get default mod in it
while {$prevmod ne $mod} {
##nagelfar ignore Found constant
set mod [getEqArrayKey mod_list $mod]
set prevmod $mod
if {[info exists mod_list($mod)]} {
switch -- [lindex $mod_list($mod) 0] {
alias - version {
set newmod [resolveModuleVersionOrAlias $mod $icase]
if {[info exists mod_list($newmod)]} {
set mod $newmod
} else {
# add specified variants to current resolution
if {[llength $vrlist] > 0} {
lassign [parseModuleSpecification 0 0 0 0 $newmod\
{*}$vrlist] newmod
}
# restart search on new modulename, constrained to
# specified dir if set, if not found in current res
return [getPathToModule $newmod $indir $report_issue]
}
}
directory {
# is implicit default disabled and none explicitly set?
if {[lindex $mod_list($mod) 1] eq {}} {
set retlist [list {} $mod $mod none "No default\
version defined for '$mod'"]
} else {
# Move to default element in directory
set mod $mod/[lindex $mod_list($mod) 1]
# restart search if default element is an hidden dir
if {![info exists mod_list($mod)] && [isModuleHidden\
$mod $modspec]} {
# add specified variants to current resolution
if {[llength $vrlist] > 0} {
lassign [parseModuleSpecification 0 0 0 0 $mod\
{*}$vrlist] mod
}
return [getPathToModule $mod $indir $report_issue]
}
}
}
modulefile {
# If mod was a file in this path, return that file
set retlist [list $dir/$mod $mod]
}
virtual {
# return virtual name with file it targets
set retlist [list [lindex $mod_list($mod) 2] $mod]
}
invalid - accesserr {
# may found mod but issue, so end search with error
set retlist [list {} $mod $mod {*}$mod_list($mod)]
}
}
}
}
# break loop if found something (valid or invalid module)
# elsewhere go to next path
if {[info exists retlist]} {
break
}
}
}
# set result if nothing found
if {![info exists retlist]} {
set retlist [list {} $mod $mod none "Unable to locate a modulefile for\
'$mod'"]
} else {
# build module name and variant with variant specified
if {[llength $vrlist] > 0} {
lassign [parseModuleSpecification 0 0 0 0 [lindex $retlist 1]\
{*}$vrlist] modnamevr
} else {
set modnamevr [lindex $retlist 1]
}
# update result if forbidden
if {[isModuleTagged $modnamevr forbidden]} {
set retlist [list {} [lindex $retlist 1] [lindex $retlist 2]\
accesserr [getForbiddenMsg $modnamevr]]
}
}
if {[lindex $retlist 0] ne {}} {
lappend retlist $modnamevr
reportTrace "'[lindex $retlist 1]' ([lindex $retlist 0]) matching\
'$mod'" {Select module}
# no error if we look at loaded modules and passed mod not found loaded
} elseif {[lindex $retlist 3] ne {notloaded} && $report_issue} {
reportIssue {*}[lrange $retlist 3 5]
}
return $retlist
}
proc isModuleLoaded {mod} {
cacheCurrentModules
return [info exists ::g_loadedModules($mod)]
}
proc getModulefileFromLoadedModule {mod} {
if {[isModuleLoaded $mod]} {
return $::g_loadedModules($mod)
} else {
return {}
}
}
proc isModulefileLoaded {modfile} {
cacheCurrentModules
return [info exists ::g_loadedModuleFiles($modfile)]
}
proc getModuleFromLoadedModulefile {modfile {idx all}} {
if {[isModulefileLoaded $modfile]} {
if {$idx eq {all}} {
return $::g_loadedModuleFiles($modfile)
} else {
return [lindex $::g_loadedModuleFiles($modfile) $idx]
}
} else {
return {}
}
}
proc isModuleLoading {mod} {
return [expr {$mod in [getLoadingModuleList]}]
}
proc isModulefileLoading {modfile} {
return [expr {$modfile in [getLoadingModuleFileList]}]
}
proc getModuleFromLoadingModulefile {modfile {idx all}} {
if {[isModulefileLoading $modfile]} {
set loadingmodlist [getLoadingModuleList]
foreach i [lsearch -all -exact [getLoadingModuleFileList] $modfile] {
lappend modlist [lindex $loadingmodlist $i]
}
if {$idx eq {all}} {
return $modlist
} else {
return [lindex $modlist $idx]
}
} else {
return {}
}
}
proc isModuleRefreshQualified {mod} {
return $::g_loadedModulesRefresh($mod)
}
proc setLoadedModule {mod modfile uasked modvr refresh} {
set ::g_loadedModules($mod) $modfile
# a loaded modfile may correspond to multiple loaded virtual modules
lappend ::g_loadedModuleFiles($modfile) $mod
# record if mod has been asked by user and relative loaded/auto-loaded tag
set loadedtag [expr {$uasked ? {loaded} : {auto-loaded}}]
setModuleTag $mod $loadedtag
# also record tag for module designation including variants if specified
if {$modvr ne {} && $mod ne $modvr} {
setModuleTag $modvr $loadedtag
}
# is module qualified for refresh evaluation
set ::g_loadedModulesRefresh($mod) $refresh
# build dependency chain
setModuleDependency $mod
}
proc unsetLoadedModule {mod modfile} {
unset ::g_loadedModules($mod)
# a loaded modfile may correspond to multiple loaded virtual modules
if {[llength $::g_loadedModuleFiles($modfile)] == 1} {
unset ::g_loadedModuleFiles($modfile)
} else {
set ::g_loadedModuleFiles($modfile) [replaceFromList\
$::g_loadedModuleFiles($modfile) $mod]
}
unset ::g_loadedModulesRefresh($mod)
# update dependencies
unsetModuleDependency $mod
}
# return the currently loaded module whose name is the closest to the
# name passed as argument. if no loaded module match at least one part
# of the passed name, an empty string is returned.
proc getLoadedWithClosestName {name} {
set ret {}
set retmax 1
if {[isModuleFullPath $name]} {
set fullname [getAbsolutePath $name]
# if module is passed as full modulefile path name, get corresponding
# short name from used modulepaths
if {[set shortname [findModuleNameFromModulefile $fullname]] ne {}} {
set nametosplit $shortname
# or look at lmfile names to return the eventual exact match
} else {
# module may be loaded with its full path name
if {[isModuleLoaded $fullname]} {
set ret $fullname
# or name corresponds to the _lmfiles_ entry of a virtual modules in
# which case lastly loaded virtual module is returned
} elseif {[isModulefileLoaded $fullname]} {
set ret [getModuleFromLoadedModulefile $fullname end]
}
}
} else {
set nametosplit $name
}
if {[info exists nametosplit]} {
cacheCurrentModules
set icase [isIcase]
defineModStartNbProc $icase
defineModEqProc $icase [getConf extended_default]
# compare name to each currently loaded module name
##nagelfar ignore Found constant
foreach mod [getLoadedModulePropertyList name] {
# if module loaded as fullpath but test name not, try to get loaded
# mod short name (with currently used modulepaths) to compare it
if {[isModuleFullPath $mod] && [set modname\
[findModuleNameFromModulefile $mod]] ne {}} {
# no alt name to retrieve if module has been loaded full path
set matchmodlist [list $modname]
} else {
# add alternative names of mod to the matching list
set matchmodlist [list $mod {*}[getLoadedAltname $mod]]
}
# compare each element of the name to find closest answer. in case of
# equality, last loaded module will be returned as it overwrites
# previously found value
foreach matchmod $matchmodlist {
if {[set i [modStartNb $matchmod $nametosplit]] >= $retmax} {
set retmax $i
set ret $mod
break
}
}
}
}
reportDebug "'$ret' closest to '$name'"
return $ret
}
# return the currently loaded module whose name is equal or include the name
# passed as argument. if no loaded module match, an empty string is returned.
# loading: look at currently loading modules instead of loaded if loading == 1
# lmlist: only take into account passed loaded module list not all loaded mods
proc getLoadedMatchingName {name {behavior {}} {loading 0} {lmlist {}}} {
set ret {}
set retmax 0
# get default behavior from unload_match_order config
if {$behavior eq {}} {
set behavior [getConf unload_match_order]
}
# use loading-specific procedures instead of loaded-specific ones
if {$loading} {
set isModulefileLoaded isModulefileLoading
set getModuleFromLoadedModulefile getModuleFromLoadingModulefile
set getLoadedModuleList [list getLoadingModuleList]
} else {
##nagelfar ignore #3 Found constant
set isModulefileLoaded isModulefileLoaded
set getModuleFromLoadedModulefile getModuleFromLoadedModulefile
set getLoadedModuleList [list getLoadedModulePropertyList name]
}
# fetch currently loaded/loading module name is no list provided
if {[llength $lmlist] == 0} {
set lmlist [{*}$getLoadedModuleList]
}
# if module is passed as full modulefile path name, look at lmfile names
# to return the eventual exact match
if {[isModuleFullPath $name]} {
set mod [getAbsolutePath $name]
# if module is loaded with its full path name loadedmodules entry is
# equivalent to _lmfiles_ corresponding entry so only check _lmfiles_
if {[$isModulefileLoaded $mod]} {
# a loaded modfile may correspond to multiple loaded virtual modules
switch -- $behavior {
returnlast {
# the last loaded/loading module will be returned
set ret [$getModuleFromLoadedModulefile $mod end]
}
returnfirst {
# the first loaded/loading module will be returned
set ret [$getModuleFromLoadedModulefile $mod 0]
}
returnall {
# all loaded/loading modules will be returned
set ret [$getModuleFromLoadedModulefile $mod]
}
}
}
} elseif {$name ne {}} {
defineModEqProc [isIcase] [getConf extended_default] [expr {!$loading}]
# compare name to each currently loaded/loading module name, if multiple
# mod match name:
foreach mod $lmlist {
# if module loaded as fullpath but test name not, try to get loaded
# mod short name (with currently used modulepaths) to compare it
if {[isModuleFullPath $mod] && [set modname\
[findModuleNameFromModulefile $mod]] ne {}} {
set matchmod $modname
} else {
set matchmod $mod
}
if {[modEq $name $matchmod eqstart 1 [expr {$loading ? 1 : 2}] 1]} {
switch -- $behavior {
returnlast {
# the last loaded module will be returned
set ret $mod
}
returnfirst {
# the first loaded module will be returned
set ret $mod
break
}
returnall {
# all loaded modules will be returned
lappend ret $mod
}
}
}
}
}
reportDebug "'$ret' matches '$name'"
return $ret
}
proc setLoadedSourceSh {mod args} {
foreach arg $args {
# each arg is a list with source-sh call string at index 0 and resulting
# modulefile commands at all later index positions
set shtomodargs [lindex $arg 0]
set modcontent [lrange $arg 1 end]
if {![info exists ::g_loadedModuleSourceSh($mod)] || $shtomodargs ni\
$::g_loadedModuleSourceSh($mod)} {
# filter alias/function/complete definition not to record them
set filtmodcont [list]
foreach modcmdlist $modcontent {
set modcmd [lindex $modcmdlist 0]
switch -- $modcmd {
set-alias - set-function {
# set an empty body to make valid unset-* call
lappend filtmodcont [list {*}[lrange $modcmdlist 0 1] {}]
}
complete {
set complist [lrange $modcmdlist 0 2]
# ensure only one order is recorded for each shell-name
if {![info exists filtcomp($complist)]} {
lappend filtmodcont [list {*}$complist {}]
set filtcomp($complist) 1
}
}
default {
lappend filtmodcont $modcmdlist
}
}
}
lappend ::g_loadedModuleSourceSh($mod) $shtomodargs $filtmodcont
}
}
}
proc unsetLoadedSourceSh {mod} {
if {[info exists ::g_loadedModuleSourceSh($mod)]} {
unset ::g_loadedModuleSourceSh($mod)
}
}
proc getLoadedSourceSh {mod {serialized 0}} {
set ret {}
set pathsep [getState path_separator]
set sub1sep [getState sub1_separator]
set sub2sep [getState sub2_separator]
set sermap [list $pathsep <EnvModEscPS> $sub1sep <EnvModEscS1>\
$sub2sep <EnvModEscS2>]
if {[info exists ::g_loadedModuleSourceSh($mod)]} {
if {$serialized} {
foreach {shtomodargs modcontent} $::g_loadedModuleSourceSh($mod) {
# escape delimiter chars if used in content
set shtomodargsser [string map $sermap $shtomodargs]
set modcontentser [string map $sermap $modcontent]
lappend modsrcsh $shtomodargsser$sub2sep[join $modcontentser\
$sub2sep]
}
set ret [join [list $mod {*}$modsrcsh] $sub1sep]
} else {
set ret $::g_loadedModuleSourceSh($mod)
}
}
return $ret
}
proc setLoadedConflict {mod args} {
appendNoDupToList ::g_loadedModuleConflict($mod) {*}$args
}
proc unsetLoadedConflict {mod} {
if {[info exists ::g_loadedModuleConflict($mod)]} {
unset ::g_loadedModuleConflict($mod)
}
}
proc getLoadedConflict {mod {serialized 0}} {
set ret {}
if {[info exists ::g_loadedModuleConflict($mod)]} {
if {$serialized} {
# get conflict info as a string that can be registered in an env var
# translate range specifier ':' into '<' to distinguish from path sep
set ret [string map {: <} [join [list $mod\
{*}$::g_loadedModuleConflict($mod)] [getState sub1_separator]]]
} else {
set ret $::g_loadedModuleConflict($mod)
}
}
return $ret
}
proc doesModuleConflict {mod} {
set does 0
set modconlist {}
set moddecconlist {}
defineModEqProc [isIcase] [getConf extended_default] 1
# get module short name if loaded by its full pathname
if {[set isfullpath [isModuleFullPath $mod]]} {
set smod [findModuleNameFromModulefile $mod]
}
# check if any loaded module has declared a conflict
foreach modcon [array names ::g_loadedModuleConflict] {
# look if some loaded or loading modules correspond to conflict defined
# by mod
if {$modcon eq $mod || ($isfullpath && $modcon eq $smod)} {
foreach withmod $::g_loadedModuleConflict($modcon) {
# skip own reflexive conflict (look at mod main and alternative
# names) and those already known
if {![modEq $withmod $mod eqstart 1 2 1] && (!$isfullpath ||\
![modEq $withmod $smod eqstart 1 2 1]) && ([set lmmodlist\
[getLoadedMatchingName $withmod returnall]] ne {} || [set\
lmmodlist [getLoadedMatchingName $withmod returnall 1]] ne\
{})} {
# multiple loaded module may match conflict declared name
foreach lmmod $lmmodlist {
appendNoDupToList modconlist $lmmod
}
appendNoDupToList moddecconlist $withmod
set does 1
}
}
# other loaded module declared conflicts (skipping those already known)
} elseif {$modcon ni $modconlist} {
foreach withmod $::g_loadedModuleConflict($modcon) {
# check if mod or one of its alt name match conflict
if {[modEq $withmod $mod eqstart 1 2 1] || ($isfullpath &&\
[modEq $withmod $smod eqstart 1 2 1])} {
lappend modconlist $modcon
lappend moddecconlist $modcon
set does 1
break
}
}
}
}
reportDebug "'$mod' conflicts with '$modconlist' (declared as\
'$moddecconlist')"
return [list $does $modconlist $moddecconlist]
}
proc setLoadedPrereq {mod args} {
appendNoDupToList ::g_loadedModulePrereq($mod) {*}$args
}
proc unsetLoadedPrereq {mod} {
if {[info exists ::g_loadedModulePrereq($mod)]} {
unset ::g_loadedModulePrereq($mod)
}
}
proc getLoadedPrereq {mod {serialized 0}} {
set ret {}
set sub2sep [getState sub2_separator]
if {[info exists ::g_loadedModulePrereq($mod)]} {
if {$serialized} {
# get prereq info as a string that can be registered in an env var
foreach pre $::g_loadedModulePrereq($mod) {
lappend modpre [join $pre $sub2sep]
}
# translate range specifier ':' into '<' to distinguish from path sep
set ret [string map {: <} [join [list $mod {*}$modpre]\
[getState sub1_separator]]]
} else {
set ret $::g_loadedModulePrereq($mod)
}
}
return $ret
}
proc setLoadedAltname {mod args} {
foreach arg $args {
switch -- [string range $arg 0 2] {
al| {
appendNoDupToList ::g_loadedModuleAliasAltname($mod) [string\
range $arg 3 end]
}
as| {
appendNoDupToList ::g_loadedModuleAutoAltname($mod) [string range\
$arg 3 end]
}
default {
appendNoDupToList ::g_loadedModuleAltname($mod) $arg
}
}
}
}
proc unsetLoadedAltname {mod} {
if {[info exists ::g_loadedModuleAltname($mod)]} {
unset ::g_loadedModuleAltname($mod)
}
if {[info exists ::g_loadedModuleAliasAltname($mod)]} {
unset ::g_loadedModuleAliasAltname($mod)
}
if {[info exists ::g_loadedModuleAutoAltname($mod)]} {
unset ::g_loadedModuleAutoAltname($mod)
}
}
proc getLoadedAltname {mod {serialized 0} {typelist {sym alias autosym}}} {
set ret {}
if {[info exists ::g_loadedModuleAltname($mod)] && {sym} in $typelist} {
set ret $::g_loadedModuleAltname($mod)
}
if {[info exists ::g_loadedModuleAliasAltname($mod)] && {alias} in\
$typelist} {
if {$serialized} {
# add a 'al|' prefix to each alias to distinguish them when
# serialized
foreach altname $::g_loadedModuleAliasAltname($mod) {
lappend ret al|$altname
}
} else {
lappend ret {*}$::g_loadedModuleAliasAltname($mod)
}
}
if {[info exists ::g_loadedModuleAutoAltname($mod)] && {autosym} in\
$typelist} {
if {$serialized} {
# add a 'as|' prefix to each auto sym to distinguish them when
# serialized
foreach altname $::g_loadedModuleAutoAltname($mod) {
lappend ret as|$altname
}
} else {
lappend ret {*}$::g_loadedModuleAutoAltname($mod)
}
}
if {$ret ne {} && $serialized} {
# get altname info as a string that can be registered in an env var
set ret [join [list $mod {*}$ret] [getState sub1_separator]]
}
return $ret
}
proc setLoadedVariant {mod args} {
lappend ::g_loadedModuleVariant($mod) {*}$args
}
proc unsetLoadedVariant {mod} {
if {[info exists ::g_loadedModuleVariant($mod)]} {
unset ::g_loadedModuleVariant($mod)
}
}
proc getLoadedVariant {mod {serialized 0}} {
set ret {}
set sub2sep [getState sub2_separator]
if {[info exists ::g_loadedModuleVariant($mod)]} {
if {$serialized} {
# get variant info as a string that can be registered in an env var
foreach vrspec $::g_loadedModuleVariant($mod) {
lappend modvrspec [join $vrspec $sub2sep]
}
# translate range specifier ':' into '<' to distinguish from path sep
set ret [string map {: <} [join [list $mod {*}$modvrspec]\
[getState sub1_separator]]]
} else {
set ret $::g_loadedModuleVariant($mod)
}
}
return $ret
}
proc getLoadedModuleWithVariantList {} {
set modvrlist [list]
foreach mod [getLoadedModulePropertyList name] {
set modvr [list $mod]
set vrlist [getVariantList $mod 5]
if {[llength $vrlist] > 0} {
lappend modvr {*}$vrlist
}
lappend modvrlist $modvr
}
return $modvrlist
}
proc getLoadedModuleWithVariantSaveTagArrayList {} {
array set tag_arr {}
foreach mod [getLoadedModulePropertyList name] {
set modvr [list $mod]
set vrlist [getVariantList $mod 1]
if {[llength $vrlist] > 0} {
lappend modvr {*}$vrlist
}
# create entry in array only if tags set
set tag_list [getSaveTagList $mod]
if {[llength $tag_list] > 0} {
set tag_arr($modvr) $tag_list
}
}
return [array get tag_arr]
}
# get current loaded state to record it as the virtual init collection
proc getLoadedInit {} {
set ret [formatCollectionContent [getModulePathList returnempty 0]\
[getLoadedModuleWithVariantList]\
[getLoadedModuleWithVariantSaveTagArrayList] {}]
# remove ending newline in collection output
set ret [string trimright $ret \n]
# get init state as a string that can be registered in an env var translate
# tag list separator ':' into '<' and line split '\n' into ':'
set ret [string map {: < \n :} $ret]
return $ret
}
# get all modules from all enabled modulepaths that matches a specification
proc getAllAvailModule {mod} {
array set mod_list {}
# search is done from lowest to greatest priority path (if result array
# content is kept later on, it will hold accurate priority information)
foreach dir [lreverse [getModulePathList]] {
array set mod_list [getModules $dir $mod 0 [list rc_defs_included]]
}
return [array names mod_list]
}
# register conflict violation state between loaded modules
proc setModuleConflictViolation {mod modconlist} {
reportDebug "set conflict violation state for '$mod'"
set ::g_conflictViolation($mod) $modconlist
# also update violation state for loaded mod conflicting with mod
foreach lmmod $modconlist {
if {[appendNoDupToList ::g_conflictViolation($lmmod) $mod]} {
reportDebug "set/update conflict violation state for '$lmmod'"
}
}
}
# unregister conflict violation state between modules
proc unsetModuleConflictViolation {mod} {
if {[info exists ::g_conflictViolation($mod)]} {
# also update violation state for loaded mod conflicting with mod
foreach lmmod $::g_conflictViolation($mod) {
set convio [replaceFromList\
$::g_conflictViolation($lmmod) $mod]
reportDebug "unset/update conflict violation state for '$lmmod'"
if {[llength $convio] == 0} {
unset ::g_conflictViolation($lmmod)
} else {
set ::g_conflictViolation($lmmod) $convio
}
}
reportDebug "unset conflict violation state for '$mod'"
unset ::g_conflictViolation($mod)
}
}
# build dependency chain between loaded modules based on registered prereqs
proc setModuleDependency {mod} {
set modlist [getLoadedModulePropertyList name]
defineModEqProc [isIcase] [getConf extended_default] 1
# only look at modules loaded prior current one to find requirements,
# modules loaded afterward are unmet dependencies as dependents have
# not been reloaded after them
set modidx [lsearch -exact $modlist $mod]
set modnpolist [lrange $modlist $modidx+1 end]
set modlist [lrange $modlist 0 $modidx]
# reverse list to get closest match if returning lastly loaded module
if {[getConf unload_match_order] eq {returnlast}} {
set modlist [lreverse $modlist]
}
set deplist {}
set depnpolist {}
foreach prereq [getLoadedPrereq $mod] {
# get corresponding loaded module for each element of the prereq order
set lmprelist {}
set lmnpolist {}
foreach modpre $prereq {
set lmfound {}
foreach lmmod $modlist {
if {[modEq $modpre $lmmod eqstart 1 2 1]} {
set lmfound $lmmod
break
}
}
# register an unmet dependency/requirement if no loaded mod matches
if {$lmfound eq {}} {
reportDebug "set an unmet requirement on '$modpre' for '$mod'"
lappend ::g_moduleUnmetDep($mod) $modpre
lappend ::g_unmetDepHash($modpre) $mod
# add matching mod elsewhere
} else {
appendNoDupToList lmprelist $lmfound
appendNoDupToList lmnpolist $lmfound
}
# look if requirement can be found in the No Particular Order list
foreach lmmod $modnpolist {
if {[modEq $modpre $lmmod eqstart 1 2 1]} {
appendNoDupToList lmnpolist $lmmod
break
}
}
}
switch -- [llength $lmprelist] {
0 {
# prereq not satisfied
reportDebug "set prereq violation state for '$mod'"
lappend ::g_prereqViolation($mod) $prereq
}
1 {
set lmmod [lindex $lmprelist 0]
lappend deplist [list $lmmod]
# set 'is depended by' relations
lappend ::g_dependHash($lmmod) [list $mod]
}
default {
lappend deplist $lmprelist
# many modules in prereq list, means they all set an optional dep
foreach lmmod $lmprelist {
lappend ::g_dependHash($lmmod) [list $mod 1]
}
}
}
# build 'is depended by' relations not taking loading order into account
switch -- [llength $lmnpolist] {
0 {
# even on No Particular Order mode, prereq is not satisfied
reportDebug "set NPO prereq violation state for '$mod'"
lappend ::g_prereqNPOViolation($mod) $prereq
}
1 {
set lmmod [lindex $lmnpolist 0]
lappend depnpolist [list $lmmod]
# set 'is depended by' relations
lappend ::g_dependNPOHash($lmmod) [list $mod]
}
default {
lappend depnpolist $lmnpolist
# many modules in prereq list, means they all set an optional dep
foreach lmmod $lmnpolist {
lappend ::g_dependNPOHash($lmmod) [list $mod 1]
}
}
}
}
# conflict not satisfied
lassign [doesModuleConflict $mod] doescon modconlist
if {$doescon} {
setModuleConflictViolation $mod $modconlist
}
# update eventual registered unmet dependencies
foreach modpre [array names ::g_unmetDepHash] {
if {[modEq $modpre $mod eqstart 1 2 1]} {
reportDebug "refresh requirements targeting '$modpre'"
foreach lmmod $::g_unmetDepHash($modpre) {
if {$mod in [getDependentLoadedModuleList [list $lmmod] 0 0]} {
reportDebug "skip deps refresh for '$lmmod' as dep cycle\
detected with '$mod'"
# remove dependency link in no particular order structs to
# avoid cycle first in 'is depended by' struct
if {[info exists ::g_dependNPOHash($mod)]} {
set depmodlist $::g_dependNPOHash($mod)
for {set i 0} {$i < [llength $depmodlist]} {incr i 1} {
if {[lindex [lindex $depmodlist $i] 0] eq $lmmod} {
set depmodlist [lreplace $depmodlist $i $i]
break
}
}
set ::g_dependNPOHash($mod) $depmodlist
reportDebug "update NPO dependent of '$mod' to\
'$depmodlist'"
}
# then update 'depend on' struct
set lmmoddepnpolist {}
foreach depmodlist $::g_moduleNPODepend($lmmod) {
if {[set depidx [lsearch -exact $depmodlist $mod]] != -1} {
set depmodlist [lreplace $depmodlist $depidx $depidx]
# implies to update consistently alternate requirement or
# violation state if no alternative loaded
switch -- [llength $depmodlist] {
0 {
# do not know exact prereq name, so use correspond.
# loaded module matching it
lappend ::g_prereqNPOViolation($lmmod) $mod
reportDebug "set NPO prereq violation state for\
'$lmmod'"
}
1 {
# update alternate loaded mod which became a strong
# requirement
set altmod [lindex $depmodlist 0]
set ::g_dependNPOHash($altmod) [replaceFromList\
$::g_dependNPOHash($altmod) [list $lmmod 1]\
$lmmod]
reportDebug "update NPO dependent of '$altmod' to\
'$::g_dependNPOHash($altmod)'"
}
}
}
lappend lmmoddepnpolist $depmodlist
}
reportDebug "update NPO requirement of '$lmmod' to\
'$lmmoddepnpolist'"
set ::g_moduleNPODepend($lmmod) $lmmoddepnpolist
} else {
# refresh actual dependencies of targeting mod
unsetModuleDependency $lmmod
setModuleDependency $lmmod
}
}
}
}
# set 'depends on' relation
reportDebug "set requirements of '$mod' to '$deplist'"
set ::g_moduleDepend($mod) $deplist
reportDebug "set NPO requirements of '$mod' to '$depnpolist'"
set ::g_moduleNPODepend($mod) $depnpolist
}
# update dependency chain when unloading module
proc unsetModuleDependency {mod} {
foreach lmmodlist $::g_moduleDepend($mod) {
set manymod [expr {[llength $lmmodlist] > 1}]
# unset 'is depended by' mod relations
foreach lmmod $lmmodlist {
if {[info exists ::g_dependHash($lmmod)]} {
if {$manymod} {
set hashdep [list $mod 1]
} else {
set hashdep [list $mod]
}
set ::g_dependHash($lmmod) [replaceFromList\
$::g_dependHash($lmmod) $hashdep]
if {[llength $::g_dependHash($lmmod)] == 0} {
unset ::g_dependHash($lmmod)
}
}
}
}
# unset mod's 'depends on' relation
reportDebug "unset requirements of '$mod'"
unset ::g_moduleDepend($mod)
foreach lmmodlist $::g_moduleNPODepend($mod) {
set manymod [expr {[llength $lmmodlist] > 1}]
# unset 'is depended by' mod relations
foreach lmmod $lmmodlist {
if {[info exists ::g_dependNPOHash($lmmod)]} {
if {$manymod} {
set hashdep [list $mod 1]
} else {
set hashdep [list $mod]
}
set ::g_dependNPOHash($lmmod) [replaceFromList\
$::g_dependNPOHash($lmmod) $hashdep]
if {[llength $::g_dependNPOHash($lmmod)] == 0} {
unset ::g_dependNPOHash($lmmod)
}
}
}
}
# unset mod's No Particular Order 'depends on' relation
reportDebug "unset NPO requirements of '$mod'"
unset ::g_moduleNPODepend($mod)
# unset eventual violation states
if {[info exists ::g_prereqViolation($mod)]} {
reportDebug "unset prereq violation state for '$mod'"
unset ::g_prereqViolation($mod)
}
if {[info exists ::g_prereqNPOViolation($mod)]} {
reportDebug "unset NPO prereq violation state for '$mod'"
unset ::g_prereqNPOViolation($mod)
}
unsetModuleConflictViolation $mod
# unset eventual registered unmet dependencies
if {[info exists ::g_moduleUnmetDep($mod)]} {
foreach ummod $::g_moduleUnmetDep($mod) {
if {[info exists ::g_unmetDepHash($ummod)]} {
set ::g_unmetDepHash($ummod) [replaceFromList\
$::g_unmetDepHash($ummod) $mod]
if {[llength $::g_unmetDepHash($ummod)] == 0} {
unset ::g_unmetDepHash($ummod)
}
}
}
reportDebug "unset unmet requirements for '$mod'"
unset ::g_moduleUnmetDep($mod)
}
# unset mod's 'is depended by' relations
set hashdeplist [getDirectDependentList $mod]
if {[llength $hashdeplist] > 0} {
reportDebug "refresh dependent of '$mod'"
foreach lmmod $hashdeplist {
# refresh actual dependencies of targeting mod
unsetModuleDependency $lmmod
setModuleDependency $lmmod
}
}
}
# returns if any loaded module (if passed mod is empty) or passed mod and all
# its requirement chain satisfy their loading constraints (prereq & conflict)
proc areModuleConstraintsSatisfied {{mod {}} {nporeq 0}} {
set ret 1
cacheCurrentModules
# are requirements loaded after their dependent included or not
if {$nporeq} {
set reqVioVar ::g_prereqNPOViolation
set reqListVar ::g_moduleNPODepend
} else {
set reqVioVar ::g_prereqViolation
set reqListVar ::g_moduleDepend
}
# check if any loaded module violates its prereq or conflict constraints
##nagelfar vartype reqVioVar varName
if {$mod eq {}} {
if {[array size ::g_conflictViolation] > 0 || [array size\
$reqVioVar] > 0} {
set ret 0
}
} else {
set fulllist [list $mod]
for {set i 0} {$i < [llength $fulllist]} {incr i 1} {
set depmod [lindex $fulllist $i]
# check if depmod violates its prereq or conflict constraints
##nagelfar ignore +2 Suspicious variable name
if {[info exists ::g_conflictViolation($depmod)] || [info exists\
${reqVioVar}($depmod)]} {
# found violation among the requirement chain of mod so the
# constraint of mod are not satisfied
set ret 0
break
}
# add requirements of depmod to the module to check list
##nagelfar ignore Suspicious variable name
foreach lmmodlist [set ${reqListVar}($depmod)] {
appendNoDupToList fulllist {*}$lmmodlist
}
}
}
return $ret
}
proc cacheCurrentModules {{exitonerr 1}} {
# parse loaded modules information only once, global arrays are updated
# afterwards when module commands update loaded modules state
if {![isStateDefined lm_info_cached]} {
setState lm_info_cached 1
# mark specific as well as generic modules as loaded
set i 0
set modfilelist [getLoadedModulePropertyList file]
set modlist [getLoadedModulePropertyList name]
set refreshlist [getLoadedModulePropertyList refresh]
if {[llength $modlist] == [llength $modfilelist]} {
# cache declared variant of loaded modules
foreach modvrspec [getLoadedModulePropertyList variant] {
setLoadedVariant {*}$modvrspec
# prepare modvr designation of loaded mod needed in next steps
set mod [lindex $modvrspec 0]
set vrlist [getVariantList $mod 6]
set modvr [list $mod {*}$vrlist]
set modvrarr($mod) $modvr
}
# cache declared tags of loaded modules
foreach modtag [getLoadedModulePropertyList tag] {
setModuleTag {*}$modtag
# also record tag over full mod and vr designation
set mod [lindex $modtag 0]
if {[info exists modvrarr($mod)]} {
setModuleTag $modvrarr($mod) {*}[lrange $modtag 1 end]
}
}
foreach modtag [getLoadedModulePropertyList extratag] {
setModuleExtraTag {*}$modtag
# also record tag over full mod and vr designation
set mod [lindex $modtag 0]
if {[info exists modvrarr($mod)]} {
setModuleExtraTag $modvrarr($mod) {*}[lrange $modtag 1 end]
}
}
# cache declared alternative names of loaded modules
foreach modalt [getLoadedModulePropertyList altname] {
setLoadedAltname {*}$modalt
}
# cache declared source-sh of loaded modules
foreach modsrcsh [getLoadedModulePropertyList sourcesh] {
setLoadedSourceSh {*}$modsrcsh
}
# cache declared conflict of loaded modules
foreach modcon [getLoadedModulePropertyList conflict] {
# parse module version specification to record translation
foreach modconelt [lrange $modcon 1 end] {
parseModuleSpecification 0 0 0 0 {*}$modconelt
}
setLoadedConflict {*}$modcon
}
# cache declared prereq of loaded modules, prior to setLoadedModule
# which triggers dependency chain build
foreach modpre [getLoadedModulePropertyList prereq] {
# parse module version specification to record translation
foreach modpreeltlist [lrange $modpre 1 end] {
foreach modpreelt $modpreeltlist {
parseModuleSpecification 0 0 0 0 {*}$modpreelt
}
}
setLoadedPrereq {*}$modpre
}
foreach mod $modlist {
# get all tags also recorded on mod and vr designation
if {[info exists modvrarr($mod)]} {
set modvr $modvrarr($mod)
} else {
set modvr {}
}
setLoadedModule $mod [lindex $modfilelist $i] [expr\
{![isModuleTagged $mod auto-loaded 1]}] $modvr [expr {$mod in\
$refreshlist}]
incr i
}
reportDebug "$i loaded"
} else {
set errproc [expr {$exitonerr ? {reportErrorAndExit} :\
{reportError}}]
$errproc "Loaded environment state is\
inconsistent\nLOADEDMODULES=$modlist\n_LMFILES_=$modfilelist"
}
}
}
# This proc resolves module aliases or version aliases to the real module name
# and version.
proc resolveModuleVersionOrAlias {name icase} {
set name [getArrayKey ::g_moduleResolved $name $icase]
if {[info exists ::g_moduleResolved($name)]} {
set ret $::g_moduleResolved($name)
} else {
set ret $name
}
reportTrace "'$name' into '$ret'" Resolve
return $ret
}
proc parseAccessIssue {modfile} {
# retrieve and return access issue message
if {[regexp {POSIX .* \{(.*)\}$} $::errorCode match errMsg]} {
return "[string totitle $errMsg] on '$modfile'"
} else {
return "Cannot access '$modfile'"
}
}
proc checkValidModule {modfile} {
# test file only once, cache result obtained to minimize file query
# consider modfile valid without reading it if mcookie_check < always
return [expr {[info exists ::g_modfileValid($modfile)]\
? $::g_modfileValid($modfile)\
: [set ::g_modfileValid($modfile) [expr {[getConf mcookie_check] eq\
{always} ? [readModuleContent $modfile 1 1] : [list true {}]}]]}]
}
# get file modification time, cache it at first query, use cache afterward
proc getFileMtime {fpath} {
if {[info exists ::g_fileMtime($fpath)]} {
return $::g_fileMtime($fpath)
} else {
# protect 'file mtime' call in case we do not know what we are checking
# when mcookie is not checked
if {[catch {
set mtime [file mtime $fpath]
} errMsg ]} {
reportError [parseAccessIssue $fpath]
set mtime {}
}
return [set ::g_fileMtime($fpath) $mtime]
}
}
# define proc that will be used as fallback to command provided by extension
# library in case this library is not loaded
proc __readFile {filename {firstline 0} {must_have_cookie 0}} {
set fid [open $filename r]
if {$firstline} {
set fdata [gets $fid]
} else {
# read a first data chunk and check if magic cookie is there if
# mandatory. skip read of any additional content if mandatory cookie is
# not found
set fdata [read $fid 4096]
if {![eof $fid] && (!$must_have_cookie || [string equal -length 8\
$fdata {#%Module}])} {
append fdata [read $fid]
}
}
close $fid
return $fdata
}
proc readModuleContent {modfile {report_read_issue 0} {only_check_validity\
0}} {
set res {}
# read file
if {[catch {
if {[info exists ::g_modfileContent($modfile)]} {
lassign $::g_modfileContent($modfile) fh fdata
} else {
# only read beginning of file if just checking validity and not
# asked to always fully read files. when full file should be read
# cookie is checked if asked to avoid to fully read non modfile
set fdata [readFile $modfile [expr {$only_check_validity &&\
![currentState always_read_full_file]}] 1]
# extract magic cookie (first word of modulefile)
set fh [string trimright [lindex [split [string range $fdata 0 32]]\
0] #]
# cache full file read to minimize file operations
if {!$only_check_validity || [currentState always_read_full_file]} {
set ::g_modfileContent($modfile) [list $fh $fdata]
}
}
} errMsg ]} {
if {$report_read_issue} {
set msg [parseAccessIssue $modfile]
if {$only_check_validity} {
set res [list accesserr $msg]
} else {
reportError $msg
}
}
} else {
# check module validity
if {![string equal -length 8 $fh {#%Module}]} {
set msg {Magic cookie '#%Module' missing}
if {$only_check_validity} {
set res [list invalid $msg]
} else {
reportInternalBug $msg $modfile
}
# check if min version requirement is met
} elseif {[string length $fh] > 8 && [getConf mcookie_version_check] &&\
[versioncmp {5.3.0} [string range $fh 8 end]] <0} {
set msg "Modulefile requires at least Modules version [string range\
$fh 8 end]"
if {$only_check_validity} {
set res [list invalid $msg]
} else {
reportInternalBug $msg $modfile
}
} else {
if {$only_check_validity} {
# set validity information as result
set res [list true {}]
} else {
# set file content as result
set res $fdata
}
}
}
return $res
}
# If given module maps to default or other symbolic versions, a list of
# those versions is returned. This takes module/version as an argument.
proc getVersAliasList {mod} {
set sym_list {}
if {[info exists ::g_symbolHash($mod)]} {
set sym_list $::g_symbolHash($mod)
# withdraw hidden symbol from list
if {[info exists ::g_hiddenSymHash($mod)]} {
lassign [getDiffBetweenList $sym_list $::g_hiddenSymHash($mod)]\
sym_list
}
}
reportDebug "'$mod' has symbolic version list '$sym_list'"
return $sym_list
}
proc doesModuleHaveSym {mod} {
# is there any non-hidden symbol for mod
return [expr {[info exists ::g_symbolHash($mod)] && (![info exists\
::g_hiddenSymHash($mod)] || [llength [lindex [getDiffBetweenList\
$::g_symbolHash($mod) $::g_hiddenSymHash($mod)] 0]] > 0)}]
}
# get list of elements located in a directory passed as argument. a flag is
# set after each element to know if it is considered hidden or not. a
# fetch_dotversion argument controls whether .version file should be looked at
# in directory .proc will be used as a fallback to command provided by
# extension library
proc __getFilesInDirectory {dir fetch_dotversion} {
set dir_list [list]
set elt_list [glob -nocomplain $dir/*]
# Add each element in the current directory to the list
foreach elt $elt_list {
lappend dir_list $elt 0
}
# search for hidden files
foreach elt [glob -nocomplain -types hidden -directory $dir -tails *] {
switch -- $elt {
. - .. { }
.modulerc - .version {
if {($fetch_dotversion || $elt ne {.version}) && [file readable\
$dir/$elt]} {
lappend dir_list $dir/$elt 0
}
}
default {
lappend dir_list $dir/$elt 1
}
}
}
return $dir_list
}
# check if an existing findModules cache entry matches current search by
# evaluating search ids. if an exact match cannot be found, look at saved
# searches that contains current search (superset of looked elements), extra
# elements will be filtered-out by GetModules
proc findModulesInMemCache {searchid} {
# exact same search is cached
if {[info exists ::g_foundModulesMemCache($searchid)]} {
set match_searchid $searchid
set mod_list $::g_foundModulesMemCache($searchid)
# look for a superset search
} else {
set match_searchid {}
set mod_list {}
foreach cacheid [array names ::g_foundModulesMemCache] {
# cache id acts as pattern to check if it contains current search
if {[string match $cacheid $searchid]} {
set match_searchid $cacheid
set mod_list $::g_foundModulesMemCache($cacheid)
break
}
}
}
return [list $match_searchid $mod_list]
}
# Walk through provided list of directories and files to find modules
proc findModulesFromDirsAndFiles {dir full_list depthlvl fetch_mtime\
res_arrname {indir_arrname {}} {hidden_listname {}} {fknown_arrname {}}\
{dknown_arrname {}}} {
# link to variables/arrays from upper context
upvar $res_arrname mod_list
if {$indir_arrname ne {}} {
upvar $indir_arrname modfile_indir
}
if {$hidden_listname ne {}} {
upvar $hidden_listname hidden_list
}
if {$fknown_arrname ne {}} {
upvar $fknown_arrname fknown_arr
}
if {$dknown_arrname ne {}} {
upvar $dknown_arrname dknown_arr
}
foreach igndir [getConf ignored_dirs] {
set ignored_dirs($igndir) 1
}
array set mod_list {}
for {set i 0} {$i < [llength $full_list]} {incr i 1} {
set element [lindex $full_list $i]
set tail [file tail $element]
set modulename [getModuleNameFromModulepath $element $dir]
set parentname [file dirname $modulename]
set moddepthlvl [llength [file split $modulename]]
# check if element is a directory if we do not already know if it is a
# dir or a file from transmitted structures
if {[info exists dknown_arr($modulename)] || (![info exists\
fknown_arr($modulename)] && [file isdirectory $element])} {
if {![info exists ignored_dirs($tail)]} {
if {[catch {
set elt_list [getFilesInDirectory $element 1]
} errMsg]} {
set mod_list($modulename) [list accesserr [parseAccessIssue\
$element] $element]
} else {
# Add each element in the current directory to the list
foreach {fpelt hid} $elt_list {
lappend full_list $fpelt
# Flag hidden files
if {$hid} {
set hidden_list($fpelt) 1
}
}
}
}
} else {
switch -glob -- $tail {
.modulerc {
set mod_list($modulename) [list modulerc]
}
.version {
# skip .version file from different depth level than search
# targets if no in depth mode is enabled
if {$depthlvl == 0 || $moddepthlvl == $depthlvl} {
set mod_list($modulename) [list modulerc]
}
}
.modulecache - *~ - *,v - \#*\# { }
default {
# skip modfile in no in depth mode search if it does not relate
# to targeted depth level and one valid modfile has already be
# found for the dirs lying at other depth level
if {$depthlvl == 0 || $moddepthlvl == $depthlvl || ![info\
exists modfile_indir($parentname)]} {
lassign [checkValidModule $element] check_valid check_msg
switch -- $check_valid {
true {
set mtime [expr {$fetch_mtime ? [getFileMtime\
$element] : {}}]
set mod_list($modulename) [list modulefile $mtime\
$element]
# a valid modfile has been found in directory
if {![info exists hidden_list($element)]} {
set modfile_indir($parentname) 1
}
}
default {
# register check error and relative message to get it
# in case of direct access of this module element, but
# no registering in parent directory structure as
# element is not valid
set mod_list($modulename) [list $check_valid\
$check_msg $element]
}
}
}
}
}
}
}
}
# finds all module-related files matching mod in the module path dir
proc findModules {dir mod depthlvl fetch_mtime} {
reportDebug "finding '$mod' in $dir (depthlvl=$depthlvl,\
fetch_mtime=$fetch_mtime)"
# generated search id (for cache search/save) by compacting given args
set searchid $dir:$mod:$depthlvl:$fetch_mtime
# look at memory cache for a compatible result
lassign [findModulesInMemCache $searchid] cache_searchid cache_list
if {$cache_searchid ne {}} {
reportDebug "use cache entry '$cache_searchid'"
return $cache_list
}
# look at modulepath cache file
lassign [findModulesInCacheFile $dir $mod $depthlvl $fetch_mtime] cache_ok\
cache_list
if {$cache_ok} {
# record cache file findinds in memory cache
reportDebug "create cache entry '$searchid'"
set ::g_foundModulesMemCache($searchid) $cache_list
return $cache_list
}
defineModEqStaticProc [isIcase] [getConf extended_default] $mod
# every entries are requested
set findall [expr {$mod eq {} || $mod eq {*}}]
# use catch protection to handle non-readable and non-existent dir
if {[catch {
set full_list {}
foreach {fpelt hid} [getFilesInDirectory $dir 0] {
set elt [file tail $fpelt]
# include any .modulerc file found at the modulepath root
if {$elt eq {.modulerc} || $findall || [modEqStatic $elt match]} {
lappend full_list $fpelt
}
}
}]} {
return {}
}
# walk through list of dirs and files to find modules
findModulesFromDirsAndFiles $dir $full_list $depthlvl $fetch_mtime mod_list
reportDebug "found [array names mod_list]"
# cache search results
reportDebug "create cache entry '$searchid'"
set found_list [array get mod_list]
set ::g_foundModulesMemCache($searchid) $found_list
return $found_list
}
proc getModules {dir {mod {}} {fetch_mtime 0} {search {}} {filter {}}} {
global g_sourceAlias g_sourceVersion g_sourceVirtual g_rcAlias\
g_moduleAlias g_rcVersion g_moduleVersion g_rcVirtual g_moduleVirtual\
g_rcfilesSourced
reportDebug "get '$mod' in $dir (fetch_mtime=$fetch_mtime, search=$search,\
filter=$filter)"
# generated search id (for cache search/save) by compacting given args
set searchid $dir:$mod:$fetch_mtime:$search:$filter
# look at memory cache for a compatible result
if {[info exists ::g_gotModulesMemCache($searchid)]} {
reportDebug "use cache entry '$searchid'"
return $::g_gotModulesMemCache($searchid)
}
# extract one module name from query
set modqe [getOneModuleFromVersSpec $mod]
# perform an in depth search or not
set indepth [expr {{noindepth} ni $search}]
# set a default if none defined on directory entries
set implicitdfl [getConf implicit_default]
# automatically define latest and default sym for all modules
# disable when implicit default or advanced version spec are disabled or
# if search query does not contain a module name and version but variant
set autosymbol [expr {$implicitdfl && [getConf advanced_version_spec] &&\
![isSpecWildWithVariant $mod]}]
# match passed name against any part of avail module names
set contains [expr {{contains} in $search}]
set mtest [expr {$contains ? {matchin} : {match}}]
set icase [isIcase]
set wild [expr {{wild} in $search}]
# will only keep default or latest elts in the end or remove plain dirs
set filtering [expr {$filter eq {noplaindir}}]
set keeping [expr {!$filtering && $filter ne {}}]
# check search query string corresponds to directory
set querydir [string trimright $modqe *]
set isquerydir [expr {[string index $querydir end] eq {/}}]
set querydir [string trimright $querydir /]
set querydepth [countChar $modqe /]
# get directory relative to module name
set moddir [getModuleNameFromVersSpec $mod]
set hasmoddir [expr {$moddir ne {.}}]
set modroot [getModuleRootFromVersSpec $mod]
set earlyfilter [expr {!$contains && !$wild && $modroot eq [string\
map {* {} ? {}} $modroot]}]
# are result entries gathered in a resolution context ?
set resctx [expr {{resolve} in $search}]
# need to perform an extra match search?
set ems_required [isExtraMatchSearchRequired $mod]
# if search for global or user rc alias only, no dir lookup is performed
# and aliases from g_rcAlias are returned
if {{rc_alias_only} in $search} {
set add_rc_defs 1
array set found_list {}
} else {
# find modules by searching mod root name in order to catch all module
# related entries to correctly computed auto symbols afterward
if {$contains} {
set findmod *
} else {
set findmod $modroot
# if searched mod is an empty or flat element append wildcard
# character to match anything starting with mod
if {$wild && !$hasmoddir && [string index $findmod end] ne {*}} {
append findmod *
}
}
# add alias/version definitions from global or user rc to result
set add_rc_defs [expr {{rc_defs_included} in $search}]
# if no indepth mode search, pass the depth level of the search query
# unless EMS need to be performed (findModules should fetch everything)
set depthlvl [expr {$indepth || [isExtraMatchSearchRequired $mod] ? 0 :\
$querydepth + 1}]
array set found_list [findModules $dir $findmod $depthlvl $fetch_mtime]
}
# Phase #1: consolidate every kind of entries (directory, modulefile,
# symbolic version, alias and virtual module) in found_list
array set err_list {}
array set versmod_list {}
foreach elt [lsort [array names found_list]] {
switch -- [lindex $found_list($elt) 0] {
modulerc {
# process rc files them remove them from found_list
if {![info exists g_rcfilesSourced($dir/$elt)]} {
execute-modulerc $dir/$elt $elt $elt
# Keep track of already sourced rc files not to run them again
set g_rcfilesSourced($dir/$elt) 1
}
unset found_list($elt)
}
modulefile {
}
default {
# flag entries with error
set err_list($elt) 1
}
}
}
# add all versions found when parsing .version or .modulerc files in this
# directory or in global or user rc definitions
foreach vers [array names g_moduleVersion] {
set versmod $g_moduleVersion($vers)
if {($dir ne {} && [string first $dir/ $g_sourceVersion($vers)] == 0)\
|| [info exists g_rcVersion($vers)]} {
set found_list($vers) [list version $versmod]
# build module symbol list
lappend versmod_list($versmod) $vers
# add global/user rc def to module symbol list in any cases
} elseif {!$add_rc_defs && [info exists g_rcVersion($vers)]} {
lappend versmod_list($versmod) $vers
}
}
# add aliases found when parsing .version or .modulerc files in this
# directory (skip aliases not registered from this directory except if
# global or user rc definitions should be included)
foreach alias [array names g_moduleAlias] {
if {($dir ne {} && [string first $dir/ $g_sourceAlias($alias)] == 0)\
|| ($add_rc_defs && [info exists g_rcAlias($alias)])} {
##nagelfar ignore Found constant
set found_list($alias) [list alias $g_moduleAlias($alias)]
}
}
# add virtual mods found when parsing .version or .modulerc files in this
# directory (skip virtual mods not registered from this directory except if
# global or user rc definitions should be included)
foreach virt [array names g_moduleVirtual] {
if {($dir ne {} && [string first $dir/ $g_sourceVirtual($virt)] == 0)\
|| ($add_rc_defs && [info exists g_rcVirtual($virt)])} {
lassign [checkValidModule $g_moduleVirtual($virt)] check_valid\
check_msg
switch -- $check_valid {
true {
set mtime [expr {$fetch_mtime ? [getFileMtime\
$g_moduleVirtual($virt)] : {}}]
# set mtime at index 1 like a modulefile entry
set found_list($virt) [list virtual $mtime\
$g_moduleVirtual($virt)]
}
default {
# register check error and relative message to get it in
# case of direct access of this module element
set found_list($virt) [list $check_valid $check_msg\
$g_moduleVirtual($virt)]
set err_list($virt) 1
}
}
}
}
# Phase #2: filter-out dynamically hidden or expired elements
# define module name and version comparison procs
defineModStartNbProc $icase
defineModEqProc $icase [getConf extended_default]
defineModEqStaticProc $icase [getConf extended_default] $mod
# remove hidden elements unless they are (or their symbols) targeted by
# search query.
foreach elt [array names found_list] {
if {$earlyfilter && ![modEq $modroot $elt eqstart]} {
unset found_list($elt)
continue
}
if {[lassign [isModuleHidden $elt $mod 1] hidlvl hidmatch hidbydef]} {
# is there a symbol that matches query (bare module name query
# matches default symbol on resolve context or if onlydefaults filter
# is applied)
if {!$hidmatch && [info exists versmod_list($elt)]} {
foreach eltsym $versmod_list($elt) {
if {[modEqStatic $eltsym] || (($resctx || $filter eq\
{onlydefaults}) && "$mod/default" eq $eltsym)} {
set hidmatch 1
break
}
}
}
# consider 'default' symbols are explicitly specified if
# onlydefaults filter applied or resolving bare module name
if {!$hidmatch && [lindex $found_list($elt) 0] eq {version} && [file\
tail $elt] eq {default} && ($filter eq {onlydefaults} || ($resctx\
&& "$mod/default" eq $elt))} {
set hidmatch 1
}
# not hidden if matched unless if hard hiding apply
if {!$hidmatch || $hidlvl > 1} {
# record hidden symbol, not to display it in listModules
if {[lindex $found_list($elt) 0] eq {version}} {
lappend ::g_hiddenSymHash([lindex $found_list($elt) 1]) [file\
tail $elt]
}
# transform forbidden module in error entry if it specifically
# matches search query
if {$hidlvl == 2 && $hidmatch && [isModuleTagged $elt\
forbidden]} {
set found_list($elt) [list accesserr [getForbiddenMsg $elt]]
set err_list($elt) 1
} else {
unset found_list($elt)
}
}
}
# apply hidden tag if an hidden definition apply to module
if {$hidbydef} {
setModuleTag $elt hidden
}
}
# Phase #3: elaborate directory content with default element selection
array set dir_list {}
array set autosym_list {}
# build list of elements contained in each directory
foreach elt [array names found_list] {
# add a ref to element in its parent directory unless element has error
# or is a symbolic version then recursively add parent element until
# reaching top directory
if {![info exists err_list($elt)] && [lindex $found_list($elt) 0] ne\
{version}} {
set direlt $elt
while {[set pardir [file dirname $direlt]] ne {.}} {
appendNoDupToList dir_list($pardir) [file tail $direlt]
set direlt $pardir
}
}
}
# determine default element for each directory and record sorted elt list
# unless if an alias or a virtual module has overwritten directory entry
# but override alias entry if extra match search is required (as it
# withdrawn module aliases)
foreach elt [array names dir_list] {
if {![info exists found_list($elt)] || ($ems_required && [lindex\
$found_list($elt) 0] eq {alias})} {
set dir_list($elt) [lsort -dictionary $dir_list($elt)]
# get default element: explicitly defined default (whether it exists
# or is in error) or implicit default if enabled
if {[info exists found_list($elt/default)] && [lindex\
$found_list($elt/default) 0] eq {version}} {
set dfl [file tail [lindex $found_list($elt/default) 1]]
} elseif {$implicitdfl} {
set dfl [lindex $dir_list($elt) end]
} else {
set dfl {}
}
# record directory properties
set found_list($elt) [list directory $dfl {*}$dir_list($elt)]
# automatically define symbols for all modules matching query if
# these names do not exist yet or if in error, in which case only
# auto symbol resolution is set
if {$autosymbol && (!$hasmoddir || [modEq $modroot $elt eqstart])} {
if {![info exists found_list($elt/default)] || [info exists\
err_list($elt/default)]} {
if {![info exists found_list($elt/default)]} {
set found_list($elt/default) [list version $elt/$dfl]
lappend versmod_list($elt/$dfl) $elt/default
set autosym_list($elt/default) 1
}
setModuleResolution $elt/default $elt/$dfl default 1 1
}
if {![info exists found_list($elt/latest)] || [info exists\
err_list($elt/latest)]} {
set lat [lindex $dir_list($elt) end]
if {![info exists found_list($elt/latest)]} {
set found_list($elt/latest) [list version $elt/$lat]
lappend versmod_list($elt/$lat) $elt/latest
set autosym_list($elt/latest) 1
}
setModuleResolution $elt/latest $elt/$lat latest 1 1
}
}
}
}
# Phase #4: perform extra match search
if {$ems_required} {
filterExtraMatchSearch $mod found_list versmod_list
}
# ensure modEqStatic is defined as expected (could have been redefined
# during scan evaluation)
defineModEqStaticProc $icase [getConf extended_default] $mod
# Phase #5: filter results to keep those matching search query
# define module name and version comparison procs
defineDoesModMatchAtDepthProc $indepth $querydepth $mtest
# element to include in output
set report_dirwsym [isEltInReport dirwsym]
array set mod_list {}
array set fdir_list {}
array set keep_list {}
# keep element matching query, add directory of element matching query,
# also add directory to result if query name finishes with trailing slash;
# only keep auto syms if fully matched or version not specified in query;
# (hidden elements have been filtered on phase 2)
foreach elt [array names found_list] {
set elt_type [lindex $found_list($elt) 0]
if {(($wild && [doesModMatchAtDepth $elt]) || (!$wild && ([modEqStatic\
$elt match /*] || [modEqStatic $elt match] || ($hasmoddir &&\
$elt_type eq {directory} && [modEq $moddir $elt]))) || ($isquerydir\
&& $elt_type eq {directory} && [modEq $querydir $elt match 0])) &&\
(![info exists autosym_list($elt)] || ([countChar $elt /]\
!= $querydepth && !$contains) || [modEqStatic $elt]) && ![info\
exists mod_list($elt)]} {
if {$elt_type eq {directory}} {
# add matching directory to the result list, its entries will be
# computed in a second time and directory will be dropped if it
# has no entry in the end
set mod_list($elt) [list directory]
# add dir to the filter dir list to enable its removal in next
# step if dir is empty
if {![info exists fdir_list($elt)]} {
set fdir_list($elt) {}
}
} else {
set mod_list($elt) $found_list($elt)
}
# version may matches query but not its target, so it should be in
# this case manually added to result (if it exists)
if {$elt_type eq {version}} {
# resolve eventual icase target
set versmod [getArrayKey found_list [lindex $mod_list($elt) 1]\
$icase]
# add target to dir struct (not version) if not already recorded
set direlt .
# recursively add targets to result (process directory content if
# target is a directory
set tgt_list [list $versmod]
for {set i 0} {$i < [llength $tgt_list]} {incr i} {
set tgt [lindex $tgt_list $i]
if {![info exists mod_list($tgt)]} {
if {[info exists found_list($tgt)]} {
set mod_list($tgt) $found_list($tgt)
# version target is directory: recursively add content
if {[lindex $mod_list($tgt) 0] eq {directory}} {
foreach tgtelt $dir_list($tgt) {
lappend tgt_list $tgt/$tgtelt
}
# add dir to the filter dir list to enable its removal
# in next step if dir is empty
if {![info exists fdir_list($tgt)]} {
set fdir_list($tgt) {}
}
}
}
# record target in dir struct if part of found elts or if
# hidden but should not be in error
set pardir [file dirname $tgt]
if {([info exists found_list($tgt)] || ($pardir ne {.} &&\
![info exists found_list($pardir)] && [isModuleHidden\
$tgt $mod])) && ![info exists err_list($tgt)]} {
# create parent directory if it does not exist
if {$pardir ne {.} && ![info exists\
found_list($pardir)]} {
set found_list($pardir) [list directory]
set mod_list($pardir) [list directory]
}
if {$i == 0} {
set direlt $tgt
} else {
lappend fdir_list([file dirname $tgt]) [file tail\
$tgt]
}
}
}
}
# skip adding element to directory content if in error
} elseif {[info exists err_list($elt)]} {
set direlt .
} else {
set direlt $elt
}
# track directory content, as directory are also reported to their
# parent directory the directory structure is also tracked
if {[set pardir [file dirname $direlt]] ne {.}} {
lappend fdir_list($pardir) [file tail $direlt]
# track top level entries that will be kept if result is filtered
} elseif {$keeping && $direlt ne {.} && $elt_type ne {directory}} {
set keep_list($elt) 1
}
}
}
# determine default element for each directory and record sorted element
# list unless directory entry has been overwritten by a different module
# kind or unless only matching directory should be part of result
foreach elt [lsort -decreasing [array names fdir_list]] {
if {[lindex $found_list($elt) 0] eq {directory} && ([info exists\
mod_list($elt)] || $keeping)} {
set fdir_list($elt) [lsort -dictionary $fdir_list($elt)]
# get default element: explicitly defined default if included in
# result or not found or implicit default if enabled
if {[info exists found_list($elt/default)] && [lindex\
$found_list($elt/default) 0] eq {version} && ([info exists\
mod_list([set versmod [lindex $found_list($elt/default) 1]])] ||\
![info exists found_list($versmod)])} {
set dfl [file tail $versmod]
} elseif {$implicitdfl} {
set dfl [lindex $fdir_list($elt) end]
} else {
set dfl {}
}
# remove empty dirs
if {[llength $fdir_list($elt)] == 0} {
unset mod_list($elt)
unset fdir_list($elt)
# remove unset dir reference in parent directory. parent dir
# will be treated after unset dir (due to decreasing sort) if it
# needs to get in turn unset
if {[set pardir [file dirname $elt]] ne {.}} {
set fdir_list($pardir) [replaceFromList $fdir_list($pardir)\
[file tail $elt]]
}
} else {
# record directory properties
set mod_list($elt) [list directory $dfl {*}$fdir_list($elt)]
# list elements to keep for filtering step
if {$keeping} {
if {$filter eq {onlylatest}} {
set keepelt $elt/[lindex $fdir_list($elt) end]
} elseif {$dfl ne {}} {
set keepelt $elt/$dfl
} else {
set keepelt {}
}
# keep directory if its element depth is deeper than query
if {!$indepth && [countChar $keepelt /] > $querydepth} {
set keep_list($elt) 1
# otherwise only keep existing modules (not directories)
} elseif {[info exists mod_list($keepelt)] && [lindex\
$mod_list($keepelt) 0] ne {directory}} {
set keep_list($keepelt) 1
}
# when noplaindir filtering, only keep dirs with syms when indepth
# enabled or if corresponds to query depth when indepth disabled
} elseif {$filtering && $filter eq {noplaindir} &&\
(($indepth && (!$report_dirwsym || ![doesModuleHaveSym $elt]))\
|| (!$indepth && [countChar $elt /] != $querydepth))} {
unset mod_list($elt)
}
}
}
}
# now all matching modulefiles are settled, only keep those found at search
# query depth level if 'noindepth' mode asked
if {!$indepth} {
# remove entries with more filename path separator than query pattern
foreach elt [array names mod_list] {
if {[countChar $elt /] > $querydepth} {
unset mod_list($elt)
}
}
}
# if result should be filtered, only keep marked elements
if {$keeping} {
foreach elt [array names mod_list] {
if {![info exists keep_list($elt)]} {
unset mod_list($elt)
}
}
}
# Phase #6: consolidate tags set for retained modules
if {[currentState commandname] eq {avail}} {
# load tags from loaded modules in the global structure prior collecting
# tags found during this getModules evaluation
cacheCurrentModules 0
foreach elt [array names mod_list] {
switch -- [lindex $mod_list($elt) 0] {
alias - modulefile - virtual {
# gather all tags applying to elt
collectModuleTags $elt
}
}
}
}
reportTrace "{[array names mod_list]} matching '$mod' in '$dir'" {Get\
modules}
# cache search results
reportDebug "create cache entry '$searchid'"
set got_list [array get mod_list]
set ::g_gotModulesMemCache($searchid) $got_list
return $got_list
}
# gather for the current top evaluation the information on all evaluations
# happening under its umbrella
proc registerModuleEval {context msgrecid {failedmod {}} {failedcontext {}}} {
set evalid [topState evalid]
set unset [expr {$failedmod eq {} ? 0 : 1}]
set contextset 0
# add msgrecid to existing evaluation context list
if {[info exists ::g_moduleEval($evalid)]} {
for {set i 0} {$i < [llength $::g_moduleEval($evalid)]} {incr i 1} {
set contextevallist [lindex $::g_moduleEval($evalid) $i]
if {[lindex $contextevallist 0] eq $context} {
if {$unset} {
set contextevallist [replaceFromList $contextevallist\
$msgrecid]
} else {
lappend contextevallist $msgrecid
}
set ::g_moduleEval($evalid) [expr {[llength $contextevallist] > 1\
? [lreplace $::g_moduleEval($evalid) $i $i $contextevallist]\
: [lreplace $::g_moduleEval($evalid) $i $i]}]
set contextset 1
break
}
}
}
# add msgrecid to new evaluation context list
if {!$unset && !$contextset} {
lappend ::g_moduleEval($evalid) [list $context $msgrecid]
}
# add mod to failed evaluation list
if {$unset} {
lappend ::g_moduleFailedEval($evalid) $failedcontext $failedmod
}
}
# record that module evaluation is set hidden
proc registerModuleEvalHidden {context msgrecid} {
set evalid [topState evalid]
lappend ::g_moduleHiddenEval($evalid:$context) $msgrecid
}
# get context of currently evaluated module
proc currentModuleEvalContext {} {
return [lindex $::g_moduleEvalAttempt([currentState modulenamevr]) end]
}
# record module evaluation attempt and corresponding context
proc registerModuleEvalAttempt {context mod} {
appendNoDupToList ::g_moduleEvalAttempt($mod) $context
}
proc unregisterModuleEvalAttempt {context mod} {
set ::g_moduleEvalAttempt($mod) [replaceFromList\
$::g_moduleEvalAttempt($mod) $context]
}
# is at least one module passed as argument evaluated in passed context
proc isModuleEvaluated {context exclmod args} {
set ret 0
# look at all evaluated mod except excluded one (currently evaluated mod)
foreach evalmod [lsearch -all -inline -not [array names\
::g_moduleEvalAttempt] $exclmod] {
set evalmatch 0
# test arguments against all names of evaluated module (translate
# eventual modspec in evalmod into module names, in case module
# evaluation stopped prior module name setup)
# retrieve variants to pass them directly to modEq
set modvrlist [getVariantList $evalmod 0 0 1]
foreach mod [getAllModulesFromVersSpec $evalmod] {
foreach name $args {
# indicate module is loading to also compare against all alt names
if {[modEq $name $mod eqstart 1 1 1 $modvrlist]} {
set evalmatch 1
if {$context eq {any} || $context in\
$::g_moduleEvalAttempt($evalmod)} {
set ret 1
}
break
}
}
if {$evalmatch} {
break
}
}
if {$ret} {
break
}
}
return $ret
}
# was passed mod already evaluated for context and failed
proc isModuleEvalFailed {context mod} {
set ret 0
set evalid [topState evalid]
if {[info exists ::g_moduleFailedEval($evalid)]} {
foreach {curcon curmod} $::g_moduleFailedEval($evalid) {
if {$context eq $curcon && $mod eq $curmod} {
set ret 1
break
}
}
}
return $ret
}
# return list of currently loading modules in stack
proc getLoadingModuleList {} {
set modlist [list]
for {set i 0} {$i < [depthState modulename]} {incr i 1} {
if {[lindex [getState mode] $i] eq {load}} {
lappend modlist [lindex [getState modulename] $i]
}
}
return $modlist
}
# return list of currently loading modulefiles in stack
proc getLoadingModuleFileList {} {
set modlist [list]
for {set i 0} {$i < [depthState modulefile]} {incr i 1} {
if {[lindex [getState mode] $i] eq {load}} {
lappend modlist [lindex [getState modulefile] $i]
}
}
return $modlist
}
# return list of currently unloading modules in stack
proc getUnloadingModuleList {} {
set modlist [list]
for {set i 0} {$i < [depthState modulename]} {incr i 1} {
if {[lindex [getState mode] $i] eq {unload}} {
lappend modlist [lindex [getState modulename] $i]
}
}
return $modlist
}
# sort passed module list following both loaded and dependency orders
proc sortModulePerLoadedAndDepOrder {modlist {nporeq 0} {loading 0}} {
# sort per loaded order
set sortlist {}
if {[llength $modlist] > 0} {
foreach lmmod [getLoadedModulePropertyList name] {
if {$lmmod in $modlist} {
lappend sortlist $lmmod
}
}
# also sort eventual loading modules if asked
if {$loading} {
foreach loadingmod [lreverse [getLoadingModuleList]] {
if {$loadingmod in $modlist} {
lappend sortlist $loadingmod
}
}
}
}
# then refine sort with dependencies between loaded modules: a dependent
# module should be placed prior the loaded module requiring it
set reqListVar [expr {$nporeq ? {::g_moduleNPODepend} :\
{::g_moduleDepend}}]
set i 0
set imax [llength $sortlist]
while {$i < $imax} {
set mod [lindex $sortlist $i]
set jmin $imax
##nagelfar ignore #4 Suspicious variable name
if {[info exists ${reqListVar}($mod)]} {
# goes over all dependent modules to find the first one in the loaded
# order list located after requiring mod
foreach lmmodlist [set ${reqListVar}($mod)] {
foreach lmmod $lmmodlist {
set j [lsearch -exact $sortlist $lmmod]
if {$j > $i && $j < $jmin} {
set jmin $j
set jminmod $lmmod
}
}
}
}
# move first dependent module found after currently inspected mod right
# before it
if {$jmin != $imax} {
set sortlist [linsert [lreplace $sortlist $jmin $jmin] $i $jminmod]
# or go to next element in list if current element has not been changed
} else {
incr i
}
}
return $sortlist
}
# return list of loaded modules having an unmet requirement on passed mod
# and their recursive dependent
proc getUnmetDependentLoadedModuleList {modnamevr} {
set unmetdeplist {}
set depmodlist {}
defineModEqProc [isIcase] [getConf extended_default] 1
set mod [getModuleNameAndVersFromVersSpec $modnamevr]
set vrlist [getVariantList $modnamevr 0 0 1]
# skip dependent analysis if mod has a conflict with a loaded module
lassign [doesModuleConflict $mod] doescon modconlist
if {!$doescon} {
foreach ummod [array names ::g_unmetDepHash] {
if {[modEq $ummod $mod eqstart 1 2 1 $vrlist]} {
foreach depmod $::g_unmetDepHash($ummod) {
lappend depmodlist $depmod
# temporarily remove prereq violation of depmod if mod
# load solves it (no other prereq is missing)
if {[info exists ::g_prereqViolation($depmod)]} {
foreach prereq $::g_prereqViolation($depmod) {
foreach modpre $prereq {
# also temporarily remove prereq violation for
# requirements loaded after dependent module
if {[modEq $modpre $mod eqstart 1 2 1 $vrlist] ||\
[is-loaded $modpre]} {
# backup original violation to restore it later
if {![info exists preunvioarr($depmod)]} {
set preunvioarr($depmod)\
$::g_prereqViolation($depmod)
}
# temporarily remove matching violation
set ::g_prereqViolation($depmod) [replaceFromList\
$::g_prereqViolation($depmod) $prereq]
if {[llength $::g_prereqViolation($depmod)] == 0} {
unset ::g_prereqViolation($depmod)
}
break
}
}
}
}
}
}
}
}
# select dependent if all its constraint are now satisfied (after removing
# eventual prereq violation toward mod)
foreach depmod $depmodlist {
if {[areModuleConstraintsSatisfied $depmod]} {
appendNoDupToList unmetdeplist $depmod
}
}
# get dependent of dependent
set deplist [getDependentLoadedModuleList $unmetdeplist 0 0 0 0 1]
# restore temporarily lift prereq violation
if {[array exists preunvioarr]} {
foreach depmod [array names preunvioarr] {
set ::g_prereqViolation($depmod) $preunvioarr($depmod)
}
}
set sortlist [sortModulePerLoadedAndDepOrder [list {*}$unmetdeplist\
{*}$deplist]]
reportDebug "got '$sortlist'"
return $sortlist
}
# return list of loaded modules declaring a prereq on passed mod with
# distinction made with strong prereqs (no alternative loaded) or weak and
# also with prereq loaded after their dependent module
proc getDirectDependentList {mod {strong 0} {nporeq 0} {loading 0}\
{othmodlist {}}} {
set deplist {}
# include or not requirements loaded after their dependent
if {$nporeq} {
set depListVar ::g_dependNPOHash
set reqListVar ::g_moduleNPODepend
} else {
set depListVar ::g_dependHash
set reqListVar ::g_moduleDepend
}
##nagelfar ignore #2 Suspicious variable name
if {[info exists ${depListVar}($mod)]} {
foreach depmod [set ${depListVar}($mod)] {
set add 1
# skip optional dependency if only looking for strong ones
# look at an additionally processed mod list to determine if all
# mods from a dependent list (composed of optional parts) are part
# of the search, which means mod is not optional but strong dependent
if {$strong && [llength $depmod] > 1} {
##nagelfar ignore Suspicious variable name
foreach lmmodlist [set ${reqListVar}([lindex $depmod 0])] {
if {$mod in $lmmodlist} {
foreach lmmod $lmmodlist {
# other mod part of the opt list is not there so mod
# is considered optional
if {$lmmod ni $othmodlist} {
set add 0
break
}
}
break
}
}
}
if {$add} {
lappend deplist [lindex $depmod 0]
}
}
}
# take currently loading modules into account if asked
if {$loading} {
set modlist [getLoadedModulePropertyList name]
defineModEqProc [isIcase] [getConf extended_default] 1
# reverse list to get closest match if returning lastly loaded module
if {[getConf unload_match_order] eq {returnlast}} {
set modlist [lreverse $modlist]
}
foreach loadingmod [getLoadingModuleList] {
foreach prereq [getLoadedPrereq $loadingmod] {
set lmprelist {}
set moddep 0
foreach modpre $prereq {
foreach lmmod $modlist {
if {[modEq $modpre $lmmod eqstart 1 2 1]} {
lappend lmprelist $lmmod
if {$lmmod eq $mod} {
set moddep 1
}
break
}
}
}
if {$moddep && (!$strong || [llength $lmprelist] == 1)} {
lappend deplist $loadingmod
break
}
}
}
}
return $deplist
}
# gets the list of all loaded modules which are dependent of passed modlist
# ordered by load position. strong argument controls whether only the active
# dependent modules should be returned or also those that are optional. direct
# argument controls if only dependent module directly requiring passed mods
# should be returned or its full dependent tree. nporeq argument tells if
# requirement loaded after their dependent should be returned. sat_constraint
# argument controls whether only the loaded module satisfying their constraint
# should be part or not of the resulting list. being_unload argument controls
# whether loaded modules in conflict with one or multiple modules from modlist
# should be added to the dependent list as these modules are currently being
# unloaded and these conflicting loaded modules should be refreshed.
proc getDependentLoadedModuleList {modlist {strong 1} {direct 1} {nporeq 0}\
{loading 1} {sat_constraint 0} {being_unload 0}} {
reportDebug "get loaded mod dependent of '$modlist' (strong=$strong,\
direct=$direct, nporeq=$nporeq, loading=$loading,\
sat_constraint=$sat_constraint, being_unload=$being_unload)"
set deplist {}
set fulllist $modlist
# look at consistent requirements for unloading modules
set unlonporeq [expr {$being_unload ? 0 : $nporeq}]
foreach mod $modlist {
# no duplicates or modules from query list
appendNoDupToList fulllist {*}[getDirectDependentList $mod $strong\
$unlonporeq $loading $fulllist]
}
if {$being_unload} {
# invite modules in violation with mods to be part of the dependent list
# with their own dependent modules as mod is being unloaded. Achieve so
# by faking that conflict violation is gone
foreach mod $modlist {
lassign [doesModuleConflict $mod] doescon modconlist
if {$doescon} {
unsetModuleConflictViolation $mod
set conunvioarr($mod) $modconlist
appendNoDupToList fulllist {*}$modconlist
}
}
}
set unloadingmodlist [getUnloadingModuleList]
for {set i [llength $modlist]} {$i < [llength $fulllist]} {incr i 1} {
set depmod [lindex $fulllist $i]
# skip already added mod or mod violating constraints if asked
if {!$sat_constraint || [areModuleConstraintsSatisfied $depmod\
$nporeq]} {
# get dependent mod of dep mod when looking at full dep tree
if {!$direct} {
appendNoDupToList fulllist {*}[getDirectDependentList $depmod\
$strong $nporeq 0 $fulllist]
}
# avoid module currently unloading from result list
if {$depmod ni $unloadingmodlist} {
lappend deplist $depmod
}
}
}
# restore conflict violation if any
if {[array exists conunvioarr]} {
foreach conunvio [array names conunvioarr] {
setModuleConflictViolation $conunvio $conunvioarr($conunvio)
}
}
# sort complete result list to match both loaded and dependency orders
set sortlist [sortModulePerLoadedAndDepOrder $deplist $nporeq $loading]
reportDebug "got '$sortlist'"
return $sortlist
}
# test if passed 'mod' could be automatically unloaded or not, which means it
# has been loaded automatically and no loaded modules require it anymore.
# unmodlist: pass a list of modules that are going to be unloaded
proc isModuleUnloadable {mod {unmodlist {}}} {
set ret 1
# get currently unloading modules if no specific unmodlist set
if {[llength $unmodlist] == 0} {
set unmodlist [getUnloadingModuleList]
}
# loaded tag means module was not auto-loaded. keep-loaded means module is
# not auto-unloadable even if auto-loaded
if {[isModuleTagged $mod loaded 1] || [isModuleTagged $mod keep-loaded\
1]} {
set ret 0
} else {
# mod is unloadable if all its dependent are unloaded or unloading
foreach depmod [getDirectDependentList $mod] {
if {$depmod ni $unmodlist} {
set ret 0
break
}
}
}
return $ret
}
# gets the list of all loaded modules which are required by passed modlist
# ordered by load position.
proc getRequiredLoadedModuleList {modlist} {
# search over all list of loaded modules, starting with passed module
# list, then adding in turns their requirements
set fulllist $modlist
for {set i 0} {$i < [llength $fulllist]} {incr i 1} {
# gets the list of loaded modules which are required by depmod
appendNoDupToList fulllist {*}$::g_moduleDepend([lindex $fulllist $i])
}
# sort complete result list to match both loaded and dependency orders
set sortlist [sortModulePerLoadedAndDepOrder [lrange $fulllist [llength\
$modlist] end]]
reportDebug "got '$sortlist'"
return $sortlist
}
# finds required modules that can be unloaded if passed modules are unloaded:
# they have been loaded automatically and are not depended (mandatory or
# optionally) by other module
proc getUnloadableLoadedModuleList {modlist} {
# search over all list of unloaded modules, starting with passed module
# list, then adding in turns unloadable requirements
set fulllist $modlist
for {set i 0} {$i < [llength $fulllist]} {incr i 1} {
set depmod [lindex $fulllist $i]
# gets the list of loaded modules which are required by depmod
set deplist {}
foreach lmmodlist $::g_moduleDepend($depmod) {
foreach lmmod $lmmodlist {
if {$lmmod ni $fulllist} {
lappend deplist $lmmod
}
}
}
# get those required module that have been automatically loaded and are
# only required by modules currently being unloaded
foreach lmmod $deplist {
if {[isModuleUnloadable $lmmod $fulllist]} {
lappend fulllist $lmmod
}
}
}
# sort complete result list to match both loaded and dependency orders
set sortlist [sortModulePerLoadedAndDepOrder [lrange $fulllist [llength\
$modlist] end]]
reportDebug "got '$sortlist'"
return $sortlist
}
# how many settings bundle are currently saved
proc getSavedSettingsStackDepth {} {
return [llength $::g_SAVE_g_loadedModules]
}
# manage settings to save as a stack to have a separate set of settings
# for each module loaded or unloaded in order to be able to restore the
# correct set in case of failure
proc pushSettings {} {
foreach var {env g_clearedEnvVars g_Aliases g_stateEnvVars g_stateAliases\
g_stateFunctions g_Functions g_stateCompletes g_Completes\
g_newXResources g_delXResources g_loadedModules g_loadedModuleFiles\
g_loadedModuleVariant g_loadedModuleConflict g_loadedModulePrereq\
g_loadedModulesRefresh g_loadedModuleAltname g_loadedModuleAutoAltname\
g_loadedModuleAliasAltname g_moduleDepend g_dependHash\
g_moduleNPODepend g_dependNPOHash g_prereqViolation\
g_prereqNPOViolation g_conflictViolation g_moduleUnmetDep\
g_unmetDepHash g_moduleEval g_moduleHiddenEval g_scanModuleVariant} {
##nagelfar ignore Suspicious variable name
lappend ::g_SAVE_$var [array get ::$var]
}
# save non-array variable and indication if it was set
foreach var {g_changeDir g_stdoutPuts g_prestdoutPuts g_return_text} {
##nagelfar ignore #4 Suspicious variable name
if {[info exists ::$var]} {
lappend ::g_SAVE_$var [list 1 [set ::$var]]
} else {
lappend ::g_SAVE_$var [list 0 {}]
}
}
reportDebug "settings saved (#[getSavedSettingsStackDepth])"
}
proc popSettings {} {
set flushedid [getSavedSettingsStackDepth]
foreach var {env g_clearedEnvVars g_Aliases g_stateEnvVars g_stateAliases\
g_stateFunctions g_Functions g_stateCompletes g_Completes\
g_newXResources g_delXResources g_changeDir g_stdoutPuts\
g_prestdoutPuts g_return_text g_loadedModules g_loadedModuleFiles\
g_loadedModuleVariant g_loadedModuleConflict g_loadedModulePrereq\
g_loadedModulesRefresh g_loadedModuleAltname g_loadedModuleAutoAltname\
g_loadedModuleAliasAltname g_moduleDepend g_dependHash\
g_moduleNPODepend g_dependNPOHash g_prereqViolation\
g_prereqNPOViolation g_conflictViolation g_moduleUnmetDep\
g_unmetDepHash g_moduleEval g_moduleHiddenEval g_scanModuleVariant} {
##nagelfar ignore Suspicious variable name
set ::g_SAVE_$var [lrange [set ::g_SAVE_$var] 0 end-1]
}
reportDebug "previously saved settings flushed (#$flushedid)"
}
proc restoreSettings {} {
foreach var {g_clearedEnvVars g_Aliases g_stateEnvVars g_stateAliases\
g_stateFunctions g_Functions g_stateCompletes g_Completes\
g_newXResources g_delXResources g_loadedModules g_loadedModuleFiles\
g_loadedModuleVariant g_loadedModuleConflict g_loadedModulePrereq\
g_loadedModulesRefresh g_loadedModuleAltname g_loadedModuleAutoAltname\
g_loadedModuleAliasAltname g_moduleDepend g_dependHash\
g_moduleNPODepend g_dependNPOHash g_prereqViolation\
g_prereqNPOViolation g_conflictViolation g_moduleUnmetDep\
g_unmetDepHash g_moduleEval g_moduleHiddenEval g_scanModuleVariant} {
# clear current $var arrays
##nagelfar ignore #5 Suspicious variable name
if {[info exists ::$var]} {
unset ::$var
array set ::$var {}
}
array set ::$var [lindex [set ::g_SAVE_$var] end]
}
# specific restore mechanism for ::env as unsetting this array will make
# Tcl stop monitoring env accesses and not update env variables anymore
set envvarlist [list]
foreach {var val} [lindex $::g_SAVE_env end] {
lappend envvarlist $var
interp-sync-env set $var $val
}
foreach var [array names ::env] {
if {$var ni $envvarlist} {
interp-sync-env unset $var
}
}
# restore non-array variable if it was set
foreach var {g_changeDir g_stdoutPuts g_prestdoutPuts g_return_text} {
##nagelfar ignore #6 Suspicious variable name
if {[info exists ::$var]} {
unset ::$var
}
lassign [lindex [set ::g_SAVE_$var] end] isdefined val
if {$isdefined} {
set ::$var $val
}
}
reportDebug "previously saved settings restored\
(#[getSavedSettingsStackDepth])"
}
# load modules passed as args designated as requirement
proc loadRequirementModuleList {tryload optional tag_list args} {
set ret 0
set prereqloaded 0
# calling procedure must have already parsed module specification in args
set loadedmod_list {}
foreach mod $args {
# get all loaded or loading mod in args list
if {[set loadedmod [getLoadedMatchingName $mod returnfirst]] ne {} ||\
[set loadedmod [getLoadedMatchingName $mod returnfirst 1]] ne {}} {
lappend loadedmod_list $loadedmod
}
}
if {[llength $loadedmod_list] == 0} {
set imax [llength $args]
# if prereq list specified, try to load first then
# try next if load of first module not successful
for {set i 0} {$i<$imax && $prereqloaded==0} {incr i 1} {
set arg [lindex $args $i]
# hold output of each evaluation until they are all done to drop
# those that failed if one succeed or if optional
set curholdid load-$i-$arg
lappendState reportholdid $curholdid
if {[catch {set retlo [cmdModuleLoad reqlo 0 $tryload 0 $tag_list\
$arg]} errorMsg]} {
# if an error is raised, release output and rethrow the error
# (could be raised if no modulepath defined for instance)
lpopState reportholdid
lappend holdidlist $curholdid report
releaseHeldReport {*}$holdidlist
knerror $errorMsg
}
# update return value if an issue occurred in cmdModuleLoad
if {$retlo != 0} {
set ret $retlo
}
lpopState reportholdid
if {[is-loaded $arg]} {
set prereqloaded 1
# set previous reports to be dropped as this one succeed
if {[info exists holdidlist]} {
foreach {holdid action} $holdidlist {
lappend newholdidlist $holdid drop
}
set holdidlist $newholdidlist
}
}
# drop report if not loaded and optional
set action [expr {$prereqloaded || !$optional ? {report} : {drop}}]
lappend holdidlist $curholdid $action
}
# output held messages
releaseHeldReport {*}$holdidlist
} else {
set prereqloaded 1
# apply missing tag to all loaded module found
cmdModuleTag 0 0 $tag_list {*}$loadedmod_list
}
return [list $ret $prereqloaded]
}
# unload phase of a list of modules reload process
proc reloadModuleListUnloadPhase {lmname {force 0} {errmsgtpl {}} {context\
unload}} {
upvar $lmname lmlist
# unload one by one to ensure same behavior whatever auto_handling state
foreach mod [lreverse $lmlist] {
# record hint that mod will be reloaded (useful in case mod is sticky)
lappendState reloading_sticky $mod
lappendState reloading_supersticky $mod
# save user asked state before it vanishes
set isuasked($mod) [isModuleTagged $mod loaded 1]
# save variants set for modules
set vr($mod) [getVariantList $mod 1 2]
# save extra tags set
set extratag($mod) [getExtraTagList $mod]
# force unload even if requiring mods are not part of the unload list
# (violation state) as modules are loaded again just after
if {[cmdModuleUnload $context match 0 1 0 0 $mod]} {
# avoid failing module on load phase
set lmlist [replaceFromList $lmlist $mod]
set errMsg [string map [list _MOD_ [getModuleDesignation loaded\
$mod]] $errmsgtpl]
if {$force} {
# errMsg will always be set as force mode could not be enabled
# for reload sub-cmd which provides an empty msg template
reportWarning $errMsg 1
# stop if one unload fails unless force mode enabled
} else {
lpopState reloading_sticky
lpopState reloading_supersticky
knerror $errMsg
}
}
lpopState reloading_sticky
lpopState reloading_supersticky
}
return [list [array get isuasked] [array get vr] [array get extratag]]
}
# load phase of a list of modules reload process
proc reloadModuleListLoadPhase {lmname isuaskedlist vrlist extrataglist\
{force 0} {errmsgtpl {}} {context load}} {
upvar $lmname lmlist
array set isuasked $isuaskedlist
array set vr $vrlist
array set extratag $extrataglist
# loads are made with auto handling mode disabled to avoid disturbances
# from a missing prereq automatically reloaded, so these module loads may
# fail as prereq may not be satisfied anymore
setConf auto_handling 0
foreach mod $lmlist {
# if an auto set default was excluded, module spec need parsing
lassign [parseModuleSpecification 0 0 0 0 $mod {*}$vr($mod)] modnamevr
# reload module with user asked property and extra tags preserved
if {[cmdModuleLoad $context $isuasked($mod) 0 0 $extratag($mod)\
$modnamevr]} {
set errMsg [string map [list _MOD_ [getModuleDesignation spec\
$modnamevr]] $errmsgtpl]
if {$force} {
# errMsg will always be set as force mode could not be enabled
# for reload sub-cmd which provides an empty msg template
reportWarning $errMsg 1
# stop if one load fails unless force mode enabled
} else {
knerror $errMsg
}
}
}
setConf auto_handling 1
}
# test if loaded module 'mod' is sticky and if stickiness definition applies
# to one of the reloading module
proc isStickinessReloading {mod reloading_modlist {tag sticky}} {
set res 0
set modname [getModuleNameAndVersFromVersSpec $mod]
if {[isModuleTagged $modname $tag 1]} {
# evaluate the module-tag commands that are related to mod
set dir [getModulepathFromModuleName [getModulefileFromLoadedModule\
$modname] $modname]
getModules $dir $modname 0 [list rc_defs_included]
set tmodspec [getModuleTag $mod $tag equal 1]
# if tag specifically applies to fully qualified module, exact same
# module should be found in reload list
if {$tmodspec ne {}} {
set tmodspec $mod
} else {
set tmodspec [getModuleTag $mod $tag eqstart 1]
}
# check if a loading mod satisfies sticky rules
foreach modlo $reloading_modlist {
if {[modEq $tmodspec $modlo eqstart 1 0 1]} {
# found match
set res 1
break
}
}
reportDebug "stickiness ($tag) applies to '$tmodspec', is\
reloading=$res"
}
return $res
}
# Define procedure to get how many parts between passed name and mod are equal
# Adapt procedure code whether icase is enabled or disabled
proc defineModStartNbProc {icase} {
set procname modStartNbProc
if {$icase} {
append procname Icase
}
# define proc if not done yet or if it was defined for another context
if {[info procs modStartNb] eq {} || $::g_modStartNb_proc ne $procname} {
if {[info exists ::g_modStartNb_proc]} {
# remove existing debug trace if any
initProcReportTrace remove modStartNb
rename ::modStartNb ::$::g_modStartNb_proc
}
##nagelfar syntax modStartNb x x
rename ::$procname ::modStartNb
# set report traces if some debug mode enabled
initProcReportTrace add modStartNb
set ::g_modStartNb_proc $procname
}
}
# alternative definitions of modStartNb proc
proc modStartNbProc {mod name} {
# first compare against name's parent chunk by chunk
set modname [getModuleNameFromVersSpec $name]
if {$modname eq {.}} {
set i 0
set imax 0
} else {
set namesplit [split $modname /]
set modsplit [split $mod /]
set imax [tcl::mathfunc::min [llength $namesplit] [llength $modsplit]]
for {set i 0} {$i < $imax} {incr i} {
if {![string equal [lindex $modsplit $i] [lindex $namesplit $i]]} {
break
}
}
}
# if name's parent matches check if full name also matches
if {$i == $imax && [modEq $name $mod eqstart]} {
incr i
}
return $i
}
proc modStartNbProcIcase {mod name} {
set modname [getModuleNameFromVersSpec $name]
if {$modname eq {.}} {
set i 0
set imax 0
} else {
set namesplit [split $modname /]
set modsplit [split $mod /]
##nagelfar ignore #2 Badly formed if statement
set imax [if {[llength $namesplit] < [llength $modsplit]} {llength\
$namesplit} {llength $modsplit}]
for {set i 0} {$i < $imax} {incr i} {
if {![string equal -nocase [lindex $modsplit $i] [lindex $namesplit\
$i]]} {
break
}
}
}
if {$i == $imax && [modEq $name $mod eqstart]} {
incr i
}
return $i
}
# Define procedure to compare module names set as array keys against pattern.
# Adapt procedure code whether implicit_default is enabled or disabled
proc defineGetEqArrayKeyProc {icase extdfl impdfl} {
set procname getEqArrayKeyProc
if {$impdfl} {
append procname Impdfl
}
# define proc if not done yet or if it was defined for another context
if {[info procs getEqArrayKey] eq {} || $::g_getEqArrayKey_proc ne\
$procname} {
if {[info exists ::g_getEqArrayKey_proc]} {
# remove existing debug trace if any
initProcReportTrace remove getEqArrayKey
rename ::getEqArrayKey ::$::g_getEqArrayKey_proc
}
##nagelfar syntax getEqArrayKey x x
rename ::$procname ::getEqArrayKey
# set report traces if some debug mode enabled
initProcReportTrace add getEqArrayKey
set ::g_getEqArrayKey_proc $procname
}
# also define modEq which is called by getEqArrayKey
defineModEqProc $icase $extdfl
}
# alternative definitions of getEqArrayKey proc
proc getEqArrayKeyProcImpdfl {arrname name} {
set icase [isIcase]
upvar $arrname arr
# extract single module specified if any
lassign [getModuleVersSpec $name] mod modname
# check name eventual icase match
set mod [getArrayKey arr [string trimright $mod /] $icase]
if {$mod ne {} && [info exists arr($mod)]} {
set match $mod
} else {
set mlist {}
foreach elt [array names arr] {
if {[modEq $name $elt]} {
lappend mlist $elt
}
}
if {[llength $mlist] == 1} {
set match [lindex $mlist 0]
# in case multiple modules match query, check directory default and
# return it if it is part of match list, elsewhere return highest result
} elseif {[llength $mlist] > 1} {
# get corresponding icase parent directory
set pname [getArrayKey arr $modname $icase]
if {[info exists arr($pname)]} {
set dfl $pname/[lindex $arr($pname) 1]
}
# resolve symbolic version entries
foreach elt $mlist {
if {[lindex $arr($elt) 0] eq {version}} {
lappend mrlist [lindex $arr($elt) 1]
} else {
lappend mrlist $elt
}
}
if {[info exists dfl] && $dfl in $mrlist} {
set match $dfl
} else {
set match [lindex [lsort -dictionary $mrlist] end]
}
}
}
if {[info exists match]} {
reportDebug "key '$match' in array '$arrname' matches '$name'"
set name $match
}
return $name
}
proc getEqArrayKeyProc {arrname name} {
set icase [isIcase]
upvar $arrname arr
lassign [getModuleVersSpec $name] mod modname cmpspec versspec modnamere\
modescglob modroot variantlist modnvspec
# check name eventual icase match
set mod [getArrayKey arr [string trimright $mod /] $icase]
if {$mod ne {} && [info exists arr($mod)]} {
set match $mod
} else {
set mlist {}
foreach elt [array names arr] {
if {[modEq $name $elt]} {
lappend mlist $elt
}
}
# must have a default part of result even if only one result
if {[llength $mlist] >= 1} {
# get corresponding icase parent directory
set pname [getArrayKey arr $modname $icase]
if {[info exists arr($pname)]} {
set dfl $pname/[lindex $arr($pname) 1]
}
# resolve symbolic version entries
foreach elt $mlist {
if {[lindex $arr($elt) 0] eq {version}} {
lappend mrlist [lindex $arr($elt) 1]
} else {
lappend mrlist $elt
}
}
if {[info exists dfl] && $dfl in $mrlist} {
set match $dfl
} else {
# raise error as no default part of result
upvar retlist retlist
set retlist [list {} $modnvspec $name none "No default version\
defined for '$name'"]
}
}
}
if {[info exists match]} {
reportDebug "key '$match' in array '$arrname' matches '$name'"
set name $match
}
return $name
}
# Check a module name does match query at expected depth level when indepth
# search is disabled. Define procedure on the fly to adapt its
# code to indepth configuration option and querydepth and test mode params.
proc defineDoesModMatchAtDepthProc {indepth querydepth test} {
set procprops $indepth:$querydepth:$test
# define proc if not done yet or if it was defined for another context
if {[info procs doesModMatchAtDepth] eq {} ||\
$::g_doesModMatchAtDepth_procprops ne $procprops} {
if {[info exists ::g_doesModMatchAtDepth_procprops]} {
# remove existing debug trace if any
initProcReportTrace remove doesModMatchAtDepth
rename ::doesModMatchAtDepth {}
}
set ::g_doesModMatchAtDepth_procprops $procprops
# define optimized procedure
if {$indepth} {
set atdepth {$mod}
} else {
set atdepth "\[join \[lrange \[split \$mod /\] 0 $querydepth\] /\]"
}
##nagelfar syntax doesModMatchAtDepth x
##nagelfar ignore Non constant argument to proc
proc doesModMatchAtDepth {mod} "return \[modEqStatic $atdepth $test *\]"
# set report traces if some debug mode enabled
initProcReportTrace add doesModMatchAtDepth
}
}
# Define procedure to check module version equals pattern. Adapt procedure
# code whether icase and extended_default are enabled or disabled
proc defineModVersCmpProc {icase extdfl} {
set procname modVersCmpProc
if {$icase} {
append procname Icase
}
if {$extdfl} {
append procname Extdfl
}
# define proc if not done yet or if it was defined for another context
if {[info procs modVersCmp] eq {} || $::g_modVersCmp_proc ne $procname} {
if {[info exists ::g_modVersCmp_proc]} {
# remove existing debug trace if any
initProcReportTrace remove modVersCmp
rename ::modVersCmp ::$::g_modVersCmp_proc
}
##nagelfar syntax modVersCmp x x x x x?
rename ::$procname ::modVersCmp
# set report traces if some debug mode enabled
initProcReportTrace add modVersCmp
set ::g_modVersCmp_proc $procname
}
}
# alternative definitions of modVersCmp proc
proc modVersCmpProc {cmpspec versspec modvers test {psuf {}}} {
set ret 0
switch -- $cmpspec {
in {
# check each verspec in list until match
foreach inspec $versspec {
lassign $inspec incmp invers
if {[set ret [modVersCmp $incmp $invers $modvers $test $psuf]]} {
break
}
}
}
eq {
append versspec $psuf
if {$test eq {eqstart}} {
set ret [string equal -length [string length $versspec/]\
$versspec/ $modvers/]
} else {
##nagelfar ignore Non static subcommand
set ret [string $test $versspec $modvers]
}
}
ge {
# as we work here on a version range: psuf suffix is ignored, checks
# are always extended_default-enabled (as 1.2 includes 1.2.12 for
# instance) and equal, eqstart and match tests are equivalent
set ret [expr {[isVersion $modvers] && ([versioncmp $modvers\
$versspec] != -1 || [string match $versspec.* $modvers])}]
}
le {
# 'ge' comment also applies here
set ret [expr {[isVersion $modvers] && ([versioncmp $versspec\
$modvers] != -1 || [string match $versspec.* $modvers])}]
}
be {
# 'ge' comment also applies here
lassign $versspec lovers hivers
set ret [expr {[isVersion $modvers] && ([versioncmp $modvers\
$lovers] != -1 || [string match $lovers.* $modvers]) &&\
([versioncmp $hivers $modvers] != -1 || [string match\
$hivers.* $modvers])}]
}
}
return $ret
}
proc modVersCmpProcIcase {cmpspec versspec modvers test {psuf {}}} {
set ret 0
switch -- $cmpspec {
in {
foreach inspec $versspec {
lassign $inspec incmp invers
if {[set ret [modVersCmp $incmp $invers $modvers $test $psuf]]} {
break
}
}
}
eq {
append versspec $psuf
if {$test eq {eqstart}} {
set ret [string equal -nocase -length [string length $versspec/]\
$versspec/ $modvers/]
} else {
##nagelfar ignore Non static subcommand
set ret [string $test -nocase $versspec $modvers]
}
}
ge {
set ret [expr {[isVersion $modvers] && ([versioncmp $modvers\
$versspec] != -1 || [string match -nocase $versspec.* $modvers])}]
}
le {
set ret [expr {[isVersion $modvers] && ([versioncmp $versspec\
$modvers] != -1 || [string match -nocase $versspec.* $modvers])}]
}
be {
lassign $versspec lovers hivers
set ret [expr {[isVersion $modvers] && ([versioncmp $modvers\
$lovers] != -1 || [string match $lovers.* $modvers]) &&\
([versioncmp $hivers $modvers] != -1 || [string match -nocase\
$hivers.* $modvers])}]
}
}
return $ret
}
proc modVersCmpProcExtdfl {cmpspec versspec modvers test {psuf {}}} {
set ret 0
switch -- $cmpspec {
in {
foreach inspec $versspec {
lassign $inspec incmp invers
if {[set ret [modVersCmp $incmp $invers $modvers $test $psuf]]} {
break
}
}
}
eq {
append versspec $psuf
if {$test eq {eqstart}} {
set ret [string equal -length [string length $versspec/]\
$versspec/ $modvers/]
} else {
##nagelfar ignore Non static subcommand
set ret [string $test $versspec $modvers]
}
if {!$ret && [string match $versspec.* $modvers]} {
set ret 1
}
}
ge {
set ret [expr {[isVersion $modvers] && ([versioncmp $modvers\
$versspec] != -1 || [string match $versspec.* $modvers])}]
}
le {
set ret [expr {[isVersion $modvers] && ([versioncmp $versspec\
$modvers] != -1 || [string match $versspec.* $modvers])}]
}
be {
lassign $versspec lovers hivers
set ret [expr {[isVersion $modvers] && ([versioncmp $modvers\
$lovers] != -1 || [string match $lovers.* $modvers]) &&\
([versioncmp $hivers $modvers] != -1 || [string match\
$hivers.* $modvers])}]
}
}
return $ret
}
proc modVersCmpProcIcaseExtdfl {cmpspec versspec modvers test {psuf {}}} {
set ret 0
switch -- $cmpspec {
in {
foreach inspec $versspec {
lassign $inspec incmp invers
if {[set ret [modVersCmp $incmp $invers $modvers $test $psuf]]} {
break
}
}
}
eq {
append versspec $psuf
if {$test eq {eqstart}} {
set ret [string equal -nocase -length [string length $versspec/]\
$versspec/ $modvers/]
} else {
##nagelfar ignore Non static subcommand
set ret [string $test -nocase $versspec $modvers]
}
if {!$ret && [string match -nocase $versspec.* $modvers]} {
set ret 1
}
}
ge {
set ret [expr {[isVersion $modvers] && ([versioncmp $modvers\
$versspec] != -1 || [string match -nocase $versspec.* $modvers])}]
}
le {
set ret [expr {[isVersion $modvers] && ([versioncmp $versspec\
$modvers] != -1 || [string match -nocase $versspec.* $modvers])}]
}
be {
lassign $versspec lovers hivers
set ret [expr {[isVersion $modvers] && ([versioncmp $modvers\
$lovers] != -1 || [string match $lovers.* $modvers]) &&\
([versioncmp $hivers $modvers] != -1 || [string match -nocase\
$hivers.* $modvers])}]
}
}
return $ret
}
proc modVariantCmp {pvrlist modvrlist {missmean 0}} {
set ret 1
# missing variant in mod spec means default value
if {$missmean == 1} {
foreach {modvrname modvrval modvrisdfl} $modvrlist {
set modvrarr($modvrname) $modvrval
set modvrisdflarr($modvrname) $modvrisdfl
}
} else {
array set modvrarr $modvrlist
# if missmean == 2 pattern is mod, thus missing variant on mod is ok
# it is used for extra specifier where pattern is definition inside
# modulefile and mod is extra specifier defined on command line
}
foreach pvr $pvrlist {
set pvrarr([lindex $pvr 0]) [lindex $pvr 1]
}
# no match if a specified variant is not found among module variants (and
# if miss is not ok) or if the value differs
foreach vrname [array names pvrarr] {
if {(![info exists modvrarr($vrname)] && $missmean != 2) || ([info\
exists modvrarr($vrname)] && $pvrarr($vrname) ne\
$modvrarr($vrname))} {
set ret 0
break
}
}
# if an unset variant on pattern means variant default value pattern and
# mod are not equal if variant unset on pattern and non-default value is
# set for variant on mod
if {$missmean == 1} {
foreach vrname [array names modvrisdflarr] {
if {!$modvrisdflarr($vrname) && ![info exists pvrarr($vrname)]} {
set ret 0
break
}
}
}
return $ret
}
# Setup a hardwire version of modEq procedure called modEqStatic. This
# optimized procedure already knows the module pattern to compare to, whose
# specification has already been resolved at procedure definition time, which
# saves lot of processing time.
# modEqStatic does not compare against loaded modules so it has no need to
# compare variants set on module specification
proc defineModEqStaticProc {icase extdfl modspec} {
set procprops $icase:$extdfl:$modspec
# define proc if not done yet or if it was defined for another context
if {[info procs modEqStatic] eq {} || $::g_modEqStatic_procprops ne\
$procprops} {
if {[info exists ::g_modEqStatic_procprops]} {
# remove existing debug trace if any
initProcReportTrace remove modEqStatic
rename ::modEqStatic {}
} else {
# also define modVersCmp which is called by modEqStatic
defineModVersCmpProc $icase $extdfl
}
set ::g_modEqStatic_procprops $procprops
# define optimized procedure
lassign [getModuleVersSpec $modspec] pmod pmodname cmpspec versspec\
pmodnamere pmodescglob
# trim dup trailing / char and adapt pmod suffix if it starts with /
if {[string index $pmod end] eq {/}} {
set pmod [string trimright $pmod /]/
set endwslash 1
} else {
set endwslash 0
}
set nocasearg [expr {$icase ? {-nocase } : {}}]
set pmodnameslen [string length $pmodname/]
if {$pmod ne {} || $modspec eq {}} {
set procbody "
set pmod {$pmod}
if {\$psuf ne {}} {
if {$endwslash && \[string index \$psuf 0\] eq {/}} {
append pmod \[string range \$psuf 1 end\]
} else {
append pmod \$psuf
}
}
if {\$test eq {eqstart}} {
set ret \[string equal $nocasearg-length \[string length\
\$pmod/\] \$pmod/ \$mod/\]
} else {
if {\$test eq {matchin}} {
set test match
set pmod *\$pmod
}
set ret \[string \$test $nocasearg\$pmod \$mod\]
}"
if {$extdfl} {
append procbody "
if {!\$ret && \[string first / \$pmod\] != -1} {
if {\$test eq {match}} {
set pmodextdfl \$pmod.*
} else {
set pmodextdfl {$pmodescglob.*}
}
set ret \[string match $nocasearg\$pmodextdfl \$mod\]
}"
}
} else {
set procbody "
set pmodname {$pmodname}
set pmodnamere {$pmodnamere}
if {\$test eq {matchin}} {
set test match
if {\$pmodnamere ne {}} {
set pmodnamere .*\$pmodnamere
} else {
set pmodnamere {.*$pmodname}
}
}
if {(\$pmodnamere ne {} && \$test eq {match} && \[regexp\
$nocasearg (^\$pmodnamere)/ \$mod/ rematch pmodname\]) ||\
\[string equal $nocasearg -length $pmodnameslen {$pmodname/}\
\$mod/\]} {
set modvers \[string range \$mod \[string length \$pmodname/\]\
end\]
set ret \[modVersCmp {$cmpspec} {$versspec} \$modvers \$test\
\$psuf\]
} else {
set ret 0
}"
}
append procbody "
return \$ret"
##nagelfar syntax modEqStatic x x? x?
##nagelfar ignore Non constant argument to proc
proc modEqStatic {mod {test equal} {psuf {}}} $procbody
# set report traces if some debug mode enabled
initProcReportTrace add modEqStatic
}
}
# Define procedure to check module name equals pattern. Adapt procedure
# code whether icase and extended_default are enabled or disabled
proc defineModEqProc {icase extdfl {loadedmod 0}} {
set procname modEqProc
if {$icase} {
append procname Icase
}
if {$extdfl} {
append procname Extdfl
}
# define proc if not done yet or if it was defined for another context
if {[info procs modEq] eq {} || $::g_modEq_proc ne $procname} {
if {[info exists ::g_modEq_proc]} {
# remove existing debug trace if any
initProcReportTrace remove modEq
rename ::modEq ::$::g_modEq_proc
}
##nagelfar syntax modEq x x x? x? x? x? x? x?
rename ::$procname ::modEq
# set report traces if some debug mode enabled
initProcReportTrace add modEq
set ::g_modEq_proc $procname
}
# also define modVersCmp which is called by modEq
defineModVersCmpProc $icase $extdfl
# comparing against loaded modules requires to know their alternative names
if {$loadedmod} {
cacheCurrentModules
}
}
# alternative definitions of modEq proc
proc modEqProc {pattern mod {test equal} {trspec 1} {ismodlo 0} {vrcmp 0}\
{modvrlist 0} {psuf {}}} {
# extract specified module name from name and version spec
if {$trspec} {
lassign [getModuleVersSpec $pattern] pmod pmodname cmpspec versspec\
pmodnamere pmodescglob pmodroot pvrlist
} else {
set pmod $pattern
}
# trim dup trailing / char and adapt pmod suffix if it starts with /
if {[string index $pmod end] eq {/}} {
set pmod [string trimright $pmod /]/
set endwslash 1
} else {
set endwslash 0
}
# get alternative names if mod is loading(1) or loaded(2)
set altlist [switch -- $ismodlo {
5 {getAvailListFromVersSpec $mod}
4 {getAllModuleResolvedName $mod 0 {} 1}
3 {getLoadedAltAndSimplifiedName $mod}
2 {getLoadedAltname $mod}
1 {getAllModuleResolvedName $mod}
0 {list}}]
# fetch variant definition from spec if not loaded/loading
if {$vrcmp && $ismodlo in {0 5}} {
set modvrlist [getVariantList $mod 0 0 1]
set mod [getModuleNameAndVersFromVersSpec $mod]
}
# specified module can be translated in a simple mod name/vers or is empty
if {$pmod ne {} || $pattern eq {}} {
if {$psuf ne {}} {
if {$endwslash && [string index $psuf 0] eq {/}} {
append pmod [string range $psuf 1 end]
} else {
append pmod $psuf
}
}
if {$test eq {eqstart}} {
set ret [string equal -length [string length $pmod/] $pmod/ $mod/]
# apply comparison to alternative names if any and no match for mod
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
if {[set ret [string equal -length [string length $pmod/]\
$pmod/ $alt/]]} {
break
}
}
}
} else {
# contains test
if {$test eq {matchin}} {
set test match
set pmod *$pmod
} elseif {$test eq {eqspec}} {
set test equal
}
##nagelfar ignore Non static subcommand
set ret [string $test $pmod $mod]
# apply comparison to alternative names if any and no match for mod
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
##nagelfar ignore Non static subcommand
if {[set ret [string $test $pmod $alt]]} {
break
}
}
}
}
} elseif {$test eq {eqspec}} {
# test equality against all version described in spec (list or range
# boundaries), trspec is considered enabled and psuf empty
foreach pmod [getAllModulesFromVersSpec $pattern] {
if {[set ret [string equal $pmod $mod]]} {
break
}
}
} else {
# contains test
if {$test eq {matchin}} {
set test match
if {$pmodnamere ne {}} {
set pmodnamere .*$pmodnamere
} else {
set pmodnamere .*$pmodname
}
}
# for more complex specification, first check if module name matches
# use a regexp test if module name contains wildcard characters
if {($pmodnamere ne {} && $test eq {match} && [regexp (^$pmodnamere)/\
$mod/ rematch pmodname]) || [string equal -length [string length\
$pmodname/] $pmodname/ $mod/]} {
# then compare versions
set modvers [string range $mod [string length $pmodname/] end]
set ret [modVersCmp $cmpspec $versspec $modvers $test $psuf]
} else {
set ret 0
}
# apply comparison to alternative names if any and no match for mod
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
if {($pmodnamere ne {} && $test eq {match} && [regexp\
(^$pmodnamere)/ $alt/ rematch pmodname]) || [string equal\
-length [string length $pmodname/] $pmodname/ $alt/]} {
# then compare versions
set modvers [string range $alt [string length $pmodname/] end]
if {[set ret [modVersCmp $cmpspec $versspec $modvers $test\
$psuf]]} {
break
}
}
}
}
}
# check if variant specified matches those of selected loaded/ing module
if {$ret && $vrcmp && $ismodlo ni {3 5} && [llength $pvrlist] > 0} {
if {$modvrlist eq {0}} {
set modvrlist [getVariantList $mod]
}
set ret [modVariantCmp $pvrlist $modvrlist]
# variant miss means variant default val when comparing collection content
} elseif {$ret && $vrcmp && $ismodlo == 3} {
set ret [modVariantCmp $pvrlist [getVariantList $mod 3] 1]
# variant miss is ok when comparing an extra specifier passed as mod
} elseif {$ret && $vrcmp && $ismodlo == 5} {
set ret [modVariantCmp $pvrlist $modvrlist 2]
}
return $ret
}
proc modEqProcIcase {pattern mod {test equal} {trspec 1} {ismodlo 0} {vrcmp\
0} {modvrlist 0} {psuf {}}} {
if {$trspec} {
lassign [getModuleVersSpec $pattern] pmod pmodname cmpspec versspec\
pmodnamere pmodescglob pmodroot pvrlist
} else {
set pmod $pattern
}
if {[string index $pmod end] eq {/}} {
set pmod [string trimright $pmod /]/
set endwslash 1
} else {
set endwslash 0
}
set altlist [switch -- $ismodlo {
5 {getAvailListFromVersSpec $mod}
4 {getAllModuleResolvedName $mod 0 {} 1}
3 {getLoadedAltAndSimplifiedName $mod}
2 {getLoadedAltname $mod}
1 {getAllModuleResolvedName $mod}
0 {list}}]
if {$vrcmp && $ismodlo in {0 5}} {
set modvrlist [getVariantList $mod 0 0 1]
set mod [getModuleNameAndVersFromVersSpec $mod]
}
if {$pmod ne {} || $pattern eq {}} {
if {$psuf ne {}} {
if {$endwslash && [string index $psuf 0] eq {/}} {
append pmod [string range $psuf 1 end]
} else {
append pmod $psuf
}
}
if {$test eq {eqstart}} {
set ret [string equal -nocase -length [string length $pmod/] $pmod/\
$mod/]
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
if {[set ret [string equal -nocase -length [string length\
$pmod/] $pmod/ $alt/]]} {
break
}
}
}
} else {
# contains test
if {$test eq {matchin}} {
set test match
set pmod *$pmod
} elseif {$test eq {eqspec}} {
set test equal
}
##nagelfar ignore Non static subcommand
set ret [string $test -nocase $pmod $mod]
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
##nagelfar ignore Non static subcommand
if {[set ret [string $test -nocase $pmod $alt]]} {
break
}
}
}
}
} elseif {$test eq {eqspec}} {
# test equality against all version described in spec (list or range
# boundaries), trspec is considered enabled and psuf empty
foreach pmod [getAllModulesFromVersSpec $pattern] {
if {[set ret [string equal -nocase $pmod $mod]]} {
break
}
}
} else {
# contains test
if {$test eq {matchin}} {
set test match
if {$pmodnamere ne {}} {
set pmodnamere .*$pmodnamere
} else {
set pmodnamere .*$pmodname
}
}
# for more complex specification, first check if module name matches
# use a regexp test if module name contains wildcard characters
if {($pmodnamere ne {} && $test eq {match} && [regexp -nocase\
(^$pmodnamere)/ $mod/ rematch pmodname]) || [string equal -nocase\
-length [string length $pmodname/] $pmodname/ $mod/]} {
# then compare versions
set modvers [string range $mod [string length $pmodname/] end]
set ret [modVersCmp $cmpspec $versspec $modvers $test $psuf]
} else {
set ret 0
}
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
if {($pmodnamere ne {} && $test eq {match} && [regexp -nocase\
(^$pmodnamere)/ $alt/ rematch pmodname]) || [string equal\
-nocase -length [string length $pmodname/] $pmodname/ $alt/]} {
# then compare versions
set modvers [string range $alt [string length $pmodname/] end]
if {[set ret [modVersCmp $cmpspec $versspec $modvers $test\
$psuf]]} {
break
}
}
}
}
}
if {$ret && $vrcmp && $ismodlo ni {3 5} && [llength $pvrlist] > 0} {
if {$modvrlist eq {0}} {
set modvrlist [getVariantList $mod]
}
set ret [modVariantCmp $pvrlist $modvrlist]
} elseif {$ret && $vrcmp && $ismodlo == 3} {
set ret [modVariantCmp $pvrlist [getVariantList $mod 3] 1]
} elseif {$ret && $vrcmp && $ismodlo == 5} {
set ret [modVariantCmp $pvrlist $modvrlist 2]
}
return $ret
}
proc modEqProcExtdfl {pattern mod {test equal} {trspec 1} {ismodlo 0} {vrcmp\
0} {modvrlist 0} {psuf {}}} {
if {$trspec} {
lassign [getModuleVersSpec $pattern] pmod pmodname cmpspec versspec\
pmodnamere pmodescglob pmodroot pvrlist
} else {
set pmod $pattern
}
if {[string index $pmod end] eq {/}} {
set pmod [string trimright $pmod /]/
set endwslash 1
} else {
set endwslash 0
}
set altlist [switch -- $ismodlo {
5 {getAvailListFromVersSpec $mod}
4 {getAllModuleResolvedName $mod 0 {} 1}
3 {getLoadedAltAndSimplifiedName $mod}
2 {getLoadedAltname $mod}
1 {getAllModuleResolvedName $mod}
0 {list}}]
if {$vrcmp && $ismodlo in {0 5}} {
set modvrlist [getVariantList $mod 0 0 1]
set mod [getModuleNameAndVersFromVersSpec $mod]
}
if {$pmod ne {} || $pattern eq {}} {
if {$psuf ne {}} {
if {$endwslash && [string index $psuf 0] eq {/}} {
append pmod [string range $psuf 1 end]
} else {
append pmod $psuf
}
}
if {$test eq {eqstart}} {
set ret [string equal -length [string length $pmod/] $pmod/ $mod/]
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
if {[set ret [string equal -length [string length $pmod/]\
$pmod/ $alt/]]} {
break
}
}
}
} else {
# contains test
if {$test eq {matchin}} {
set test match
set pmod *$pmod
} elseif {$test eq {eqspec}} {
set test equal
set eqspec 1
}
##nagelfar ignore Non static subcommand
set ret [string $test $pmod $mod]
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
##nagelfar ignore Non static subcommand
if {[set ret [string $test $pmod $alt]]} {
break
}
}
}
}
# try the extended default match if not root module and not eqspec test
if {![info exists eqspec] && !$ret && [string first / $pmod] != -1} {
if {$test eq {match}} {
set pmodextdfl $pmod.*
} else {
set pmodextdfl $pmodescglob.*
}
set ret [string match $pmodextdfl $mod]
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
if {[set ret [string match $pmodextdfl $alt]]} {
break
}
}
}
}
} elseif {$test eq {eqspec}} {
# test equality against all version described in spec (list or range
# boundaries), trspec is considered enabled and psuf empty
foreach pmod [getAllModulesFromVersSpec $pattern] {
if {[set ret [string equal $pmod $mod]]} {
break
}
}
} else {
# contains test
if {$test eq {matchin}} {
set test match
if {$pmodnamere ne {}} {
set pmodnamere .*$pmodnamere
} else {
set pmodnamere .*$pmodname
}
}
# for more complex specification, first check if module name matches
# use a regexp test if module name contains wildcard characters
if {($pmodnamere ne {} && $test eq {match} && [regexp (^$pmodnamere)/\
$mod/ rematch pmodname]) || [string equal -length [string length\
$pmodname/] $pmodname/ $mod/]} {
# then compare versions
set modvers [string range $mod [string length $pmodname/] end]
set ret [modVersCmp $cmpspec $versspec $modvers $test $psuf]
} else {
set ret 0
}
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
if {($pmodnamere ne {} && $test eq {match} && [regexp\
(^$pmodnamere)/ $alt/ rematch pmodname]) || [string equal\
-length [string length $pmodname/] $pmodname/ $alt/]} {
# then compare versions
set modvers [string range $alt [string length $pmodname/] end]
if {[set ret [modVersCmp $cmpspec $versspec $modvers $test\
$psuf]]} {
break
}
}
}
}
}
if {$ret && $vrcmp && $ismodlo ni {3 5} && [llength $pvrlist] > 0} {
if {$modvrlist eq {0}} {
set modvrlist [getVariantList $mod]
}
set ret [modVariantCmp $pvrlist $modvrlist]
} elseif {$ret && $vrcmp && $ismodlo == 3} {
set ret [modVariantCmp $pvrlist [getVariantList $mod 3] 1]
} elseif {$ret && $vrcmp && $ismodlo == 5} {
set ret [modVariantCmp $pvrlist $modvrlist 2]
}
return $ret
}
proc modEqProcIcaseExtdfl {pattern mod {test equal} {trspec 1} {ismodlo 0}\
{vrcmp 0} {modvrlist 0} {psuf {}}} {
if {$trspec} {
lassign [getModuleVersSpec $pattern] pmod pmodname cmpspec versspec\
pmodnamere pmodescglob pmodroot pvrlist
} else {
set pmod $pattern
}
if {[string index $pmod end] eq {/}} {
set pmod [string trimright $pmod /]/
set endwslash 1
} else {
set endwslash 0
}
set altlist [switch -- $ismodlo {
5 {getAvailListFromVersSpec $mod}
4 {getAllModuleResolvedName $mod 0 {} 1}
3 {getLoadedAltAndSimplifiedName $mod}
2 {getLoadedAltname $mod}
1 {getAllModuleResolvedName $mod}
0 {list}}]
if {$vrcmp && $ismodlo in {0 5}} {
set modvrlist [getVariantList $mod 0 0 1]
set mod [getModuleNameAndVersFromVersSpec $mod]
}
if {$pmod ne {} || $pattern eq {}} {
if {$psuf ne {}} {
if {$endwslash && [string index $psuf 0] eq {/}} {
append pmod [string range $psuf 1 end]
} else {
append pmod $psuf
}
}
if {$test eq {eqstart}} {
set ret [string equal -nocase -length [string length $pmod/] $pmod/\
$mod/]
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
if {[set ret [string equal -nocase -length [string length\
$pmod/] $pmod/ $alt/]]} {
break
}
}
}
} else {
# contains test
if {$test eq {matchin}} {
set test match
set pmod *$pmod
} elseif {$test eq {eqspec}} {
set test equal
set eqspec 1
}
##nagelfar ignore Non static subcommand
set ret [string $test -nocase $pmod $mod]
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
##nagelfar ignore Non static subcommand
if {[set ret [string $test -nocase $pmod $alt]]} {
break
}
}
}
}
# try the extended default match if not root module and not eqspec test
if {![info exists eqspec] && !$ret && [string first / $pmod] != -1} {
if {$test eq {match}} {
set pmodextdfl $pmod.*
} else {
set pmodextdfl $pmodescglob.*
}
set ret [string match -nocase $pmodextdfl $mod]
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
if {[set ret [string match -nocase $pmodextdfl $alt]]} {
break
}
}
}
}
} elseif {$test eq {eqspec}} {
# test equality against all version described in spec (list or range
# boundaries), trspec is considered enabled and psuf empty
foreach pmod [getAllModulesFromVersSpec $pattern] {
if {[set ret [string equal -nocase $pmod $mod]]} {
break
}
}
} else {
# contains test
if {$test eq {matchin}} {
set test match
if {$pmodnamere ne {}} {
set pmodnamere .*$pmodnamere
} else {
set pmodnamere .*$pmodname
}
}
# for more complex specification, first check if module name matches
# use a regexp test if module name contains wildcard characters
if {($pmodnamere ne {} && $test eq {match} && [regexp -nocase\
(^$pmodnamere)/ $mod/ rematch pmodname]) || [string equal -nocase\
-length [string length $pmodname/] $pmodname/ $mod/]} {
# then compare versions
set modvers [string range $mod [string length $pmodname/] end]
set ret [modVersCmp $cmpspec $versspec $modvers $test $psuf]
} else {
set ret 0
}
if {!$ret && [llength $altlist] > 0} {
foreach alt $altlist {
if {($pmodnamere ne {} && $test eq {match} && [regexp -nocase\
(^$pmodnamere)/ $alt/ rematch pmodname]) || [string equal\
-nocase -length [string length $pmodname/] $pmodname/ $alt/]} {
# then compare versions
set modvers [string range $alt [string length $pmodname/] end]
if {[set ret [modVersCmp $cmpspec $versspec $modvers $test\
$psuf]]} {
break
}
}
}
}
}
if {$ret && $vrcmp && $ismodlo ni {3 5} && [llength $pvrlist] > 0} {
if {$modvrlist eq {0}} {
set modvrlist [getVariantList $mod]
}
set ret [modVariantCmp $pvrlist $modvrlist]
} elseif {$ret && $vrcmp && $ismodlo == 3} {
set ret [modVariantCmp $pvrlist [getVariantList $mod 3] 1]
} elseif {$ret && $vrcmp && $ismodlo == 5} {
set ret [modVariantCmp $pvrlist $modvrlist 2]
}
return $ret
}
# analyze module version specified within module specification
proc parseModuleVersionSpecifier {modspec} {
set invalidversspec 0
set invalidversrange 0
set islist [expr {[string first , $modspec] != -1}]
set isrange [expr {[string first : $modspec] != -1}]
# no deep version specification allowed
if {[string first / $modspec] != -1} {
set invalidversspec 1
# ',' separates multiple versions
} elseif {$islist} {
set cmpspec in
set inspeclist [split $modspec ,]
# empty element in list is erroneous
set invalidversspec [expr {[lsearch -exact $inspeclist {}] != -1}]
if {!$invalidversspec} {
# recursive call to check each element in list (can be range, etc)
foreach inspec $inspeclist {
lappend versspec [parseModuleVersionSpecifier $inspec]
}
}
# ':' separates range elements
} elseif {$isrange} {
set versspec [split $modspec :]
set lovers [lindex $versspec 0]
set hivers [lindex $versspec 1]
if {[llength $versspec] != 2 || ($lovers eq {} && $hivers eq {})} {
set invalidversspec 1
} elseif {($lovers ne {} && ![isVersion $lovers]) || ($hivers ne {} &&\
![isVersion $hivers])} {
set invalidversrange 1
# greater or equal
} elseif {$hivers eq {}} {
set cmpspec ge
set versspec $lovers
# lower or equal
} elseif {$lovers eq {}} {
set cmpspec le
set versspec $hivers
# between or equal
} elseif {[versioncmp $lovers $hivers] == 1} {
set invalidversrange 1
} else {
set cmpspec be
}
} else {
set cmpspec eq
set versspec $modspec
}
if {$invalidversspec} {
knerror "Invalid version specifier '$modspec'"
}
if {$invalidversrange} {
knerror "Invalid version range '$modspec'"
}
return [list $cmpspec $versspec]
}
# Define procedure to parse modulefile specification passed as argument
# Adapt procedure code whether advanced_version_spec is enabled or disabled
proc defineParseModuleSpecificationProc {advverspec} {
set procname parseModuleSpecificationProc
if {$advverspec} {
append procname AdvVersSpec
# resolved configured variant shortcut
getConf variant_shortcut
}
# define proc if not done yet or if it was defined for another context
if {[info procs parseModuleSpecification] eq {} ||\
$::g_parseModuleSpecification_proc ne $procname} {
if {[info exists ::g_parseModuleSpecification_proc]} {
# remove existing debug trace if any
initProcReportTrace remove parseModuleSpecification
rename ::parseModuleSpecification\
::$::g_parseModuleSpecification_proc
}
##nagelfar syntax parseModuleSpecification x x x x x*
rename ::$procname ::parseModuleSpecification
# set report traces if some debug mode enabled
initProcReportTrace add parseModuleSpecification
set ::g_parseModuleSpecification_proc $procname
}
}
# when advanced_version_spec option is enabled, parse argument list to set in
# a global context version specification of modules passed as argument.
# mlspec: specification may vary whether it comes from the ml or another
# command. nonamespec: sometimes specification may omit module name and
# version and just provides variant properties. xtspec: is extra specifier
# specification allowed. getavails: query available modules to get those
# matching module name and version
proc parseModuleSpecificationProc {mlspec nonamespec xtspec getavails args} {
# skip arg parse if proc was already call with same arg set by an upper
# proc. check all args to ensure current arglist does not deviate from
# what was previously parsed
foreach arg $args {
if {![info exists ::g_moduleVersSpec($arg)]} {
set need_parse 1
break
}
}
if {![info exists need_parse]} {
return $args
}
set unarglist [list]
set arglist [list]
foreach arg $args {
if {$mlspec && [string index $arg 0] eq {-}} {
set modname [string range $arg 1 end]
set mlunload 1
} else {
set modname $arg
set mlunload 0
}
# keep arg enclosed if composed of several words
if {[string first { } $modname] != -1} {
set modarg "{$modname}"
} else {
set modarg $modname
}
# record spec, especially needed if arg is enclosed
setModuleVersSpec $modarg $modname eq {} {} {} $arg {} $getavails
# append to unload list if ml spec and - prefix used
if {$mlunload} {
lappend unarglist $modarg
} else {
lappend arglist $modarg
}
}
if {$mlspec} {
return [list $unarglist $arglist]
} else {
return $arglist
}
}
proc parseModuleSpecificationProcAdvVersSpec {mlspec nonamespec xtspec\
getavails args} {
foreach arg $args {
if {![info exists ::g_moduleVersSpec($arg)]} {
set need_parse 1
break
}
}
if {![info exists need_parse]} {
return $args
}
# define extra specifier known list, to raise error if argument does not
# match
set xtelt_valid_list [list always-load append-path chdir complete conflict\
depends-on envvar family incompat load load-any prepend-path prereq\
prereq-all prereq-any pushenv remove-path require set-alias\
set-function setenv switch switch-on switch-off try-load uncomplete\
unload unset-alias unset-function unsetenv variant]
set xtelt_modspec_list [list always-load conflict depends-on incompat load\
load-any prereq prereq-all prereq-any require switch switch-on\
switch-off try-load unload]
set mlunload 0
set nextmlunload 0
set arglist [list]
set unarglist [list]
set vrlist [list]
set vridx -1
set xtlist [list]
set rawarg [list]
foreach arg $args {
# set each specification element as separate word but preserve space
# character in each arg
set curarglist {}
# skip argument split if extra specifier detected
if {[regexp {^[a-z-]+:} $arg]} {
lappend curarglist $arg
} else {
set previ 0
for {set i 1} {$i < [string length $arg]} {incr i} {
set c [string index $arg $i]
switch -- $c {
@ - ~ {
lappend curarglist [string range $arg $previ $i-1]
set previ $i
}
+ {
# allow one or more '+' char at end of module name if not
# followed by non-special character (@, ~ or /)
set nexti [expr {$i + 1}]
if {$nexti < [string length $arg]} {
switch -- [string index $arg $nexti] {
@ - + - ~ - / {}
default {
lappend curarglist [string range $arg $previ $i-1]
set previ $i
}
}
}
}
default {
# check if a variant shortcut matches
if {[info exists ::g_shortcutVariant($c)]} {
lappend curarglist [string range $arg $previ $i-1]
set previ $i
}
}
}
}
lappend curarglist [string range $arg $previ $i-1]
}
# parse each specification element
foreach curarg $curarglist {
set vrisbool 0
set c [string index $curarg 0]
switch -- $c {
@ {
set modspec [string range $curarg 1 end]
lassign [parseModuleVersionSpecifier $modspec] cmpspec versspec
continue
}
+ {
set curarg [string range $curarg 1 end]
append curarg =1
set vrisbool 1
}
- {
set curarg [string range $curarg 1 end]
if {$mlspec} {
set nextmlunload 1
} else {
append curarg =0
set vrisbool 1
}
}
~ {
set curarg [string range $curarg 1 end]
append curarg =0
set vrisbool 1
}
default {
# translate shortcut in variant name in arg
if {[info exists ::g_shortcutVariant($c)]} {
set curarg [string replace $curarg 0 0\
$::g_shortcutVariant($c)=]
}
}
}
switch -glob -- $curarg {
*:* {
# extra specification may not be accepted on current context
if {!$xtspec} {
knerror "No extra specification allowed on this command"
}
# extract extra specifier spec
set xtsepidx [string first : $curarg]
set xtelt [string range $curarg 0 $xtsepidx-1]
set xtname [string range $curarg $xtsepidx+1 end]
# check no other : character is found in argument or element
# and name are not an empty string
if {[string length $xtelt] == 0 || [string length $xtname] ==\
0 || ([string last : $curarg] != $xtsepidx && $xtelt ni\
$xtelt_modspec_list)} {
knerror "Invalid extra specification '$arg'"
}
if {$xtelt ni $xtelt_valid_list} {
knerror "Invalid extra specifier '$xtelt'\nValid extra\
specifiers are: $xtelt_valid_list"
}
# parse and resolve module spec set as extra specifier value
if {$xtelt in $xtelt_modspec_list} {
lassign [parseModuleSpecification 0 0 0 1 {*}$xtname] xtname
}
# save extra specifier element and name value, same element can
# appear multiple time (means AND operator)
lappend xtlist [list $xtelt $xtname]
}
*=* {
# extract valued-variant spec
set vrsepidx [string first = $curarg]
set vrname [string range $curarg 0 $vrsepidx-1]
set vrvalue [string range $curarg $vrsepidx+1 end]
if {$vrname eq {}} {
knerror "No variant name defined in argument '$curarg'"
}
# check no other = character is found in argument
if {[string last = $curarg] != $vrsepidx} {
knerror "Invalid variant specification '$arg'"
}
# replace previous value for variant if already set
if {[info exists vrnamearr($vrname)]} {
lreplace $vrlist $vrnamearr($vrname) $vrnamearr($vrname)
} else {
incr vridx
}
# translate boolean vrvalue in canonical boolean
if {!$vrisbool && [string is boolean -strict $vrvalue] &&\
![string is integer -strict $vrvalue]} {
set vrisbool 1
set vrvalue [string is true -strict $vrvalue]
}
# save variant name and value
set vrnamearr($vrname) $vridx
lappend vrlist [list $vrname $vrvalue $vrisbool]
}
default {
# save previous mod version spec and transformed arg if any
if {[info exists modarglist]} {
set modarg [join $modarglist]
if {![info exists cmpspec]} {
set cmpspec eq
set versspec {}
}
# wild search name if no module name allowed
if {$nonamespec && ![info exists modname]} {
set modname *
set modspec *
}
if {[info exists modname] && ($modname ne {} || $modspec\
eq {})} {
setModuleVersSpec $modarg $modname $cmpspec $versspec\
$modspec $vrlist $rawarg $xtlist $getavails
# rework args to have 1 str element for whole mod spec
# append to unload list if ml spec and - prefix used
if {$mlunload} {
lappend unarglist $modarg
} else {
lappend arglist $modarg
}
} else {
knerror "No module name defined in argument '$modarg'"
}
unset modarglist
set vrlist [list]
array unset vrnamearr
set vridx -1
set xtlist [list]
set rawarg [list]
unset cmpspec versspec
}
set mlunload $nextmlunload
set nextmlunload 0
set modname $curarg
set modspec {}
}
}
}
lappend rawarg $arg
# keep arg enclosed if composed of several words
if {[string first { } $arg] != -1} {
lappend modarglist "{$arg}"
} else {
lappend modarglist $arg
}
}
# transform last args
set modarg [join $modarglist]
if {$nonamespec && ![info exists modname]} {
set modname *
set modspec *
}
if {[info exists modname] && ($modname ne {} || $modspec eq {})} {
if {![info exists cmpspec]} {
set cmpspec eq
set versspec {}
}
setModuleVersSpec $modarg $modname $cmpspec $versspec $modspec $vrlist\
$rawarg $xtlist $getavails
# rework args to have 1 string element for whole module spec
# append to unload list if ml spec and - prefix used
if {$mlunload || $nextmlunload} {
lappend unarglist $modarg
} else {
lappend arglist $modarg
}
} else {
knerror "No module name defined in argument '$modarg'"
}
if {$mlspec} {
return [list $unarglist $arglist]
} else {
return $arglist
}
}
proc setModuleVersSpec {modarg modname cmpspec versspec rawversspec\
variantlist rawarg extralist getavails} {
# translate @loaded version into currently loaded mod matching modname
if {$cmpspec eq {eq} && $versspec eq {loaded}} {
if {[set lmmod [getLoadedMatchingName $modname]] ne {}} {
set modname [file dirname $lmmod]
set versspec [file tail $lmmod]
set variantlist [getVariantList $lmmod 2]
} else {
knerror "No loaded version found for '$modname' module"
}
}
# save module root name
set modroot [lindex [file split $modname] 0]
# save module single designation if any and module name
if {$versspec eq {}} {
set mod $modname
set modname [file dirname $modname]
} else {
set modname [string trimright $modname /]
if {$cmpspec ne {eq}} {
set mod {}
} else {
set mod $modname/$versspec
}
}
# save a regexp-ready version of modname (apply
# non-greedy quantifier to '*', to avoid matching final
# '/' in string comparison
set modnamere [string map {. \\. + \\+ * .*? ? .} $modname]
if {$modname eq $modnamere} {
set modnamere {}
}
# save a glob-special-chars escaped version of mod
set modescglob [string map {* \\* ? \\?} $mod]
# save module name and version specification (without variant specs)
if {$mod eq {} && $rawversspec ne {} && $modname ne {.}} {
set modnvspec ${modname}@${rawversspec}
} else {
set modnvspec $mod
}
# record most of the spec now to be able to rely on this record to get
# matching available modules
set ::g_moduleVersSpec($modarg) [list $mod $modname $cmpspec $versspec\
$modnamere $modescglob $modroot $variantlist $modnvspec $rawarg\
$extralist]
# get all available module name and version matching module name and
# version spec (inhibit extra match search not to trigger an infinite loop)
if {$getavails} {
setState inhibit_ems 1
set availlist [getAllAvailModule $modarg]
setState inhibit_ems 0
} else {
set availlist {}
}
# finalize module version spec record
lappend ::g_moduleVersSpec($modarg) $availlist
reportDebug "Set module '$mod' (escglob '$modescglob'), module name\
'$modname' (re '$modnamere'), module root '$modroot', version cmp\
'$cmpspec', version(s) '$versspec', variant(s) '$variantlist' and\
module name version spec '$modnvspec' for argument '$modarg' (raw\
'$rawarg'), extra specifier(s) '$extralist' and matching available\
module(s) '$availlist'"
}
proc getModuleVersSpec {modarg} {
if {[info exists ::g_moduleVersSpec($modarg)]} {
return $::g_moduleVersSpec($modarg)
} else {
return [list $modarg [file dirname $modarg] {} {} {} [string map {* \\*\
? \\?} $modarg] [lindex [file split $modarg] 0] {} $modarg $modarg\
{} {}]
}
}
proc unsetModuleVersSpec {modarg} {
if {[info exists ::g_moduleVersSpec($modarg)]} {
unset ::g_moduleVersSpec($modarg)
}
}
# get module name from module name and version spec if parsed
proc getModuleNameFromVersSpec {modarg} {
if {[info exists ::g_moduleVersSpec($modarg)]} {
lassign $::g_moduleVersSpec($modarg) mod modname
} else {
set modname [file dirname $modarg]
}
return $modname
}
# get module root name from module name and version spec if parsed
proc getModuleRootFromVersSpec {modarg} {
if {[info exists ::g_moduleVersSpec($modarg)]} {
set modroot [lindex $::g_moduleVersSpec($modarg) 6]
} else {
set modroot [lindex [file split $modarg] 0]
}
return $modroot
}
# translate module name version spec to return all modules mentioned
proc getAllModulesFromVersSpec {modarg} {
if {[info exists ::g_moduleVersSpec($modarg)]} {
lassign $::g_moduleVersSpec($modarg) mod modname cmpspec versspec
if {$mod eq {} && $cmpspec eq {in}} {
# loop around each spec in list
foreach inspec $versspec {
lassign $inspec incmp invers
foreach vers $invers {
lappend modlist $modname/$vers
}
}
} elseif {$mod eq {} && $cmpspec ne {eq}} {
foreach vers $versspec {
lappend modlist $modname/$vers
}
} else {
# add empty mod specification if cmpspec is 'eq'
lappend modlist $mod
}
} else {
lappend modlist $modarg
}
return $modlist
}
# translate module name version spec to return one module mentioned
proc getOneModuleFromVersSpec {modarg} {
if {[info exists ::g_moduleVersSpec($modarg)]} {
lassign $::g_moduleVersSpec($modarg) mod modname cmpspec versspec
if {$mod eq {} && $cmpspec eq {in}} {
set inspec [lindex $versspec 0]
lassign $inspec incmp invers
set mod $modname/[lindex $invers 0]
} elseif {$mod eq {} && $cmpspec ne {eq}} {
set mod $modname/[lindex $versspec 0]
}
} else {
set mod $modarg
}
return $mod
}
# translate module name version spec to return the list of variant mentioned
proc getVariantListFromVersSpec {modarg} {
if {[info exists ::g_moduleVersSpec($modarg)]} {
set variantlist [lindex $::g_moduleVersSpec($modarg) 7]
} else {
set variantlist {}
}
return $variantlist
}
# get module name and version from version spec if parsed
proc getModuleNameAndVersFromVersSpec {modarg} {
if {[info exists ::g_moduleVersSpec($modarg)]} {
set modnvspec [lindex $::g_moduleVersSpec($modarg) 8]
} else {
set modnvspec $modarg
}
return $modnvspec
}
# get raw argument specified from parsed version spec
proc getRawArgumentFromVersSpec {modarg} {
if {[info exists ::g_moduleVersSpec($modarg)]} {
set rawarg [lindex $::g_moduleVersSpec($modarg) 9]
} else {
set rawarg $modarg
}
return $rawarg
}
# translate module name version spec to return the list of extra specifier
# mentioned
proc getExtraListFromVersSpec {modarg} {
if {[info exists ::g_moduleVersSpec($modarg)]} {
set extralist [lindex $::g_moduleVersSpec($modarg) 10]
} else {
set extralist {}
}
return $extralist
}
# get available modules matching module specification
proc getAvailListFromVersSpec {modarg} {
if {[info exists ::g_moduleVersSpec($modarg)]} {
set availlist [lindex $::g_moduleVersSpec($modarg) 11]
} else {
set availlist {}
}
return $availlist
}
# is mod spec containing variant but no module name and version
proc isSpecWildWithVariant {mod} {
return [expr {[getModuleNameAndVersFromVersSpec $mod] eq {*} && [llength\
[getVariantListFromVersSpec $mod]] > 0}]
}
# Get full path name of module cache file for given modulepath
proc getModuleCacheFilename {modpath} {
return $modpath/.modulecache
}
# test if a given file path has a limited access by check permission mode set
# for others
proc isFileAccessLimited {fpath isdir} {
# check if file stat info can be fetched
if {[file readable $fpath]} {
# extract permissions for "other"
set other_perms [string index [file attributes $fpath -permissions] end]
# test file can be read by other: o+r right, which means file should at
# least have 0b100 mode, which can be binary-compared against 0b011 (3)
# if file is a directory, test it can also be searched: o+x right, which
# means dir should at least have 0b101 mode, which can be compared
# against 0b010 (2)
set perms_mask [expr {$isdir ? {2} : {3}}]
set ret [expr {($other_perms | $perms_mask) != 7}]
} else {
set ret 1
}
return $ret
}
# walk through directory content and return every files and dirs with limited
# access rights
proc getLimitedAccessesInDirectory {modpath} {
# cannot test limited accesses on Windows platform
if {[getState is_win]} {
return {}
}
foreach igndir [getConf ignored_dirs] {
set ignored_dirs($igndir) 1
}
# walk through directory to find elements with limited access
array set limited_arr {}
lappend full_list $modpath
for {set i 0} {$i < [llength $full_list]} {incr i 1} {
set elt [lindex $full_list $i]
set elttail [file tail $elt]
set eltname [getModuleNameFromModulepath $elt $modpath]
if {[file isdirectory $elt]} {
# skip ignored dirs
if {![info exists ignored_dirs($elttail)]} {
if {[isFileAccessLimited $elt 1]} {
set limited_arr($eltname) d
# only walk through directory content if its access is not limited
} else {
# get all elements found in directory (regular and dot files)
set direlt_list [glob -nocomplain $elt/*]
foreach eltindir [glob -nocomplain -types hidden -directory\
$elt -tails *] {
if {$eltindir ni {. ..}} {
lappend direlt_list $elt/$eltindir
}
}
if {[llength $direlt_list] > 0} {
lappend full_list {*}$direlt_list
}
}
}
} else {
# skip ignored files
switch -glob -- $elttail {
*~ - *,v - \#*\# {}
default {
if {[isFileAccessLimited $elt 0]} {
set limited_arr($eltname) f
}
}
}
}
}
# filter .version/.modulecache files found at the root of modulepath dir
foreach elt [list .version .modulecache] {
if {[info exists limited_arr($elt)]} {
unset limited_arr($elt)
}
}
reportDebug "found [array names limited_arr] ([array size limited_arr])\
with limited access"
return [array get limited_arr]
}
# Build cache file content for given modulepath
proc formatModuleCacheContent {modpath} {
set content {}
# collect files from modulepath directory
array set found_list [findModules $modpath * 0 1]
# collect files and dirs from modulepath directory with limited access
array set limited_list [getLimitedAccessesInDirectory $modpath]
# concatenate element found and those with limited access as the second
# kind may not be part of found list
set elt_list [lsort -unique [concat [array names found_list] [array names\
limited_list]]]
# build cache entry for every file found
foreach elt $elt_list {
# ignore element if it has been flagged in skip list (one of its parent
# directory has limited access) or if modulepath has itself a limited
# access
if {[info exists skip_list($elt)] || $elt eq {}} {
continue
}
set entry_list [list]
set fetch_content 0
# mention in cache that file or directory has limited access to test if
# they can be accessed by user when cache is evaluated
if {[info exists limited_list($elt)]} {
if {$limited_list($elt) eq {d}} {
# mark all elements contained in dir to skip them as their parent
# directory has limited access (due to lsort on foreach loop we
# are assured to treat parent dir before the entries it contains)
foreach elttoskip [array names found_list -glob $elt/*] {
set skip_list($elttoskip) 1
}
lappend entry_list limited-access-directory $elt
} else {
lappend entry_list limited-access-file $elt
}
} else {
switch -- [lindex $found_list($elt) 0] {
modulerc {
lappend entry_list modulerc-content $elt
set fetch_content 1
}
modulefile {
lappend entry_list modulefile-content $elt [lindex\
$found_list($elt) 1]
set fetch_content 1
}
default {
# also record obtained error to get all the information to
# cover everything fetched by findModules. only modulefile
# validity is checked in findModules
lappend entry_list modulefile-invalid $elt {*}[lrange\
$found_list($elt) 0 1]
}
}
}
# fetch file content
if {$fetch_content} {
if {[catch {
set fcontent [readFile $modpath/$elt]
# extract module header from the start of the file
if {![regexp {^#%Module[0-9\.]*} [string range $fcontent 0 32]\
fheader]} {
set fheader {}
}
lappend entry_list $fheader $fcontent
} errMsg]} {
# rethrow read error after parsing message
knerror [parseAccessIssue $modpath/$elt]
}
}
# format cache entry
append content "\n$entry_list"
}
# prepend header if some content has been generated
if {[string length $content] != 0} {
regexp {^\d+\.\d+} {5.3.0} majmin
set content "#%Module$majmin$content"
}
return $content
}
# read a cache file
proc readCacheContent {cachefile} {
set res {}
if {[catch {
# read full file
set fid [open $cachefile r]
# use defined buffer size to limit number of read system call
fconfigure $fid -buffersize [getConf cache_buffer_bytes]
set fdata [read $fid]
close $fid
# extract magic cookie (first word of cache file)
set fh [string trimright [lindex [split [string range $fdata 0 32]]\
0] #]
set fhvers [string range $fh 8 end]
} errMsg ]} {
reportError [parseAccessIssue $cachefile]
} else {
# check cache validity
if {![string equal -length 8 $fh {#%Module}]} {
reportInternalBug {Magic cookie '#%Module' missing} $cachefile\
{Cache ERROR}
# check if version requirement is present
} elseif {[string length $fh] <= 8} {
reportInternalBug {Modules version requirement missing} $cachefile\
{Cache ERROR}
# check if min version requirement is met
} elseif {[versioncmp {5.3.0} $fhvers] <0} {
reportInternalBug "Cache file requires at least Modules version\
$fhvers" $cachefile {Cache ERROR}
} else {
# set file content as result
set res $fdata
}
}
return $res
}
# evaluate cache file
proc execute-cachefile {cachefile modpath} {
# register current modulepath for cachefile commands to know where they are
lappendState modulepath $modpath
lappendState debug_msg_prefix "\[cache:$cachefile\] "
# initialize cache gathering structures for modulepath
set ::g_cacheModpath($modpath) {}
set ::g_cacheFLimitedModpath($modpath) {}
set ::g_cacheDLimitedModpath($modpath) {}
# initialize cache file evaluation interp configuration
if {![info exists ::g_cachefileUntrackVars]} {
# list variable that should not be tracked for saving
array set ::g_cachefileUntrackVars [list ModulesCurrentCachefile 1\
cachecontent 1 env 1]
# commands that should be renamed before aliases setup
array set ::g_cachefileRenameCmds [list]
# list interpreter alias commands to define
array set ::g_cachefileAliases [list modulefile-content\
modulefile-content modulerc-content modulerc-content\
modulefile-invalid modulefile-invalid limited-access-file\
limited-access-file limited-access-directory\
limited-access-directory reportInternalBug reportInternalBug\
readCacheContent readCacheContent formatErrStackTrace\
formatErrStackTrace]
# alias commands where an argument should be passed
array set ::g_cachefileAliasesPassArg [list]
# trace commands that should be associated to aliases
array set ::g_cachefileAliasesTraces [list]
}
set itrp __cachefile
reportTrace '$cachefile' {Evaluate cache file}
# create cachefile interpreter at first interpretation
if {![interp exists $itrp]} {
reportDebug "creating interp $itrp"
interp create $itrp
# dump initial interpreter state to restore it before each cachefile
# interpretation.
dumpInterpState $itrp g_cachefileVars g_cachefileArrayVars\
g_cachefileUntrackVars g_cachefileProcs
# interp has just been created
set fresh 1
} else {
set fresh 0
}
# reset interp state command before each interpretation
resetInterpState $itrp $fresh g_cachefileVars g_cachefileArrayVars\
g_cachefileUntrackVars g_cachefileProcs g_cachefileAliases\
g_cachefileAliasesPassArg g_cachefileAliasesTraces\
g_cachefileRenameCmds g_cachefileCommands
# reset modulefile-specific variable before each interpretation
interp eval $itrp set ::ModulesCurrentCachefile "{$cachefile}"
# evaluate cache file
##nagelfar ignore +4 Suspicious # char
set exec_res [interp eval $itrp {
set cachecontent [readCacheContent $::ModulesCurrentCachefile]
if {$cachecontent eq {}} {
# simply skip cache file, no exit on error here
return 0
}
info script $::ModulesCurrentCachefile
if {[catch {eval $cachecontent} errorMsg]} {
# format stack trace to report cachefile information only
reportInternalBug [formatErrStackTrace $::errorInfo\
$::ModulesCurrentCachefile [list {*}[info procs] {*}[info\
commands]]] {} {Cache ERROR}
return 0
} else {
return 1
}
}]
reportDebug "exiting $cachefile (result=$exec_res)"
lpopState debug_msg_prefix
lpopState modulepath
return $exec_res
}
# cache file command to record modulefile content
proc modulefile-content {mod mtime header content} {
set modfile [currentState modulepath]/$mod
# record modulefile information in memory structures
set ::g_modfileContent($modfile) [list $header $content]
set ::g_fileMtime($modfile) $mtime
set ::g_modfileValid($modfile) [list true {}]
# gather all modulefiles/modulercs of a modulepath in a global variable
# with same information structure than findModules result
lappend ::g_cacheModpath([currentState modulepath]) $mod [list modulefile\
$mtime $modfile]
}
# cache file command to record modulerc content
proc modulerc-content {modrc header content} {
set modrcfile [currentState modulepath]/$modrc
# record modulerc information in memory structures
set ::g_modfileContent($modrcfile) [list $header $content]
# gather all modulefiles/modulercs of a modulepath in a global variable
# with same information structure than findModules result
lappend ::g_cacheModpath([currentState modulepath]) $modrc [list modulerc]
}
# cache file command to record an invalid modulefile
proc modulefile-invalid {mod type msg} {
set modfile [currentState modulepath]/$mod
# record modulefile information in memory structures
set ::g_modfileValid($modfile) [list $type $msg]
# also gather all invalid modulefiles of a modulepath in a global variable
# with same information structure than findModules result
lappend ::g_cacheModpath([currentState modulepath]) $mod [list $type $msg\
$modfile]
}
# gather modulepath limited access files in specific structure
proc limited-access-file {mod} {
lappend ::g_cacheFLimitedModpath([currentState modulepath]) $mod 1
}
# gather modulepath limited access files in specific structure
proc limited-access-directory {dir} {
lappend ::g_cacheDLimitedModpath([currentState modulepath]) $dir 1
}
# finds all module-related files matching mod in the modulepath dir by looking
# into the cache file
proc findModulesInCacheFile {modpath mod depthlvl fetch_mtime} {
set cachefile [getModuleCacheFilename $modpath]
# check if cache should be ignored
if {[getConf ignore_cache]} {
return [list 0 {}]
}
# check if a cache file is available (exist, readable and not expired)
if {![info exists ::g_cachefilesAvail($cachefile)]} {
if {[file readable $cachefile]} {
reportDebug "cache file '$cachefile' exists and is readable"
# check expiry if enabled
if {[set expiry_secs [getConf cache_expiry_secs]] != 0} {
set cachemtime [getFileMtime $cachefile]
# cache is also considered expired if its mtime cannot be fetched
set ::g_cachefilesAvail($cachefile) [expr {$cachemtime ne {} &&\
$expiry_secs > ([getState clock_seconds] - $cachemtime)}]
if {!$::g_cachefilesAvail($cachefile)} {
reportDebug "cache file '$cachefile' has expired"
}
} else {
set ::g_cachefilesAvail($cachefile) 1
}
} else {
reportDebug "cache file '$cachefile' cannot be found or read"
set ::g_cachefilesAvail($cachefile) 0
}
}
# return if no cache file available
if {!$::g_cachefilesAvail($cachefile)} {
return [list 0 {}]
}
# evaluate cache file if not yet done
if {![info exists ::g_cachefilesSourced($cachefile)]} {
set exec_res [execute-cachefile $cachefile $modpath]
# keep track of already sourced cache files not to run them again
set ::g_cachefilesSourced($cachefile) $exec_res
} else {
reportDebug "cache file '$cachefile' has already been evaluated"
}
# return if cache file has not been correctly sourced
if {!$::g_cachefilesSourced($cachefile)} {
return [list 0 {}]
}
# tailor cache file content to what is requested
array set cache_arr $::g_cacheModpath($modpath)
reportDebug "[array size cache_arr] elements are cached for '$modpath'"
array set flimited_arr $::g_cacheFLimitedModpath($modpath)
reportDebug "[array size flimited_arr] limited access files for '$modpath'"
array set dlimited_arr $::g_cacheDLimitedModpath($modpath)
reportDebug "[array size dlimited_arr] limited access dirs for '$modpath'"
# filter entries unless all are requested
set findall [expr {$mod in {{} *}}]
defineModEqStaticProc [isIcase] [getConf extended_default] $mod
if {!$findall || $depthlvl > 0} {
foreach elt [array names cache_arr] {
set eltroot [lindex [file split $elt] 0]
set eltdepthlvl [llength [file split $elt]]
set elttail [file tail $elt]
set eltparent [file dirname $elt]
# exclude if not matching mod pattern (which is always a root name)
if {$eltroot ne {.modulerc} && !$findall && ![modEqStatic $eltroot\
match]} {
unset cache_arr($elt)
# also exclude if not corresponding to search depth level (or if one
# modulefile has already been added for directories lying at other
# depth level)
} elseif {$depthlvl > 0 && $elttail ne {.modulerc} && $eltdepthlvl\
!= $depthlvl && [info exists modfile_indir($eltparent)]} {
unset cache_arr($elt)
} else {
# track a valid non-hidden modulefile has been added in parent
# directory
if {[string index $elttail 0] ne {.} && ![info exists\
modfile_indir($eltparent)] && [lindex $cache_arr($elt) 0] eq\
{modulefile}} {
set modfile_indir($eltparent) 1
}
}
}
}
array set hidden_list {}
set limited_list [list]
# add limited access files and directories to result if they match query
foreach elt [concat [array names flimited_arr] [array names\
dlimited_arr]] {
set eltroot [lindex [file split $elt] 0]
if {$eltroot eq {.modulerc} || $findall || [modEqStatic $eltroot\
match]} {
set fpelt [file join $modpath $elt]
lappend limited_list $fpelt
# indicate file is hidden in structure that will be transmitted to
# findModulesFromDirsAndFiles for no-indepth module search
if {[string index [file tail $elt] 0] eq {.} && [info exists\
flimited_arr($elt)]} {
set hidden_list($fpelt) 1
}
}
}
# walk through list of matching limited access dirs and files to find
# modules available to current user (transmit list of known files and dirs
# to avoid file stat tests)
findModulesFromDirsAndFiles $modpath $limited_list $depthlvl $fetch_mtime\
cache_arr modfile_indir hidden_list flimited_arr dlimited_arr
reportDebug "found [array names cache_arr] ([array size cache_arr])"
set cache_list [array get cache_arr]
return [list 1 $cache_list]
}
# build list of what to undo then do to move from an initial list to a target
# list, eventually checking element presence in extra from/to lists
proc getMovementBetweenList {from to {extfrom {}} {extto {}} {cmp eq}} {
reportDebug "from($from) to($to) with extfrom($extfrom) extto($extto)"
set undo {}
set do {}
# determine what element to undo then do
# to restore a target list from a current list
# with preservation of the element order
##nagelfar ignore #2 Badly formed if statement
set imax [if {[llength $to] > [llength $from]} {llength $to} {llength\
$from}]
set list_equal 1
for {set i 0} {$i < $imax} {incr i} {
set to_obj [lindex $to $i]
set from_obj [lindex $from $i]
# check from/to element presence in extra from/to list
set in_extfrom [expr {$from_obj in $extfrom}]
set in_extto [expr {$to_obj in $extto}]
# are elts the sames and are both part of or missing from extra lists
# when comparing modules, ask comparison against loaded module
# alternative and simplified names (modEq will also compare variants)
if {($cmp eq {modeq} && ![modEq $to_obj $from_obj equal 1 3 1]) ||\
($cmp eq {eq} && $to_obj ne $from_obj) || $in_extfrom != $in_extto} {
set list_equal 0
}
if {$list_equal == 0} {
if {$to_obj ne {}} {
lappend do $to_obj
}
if {$from_obj ne {}} {
lappend undo $from_obj
}
}
}
return [list $undo $do]
}
# build list of currently loaded modules where modulename is registered minus
# module version if loaded version is the default one
proc getSimplifiedLoadedModuleList {} {
set curr_mod_list {}
array set curr_tag_arr {}
set modpathlist [getModulePathList]
foreach mod [getLoadedModulePropertyList name] {
set altandsimplist [getLoadedAltAndSimplifiedName $mod]
set parentmod [file dirname $mod]
set simplemod $mod
# simplify to parent name as long as it is found in simplified name list
while {$parentmod ne {.}} {
if {$parentmod in $altandsimplist} {
set simplemod $parentmod
set parentmod [file dirname $parentmod]
} else {
set parentmod .
}
}
# add each module specification as list to correctly enclose spaces in
# module name or variant name or value
set simplemodvr [list $simplemod {*}[getVariantList $mod 5 1]]
lappend curr_mod_list $simplemodvr
# record tags applying to module in simplified version form
set tag_list [getSaveTagList $mod]
if {[llength $tag_list] > 0} {
set curr_tag_arr($simplemodvr) $tag_list
}
}
return [list $curr_mod_list [array get curr_tag_arr]]
}
# return saved collections found in user directory which corresponds to
# enabled collection target if any set. extract one collection specifically
# when search mode is set to exact. only compute collection name if mode is
# set to name. translate collection name to __init__ if not found and
# swap_by_init enabled. if no_other_target enabled, ensure no result from
# other target are returned from glob search
proc findCollections {{coll *} {search glob} {swap_by_init 0} {errnomatch 0}\
{checkvalid 1} {no_other_target 0}} {
# initialize description with collection name
set colldesc $coll
if {$coll eq {}} {
reportErrorAndExit [getEmptyNameMsg collection]
} elseif {$coll eq {__init__}} {
set collfile $coll
set colldesc {}
# is collection a filepath
} elseif {[string first / $coll] > -1} {
# collection target has no influence when
# collection is specified as a filepath
set collfile $coll
# elsewhere collection is a name
} elseif {[info exists ::env(HOME)]} {
set collfile $::env(HOME)/.module/$coll
# find saved collections (matching target suffix). a target is a domain
# on which a collection is only valid. when a target is set, only the
# collections made for that target will be available to list and
# restore, and saving will register the target footprint. current target
# is ignored if --all option is set on savelist command
set colltarget [getConf collection_target]
if {$colltarget ne {} && ([getState hiding_threshold] < 2 ||\
[currentState commandname] ne {savelist})} {
append collfile .$colltarget
# add knowledge of collection target on description
append colldesc " (for target \"$colltarget\")"
}
} else {
reportErrorAndExit {HOME not defined}
}
switch -- $search {
glob {
# glob excludes by default files starting with "."
if {[catch {set clist [glob -nocomplain $collfile]} errMsg]} {
reportErrorAndExit "Cannot access collection directory.\n$errMsg"
} else {
set res {}
foreach cfile $clist {
# test collection is from correct target or no target if
# no_other_target is enabled
set cfile_ext [string range [file extension $cfile] 1 end]
if {(!$no_other_target || $cfile_ext eq [getConf\
collection_target]) && [checkValidColl $cfile]} {
lappend res $cfile
}
}
}
}
exact {
if {$coll ne {__init__}} {
# verify that file exists
if {![file exists $collfile]} {
if {$errnomatch} {
reportErrorAndExit "Collection $colldesc cannot be found"
} else {
set collfile {}
}
# error will be raised if collection not valid
} elseif {$checkvalid && ![checkValidColl $collfile\
$errnomatch]} {
set collfile {}
}
}
if {$collfile eq {} && $swap_by_init} {
set collfile __init__
set colldesc {}
}
# return coll filename and its description for exact and name modes
set res [list $collfile $colldesc]
}
name {
set res [list $collfile $colldesc]
}
}
return $res
}
proc checkValidColl {collfile {report_issue 0}} {
set res 0
if {[catch {
set fdata [readFile $collfile 1]
# extract magic cookie (first word)
set fh [string trimright [lindex [split [string range $fdata 0 32]]\
0] #]
} errMsg ]} {
if {$report_issue} {
reportErrorAndExit [parseAccessIssue $collfile]
}
} else {
# collection without magic cookie are valid
# check if min version requirement is met
if {[string equal -length 8 $fh {#%Module}] && [string length $fh] \
> 8 && [versioncmp {5.3.0} [string range $fh 8 end]] \
< 0} {
if {$report_issue} {
reportErrorAndExit "Collection $collfile requires at least\
Modules version [string range $fh 8 end]"
}
} else {
set res 1
}
}
return $res
}
# generate collection content based on provided path and module lists
proc formatCollectionContent {path_list mod_list tag_arrser header {sgr 0}} {
set content {}
array set tag_arr $tag_arrser
# graphically enhance module command if asked
set modcmd [expr {$sgr ? [sgr cm module] : {module}}]
# start collection content with modulepaths
foreach path $path_list {
# enclose path if space character found in it
if {[string first { } $path] != -1} {
set path "{$path}"
}
# 'module use' prepends paths by default so we clarify
# path order here with --append flag
append content "$modcmd use --append $path" \n
}
# then add modules
foreach mod $mod_list {
# save tags associated to module (like auto-loaded tag)
if {[info exists tag_arr($mod)] && [llength $tag_arr($mod)] > 0} {
set opt "--tag=[join $tag_arr($mod) :] "
} else {
set opt {}
}
# no need to specifically enclose module specification if space char
# used in it as $mod is a list so elements including space will be
# automatically enclosed
append content "$modcmd load $opt$mod" \n
}
# prepend header if defined and some content has been generated
if {[string length $header] != 0 && [string length $content] != 0} {
set content "$header\n$content"
}
return $content
}
# read given collection file and return the path and module lists it defines
proc readCollectionContent {collfile colldesc} {
# read file
if {[catch {
set fdata [split [readFile $collfile] \n]
} errMsg ]} {
reportErrorAndExit "Collection $colldesc cannot be read.\n$errMsg"
}
return [parseCollectionContent $fdata]
}
proc parseCollectionContent {fdata} {
# init lists (maybe coll does not set mod to load)
set path_list {}
set mod_list {}
set nuasked_list {}
array set tag_arr {}
# analyze collection content
foreach fline $fdata {
if {[regexp {module use (.*)$} $fline match patharg] == 1} {
# paths are appended by default
set stuff_path append
# manage multiple paths and path options specified on single line,
# for instance "module use --append path1 path2 path3", with list
# representation of patharg (which handles quoted elements containing
# space in their name)
foreach path $patharg {
# following path is asked to be appended
if {($path eq {--append}) || ($path eq {-a})\
|| ($path eq {-append})} {
set stuff_path append
# following path is asked to be prepended
# collection generated with 'save' does not prepend
} elseif {($path eq {--prepend}) || ($path eq {-p})\
|| ($path eq {-prepend})} {
set stuff_path prepend
} else {
# ensure given path is absolute to be able to correctly
# compare with paths registered in MODULEPATH
set path [getAbsolutePath $path]
# add path to end of list
if {$stuff_path eq {append}} {
lappend path_list $path
# insert path to first position
} else {
set path_list [linsert $path_list 0 $path]
}
}
}
} elseif {[regexp {module load (.*)$} $fline match modarg] == 1} {
# extract collection-specific flags from module specification
switch -glob -- [lindex $modarg 0] {
--notuasked {
set tag_list [list auto-loaded]
set cleanlist [lrange $modarg 1 end]
}
--tag=* {
set tag_list [split [string range [lindex $modarg 0] 6 end] :]
set cleanlist [lrange $modarg 1 end]
}
default {
set tag_list {}
set cleanlist $modarg
}
}
# parse module specification to distinguish between module + variant
# specified and multiple modules specified on a single line
set parsedlist [parseModuleSpecification 0 0 0 0 {*}$cleanlist]
foreach parsed $parsedlist {
set tag_arr($parsed) $tag_list
}
lappend mod_list {*}$parsedlist
}
}
return [list $path_list $mod_list [array get tag_arr]]
}
# return specified collection content and differences compared to currently
# defined environment
proc getDiffBetweenCurEnvAndColl {collfile colldesc} {
# read specific __init__ collection from __MODULES_LMINIT env var
if {$collfile eq {__init__}} {
lassign [parseCollectionContent [getLoadedModulePropertyList init]]\
coll_path_list coll_mod_list coll_tag_arrser
} else {
lassign [readCollectionContent $collfile $colldesc] coll_path_list\
coll_mod_list coll_tag_arrser
}
# build list of module tagged auto-loaded in collection
array set coll_tag_arr $coll_tag_arrser
set coll_nuasked_list {}
foreach mod [array names coll_tag_arr] {
if {{auto-loaded} in $coll_tag_arr($mod)} {
lappend coll_nuasked_list $mod
}
}
# collection should at least define a path or a mod, but initial env may be
# totally empty
if {$collfile ne {__init__} && [llength $coll_path_list] == 0 && [llength\
$coll_mod_list] == 0} {
reportErrorAndExit "$colldesc is not a valid collection"
}
# load tags from loaded modules
cacheCurrentModules
defineModEqProc [isIcase] [getConf extended_default]
# fetch what is currently loaded
set curr_path_list [getModulePathList returnempty 0]
# get current loaded module list
set curr_mod_list [getLoadedModulePropertyList name]
set curr_nuasked_list [getTaggedLoadedModuleList auto-loaded]
# get current save tags of loaded modules
array set curr_tag_arr [getLoadedModuleWithVariantSaveTagArrayList]
# determine what module to unload to restore collection from current
# situation with preservation of the load order (asking for a modeq
# comparison will help to check against simplified mod name and variants)
lassign [getMovementBetweenList $curr_mod_list $coll_mod_list\
$curr_nuasked_list $coll_nuasked_list modeq] mod_to_unload mod_to_load
# proceed as well for modulepath
lassign [getMovementBetweenList $curr_path_list $coll_path_list] \
path_to_unuse path_to_use
# indicate if loaded modules that matches modules in collection have
# different tags set
if {[llength $mod_to_load] == 0} {
# consider a not-set entry as an empty element when comparing collection
# and current environment tags. compare tags as unordered lists
lassign [getDiffBetweenArray curr_tag_arr coll_tag_arr 1 1] notincoll\
diff notincurr
set is_tags_diff [expr {[llength $diff] > 0}]
# if some module from collection are not yet loaded, consider there is a
# difference
} else {
set is_tags_diff 1
}
return [list $coll_path_list $coll_mod_list $coll_tag_arrser\
$coll_nuasked_list $mod_to_unload $mod_to_load $path_to_unuse\
$path_to_use $is_tags_diff]
}
proc getCollectionFromStash {stash} {
if {[string match stash-* $stash]} {
set coll $stash
} elseif {[string is integer -strict $stash]} {
# filter collection from other target (especially if no target set)
set collfile [lindex [lsort -decreasing [findCollections stash-* glob\
0 0 1 1]] $stash]
if {$collfile eq {}} {
knerror "Invalid stash index '$stash'"
}
# extract collection name (without path and target extension)
set coll [file rootname [file tail $collfile]]
} else {
knerror "Invalid stash collection name '$stash'"
}
return $coll
}
proc cmdModuleList {show_oneperline show_mtime search_match args} {
set json [isStateEqual report_format json]
# load tags from loaded modules
cacheCurrentModules
if {[llength $args] > 0} {
defineModEqProc [isIcase] [getConf extended_default]
# match passed name against any part of loaded module names
set mtest [expr {{contains} in $search_match ? {matchin} : {match}}]
set search_queries $args
# prepare header message which depend if search is performed
set loadedmsg {Currently Loaded Matching Modulefiles}
} else {
set search_queries {}
set loadedmsg {Currently Loaded Modulefiles}
}
# filter-out hidden loaded modules unless all module should be seen
if {[getState hiding_threshold] > 1} {
set loadedmodlist [getLoadedModulePropertyList name]
} else {
set loadedmodlist [list]
foreach mod [getLoadedModulePropertyList name] {
if {![isModuleTagged $mod hidden-loaded 1]} {
lappend loadedmodlist $mod
}
}
}
# same header msg if no module loaded at all whether search is made or not
set noloadedmsg [expr {[llength $loadedmodlist] == 0 ? {No Modulefiles\
Currently Loaded.} : {No Matching Modulefiles Currently Loaded.}}]
# filter loaded modules not matching any of the mod spec passed
if {[llength $args] > 0} {
set matchlist [list]
foreach mod $loadedmodlist {
foreach pattern $args {
# compare pattern against loaded module, its variant set and its
# alternative names
if {[modEq $pattern $mod $mtest 1 2 1 0 *]} {
lappend matchlist $mod
break
}
}
}
set loadedmodlist $matchlist
}
if {[llength $loadedmodlist] == 0} {
if {!$json && [isEltInReport header]} {
report $noloadedmsg
}
} else {
# build mod_list array with loaded modules
foreach mod $loadedmodlist {
set modfile [getModulefileFromLoadedModule $mod]
set mtime [expr {$show_mtime && [file exists $modfile] ?\
[getFileMtime $modfile] : {}}]
set mod_list($mod) [list modulefile $mtime $modfile]
# fetch symbols from loaded environment information
set modname [file dirname $mod]
set sym_list {}
foreach altname [getLoadedAltname $mod 0 sym] {
# skip non-symbol entry
if {$altname ne $modname} {
lappend sym_list [file tail $altname]
}
}
set ::g_symbolHash($mod) [lsort -dictionary $sym_list]
}
set one_per_line [expr {$show_mtime || $show_oneperline}]
set show_idx [expr {!$show_mtime && [isEltInReport idx]}]
set header [expr {!$json && [isEltInReport header] ? $loadedmsg :\
{noheader}}]
set theader_cols [list hi Package 39 Versions 19 {Last mod.} 19]
reportModules $search_queries $header {} terse $show_mtime $show_idx\
$one_per_line $theader_cols loaded $loadedmodlist
# display output key
if {!$show_mtime && !$json && [isEltInReport key]} {
displayKey
}
}
}
proc cmdModuleDisplay {args} {
lappendState mode display
set first_report 1
foreach mod $args {
lassign [getPathToModule $mod] modfile modname modnamevr
if {$modfile ne {}} {
# only one separator lines between 2 modules
if {$first_report} {
displaySeparatorLine
set first_report 0
}
report [sgr hi $modfile]:\n
execute-modulefile $modfile $modname modnamevr $mod
displaySeparatorLine
}
}
lpopState mode
}
proc cmdModulePaths {mod} {
set dir_list [getModulePathList exiterronundef]
foreach dir $dir_list {
array unset mod_list
array set mod_list [getModules $dir $mod 0 [list rc_defs_included]]
# prepare list of dirs for alias/symbol target search, will first search
# in currently looked dir, then in other dirs following precedence order
set target_dir_list [list $dir {*}[replaceFromList $dir_list $dir]]
# forcibly enable implicit_default to resolve alias target when it
# points to a directory
setConf implicit_default 1
# build list of modulefile to print
foreach elt [array names mod_list] {
switch -- [lindex $mod_list($elt) 0] {
modulefile {
lappend ::g_return_text $dir/$elt
}
virtual {
lappend ::g_return_text [lindex $mod_list($elt) 2]
}
alias - version {
# resolve alias target
set aliastarget [lindex $mod_list($elt) 1]
lassign [getPathToModule $aliastarget $target_dir_list 0]\
modfile modname modnamevr
# add module target as result instead of alias
if {$modfile ne {} && ![info exists mod_list($modname)]} {
lappend ::g_return_text $modfile
}
}
}
}
# reset implicit_default to restore behavior defined
unsetConf implicit_default
}
# sort results if any and remove duplicates
if {[info exists ::g_return_text]} {
set ::g_return_text [lsort -dictionary -unique $::g_return_text]
} else {
# set empty value to return empty if no result
set ::g_return_text {}
}
}
proc cmdModulePath {mod} {
lassign [getPathToModule $mod] modfile modname modnamevr
# if no result set empty value to return empty
if {$modfile eq {}} {
set ::g_return_text {}
} else {
lappend ::g_return_text $modfile
}
}
proc cmdModuleWhatIs {{mod {}}} {
cmdModuleSearch $mod {}
}
proc cmdModuleApropos {{search {}}} {
cmdModuleSearch {} $search
}
proc cmdModuleSearch {{mod {}} {search {}}} {
# disable error reporting to avoid modulefile errors
# to mix with valid search results
inhibitErrorReport
set json [isStateEqual report_format json]
set icase [isIcase]
defineModEqProc $icase [getConf extended_default]
lappend searchmod rc_defs_included
if {$mod eq {}} {
lappend searchmod wild
}
set foundmod 0
lappendState mode whatis
set dir_list [getModulePathList exiterronundef]
foreach dir $dir_list {
array unset mod_list
array set mod_list [getModules $dir $mod 0 $searchmod]
array unset interp_list
array set interp_list {}
# forcibly enable implicit_default to resolve alias target when it
# points to a directory
setConf implicit_default 1
# build list of modulefile to interpret
foreach elt [array names mod_list] {
switch -- [lindex $mod_list($elt) 0] {
modulefile {
if {[isModuleTagged $elt forbidden]} {
# register any error occurring on element matching search
if {[modEq $mod $elt]} {
set err_list($elt) [list accesserr [getForbiddenMsg\
$elt]]
Showing 512.00 KB of 654.01 KB. Use Edit/Download for full content.
Directory Contents
Dirs: 0 × Files: 1446