diff --git a/.gitignore b/.gitignore index 4631a207..257bbd4e 100644 --- a/.gitignore +++ b/.gitignore @@ -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 diff --git a/Makefile b/Makefile index 19a74d48..275e933f 100644 --- a/Makefile +++ b/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 \ diff --git a/tcl/interp.tcl.in b/tcl/interp.tcl.in new file mode 100644 index 00000000..05f621b6 --- /dev/null +++ b/tcl/interp.tcl.in @@ -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 . + +########################################################################## + +# 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: diff --git a/tcl/mfinterp.tcl.in b/tcl/mfcmd.tcl similarity index 66% rename from tcl/mfinterp.tcl.in rename to tcl/mfcmd.tcl index d2e43daa..322db56d 100644 --- a/tcl/mfinterp.tcl.in +++ b/tcl/mfcmd.tcl @@ -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