mirror of
https://github.com/envmodules/modules.git
synced 2026-05-30 00:12:31 +08:00
Split mfinterp.tcl.in file into interp.tcl.in + mfcmd.tcl
This commit is contained in:
Xavier Delaruelle
2
.gitignore
vendored
2
.gitignore
vendored
@@ -22,7 +22,7 @@
|
||||
/tcl/envmngt.tcl
|
||||
/tcl/init.tcl
|
||||
/tcl/main.tcl
|
||||
/tcl/mfinterp.tcl
|
||||
/tcl/interp.tcl
|
||||
/tcl/modfind.tcl
|
||||
/tcl/report.tcl
|
||||
/tcl/subcmd.tcl
|
||||
|
||||
50
Makefile
50
Makefile
@@ -479,7 +479,7 @@ tcl/init.tcl: tcl/init.tcl.in version.inc
|
||||
tcl/main.tcl: tcl/main.tcl.in version.inc
|
||||
$(translate-in-script)
|
||||
|
||||
tcl/mfinterp.tcl: tcl/mfinterp.tcl.in version.inc
|
||||
tcl/interp.tcl: tcl/interp.tcl.in version.inc
|
||||
$(translate-in-script)
|
||||
|
||||
tcl/modfind.tcl: tcl/modfind.tcl.in version.inc
|
||||
@@ -513,9 +513,9 @@ tcl/subcmd.tcl_i: tcl/subcmd.tcl $(NAGELFAR)
|
||||
|
||||
# join all tcl/*.tcl files to build modulecmd.tcl
|
||||
modulecmd.tcl: tcl/cache.tcl tcl/coll.tcl tcl/envmngt.tcl tcl/init.tcl \
|
||||
tcl/main.tcl tcl/mfinterp.tcl tcl/modeval.tcl tcl/modfind.tcl \
|
||||
tcl/modscan.tcl tcl/modspec.tcl tcl/report.tcl tcl/subcmd.tcl \
|
||||
tcl/util.tcl version.inc
|
||||
tcl/interp.tcl tcl/main.tcl tcl/mfcmd.tcl tcl/modeval.tcl \
|
||||
tcl/modfind.tcl tcl/modscan.tcl tcl/modspec.tcl tcl/report.tcl \
|
||||
tcl/subcmd.tcl tcl/util.tcl version.inc
|
||||
$(ECHO_GEN)
|
||||
echo "#!$(TCLSH)" > $@
|
||||
sed -e '3s/.*/# MODULECMD.TCL, a pure TCL implementation of the module command/' \
|
||||
@@ -523,7 +523,8 @@ modulecmd.tcl: tcl/cache.tcl tcl/coll.tcl tcl/envmngt.tcl tcl/init.tcl \
|
||||
sed -e '1,22d' -e '/^# vim:/d' -e '/^# ;;;/d' tcl/util.tcl >> $@
|
||||
sed -e '1,22d' -e '/^# vim:/d' -e '/^# ;;;/d' tcl/envmngt.tcl >> $@
|
||||
sed -e '1,22d' -e '/^# vim:/d' -e '/^# ;;;/d' tcl/report.tcl >> $@
|
||||
sed -e '1,22d' -e '/^# vim:/d' -e '/^# ;;;/d' tcl/mfinterp.tcl >> $@
|
||||
sed -e '1,22d' -e '/^# vim:/d' -e '/^# ;;;/d' tcl/interp.tcl >> $@
|
||||
sed -e '1,22d' -e '/^# vim:/d' -e '/^# ;;;/d' tcl/mfcmd.tcl >> $@
|
||||
sed -e '1,20d' -e '/^# vim:/d' -e '/^# ;;;/d' tcl/modscan.tcl >> $@
|
||||
sed -e '1,22d' -e '/^# vim:/d' -e '/^# ;;;/d' tcl/modfind.tcl >> $@
|
||||
sed -e '1,22d' -e '/^# vim:/d' -e '/^# ;;;/d' tcl/modeval.tcl >> $@
|
||||
@@ -840,8 +841,8 @@ endif
|
||||
rm -f tcl/coll.tcl
|
||||
rm -f tcl/envmngt.tcl
|
||||
rm -f tcl/init.tcl
|
||||
rm -f tcl/interp.tcl
|
||||
rm -f tcl/main.tcl
|
||||
rm -f tcl/mfinterp.tcl
|
||||
rm -f tcl/modfind.tcl
|
||||
rm -f tcl/report.tcl
|
||||
rm -f tcl/subcmd.tcl
|
||||
@@ -899,16 +900,17 @@ tcl/%.tcl_i: tcl/%.tcl $(NAGELFAR)
|
||||
# for coverage check, run tests on instrumented file to create coverage log
|
||||
# over split tcl source files
|
||||
$(MODULECMDTEST)_i: tcl/cache.tcl_i tcl/coll.tcl_i tcl/envmngt.tcl_i \
|
||||
tcl/init.tcl_i tcl/main.tcl_i tcl/mfinterp.tcl_i tcl/modeval.tcl_i \
|
||||
tcl/modfind.tcl_i tcl/modscan.tcl_i tcl/modspec.tcl_i tcl/report.tcl_i \
|
||||
tcl/subcmd.tcl_i tcl/util.tcl_i version.inc
|
||||
tcl/init.tcl_i tcl/interp.tcl_i tcl/main.tcl_i tcl/mfcmd.tcl_i \
|
||||
tcl/modeval.tcl_i tcl/modfind.tcl_i tcl/modscan.tcl_i tcl/modspec.tcl_i \
|
||||
tcl/report.tcl_i tcl/subcmd.tcl_i tcl/util.tcl_i version.inc
|
||||
$(ECHO_GEN)
|
||||
echo "#!$(TCLSH)" > $@
|
||||
echo 'source tcl/init.tcl_i' >> $@
|
||||
echo 'source tcl/util.tcl_i' >> $@
|
||||
echo 'source tcl/envmngt.tcl_i' >> $@
|
||||
echo 'source tcl/report.tcl_i' >> $@
|
||||
echo 'source tcl/mfinterp.tcl_i' >> $@
|
||||
echo 'source tcl/interp.tcl_i' >> $@
|
||||
echo 'source tcl/mfcmd.tcl_i' >> $@
|
||||
echo 'source tcl/modscan.tcl_i' >> $@
|
||||
echo 'source tcl/modfind.tcl_i' >> $@
|
||||
echo 'source tcl/modeval.tcl_i' >> $@
|
||||
@@ -938,8 +940,9 @@ ifeq ($(COVERAGE),y)
|
||||
$(NAGELFAR) -markup tcl/coll.tcl
|
||||
$(NAGELFAR) -markup tcl/envmngt.tcl
|
||||
$(NAGELFAR) -markup tcl/init.tcl
|
||||
$(NAGELFAR) -markup tcl/interp.tcl
|
||||
$(NAGELFAR) -markup tcl/main.tcl
|
||||
$(NAGELFAR) -markup tcl/mfinterp.tcl
|
||||
$(NAGELFAR) -markup tcl/mfcmd.tcl
|
||||
$(NAGELFAR) -markup tcl/modeval.tcl
|
||||
$(NAGELFAR) -markup tcl/modscan.tcl
|
||||
$(NAGELFAR) -markup tcl/modfind.tcl
|
||||
@@ -1007,12 +1010,12 @@ $(NAGELFAR):
|
||||
|
||||
# build Ctags index
|
||||
tcl/tags: tcl/cache.tcl.in tcl/coll.tcl.in tcl/envmngt.tcl.in tcl/init.tcl.in \
|
||||
tcl/main.tcl.in tcl/mfinterp.tcl.in tcl/modeval.tcl tcl/modfind.tcl.in \
|
||||
tcl/modscan.tcl tcl/modspec.tcl tcl/report.tcl.in tcl/subcmd.tcl.in \
|
||||
tcl/util.tcl
|
||||
tcl/interp.tcl.in tcl/main.tcl.in tcl/mfcmd.tcl tcl/modeval.tcl \
|
||||
tcl/modfind.tcl.in tcl/modscan.tcl tcl/modspec.tcl tcl/report.tcl.in \
|
||||
tcl/subcmd.tcl.in tcl/util.tcl
|
||||
ctags --tag-relative -f $@ --langmap=tcl:.tcl.in tcl/cache.tcl.in \
|
||||
tcl/coll.tcl.in tcl/envmngt.tcl.in tcl/init.tcl.in tcl/main.tcl.in \
|
||||
tcl/mfinterp.tcl.in tcl/modeval.tcl tcl/modfind.tcl.in \
|
||||
tcl/coll.tcl.in tcl/envmngt.tcl.in tcl/init.tcl.in tcl/interp.tcl.in \
|
||||
tcl/main.tcl.in tcl/mfcmd.tcl tcl/modeval.tcl tcl/modfind.tcl.in \
|
||||
tcl/modscan.tcl tcl/modspec.tcl tcl/report.tcl.in tcl/subcmd.tcl.in \
|
||||
tcl/util.tcl
|
||||
|
||||
@@ -1022,8 +1025,9 @@ tcl/gtags.file:
|
||||
echo coll.tcl.in >> $@
|
||||
echo envmngt.tcl.in >> $@
|
||||
echo init.tcl.in >> $@
|
||||
echo interp.tcl.in >> $@
|
||||
echo main.tcl.in >> $@
|
||||
echo mfinterp.tcl.in >> $@
|
||||
echo mfcmd.tcl >> $@
|
||||
echo modeval.tcl >> $@
|
||||
echo modscan.tcl >> $@
|
||||
echo modfind.tcl.in >> $@
|
||||
@@ -1034,9 +1038,9 @@ tcl/gtags.file:
|
||||
|
||||
# build Gtags tag file
|
||||
tcl/GTAGS: tcl/cache.tcl.in tcl/coll.tcl.in tcl/envmngt.tcl.in tcl/init.tcl.in \
|
||||
tcl/main.tcl.in tcl/mfinterp.tcl.in tcl/modeval.tcl tcl/modfind.tcl.in \
|
||||
tcl/modscan.tcl tcl/modspec.tcl tcl/report.tcl.in tcl/subcmd.tcl.in \
|
||||
tcl/util.tcl tcl/gtags.file
|
||||
tcl/interp.tcl.in tcl/main.tcl.in tcl/mfcmd.tcl tcl/modeval.tcl \
|
||||
tcl/modfind.tcl.in tcl/modscan.tcl tcl/modspec.tcl tcl/report.tcl.in \
|
||||
tcl/subcmd.tcl.in tcl/util.tcl tcl/gtags.file
|
||||
gtags -C tcl --gtagsconf ../.globalrc
|
||||
|
||||
tcl/syntaxdb.tcl: modulecmd.tcl $(NAGELFAR)
|
||||
@@ -1071,9 +1075,9 @@ endif
|
||||
# let verbose by default the install/clean/test and other specific non-build targets
|
||||
$(V).SILENT: initdir pkgdoc doc version.inc contrib/rpm/environment-modules.spec \
|
||||
modulecmd.tcl tcl/cache.tcl tcl/coll.tcl tcl/envmngt.tcl tcl/init.tcl \
|
||||
tcl/main.tcl tcl/mfinterp.tcl tcl/modfind.tcl tcl/report.tcl tcl/subcmd.tcl \
|
||||
tcl/cache.tcl_i tcl/coll.tcl_i tcl/envmngt.tcl_i tcl/init.tcl_i \
|
||||
tcl/main.tcl_i tcl/mfinterp.tcl_i tcl/modfind.tcl_i tcl/modeval.tcl_i \
|
||||
tcl/interp.tcl tcl/main.tcl tcl/modfind.tcl tcl/report.tcl tcl/subcmd.tcl \
|
||||
tcl/cache.tcl_i tcl/coll.tcl_i tcl/envmngt.tcl_i tcl/init.tcl_i tcl/interp.tcl_i \
|
||||
tcl/main.tcl_i tcl/mfcmd.tcl_i tcl/modfind.tcl_i tcl/modeval.tcl_i \
|
||||
tcl/modscan.tcl_i tcl/modspec.tcl_i tcl/report.tcl_i tcl/subcmd.tcl_i \
|
||||
tcl/util.tcl_i ChangeLog.gz README script/add.modules \
|
||||
script/gitlog2changelog.py script/modulecmd \
|
||||
|
||||
839
tcl/interp.tcl.in
Normal file
839
tcl/interp.tcl.in
Normal file
@@ -0,0 +1,839 @@
|
||||
##########################################################################
|
||||
|
||||
# INTERP.TCL, sub-interpreter management procedures
|
||||
# Copyright (C) 2002-2004 Mark Lakata
|
||||
# Copyright (C) 2004-2017 Kent Mein
|
||||
# Copyright (C) 2016-2023 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/>.
|
||||
|
||||
##########################################################################
|
||||
|
||||
# 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]]} {
|
||||
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\
|
||||
modulepath-label modulepath-label exit exitModfileCmd reportCmdTrace\
|
||||
reportCmdTrace reportWarning reportWarning reportError reportError\
|
||||
raiseErrorCount raiseErrorCount report report isWin initStateIsWin\
|
||||
puts putsModfileCmd readModuleContent readModuleContent]
|
||||
|
||||
if {[getConf source_cache]} {
|
||||
lappend ::g_modfileBaseAliases source sourceModfileCmd
|
||||
}
|
||||
|
||||
# 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 #42 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 }
|
||||
unique-name-conflict {unique-name-conflict nop nop 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__] source [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 and unique-name-conflict)
|
||||
} elseif {$mode eq {display} && $alias ni {source-sh\
|
||||
unique-name-conflict}} {
|
||||
set traces($alias) reportCmdTrace
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# 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
|
||||
proc skipUnloadIfSticky {mode modname modfile} {
|
||||
if {$mode ne {unload}} {
|
||||
return 0
|
||||
}
|
||||
|
||||
# when loaded, tags applies to mod name and version (not with variant)
|
||||
set is_supersticky_not_reloading [expr {[isModuleTagged $modname\
|
||||
super-sticky 1 $modfile] && [currentState reloading_supersticky] ne\
|
||||
$modname}]
|
||||
set is_sticky_not_reloading [expr {[isModuleTagged $modname sticky 1\
|
||||
$modfile] && [currentState reloading_sticky] ne $modname &&\
|
||||
[currentState unloading_sticky] ne $modname}]
|
||||
set sticky_purge [expr {[getState commandname] eq {purge} ? [getConf\
|
||||
sticky_purge] : {}}]
|
||||
|
||||
if {!$is_supersticky_not_reloading && $is_sticky_not_reloading &&\
|
||||
[getState force]} {
|
||||
reportWarning [getStickyForcedUnloadMsg]
|
||||
} elseif {$is_supersticky_not_reloading || $is_sticky_not_reloading} {
|
||||
# restore changed states prior raising error
|
||||
lpopState debug_msg_prefix
|
||||
lpopState modulepath
|
||||
lpopState specifiedname
|
||||
lpopState modulename
|
||||
lpopState modulenamevr
|
||||
lpopState modulefile
|
||||
|
||||
set msg [getStickyUnloadMsg [expr {$is_supersticky_not_reloading ?\
|
||||
{super-sticky} : {sticky}}]]
|
||||
# no message if sticky_purge is set to silent
|
||||
switch -- $sticky_purge {
|
||||
error - {} {knerror $msg}
|
||||
warning {reportWarning $msg}
|
||||
}
|
||||
|
||||
# skip unload without raised error
|
||||
return 1
|
||||
}
|
||||
|
||||
return 0
|
||||
}
|
||||
|
||||
proc execute-modulefile {modfile modname modnamevrvar modspec {up_namevr 1}\
|
||||
{fetch_tags 1} {modpath {}}} {
|
||||
# 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
|
||||
lappendState modulepath $modpath
|
||||
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\
|
||||
$modfile]} {
|
||||
reportWarning [getNearlyForbiddenMsg $modnamevr $modfile]
|
||||
set nearlyforbidwarn 1
|
||||
}
|
||||
|
||||
# fail unload when sticky
|
||||
if {[skipUnloadIfSticky $mode $modname $modfile]} {
|
||||
# skip end of unload upper level process when no error raised
|
||||
return -code continue 0
|
||||
}
|
||||
|
||||
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\
|
||||
{@MODULES_RELEASE@}]
|
||||
|
||||
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
|
||||
lassign [interp eval $itrp {
|
||||
set modcontent [readModuleContent $::ModulesCurrentModulefile 1]
|
||||
if {$modcontent eq {}} {
|
||||
return [list 2 {}]
|
||||
}
|
||||
info script $::ModulesCurrentModulefile
|
||||
# eval then call for specific proc depending mode under same catch
|
||||
set sourceFailed [catch {
|
||||
# raise conflict error if one name of currently loading module is
|
||||
# shared by an already loaded module
|
||||
unique-name-conflict
|
||||
|
||||
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]} {
|
||||
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]
|
||||
return [list $sourceFailed $errorMsg]
|
||||
}] sourceFailed errorMsg
|
||||
|
||||
set eval_return_code 0
|
||||
set report_proc reportError
|
||||
if {$sourceFailed} {
|
||||
# error obtained when reading modulefile, message has already been sent
|
||||
if {$sourceFailed == 2} {
|
||||
set eval_return_code 1
|
||||
# no error in case of "continue" command
|
||||
# catch continue even if called outside of a loop
|
||||
} elseif {$errorMsg eq {invoked "continue" outside of a loop} ||\
|
||||
$sourceFailed == 4} {
|
||||
# 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 {} && [getInterpVar $itrp ::errorInfo] eq {}) ||\
|
||||
(![isInterpVarDefined $itrp ::errorCode] && $sourceFailed == 3)} {
|
||||
# report load/unload/refresh evaluation break if verbosity level
|
||||
# >= normal, no error count raise during scan evaluation
|
||||
if {$mode in {load unload refresh} && [isVerbosityLevel normal]} {
|
||||
set msg_to_report {Module evaluation aborted}
|
||||
} elseif {$mode ne {scan}} {
|
||||
set raise_error_count 1
|
||||
}
|
||||
set eval_return_code 1
|
||||
} elseif {[getInterpVar $itrp errorCode] eq {MODULES_ERR_SUBFAILED}} {
|
||||
# error counter and message already handled, just return err code
|
||||
set eval_return_code 1
|
||||
} elseif {[getInterpVar $itrp errorCode] eq {MODULES_ERR_GLOBAL}} {
|
||||
set msg_to_report $errorMsg
|
||||
set eval_return_code 1
|
||||
} else {
|
||||
set msg_to_report [formatInterpErrStackTrace $itrp $modfile]
|
||||
set report_proc reportInternalBug
|
||||
set eval_return_code 1
|
||||
}
|
||||
}
|
||||
|
||||
if {[info exists msg_to_report]} {
|
||||
$report_proc $msg_to_report
|
||||
} elseif {[info exists raise_error_count]} {
|
||||
raiseErrorCount
|
||||
}
|
||||
|
||||
# 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 $modfile]
|
||||
set modnamevr_extratag_list [getExtraTagList $modnamevr]
|
||||
lassign [parseModuleSpecification 0 0 0 0 {*}$newmodnamevr] modnamevr
|
||||
# $up_namevr is only enabled when $fetch_tags is also enabled
|
||||
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 $modfile]} {
|
||||
set eval_return_code 1
|
||||
reportError [getForbiddenMsg $modnamevr $modfile]
|
||||
} elseif {![info exists nearlyforbidwarn] && [isModuleTagged $modnamevr\
|
||||
nearly-forbidden 1 $modfile]} {
|
||||
reportWarning [getNearlyForbiddenMsg $modnamevr $modfile]
|
||||
}
|
||||
}
|
||||
|
||||
reportDebug "exiting $modfile"
|
||||
lpopState debug_msg_prefix
|
||||
lpopState modulepath
|
||||
lpopState specifiedname
|
||||
lpopState modulename
|
||||
lpopState modulenamevr
|
||||
lpopState modulefile
|
||||
|
||||
return $eval_return_code
|
||||
}
|
||||
|
||||
# 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 modulepath-label\
|
||||
modulepath-label setModulesVersion setModulesVersion\
|
||||
readModuleContent readModuleContent]
|
||||
|
||||
if {[getConf source_cache]} {
|
||||
set ::g_modrcAliases(source) sourceModfileCmd
|
||||
}
|
||||
|
||||
# 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 source [list __itrp__]]
|
||||
|
||||
# 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\
|
||||
{@MODULES_RELEASE@}]
|
||||
|
||||
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 eval_return_code [interp eval $itrp {
|
||||
set modcontent [readModuleContent $::ModulesCurrentModulefile]
|
||||
if {$modcontent eq {}} {
|
||||
# simply skip rc file, no exit on error here
|
||||
return 2
|
||||
}
|
||||
info script $::ModulesCurrentModulefile
|
||||
if [catch {eval $modcontent} errorMsg] {
|
||||
return 1
|
||||
} else {
|
||||
# pass ModulesVersion value to main interp
|
||||
if {[info exists ::ModulesVersion]} {
|
||||
setModulesVersion $::ModulesVersion
|
||||
}
|
||||
return 0
|
||||
}
|
||||
}]
|
||||
|
||||
if {$eval_return_code == 1} {
|
||||
reportInternalBug [formatInterpErrStackTrace $itrp $modfile]
|
||||
}
|
||||
|
||||
# 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
|
||||
}
|
||||
|
||||
proc isInterpVarDefined {itrp var_name} {
|
||||
return [interp eval $itrp info exists $var_name]
|
||||
}
|
||||
|
||||
proc getInterpVar {itrp var_name {val_if_unset {}}} {
|
||||
if {[isInterpVarDefined $itrp $var_name]} {
|
||||
return [interp eval $itrp set $var_name]
|
||||
} else {
|
||||
return $val_if_unset
|
||||
}
|
||||
}
|
||||
|
||||
# format error stack trace to report modulefile information only
|
||||
proc formatInterpErrStackTrace {itrp modfile} {
|
||||
return [formatErrStackTrace [getInterpVar $itrp ::errorInfo] $modfile\
|
||||
[concat [interp eval $itrp info procs] [interp eval $itrp info\
|
||||
commands]]]
|
||||
}
|
||||
|
||||
# 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)]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ;;; Local Variables: ***
|
||||
# ;;; mode:tcl ***
|
||||
# ;;; End: ***
|
||||
# vim:set tabstop=3 shiftwidth=3 expandtab autoindent:
|
||||
@@ -1,6 +1,6 @@
|
||||
##########################################################################
|
||||
|
||||
# MFINTERP.TCL, modulefile interpretation procedures
|
||||
# MFCMD.TCL, modulefile command procedures
|
||||
# Copyright (C) 2002-2004 Mark Lakata
|
||||
# Copyright (C) 2004-2017 Kent Mein
|
||||
# Copyright (C) 2016-2023 Xavier Delaruelle
|
||||
@@ -20,827 +20,6 @@
|
||||
|
||||
##########################################################################
|
||||
|
||||
#
|
||||
# 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]]} {
|
||||
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\
|
||||
modulepath-label modulepath-label exit exitModfileCmd reportCmdTrace\
|
||||
reportCmdTrace reportWarning reportWarning reportError reportError\
|
||||
raiseErrorCount raiseErrorCount report report isWin initStateIsWin\
|
||||
puts putsModfileCmd readModuleContent readModuleContent]
|
||||
|
||||
if {[getConf source_cache]} {
|
||||
lappend ::g_modfileBaseAliases source sourceModfileCmd
|
||||
}
|
||||
|
||||
# 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 #42 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 }
|
||||
unique-name-conflict {unique-name-conflict nop nop 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__] source [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 and unique-name-conflict)
|
||||
} elseif {$mode eq {display} && $alias ni {source-sh\
|
||||
unique-name-conflict}} {
|
||||
set traces($alias) reportCmdTrace
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# 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
|
||||
proc skipUnloadIfSticky {mode modname modfile} {
|
||||
if {$mode ne {unload}} {
|
||||
return 0
|
||||
}
|
||||
|
||||
# when loaded, tags applies to mod name and version (not with variant)
|
||||
set is_supersticky_not_reloading [expr {[isModuleTagged $modname\
|
||||
super-sticky 1 $modfile] && [currentState reloading_supersticky] ne\
|
||||
$modname}]
|
||||
set is_sticky_not_reloading [expr {[isModuleTagged $modname sticky 1\
|
||||
$modfile] && [currentState reloading_sticky] ne $modname &&\
|
||||
[currentState unloading_sticky] ne $modname}]
|
||||
set sticky_purge [expr {[getState commandname] eq {purge} ? [getConf\
|
||||
sticky_purge] : {}}]
|
||||
|
||||
if {!$is_supersticky_not_reloading && $is_sticky_not_reloading &&\
|
||||
[getState force]} {
|
||||
reportWarning [getStickyForcedUnloadMsg]
|
||||
} elseif {$is_supersticky_not_reloading || $is_sticky_not_reloading} {
|
||||
# restore changed states prior raising error
|
||||
lpopState debug_msg_prefix
|
||||
lpopState modulepath
|
||||
lpopState specifiedname
|
||||
lpopState modulename
|
||||
lpopState modulenamevr
|
||||
lpopState modulefile
|
||||
|
||||
set msg [getStickyUnloadMsg [expr {$is_supersticky_not_reloading ?\
|
||||
{super-sticky} : {sticky}}]]
|
||||
# no message if sticky_purge is set to silent
|
||||
switch -- $sticky_purge {
|
||||
error - {} {knerror $msg}
|
||||
warning {reportWarning $msg}
|
||||
}
|
||||
|
||||
# skip unload without raised error
|
||||
return 1
|
||||
}
|
||||
|
||||
return 0
|
||||
}
|
||||
|
||||
proc execute-modulefile {modfile modname modnamevrvar modspec {up_namevr 1}\
|
||||
{fetch_tags 1} {modpath {}}} {
|
||||
# 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
|
||||
lappendState modulepath $modpath
|
||||
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\
|
||||
$modfile]} {
|
||||
reportWarning [getNearlyForbiddenMsg $modnamevr $modfile]
|
||||
set nearlyforbidwarn 1
|
||||
}
|
||||
|
||||
# fail unload when sticky
|
||||
if {[skipUnloadIfSticky $mode $modname $modfile]} {
|
||||
# skip end of unload upper level process when no error raised
|
||||
return -code continue 0
|
||||
}
|
||||
|
||||
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\
|
||||
{@MODULES_RELEASE@}]
|
||||
|
||||
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
|
||||
lassign [interp eval $itrp {
|
||||
set modcontent [readModuleContent $::ModulesCurrentModulefile 1]
|
||||
if {$modcontent eq {}} {
|
||||
return [list 2 {}]
|
||||
}
|
||||
info script $::ModulesCurrentModulefile
|
||||
# eval then call for specific proc depending mode under same catch
|
||||
set sourceFailed [catch {
|
||||
# raise conflict error if one name of currently loading module is
|
||||
# shared by an already loaded module
|
||||
unique-name-conflict
|
||||
|
||||
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]} {
|
||||
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]
|
||||
return [list $sourceFailed $errorMsg]
|
||||
}] sourceFailed errorMsg
|
||||
|
||||
set eval_return_code 0
|
||||
set report_proc reportError
|
||||
if {$sourceFailed} {
|
||||
# error obtained when reading modulefile, message has already been sent
|
||||
if {$sourceFailed == 2} {
|
||||
set eval_return_code 1
|
||||
# no error in case of "continue" command
|
||||
# catch continue even if called outside of a loop
|
||||
} elseif {$errorMsg eq {invoked "continue" outside of a loop} ||\
|
||||
$sourceFailed == 4} {
|
||||
# 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 {} && [getInterpVar $itrp ::errorInfo] eq {}) ||\
|
||||
(![isInterpVarDefined $itrp ::errorCode] && $sourceFailed == 3)} {
|
||||
# report load/unload/refresh evaluation break if verbosity level
|
||||
# >= normal, no error count raise during scan evaluation
|
||||
if {$mode in {load unload refresh} && [isVerbosityLevel normal]} {
|
||||
set msg_to_report {Module evaluation aborted}
|
||||
} elseif {$mode ne {scan}} {
|
||||
set raise_error_count 1
|
||||
}
|
||||
set eval_return_code 1
|
||||
} elseif {[getInterpVar $itrp errorCode] eq {MODULES_ERR_SUBFAILED}} {
|
||||
# error counter and message already handled, just return err code
|
||||
set eval_return_code 1
|
||||
} elseif {[getInterpVar $itrp errorCode] eq {MODULES_ERR_GLOBAL}} {
|
||||
set msg_to_report $errorMsg
|
||||
set eval_return_code 1
|
||||
} else {
|
||||
set msg_to_report [formatInterpErrStackTrace $itrp $modfile]
|
||||
set report_proc reportInternalBug
|
||||
set eval_return_code 1
|
||||
}
|
||||
}
|
||||
|
||||
if {[info exists msg_to_report]} {
|
||||
$report_proc $msg_to_report
|
||||
} elseif {[info exists raise_error_count]} {
|
||||
raiseErrorCount
|
||||
}
|
||||
|
||||
# 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 $modfile]
|
||||
set modnamevr_extratag_list [getExtraTagList $modnamevr]
|
||||
lassign [parseModuleSpecification 0 0 0 0 {*}$newmodnamevr] modnamevr
|
||||
# $up_namevr is only enabled when $fetch_tags is also enabled
|
||||
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 $modfile]} {
|
||||
set eval_return_code 1
|
||||
reportError [getForbiddenMsg $modnamevr $modfile]
|
||||
} elseif {![info exists nearlyforbidwarn] && [isModuleTagged $modnamevr\
|
||||
nearly-forbidden 1 $modfile]} {
|
||||
reportWarning [getNearlyForbiddenMsg $modnamevr $modfile]
|
||||
}
|
||||
}
|
||||
|
||||
reportDebug "exiting $modfile"
|
||||
lpopState debug_msg_prefix
|
||||
lpopState modulepath
|
||||
lpopState specifiedname
|
||||
lpopState modulename
|
||||
lpopState modulenamevr
|
||||
lpopState modulefile
|
||||
|
||||
return $eval_return_code
|
||||
}
|
||||
|
||||
# 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 modulepath-label\
|
||||
modulepath-label setModulesVersion setModulesVersion\
|
||||
readModuleContent readModuleContent]
|
||||
|
||||
if {[getConf source_cache]} {
|
||||
set ::g_modrcAliases(source) sourceModfileCmd
|
||||
}
|
||||
|
||||
# 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 source [list __itrp__]]
|
||||
|
||||
# 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\
|
||||
{@MODULES_RELEASE@}]
|
||||
|
||||
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 eval_return_code [interp eval $itrp {
|
||||
set modcontent [readModuleContent $::ModulesCurrentModulefile]
|
||||
if {$modcontent eq {}} {
|
||||
# simply skip rc file, no exit on error here
|
||||
return 2
|
||||
}
|
||||
info script $::ModulesCurrentModulefile
|
||||
if [catch {eval $modcontent} errorMsg] {
|
||||
return 1
|
||||
} else {
|
||||
# pass ModulesVersion value to main interp
|
||||
if {[info exists ::ModulesVersion]} {
|
||||
setModulesVersion $::ModulesVersion
|
||||
}
|
||||
return 0
|
||||
}
|
||||
}]
|
||||
|
||||
if {$eval_return_code == 1} {
|
||||
reportInternalBug [formatInterpErrStackTrace $itrp $modfile]
|
||||
}
|
||||
|
||||
# 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
|
||||
}
|
||||
|
||||
proc isInterpVarDefined {itrp var_name} {
|
||||
return [interp eval $itrp info exists $var_name]
|
||||
}
|
||||
|
||||
proc getInterpVar {itrp var_name {val_if_unset {}}} {
|
||||
if {[isInterpVarDefined $itrp $var_name]} {
|
||||
return [interp eval $itrp set $var_name]
|
||||
} else {
|
||||
return $val_if_unset
|
||||
}
|
||||
}
|
||||
|
||||
# format error stack trace to report modulefile information only
|
||||
proc formatInterpErrStackTrace {itrp modfile} {
|
||||
return [formatErrStackTrace [getInterpVar $itrp ::errorInfo] $modfile\
|
||||
[concat [interp eval $itrp info procs] [interp eval $itrp info\
|
||||
commands]]]
|
||||
}
|
||||
|
||||
# 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
|
||||
Reference in New Issue
Block a user