mirror of
https://github.com/envmodules/modules.git
synced 2026-06-10 00:56:30 +08:00
9dcc70165b
Add the ability to always record module name + version even if this version corresponds to the default one. By default, version number is omitted if it corresponds to the implicit or explicitly set default version. If MODULES_COLLECTION_PIN_VERSION environment variable is set to 1, version number is always recorded. When restoring a collection, we do not know for sure if it was saved with pinned versions or not, so module load and unload movements are determined on both simplified or raw module list. Results with less module to load or unload (means with more matches between module lists) are kept. Acknowledgment: this development has been made and funded within the framework of the PRACE Fifth Implementation Phase (PRACE-5IP) project (http://www.prace-ri.eu/). PRACE-5IP receives funding from the EU's Horizon 2020 research and innovation programme (2014-2020) under grant agreement no. 730913. Closes #89
6112 lines
193 KiB
Tcl
Executable File
6112 lines
193 KiB
Tcl
Executable File
#!@TCLSHDIR@/tclsh
|
|
#
|
|
# MODULECMD.TCL, a pure TCL implementation of the module command
|
|
# Copyright (C) 2002-2004 Mark Lakata
|
|
# Copyright (C) 2004-2017 Kent Mein
|
|
# Copyright (C) 2016-2017 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/>.
|
|
|
|
##########################################################################
|
|
|
|
#
|
|
# Some Global Variables.....
|
|
#
|
|
set g_debug 0 ;# Set to 1 to enable debugging
|
|
set error_count 0 ;# Start with 0 errors
|
|
set g_return_false 0 ;# False value is rendered if == 1
|
|
set g_autoInit 0
|
|
set g_inhibit_interp 0 ;# Modulefile interpretation disabled if == 1
|
|
set g_inhibit_errreport 0 ;# Non-critical error reporting disabled if == 1
|
|
set g_inhibit_dispreport 0 ;# Display-mode reporting disabled if == 1
|
|
set g_force 0 ;# Path element reference counting if == 0
|
|
set CSH_LIMIT 4000 ;# Workaround for commandline limits in csh
|
|
set flag_default_dir 1 ;# Report default directories
|
|
set flag_default_mf 1 ;# Report default modulefiles and version alias
|
|
set reportfd "stderr" ;# File descriptor to use to report messages
|
|
|
|
set g_pager "@pager@" ;# Default command to page into, empty=disable
|
|
set g_pager_opts "@pageropts@" ;# Options to pass to the pager command
|
|
|
|
# Used to tell if a machine is running Windows or not
|
|
proc isWin {} {
|
|
global tcl_platform
|
|
|
|
if { $tcl_platform(platform) eq "windows" } {
|
|
return 1
|
|
} else {
|
|
return 0
|
|
}
|
|
}
|
|
|
|
#
|
|
# Set Default Path separator
|
|
#
|
|
if { [isWin] } {
|
|
set g_def_separator "\;"
|
|
} else {
|
|
set g_def_separator ":"
|
|
}
|
|
|
|
# Detect if terminal is attached to stderr message channel
|
|
proc isStderrTty {} {
|
|
global g_is_stderr_tty
|
|
|
|
if {![info exists g_is_stderr_tty]} {
|
|
set g_is_stderr_tty [expr {![catch {fconfigure stderr -mode}]}]
|
|
}
|
|
|
|
return $g_is_stderr_tty
|
|
}
|
|
|
|
# Provide columns number for output formatting
|
|
proc getTtyColumns {} {
|
|
global g_tty_columns
|
|
|
|
if {![info exists g_tty_columns]} {
|
|
# determine col number from tty capabilites
|
|
if {[catch {exec stty size} stty_size] == 0 && $stty_size ne ""} {
|
|
set g_tty_columns [lindex $stty_size 1]
|
|
} else {
|
|
# default size if tty cols cannot be found
|
|
set g_tty_columns 80
|
|
}
|
|
}
|
|
|
|
return $g_tty_columns
|
|
}
|
|
|
|
# Use MODULECONTACT variable to set your support email address
|
|
if {[info exists env(MODULECONTACT)]} {
|
|
set contact $env(MODULECONTACT)
|
|
} else {
|
|
# Or change this to your support email address...
|
|
set contact "root@localhost"
|
|
}
|
|
|
|
# Set some directories to ignore when looking for modules.
|
|
set ignoreDir(CVS) 1
|
|
set ignoreDir(RCS) 1
|
|
set ignoreDir(SCCS) 1
|
|
set ignoreDir(.svn) 1
|
|
set ignoreDir(.git) 1
|
|
|
|
global g_shellType
|
|
global g_shell
|
|
|
|
set show_oneperline 0 ;# Gets set if you do module list/avail -t
|
|
set show_modtimes 0 ;# Gets set if you do module list/avail -l
|
|
set show_filter "" ;# Gets set if you do module avail -d or -L
|
|
|
|
proc raiseErrorCount {} {
|
|
global error_count
|
|
incr error_count
|
|
}
|
|
|
|
proc renderFalse {} {
|
|
global g_shellType g_false_rendered
|
|
|
|
reportDebug "renderFalse: called."
|
|
|
|
if {[info exists g_false_rendered]} {
|
|
reportDebug "renderFalse: false already rendered"
|
|
} elseif {[info exists g_shellType]} {
|
|
# setup flag to render only once
|
|
set g_false_rendered 1
|
|
|
|
# render a false value most of the time through a variable assignement
|
|
# that will be looked at in the shell module function calling
|
|
# modulecmd.tcl to return in turns a boolean status. Except for python
|
|
# and cmake, the value assigned to variable is also returned as the
|
|
# entire rendering status
|
|
switch -- $g_shellType {
|
|
{sh} - {csh} - {fish} {
|
|
# no need to set a variable on real shells as last statement
|
|
# result can easily be checked
|
|
puts stdout "test 0 = 1;"
|
|
}
|
|
{tcl} {
|
|
puts stdout "set _mlstatus 0;"
|
|
}
|
|
{cmd} {
|
|
# nothing needed, reserved for future cygwin, MKS, etc
|
|
}
|
|
{perl} {
|
|
puts stdout "\$_mlstatus = 0;"
|
|
}
|
|
{python} {
|
|
puts stdout "_mlstatus = False"
|
|
}
|
|
{ruby} {
|
|
puts stdout "_mlstatus = false"
|
|
}
|
|
{lisp} {
|
|
puts stdout "nil"
|
|
}
|
|
{cmake} {
|
|
puts stdout "set(_mlstatus FALSE)"
|
|
}
|
|
{r} {
|
|
puts stdout "mlstatus <- FALSE"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc renderTrue {} {
|
|
global g_shellType
|
|
|
|
reportDebug "renderTrue: called."
|
|
|
|
# render a true value most of the time through a variable assignement that
|
|
# will be looked at in the shell module function calling modulecmd.tcl to
|
|
# return in turns a boolean status. Except for python and cmake, the
|
|
# value assigned to variable is also returned as the full rendering status
|
|
switch -- $g_shellType {
|
|
{sh} - {csh} - {fish} {
|
|
# no need to set a variable on real shells as last statement
|
|
# result can easily be checked
|
|
puts stdout "test 0;"
|
|
}
|
|
{tcl} {
|
|
puts stdout "set _mlstatus 1;"
|
|
}
|
|
{perl} {
|
|
puts stdout "\$_mlstatus = 1;"
|
|
}
|
|
{python} {
|
|
puts stdout "_mlstatus = True"
|
|
}
|
|
{ruby} {
|
|
puts stdout "_mlstatus = true"
|
|
}
|
|
{lisp} {
|
|
puts stdout "t"
|
|
}
|
|
{cmake} {
|
|
puts stdout "set(_mlstatus TRUE)"
|
|
}
|
|
{r} {
|
|
puts stdout "mlstatus <- TRUE"
|
|
}
|
|
}
|
|
}
|
|
|
|
proc renderText {text} {
|
|
global g_shellType
|
|
|
|
reportDebug "renderText: called ($text)."
|
|
|
|
# render a text value most of the time through a variable assignement that
|
|
# will be looked at in the shell module function calling modulecmd.tcl to
|
|
# return in turns a string value.
|
|
switch -- $g_shellType {
|
|
{sh} - {csh} - {fish} {
|
|
foreach word $text {
|
|
# no need to set a variable on real shells, echoing text will make
|
|
# it available as result
|
|
puts stdout "echo '$word';"
|
|
}
|
|
}
|
|
{tcl} {
|
|
puts stdout "set _mlstatus \"$text\";"
|
|
}
|
|
{perl} {
|
|
puts stdout "\$_mlstatus = '$text';"
|
|
}
|
|
{python} {
|
|
puts stdout "_mlstatus = '$text'"
|
|
}
|
|
{ruby} {
|
|
puts stdout "_mlstatus = '$text'"
|
|
}
|
|
{lisp} {
|
|
puts stdout "(message \"$text\")"
|
|
}
|
|
{cmake} {
|
|
puts stdout "set(_mlstatus \"$text\")"
|
|
}
|
|
{r} {
|
|
puts stdout "mlstatus <- '$text'"
|
|
}
|
|
}
|
|
}
|
|
|
|
#
|
|
# Debug, Info, Warnings and Error message handling.
|
|
#
|
|
proc reportDebug {message {nonewline ""}} {
|
|
global g_debug
|
|
|
|
if {$g_debug} {
|
|
report "DEBUG $message" "$nonewline"
|
|
}
|
|
}
|
|
|
|
proc reportWarning {message {nonewline ""}} {
|
|
global g_inhibit_errreport
|
|
|
|
if {!$g_inhibit_errreport} {
|
|
report "WARNING: $message" "$nonewline"
|
|
}
|
|
}
|
|
|
|
proc reportError {message {nonewline ""}} {
|
|
global g_inhibit_errreport
|
|
|
|
# if report disabled, also disable error raise to get a coherent
|
|
# behavior (if no message printed, no error code change)
|
|
if {!$g_inhibit_errreport} {
|
|
raiseErrorCount
|
|
report "ERROR: $message" "$nonewline"
|
|
}
|
|
}
|
|
|
|
proc reportErrorAndExit {message} {
|
|
raiseErrorCount
|
|
renderFalse
|
|
error "$message"
|
|
}
|
|
|
|
proc reportInternalBug {message modfile} {
|
|
global contact g_inhibit_errreport
|
|
|
|
# if report disabled, also disable error raise to get a coherent
|
|
# behavior (if no message printed, no error code change)
|
|
if {!$g_inhibit_errreport} {
|
|
raiseErrorCount
|
|
report "Module ERROR: $message\n In '$modfile'\n Please contact\
|
|
<$contact>"
|
|
}
|
|
}
|
|
|
|
proc report {message {nonewline ""}} {
|
|
global has_yet_report reportfd
|
|
|
|
# first message report, initialize
|
|
if {![info exists has_yet_report]} {
|
|
set has_yet_report 1
|
|
# setup message paging if enabled
|
|
initPager
|
|
}
|
|
|
|
# protect from issue with fd, just ignore it
|
|
catch {
|
|
if {$nonewline ne ""} {
|
|
puts -nonewline $reportfd "$message"
|
|
} else {
|
|
puts $reportfd "$message"
|
|
}
|
|
}
|
|
}
|
|
|
|
# report error the correct way depending of its type
|
|
proc reportIssue {issuetype issuemsg {issuefile {}}} {
|
|
switch -- $issuetype {
|
|
{invalid} {
|
|
reportInternalBug $issuemsg $issuefile
|
|
}
|
|
default {
|
|
reportError $issuemsg
|
|
}
|
|
}
|
|
}
|
|
|
|
proc reportVersion {} {
|
|
report "Modules Release @MODULES_RELEASE@@MODULES_BUILD@\
|
|
(@MODULES_BUILD_DATE@)"
|
|
}
|
|
|
|
# disable error reporting (non-critical report only) unless debug enabled
|
|
proc inhibitErrorReport {} {
|
|
global g_inhibit_errreport g_debug
|
|
|
|
if {!$g_debug} {
|
|
set g_inhibit_errreport 1
|
|
}
|
|
}
|
|
|
|
proc reenableErrorReport {} {
|
|
global g_inhibit_errreport
|
|
|
|
set g_inhibit_errreport 0
|
|
}
|
|
|
|
proc isErrorReportInhibited {} {
|
|
global g_inhibit_errreport
|
|
|
|
return $g_inhibit_errreport
|
|
}
|
|
|
|
# exit in a clean manner by closing interaction with external components
|
|
proc cleanupAndExit {code} {
|
|
global reportfd
|
|
|
|
# close pager if enabled
|
|
if {$reportfd ne "stderr"} {
|
|
catch {flush $reportfd}
|
|
catch {close $reportfd}
|
|
}
|
|
|
|
exit $code
|
|
}
|
|
|
|
# init configuration for output paging then start paging if enabled
|
|
proc initPager {} {
|
|
global env g_pager g_pager_opts asked_pager
|
|
global argdebugmsgs argwarnmsgs reportfd
|
|
|
|
# default pager enablement depends of pager command value
|
|
if {$g_pager eq "" || [file tail $g_pager] eq "cat"} {
|
|
set use_pager 0
|
|
set init_use_pager 0
|
|
} else {
|
|
set use_pager 1
|
|
set init_use_pager 1
|
|
}
|
|
|
|
if {[file tail $g_pager] eq "less" && $g_pager_opts ne "" &&\
|
|
[info exists env(LESS)]} {
|
|
lappend argdebugmsgs "initPager: clear 'less' pager options as LESS\
|
|
variable defined"
|
|
set g_pager_opts ""
|
|
}
|
|
|
|
foreach var [list MODULES_PAGER PAGER] {
|
|
if {[info exists env($var)]} {
|
|
if {$env($var) ne ""} {
|
|
# MODULES_PAGER env variable set means pager should be enabled
|
|
if {!$use_pager && $var eq "MODULES_PAGER"} {
|
|
set use_pager 1
|
|
}
|
|
# fetch pager command and option
|
|
set g_pager [lindex $env($var) 0]
|
|
set g_pager_opts [lrange $env($var) 1 end]
|
|
|
|
# variable defined empty means no-pager
|
|
} else {
|
|
set use_pager 0
|
|
set g_pager ""
|
|
set g_pager_opts ""
|
|
}
|
|
|
|
lappend argdebugmsgs "initPager: configure pager from $var variable\
|
|
(use_pager=$use_pager, cmd='$g_pager', opts='$g_pager_opts')"
|
|
|
|
# if MODULES_PAGER set, no look at PAGER
|
|
break
|
|
}
|
|
}
|
|
|
|
# paging may have been enabled or disabled from the command-line
|
|
if {[info exists asked_pager]} {
|
|
# enable from command-line only if it is enabled in script config
|
|
if {$asked_pager && !$use_pager && $init_use_pager} {
|
|
set use_pager 1
|
|
} elseif {!$asked_pager && $use_pager} {
|
|
set use_pager 0
|
|
}
|
|
set asked $asked_pager
|
|
} else {
|
|
set asked "-"
|
|
}
|
|
|
|
# empty or 'cat' pager command means no-pager
|
|
if {$use_pager && ($g_pager eq "" || [file tail $g_pager] eq "cat")} {
|
|
set use_pager 0
|
|
}
|
|
|
|
# setup paging if enabled and if error stream is attached to a terminal
|
|
set is_tty [isStderrTty]
|
|
if {$is_tty && $use_pager} {
|
|
lappend argdebugmsgs "initPager: start pager (asked_pager=$asked,\
|
|
cmd='$g_pager', opts='$g_pager_opts')"
|
|
if {[catch {
|
|
set reportfd [open "|$g_pager $g_pager_opts >@stderr 2>@stderr" w]
|
|
fconfigure $reportfd -buffering line -blocking 1 -buffersize 65536
|
|
} errMsg]} {
|
|
lappend argwarnmsgs $errMsg
|
|
}
|
|
} else {
|
|
lappend argdebugmsgs "initPager: no pager start (is_tty=$is_tty,\
|
|
use_pager=$use_pager, asked_pager=$asked, cmd='$g_pager',\
|
|
opts='$g_pager_opts')"
|
|
}
|
|
}
|
|
|
|
########################################################################
|
|
# Use a slave TCL interpreter to execute modulefiles
|
|
#
|
|
|
|
proc unset-env {var} {
|
|
global env
|
|
|
|
if {[info exists env($var)]} {
|
|
reportDebug "unset-env: $var"
|
|
unset env($var)
|
|
}
|
|
}
|
|
|
|
proc execute-modulefile {modfile {must_have_cookie 1}} {
|
|
global g_debug g_inhibit_interp g_inhibit_errreport g_inhibit_dispreport
|
|
global ModulesCurrentModulefile
|
|
global g_modfileUntrackVars g_modfileAliases
|
|
|
|
set ModulesCurrentModulefile $modfile
|
|
|
|
# skip modulefile if interpretation has been inhibited
|
|
if {$g_inhibit_interp} {
|
|
reportDebug "execute-modulefile: Skipping $modfile"
|
|
return 1
|
|
}
|
|
|
|
reportDebug "execute-modulefile: Starting $modfile"
|
|
|
|
if {![info exists g_modfileUntrackVars]} {
|
|
# list variable that should not be tracked for saving
|
|
array set g_modfileUntrackVars [list g_debug 1 g_inhibit_interp 1\
|
|
g_inhibit_errreport 1 g_inhibit_dispreport 1\
|
|
ModulesCurrentModulefile 1 must_have_cookie 1 modcontent 1 env 1]
|
|
|
|
# list interpreter alias commands to define
|
|
array set g_modfileAliases [list setenv setenv unsetenv unsetenv getenv\
|
|
getenv system system chdir chdir append-path append-path\
|
|
prepend-path prepend-path remove-path remove-path prereq prereq\
|
|
conflict conflict is-loaded is-loaded is-saved is-saved is-used\
|
|
is-used is-avail is-avail module module module-info\
|
|
module-info module-whatis module-whatis set-alias set-alias\
|
|
unset-alias unset-alias uname uname x-resource x-resource exit\
|
|
exitModfileCmd module-version module-version module-alias\
|
|
module-alias module-trace module-trace module-verbosity\
|
|
module-verbosity module-user module-user module-log module-log\
|
|
reportInternalBug reportInternalBug reportWarning reportWarning\
|
|
reportError reportError raiseErrorCount raiseErrorCount report\
|
|
report isWin isWin puts putsModfileCmd readModuleContent\
|
|
readModuleContent]
|
|
}
|
|
|
|
# dedicate an interpreter per level of interpretation to have in case of
|
|
# cascaded interpretations a specific interpreter per level
|
|
set itrp "__modfile[info level]"
|
|
|
|
# create modulefile interpreter at first interpretation
|
|
if {![interp exists $itrp]} {
|
|
interp create $itrp
|
|
|
|
# dump initial interpreter state to restore it before each modulefile
|
|
# interpreation
|
|
dumpInterpState $itrp g_modfileVars g_modfileArrayVars\
|
|
g_modfileUntrackVars g_modfileProcs
|
|
}
|
|
|
|
# reset interp state command before each interpretation
|
|
resetInterpState $itrp g_modfileVars g_modfileArrayVars\
|
|
g_modfileUntrackVars g_modfileProcs g_modfileAliases g_modfileCommands
|
|
|
|
# reset modulefile-specific variable before each interpretation
|
|
interp eval $itrp {global ModulesCurrentModulefile g_debug\
|
|
g_inhibit_interp g_inhibit_errreport g_inhibit_dispreport}
|
|
interp eval $itrp set ModulesCurrentModulefile $modfile
|
|
interp eval $itrp set g_debug $g_debug
|
|
interp eval $itrp set g_inhibit_interp $g_inhibit_interp
|
|
interp eval $itrp set g_inhibit_errreport $g_inhibit_errreport
|
|
interp eval $itrp set g_inhibit_dispreport $g_inhibit_dispreport
|
|
interp eval $itrp set must_have_cookie $must_have_cookie
|
|
|
|
set errorVal [interp eval $itrp {
|
|
set modcontent [readModuleContent $ModulesCurrentModulefile 1\
|
|
$must_have_cookie]
|
|
if {$modcontent eq ""} {
|
|
return 1
|
|
}
|
|
info script $ModulesCurrentModulefile
|
|
# eval then call for specific proc depending mode under same catch
|
|
set sourceFailed [catch {
|
|
eval $modcontent
|
|
switch -- [module-info mode] {
|
|
{help} {
|
|
if {[info procs "ModulesHelp"] eq "ModulesHelp"} {
|
|
ModulesHelp
|
|
} else {
|
|
reportWarning "Unable to find ModulesHelp in\
|
|
$ModulesCurrentModulefile."
|
|
}
|
|
}
|
|
{display} {
|
|
if {[info procs "ModulesDisplay"] eq "ModulesDisplay"} {
|
|
ModulesDisplay
|
|
}
|
|
}
|
|
{test} {
|
|
if {[info procs "ModulesTest"] eq "ModulesTest"} {
|
|
if {[string is true -strict [ModulesTest]]} {
|
|
report "Test result: PASS"
|
|
} else {
|
|
report "Test result: FAIL"
|
|
raiseErrorCount
|
|
}
|
|
} else {
|
|
reportWarning "Unable to find ModulesTest in\
|
|
$ModulesCurrentModulefile."
|
|
}
|
|
}
|
|
}
|
|
} errorMsg]
|
|
if {$sourceFailed} {
|
|
global errorInfo
|
|
# no error in case of "continue" command
|
|
# catch continue even if called outside of a loop
|
|
if {$errorMsg eq "invoked \"continue\" outside of a loop"\
|
|
|| $sourceFailed == 4} {
|
|
unset errorMsg
|
|
return 0
|
|
# catch break even if called outside of a loop
|
|
} elseif {$errorMsg eq "invoked \"break\" outside of a loop"\
|
|
|| ($errorMsg eq "" && (![info exists errorInfo]\
|
|
|| $errorInfo eq ""))} {
|
|
raiseErrorCount
|
|
unset errorMsg
|
|
return 1
|
|
} elseif {$errorMsg eq "SUB_FAILED"} {
|
|
# error counter and message already handled, just return error
|
|
return 1
|
|
} elseif [regexp "^WARNING" $errorMsg] {
|
|
raiseErrorCount
|
|
report $errorMsg
|
|
return 1
|
|
} else {
|
|
reportInternalBug $errorMsg $ModulesCurrentModulefile
|
|
return 1
|
|
}
|
|
} else {
|
|
unset errorMsg
|
|
return 0
|
|
}
|
|
}]
|
|
|
|
reportDebug "Exiting $modfile"
|
|
return $errorVal
|
|
}
|
|
|
|
# Smaller subset than main module load... This function runs modulerc and
|
|
# .version files
|
|
proc execute-modulerc {modfile} {
|
|
global g_rcfilesSourced ModulesVersion
|
|
global g_debug g_inhibit_errreport g_inhibit_dispreport
|
|
global ModulesCurrentModulefile
|
|
global g_modrcUntrackVars g_modrcAliases
|
|
|
|
reportDebug "execute-modulerc: $modfile"
|
|
|
|
set ModulesCurrentModulefile $modfile
|
|
set ModulesVersion {}
|
|
# does not report commands from rc file on display mode
|
|
set g_inhibit_dispreport 1
|
|
|
|
set modname [file dirname [currentModuleName]]
|
|
|
|
if {![info exists g_rcfilesSourced($modfile)]} {
|
|
if {![info exists g_modrcUntrackVars]} {
|
|
# list variable that should not be tracked for saving
|
|
array set g_modrcUntrackVars [list g_debug 1 g_inhibit_errreport 1\
|
|
g_inhibit_dispreport 1 ModulesCurrentModulefile 1\
|
|
ModulesVersion 1 modcontent 1 env 1]
|
|
|
|
# list interpreter alias commands to define
|
|
array set g_modrcAliases [list uname uname system system chdir\
|
|
chdir module-version module-version module-alias module-alias\
|
|
module module module-info module-info module-trace module-trace\
|
|
module-verbosity module-verbosity module-user module-user\
|
|
module-log module-log reportInternalBug reportInternalBug\
|
|
setModulesVersion setModulesVersion readModuleContent\
|
|
readModuleContent]
|
|
}
|
|
|
|
# dedicate an interpreter per level of interpretation to have in case of
|
|
# cascaded interpretations a specific interpreter per level
|
|
set itrp "__modrc[info level]"
|
|
|
|
reportDebug "execute-modulerc: sourcing rc $modfile"
|
|
# create modulerc interpreter at first interpretation
|
|
if {![interp exists $itrp]} {
|
|
interp create $itrp
|
|
|
|
# dump initial interpreter state to restore it before each modulerc
|
|
# interpreation
|
|
dumpInterpState $itrp g_modrcVars g_modrcArrayVars\
|
|
g_modrcUntrackVars g_modrcProcs
|
|
}
|
|
|
|
# reset interp state command before each interpretation
|
|
resetInterpState $itrp g_modrcVars g_modrcArrayVars\
|
|
g_modrcUntrackVars g_modrcProcs g_modrcAliases g_modrcCommands
|
|
|
|
interp eval $itrp {global ModulesCurrentModulefile g_debug\
|
|
g_inhibit_errreport g_inhibit_dispreport ModulesVersion}
|
|
interp eval $itrp set ModulesCurrentModulefile $modfile
|
|
interp eval $itrp set g_debug $g_debug
|
|
interp eval $itrp set g_inhibit_errreport $g_inhibit_errreport
|
|
interp eval $itrp set g_inhibit_dispreport $g_inhibit_dispreport
|
|
interp eval $itrp {set ModulesVersion {}}
|
|
|
|
set errorVal [interp eval $itrp {
|
|
set modcontent [readModuleContent $ModulesCurrentModulefile]
|
|
if {$modcontent eq ""} {
|
|
# simply skip rc file, no exit on error here
|
|
return 1
|
|
}
|
|
info script $ModulesCurrentModulefile
|
|
if [catch {eval $modcontent} errorMsg] {
|
|
reportInternalBug $errorMsg $ModulesCurrentModulefile
|
|
return 1
|
|
} else {
|
|
# pass ModulesVersion value to master interp
|
|
if {[info exists ModulesVersion]} {
|
|
setModulesVersion $ModulesVersion
|
|
}
|
|
return 0
|
|
}
|
|
}]
|
|
|
|
# default version set via ModulesVersion variable in .version file
|
|
# override previously defined default version for modname
|
|
if {[file tail $modfile] eq ".version" && $ModulesVersion ne ""} {
|
|
setModuleResolution "$modname/default" $modname/$ModulesVersion\
|
|
"default"
|
|
}
|
|
|
|
# Keep track of rc files we already sourced so we don't run them again
|
|
set g_rcfilesSourced($modfile) $ModulesVersion
|
|
}
|
|
|
|
# re-enable command report on display mode
|
|
set g_inhibit_dispreport 0
|
|
|
|
return $g_rcfilesSourced($modfile)
|
|
}
|
|
|
|
# Save list of the defined procedure and the global variables with their
|
|
# associated values set in slave 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
|
|
|
|
# save name and value for any other global variables
|
|
foreach var [$itrp eval {info globals}] {
|
|
if {![info exists untrackVars($var)]} {
|
|
reportDebug "dumpInterpState: saving for $itrp 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 "dumpInterpState: saving for $itrp proc list [array names\
|
|
dumpProcs]"
|
|
}
|
|
|
|
# Restore initial setup of slave interpreter passed as argument based on
|
|
# global structure previously filled with initial list of defined procedure
|
|
# and values of global variable.
|
|
proc resetInterpState {itrp dumpVarsVN dumpArrayVarsVN untrackVarsVN\
|
|
dumpProcsVN aliasesVN dumpCommandsVN} {
|
|
upvar #0 $dumpVarsVN dumpVars
|
|
upvar #0 $dumpArrayVarsVN dumpArrayVars
|
|
upvar #0 $untrackVarsVN untrackVars
|
|
upvar #0 $dumpProcsVN dumpProcs
|
|
upvar #0 $aliasesVN aliases
|
|
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 "resetInterpState: removing on $itrp proc $var"
|
|
$itrp eval [list rename $var {}]
|
|
}
|
|
}
|
|
|
|
# set interpreter alias commands each time to guaranty them being
|
|
# defined and not overridden by modulefile or modulerc content
|
|
foreach alias [array names aliases] {
|
|
interp alias $itrp $alias {} $aliases($alias)
|
|
}
|
|
|
|
# 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 "resetInterpState: 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 "resetInterpState: missing command(s), recreating $itrp"
|
|
interp delete $itrp
|
|
interp create $itrp
|
|
# set aliases again on fresh interpreter
|
|
foreach alias [array names aliases] {
|
|
interp alias $itrp $alias {} $aliases($alias)
|
|
}
|
|
}
|
|
|
|
# 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 "resetInterpState: removing on $itrp var $var"
|
|
$itrp eval unset ::$var
|
|
} elseif {![info exists dumpArrayVars($var)]} {
|
|
if {$dumpVars($var) ne [$itrp eval set ::$var]} {
|
|
reportDebug "resetInterpState: restoring on $itrp var $var"
|
|
$itrp eval set ::$var $dumpVars($var)
|
|
}
|
|
} else {
|
|
if {$dumpVars($var) ne [$itrp eval array get ::$var]} {
|
|
reportDebug "resetInterpState: restoring on $itrp var $var"
|
|
$itrp eval array set ::$var [list $dumpVars($var)]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
########################################################################
|
|
# commands run from inside a module file
|
|
#
|
|
set ModulesCurrentModulefile {}
|
|
|
|
# Dummy procedures for commands available on C-version but not
|
|
# implemented here. These dummy procedures enables support for
|
|
# modulefiles using these commands while warning users these
|
|
# commands have no effect.
|
|
proc module-log {args} {
|
|
reportWarning "'module-log' command not implemented"
|
|
}
|
|
|
|
proc module-verbosity {args} {
|
|
reportWarning "'module-verbosity' command not implemented"
|
|
}
|
|
|
|
proc module-user {args} {
|
|
reportWarning "'module-user' command not implemented"
|
|
}
|
|
|
|
proc module-trace {args} {
|
|
reportWarning "'module-trace' command not implemented"
|
|
}
|
|
|
|
proc module-info {what {more {}}} {
|
|
global g_shellType g_shell tcl_platform
|
|
|
|
set mode [currentMode]
|
|
|
|
reportDebug "module-info: $what $more mode=$mode"
|
|
|
|
switch -- $what {
|
|
{mode} {
|
|
if {$more ne ""} {
|
|
set command [currentCommandName]
|
|
if {$mode eq $more || ($more eq "remove" && $mode eq "unload")\
|
|
|| ($more eq "switch" && $command eq "switch")} {
|
|
return 1
|
|
} else {
|
|
return 0
|
|
}
|
|
} else {
|
|
return $mode
|
|
}
|
|
}
|
|
{command} {
|
|
set command [currentCommandName]
|
|
if {$more eq ""} {
|
|
return $command
|
|
} elseif {$command eq $more} {
|
|
return 1
|
|
} else {
|
|
return 0
|
|
}
|
|
}
|
|
{name} {
|
|
return [currentModuleName]
|
|
}
|
|
{specified} {
|
|
return [currentSpecifiedName]
|
|
}
|
|
{shell} {
|
|
if {$more ne ""} {
|
|
if {$g_shell eq $more} {
|
|
return 1
|
|
} else {
|
|
return 0
|
|
}
|
|
} else {
|
|
return $g_shell
|
|
}
|
|
}
|
|
{flags} {
|
|
# C-version specific option, not relevant for Tcl-version but return
|
|
# a zero integer value to avoid breaking modulefiles using it
|
|
return 0
|
|
}
|
|
{shelltype} {
|
|
if {$more ne ""} {
|
|
if {$g_shellType eq $more} {
|
|
return 1
|
|
} else {
|
|
return 0
|
|
}
|
|
} else {
|
|
return $g_shellType
|
|
}
|
|
}
|
|
{user} {
|
|
# C-version specific option, not relevant for Tcl-version but return
|
|
# an empty value or false to avoid breaking modulefiles using it
|
|
if {$more ne ""} {
|
|
return 0
|
|
} else {
|
|
return {}
|
|
}
|
|
}
|
|
{alias} {
|
|
set ret [resolveModuleVersionOrAlias $more]
|
|
if {$ret ne $more} {
|
|
return $ret
|
|
} else {
|
|
return {}
|
|
}
|
|
}
|
|
{trace} {
|
|
return {}
|
|
}
|
|
{tracepat} {
|
|
return {}
|
|
}
|
|
{type} {
|
|
return "Tcl"
|
|
}
|
|
{symbols} {
|
|
lassign [getModuleNameVersion $more 1] mod modname modversion
|
|
set tag_list [getVersAliasList $mod]
|
|
# if querying special symbol "default" but nothing found registered
|
|
# on it, look at symbol registered on bare module name in case there
|
|
# are symbols registered on it but no default symbol set yet to link
|
|
# to them
|
|
if {[llength $tag_list] == 0 && $modversion eq "default"} {
|
|
set tag_list [getVersAliasList $modname]
|
|
}
|
|
return [join $tag_list ":"]
|
|
}
|
|
{version} {
|
|
lassign [getModuleNameVersion $more 1] mod
|
|
return [resolveModuleVersionOrAlias $mod]
|
|
}
|
|
{loaded} {
|
|
lassign [getModuleNameVersion $more 1] mod
|
|
return [getLoadedMatchingName $mod "returnall"]
|
|
}
|
|
default {
|
|
error "module-info $what not supported"
|
|
return {}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc module-whatis {args} {
|
|
global g_whatis
|
|
set mode [currentMode]
|
|
set message [join $args " "]
|
|
|
|
reportDebug "module-whatis: $message mode=$mode"
|
|
|
|
if {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "module-whatis\t$message"
|
|
}\
|
|
elseif {$mode eq "whatis"} {
|
|
lappend g_whatis $message
|
|
}
|
|
return {}
|
|
}
|
|
|
|
# deduce modulepath from modulefile and module name
|
|
proc getModulepathFromModuleName {modfile modname} {
|
|
return [string range $modfile 0 end-[string length "/$modname"]]
|
|
}
|
|
|
|
# deduce module name from modulefile and modulepath
|
|
proc getModuleNameFromModulepath {modfile modpath} {
|
|
return [string range $modfile [string length "$modpath/"] end]
|
|
}
|
|
|
|
# extract module name from modulefile and currently enabled modulepaths
|
|
proc findModuleNameFromModulefile {modfile} {
|
|
set ret ""
|
|
|
|
foreach modpath [getModulePathList] {
|
|
if {[string first "$modpath/" "$modfile/"] == 0} {
|
|
set ret [getModuleNameFromModulepath $modfile $modpath]
|
|
break
|
|
}
|
|
}
|
|
return $ret
|
|
}
|
|
|
|
# Determine with a name provided as argument the corresponding module name,
|
|
# version and name/version. Module name is guessed from current module name
|
|
# when shorthand version notation is used. Both name and version are guessed
|
|
# from current module if name provided is empty. If 'name_relative_tocur' is
|
|
# enabled then name argument may be interpreted as a name relative to the
|
|
# current modulefile directory (useful for module-version and module-alias
|
|
# for instance).
|
|
proc getModuleNameVersion {{name {}} {name_relative_tocur 0}} {
|
|
set curmod [currentModuleName]
|
|
set curmodname [file dirname $curmod]
|
|
set curmodversion [file tail $curmod]
|
|
|
|
if {$name eq ""} {
|
|
set name $curmodname
|
|
set version $curmodversion
|
|
# check for shorthand version notation like "/version" or "./version"
|
|
# only if we are currently interpreting a modulefile or modulerc
|
|
} elseif {$curmod ne "" && [regexp {^\.?\/(.*)$} $name match version]} {
|
|
# if we cannot distinguish a module name, raise error when
|
|
# shorthand version notation is used
|
|
global ModulesCurrentModulefile
|
|
if {$ModulesCurrentModulefile ne $curmod} {
|
|
# name is the name of current module directory
|
|
set name $curmodname
|
|
} else {
|
|
reportError "Invalid modulename '$name' found"
|
|
return {}
|
|
}
|
|
} else {
|
|
set name [string trimright $name "/"]
|
|
set version [file tail $name]
|
|
if {$name eq $version} {
|
|
set version ""
|
|
} else {
|
|
set name [file dirname $name]
|
|
}
|
|
# name may correspond to last part of current module
|
|
# if so name is replaced by current module name
|
|
if {$name_relative_tocur && [file tail $curmodname] eq $name} {
|
|
set name $curmodname
|
|
}
|
|
}
|
|
|
|
if {$version eq ""} {
|
|
set mod $name
|
|
} else {
|
|
set mod $name/$version
|
|
}
|
|
|
|
return [list $mod $name $version]
|
|
}
|
|
|
|
# Register alias or symbolic version deep resolution in a global array that
|
|
# can be used thereafter to get in one query the actual modulefile behind
|
|
# a virtual name. Also consolidate a global array that in the same manner
|
|
# list all the symbols held by modulefiles.
|
|
proc setModuleResolution {mod target {symver {}} {override_res_path 1}} {
|
|
global g_moduleResolved g_resolvedHash g_resolvedPath
|
|
global g_symbolHash g_moduleVersion g_sourceVersion
|
|
global g_moduleAltName ModulesCurrentModulefile
|
|
|
|
# find end-point module and register step-by-step path to get to it
|
|
set res $target
|
|
set res_path $res
|
|
while {$mod ne $res && [info exists g_resolvedPath($res)]} {
|
|
set res $g_resolvedPath($res)
|
|
lappend res_path $res
|
|
}
|
|
|
|
# error if resolution end on initial module
|
|
if {$mod eq $res} {
|
|
reportError "Resolution loop on '$res' detected"
|
|
return 0
|
|
}
|
|
|
|
# module name will be useful when registering symbol
|
|
if {$symver ne ""} {
|
|
lassign [getModuleNameVersion $mod] modfull modname
|
|
}
|
|
|
|
# change default symbol owner if previously given
|
|
if {$symver eq "default"} {
|
|
# alternative name "modname" is set when mod = "modname/default" both
|
|
# names will be registered to be known for queries and resolution defs
|
|
set modalt $modname
|
|
|
|
if {[info exists g_moduleResolved($mod)]} {
|
|
set prev $g_moduleResolved($mod)
|
|
# no test needed, there must be a "default" in $prev symbol list
|
|
set idx [lsearch -exact $g_symbolHash($prev) "default"]
|
|
reportDebug "setModuleResolution: remove symbol 'default' from\
|
|
'$prev'"
|
|
set g_symbolHash($prev) [lreplace $g_symbolHash($prev) $idx $idx]
|
|
}
|
|
}
|
|
|
|
# register end-point resolution
|
|
reportDebug "setModuleResolution: $mod resolved to $res"
|
|
set g_moduleResolved($mod) $res
|
|
# set first element of resolution path only if not already set or
|
|
# scratching enabled, no change when propagating symbol along res path
|
|
if {$override_res_path || ![info exists g_resolvedPath($mod)]} {
|
|
set g_resolvedPath($mod) $target
|
|
}
|
|
lappend g_resolvedHash($res) $mod
|
|
|
|
# also register resolution on alternative name if any
|
|
if {[info exists modalt]} {
|
|
reportDebug "setModuleResolution: $modalt resolved to $res"
|
|
set g_moduleResolved($modalt) $res
|
|
if {$override_res_path || ![info exists g_resolvedPath($modalt)]} {
|
|
set g_resolvedPath($modalt) $target
|
|
}
|
|
lappend g_resolvedHash($res) $modalt
|
|
# register name alternative to know their existence
|
|
set g_moduleAltName($modalt) $mod
|
|
set g_moduleAltName($mod) $modalt
|
|
}
|
|
|
|
# if other modules were pointing to this one, adapt resolution end-point
|
|
set relmod_list {}
|
|
if {[info exists g_resolvedHash($mod)]} {
|
|
set relmod_list $g_resolvedHash($mod)
|
|
unset g_resolvedHash($mod)
|
|
}
|
|
# also adapt resolution for modules pointing to the alternative name
|
|
if {[info exists modalt] && [info exists g_resolvedHash($modalt)]} {
|
|
set relmod_list [concat $relmod_list $g_resolvedHash($modalt)]
|
|
unset g_resolvedHash($modalt)
|
|
}
|
|
foreach relmod $relmod_list {
|
|
set g_moduleResolved($relmod) $res
|
|
reportDebug "setModuleResolution: $relmod now resolved to $res"
|
|
lappend g_resolvedHash($res) $relmod
|
|
}
|
|
|
|
# register and propagate symbols to the resolution path
|
|
if {[info exists g_symbolHash($mod)]} {
|
|
set sym_list $g_symbolHash($mod)
|
|
} else {
|
|
set sym_list {}
|
|
}
|
|
if {$symver ne ""} {
|
|
# merge symbol definitions in case of alternative name
|
|
if {[info exists modalt] && [info exists g_symbolHash($modalt)]} {
|
|
set sym_list [lsort -dictionary -unique [concat $sym_list\
|
|
$g_symbolHash($modalt)]]
|
|
reportDebug "setModuleResolution: set symbols '$sym_list' to $mod\
|
|
and $modalt"
|
|
set g_symbolHash($mod) $sym_list
|
|
set g_symbolHash($modalt) $sym_list
|
|
}
|
|
|
|
# dictionary-sort symbols and remove eventual duplicates
|
|
set sym_list [lsort -dictionary -unique [concat $sym_list\
|
|
[list $symver]]]
|
|
|
|
# propagate symbols in g_symbolHash and g_moduleVersion toward the
|
|
# resolution path, handle that locally if we still work on same
|
|
# modulename, call for a proper resolution as soon as we change of
|
|
# module to get this new resolution registered
|
|
foreach modres $res_path {
|
|
lassign [getModuleNameVersion $modres] modfull modresname
|
|
if {$modname eq $modresname} {
|
|
if {[info exists g_symbolHash($modres)]} {
|
|
set modres_sym_list [lsort -dictionary -unique [concat\
|
|
$g_symbolHash($modres) $sym_list]]
|
|
} else {
|
|
set modres_sym_list $sym_list
|
|
}
|
|
# sync symbols of alternative name if any
|
|
if {[info exists g_moduleAltName($modres)]} {
|
|
set altmodres $g_moduleAltName($modres)
|
|
reportDebug "setModuleResolution: set symbols\
|
|
'$modres_sym_list' to $modres and $altmodres"
|
|
set g_symbolHash($altmodres) $modres_sym_list
|
|
} else {
|
|
reportDebug "setModuleResolution: set symbols\
|
|
'$modres_sym_list' to $modres"
|
|
}
|
|
set g_symbolHash($modres) $modres_sym_list
|
|
|
|
# register symbolic version for querying in g_moduleVersion
|
|
foreach symelt $sym_list {
|
|
set modvers "$modresname/$symelt"
|
|
reportDebug "setModuleResolution: module-version $modvers =\
|
|
$modres"
|
|
set g_moduleVersion($modvers) $modres
|
|
set g_sourceVersion($modvers) $ModulesCurrentModulefile
|
|
}
|
|
# as we change of module name a proper resolution call should be
|
|
# made (see below) and will handle the rest of the resolution path
|
|
} else {
|
|
set need_set_res 1
|
|
break
|
|
}
|
|
}
|
|
# when registering an alias, existing symbols on alias source name should
|
|
# be broadcast along the resolution path with a proper resolution call
|
|
# (see below)
|
|
} else {
|
|
lassign [getModuleNameVersion $target] modres modresname
|
|
set need_set_res 1
|
|
}
|
|
|
|
# resolution needed to broadcast symbols along resolution path without
|
|
# altering initial path already set for these symbols
|
|
if {[info exists need_set_res]} {
|
|
foreach symelt $sym_list {
|
|
set modvers "$modresname/$symelt"
|
|
reportDebug "setModuleResolution: set resolution for $modvers"
|
|
setModuleResolution $modvers $modres $symelt 0
|
|
}
|
|
}
|
|
|
|
return 1
|
|
}
|
|
|
|
# Specifies a default or alias version for a module that points to an
|
|
# existing module version Note that aliases defaults are stored by the
|
|
# short module name (not the full path) so aliases and defaults from one
|
|
# directory will apply to modules of the same name found in other
|
|
# directories.
|
|
proc module-version {args} {
|
|
global g_moduleVersion
|
|
|
|
reportDebug "module-version: executing module-version $args"
|
|
lassign [getModuleNameVersion [lindex $args 0] 1] mod modname modversion
|
|
|
|
# go for registration only if valid modulename
|
|
if {$mod ne ""} {
|
|
foreach version [lrange $args 1 end] {
|
|
set aliasversion "$modname/$version"
|
|
# do not alter a previously defined alias version
|
|
if {![info exists g_moduleVersion($aliasversion)]} {
|
|
setModuleResolution $aliasversion $mod $version
|
|
} else {
|
|
reportWarning "Symbolic version '$aliasversion' already defined"
|
|
}
|
|
}
|
|
}
|
|
|
|
if {[currentMode] eq "display" && !$::g_inhibit_dispreport} {
|
|
report "module-version\t$args"
|
|
}
|
|
return {}
|
|
}
|
|
|
|
proc module-alias {args} {
|
|
global g_moduleAlias
|
|
global g_sourceAlias ModulesCurrentModulefile
|
|
|
|
lassign [getModuleNameVersion [lindex $args 0]] alias
|
|
lassign [getModuleNameVersion [lindex $args 1] 1] mod
|
|
|
|
reportDebug "module-alias: $alias = $mod"
|
|
|
|
if {[setModuleResolution $alias $mod]} {
|
|
set g_moduleAlias($alias) $mod
|
|
set g_sourceAlias($alias) $ModulesCurrentModulefile
|
|
}
|
|
|
|
if {[currentMode] eq "display" && !$::g_inhibit_dispreport} {
|
|
report "module-alias\t$args"
|
|
}
|
|
|
|
return {}
|
|
}
|
|
|
|
proc module {command args} {
|
|
set mode [currentMode]
|
|
|
|
# guess if called from top level
|
|
set topcall [expr {[info level] == 1}]
|
|
if {$topcall} {
|
|
set msgprefix ""
|
|
} else {
|
|
set msgprefix "module: "
|
|
}
|
|
|
|
switch -regexp -- $command {
|
|
{^(add|lo)} {
|
|
# no error raised on empty argument list to cope with
|
|
# initadd command that may expect this behavior
|
|
if {[llength $args] > 0} {
|
|
set ret 0
|
|
pushCommandName "load"
|
|
if {$topcall || $mode eq "load"} {
|
|
set ret [eval cmdModuleLoad $args]
|
|
}\
|
|
elseif {$mode eq "unload"} {
|
|
# on unload mode, unload mods in reverse order
|
|
set ret [eval cmdModuleUnload "match" [lreverse $args]]
|
|
}\
|
|
elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "module load\t$args"
|
|
}
|
|
popCommandName
|
|
# sub-module interpretation failed, raise error
|
|
if {$ret && !$topcall} {
|
|
set errormsg "SUB_FAILED"
|
|
}
|
|
}
|
|
}
|
|
{^(rm|unlo)} {
|
|
if {[llength $args] == 0} {
|
|
set errormsg "Unexpected number of args for 'unload' command"
|
|
} else {
|
|
set ret 0
|
|
pushCommandName "unload"
|
|
if {$topcall || $mode eq "load"} {
|
|
set ret [eval cmdModuleUnload "match" $args]
|
|
}\
|
|
elseif {$mode eq "unload"} {
|
|
set ret [eval cmdModuleUnload "match" $args]
|
|
}\
|
|
elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "module unload\t$args"
|
|
}
|
|
popCommandName
|
|
# sub-module interpretation failed, raise error
|
|
if {$ret && !$topcall} {
|
|
set errormsg "SUB_FAILED"
|
|
}
|
|
}
|
|
}
|
|
{^(ref|rel)} {
|
|
if {[llength $args] != 0} {
|
|
set errormsg "Unexpected number of args for 'reload' command"
|
|
} else {
|
|
pushCommandName "reload"
|
|
cmdModuleReload
|
|
popCommandName
|
|
}
|
|
}
|
|
{^use$} {
|
|
if {$topcall || $mode eq "load"} {
|
|
eval cmdModuleUse $args
|
|
} elseif {$mode eq "unload"} {
|
|
eval cmdModuleUnuse $args
|
|
} elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "module use\t$args"
|
|
}
|
|
}
|
|
{^unuse$} {
|
|
if {$topcall || $mode eq "load" || $mode eq "unload"} {
|
|
eval cmdModuleUnuse $args
|
|
} elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "module unuse\t$args"
|
|
}
|
|
}
|
|
{^source$} {
|
|
if {[llength $args] == 0} {
|
|
set errormsg "Unexpected number of args for 'source' command"
|
|
} else {
|
|
pushCommandName "source"
|
|
if {$topcall || $mode eq "load"} {
|
|
eval cmdModuleSource $args
|
|
} elseif {$mode eq "unload"} {
|
|
# on unload mode, unsource script in reverse order
|
|
eval cmdModuleUnsource [lreverse $args]
|
|
} elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "module source\t$args"
|
|
}
|
|
popCommandName
|
|
}
|
|
}
|
|
{^sw} {
|
|
if {[llength $args] == 0 || [llength $args] > 2} {
|
|
set errormsg "Unexpected number of args for 'switch' command"
|
|
} else {
|
|
pushCommandName "switch"
|
|
eval cmdModuleSwitch $args
|
|
popCommandName
|
|
}
|
|
}
|
|
{^(di|show)} {
|
|
if {[llength $args] == 0} {
|
|
set errormsg "Unexpected number of args for 'show' command"
|
|
} else {
|
|
pushCommandName "display"
|
|
eval cmdModuleDisplay $args
|
|
popCommandName
|
|
}
|
|
}
|
|
{^av} {
|
|
pushCommandName "avail"
|
|
if {$args ne ""} {
|
|
foreach arg $args {
|
|
cmdModuleAvail $arg
|
|
}
|
|
} else {
|
|
cmdModuleAvail
|
|
}
|
|
popCommandName
|
|
}
|
|
{^al} {
|
|
if {[llength $args] != 0} {
|
|
set errormsg "Unexpected number of args for 'aliases' command"
|
|
} else {
|
|
pushCommandName "aliases"
|
|
cmdModuleAliases
|
|
popCommandName
|
|
}
|
|
}
|
|
{^path$} {
|
|
if {$topcall} {
|
|
if {[llength $args] != 1} {
|
|
set errormsg "Unexpected number of args for 'path' command"
|
|
} else {
|
|
eval cmdModulePath $args
|
|
}
|
|
} else {
|
|
# no call other than from top level as it renders a result value
|
|
set errormsg "${msgprefix}Command '$command' not supported"
|
|
}
|
|
}
|
|
{^paths$} {
|
|
if {$topcall} {
|
|
if {[llength $args] != 1} {
|
|
set errormsg "Unexpected number of args for 'paths' command"
|
|
} else {
|
|
eval cmdModulePaths $args
|
|
}
|
|
} else {
|
|
# no call other than from top level as it renders a result value
|
|
set errormsg "${msgprefix}Command '$command' not supported"
|
|
}
|
|
}
|
|
{^li} {
|
|
if {[llength $args] != 0} {
|
|
set errormsg "Unexpected number of args for 'list' command"
|
|
} else {
|
|
pushCommandName "list"
|
|
cmdModuleList
|
|
popCommandName
|
|
}
|
|
}
|
|
{^wh} {
|
|
pushCommandName "whatis"
|
|
if {$args ne ""} {
|
|
foreach arg $args {
|
|
cmdModuleWhatIs $arg
|
|
}
|
|
} else {
|
|
cmdModuleWhatIs
|
|
}
|
|
popCommandName
|
|
}
|
|
{^(apropos|search|keyword)$} {
|
|
if {[llength $args] > 1} {
|
|
set errormsg "Unexpected number of args for '$command' command"
|
|
} else {
|
|
pushCommandName "search"
|
|
eval cmdModuleApropos $args
|
|
popCommandName
|
|
}
|
|
}
|
|
{^pu} {
|
|
if {[llength $args] != 0} {
|
|
set errormsg "Unexpected number of args for 'purge' command"
|
|
} else {
|
|
pushCommandName "purge"
|
|
eval cmdModulePurge
|
|
popCommandName
|
|
}
|
|
}
|
|
{^save$} {
|
|
if {[llength $args] > 1} {
|
|
set errormsg "Unexpected number of args for 'save' command"
|
|
} else {
|
|
eval cmdModuleSave $args
|
|
}
|
|
}
|
|
{^restore$} {
|
|
if {[llength $args] > 1} {
|
|
set errormsg "Unexpected number of args for 'restore' command"
|
|
} else {
|
|
pushCommandName "restore"
|
|
eval cmdModuleRestore $args
|
|
popCommandName
|
|
}
|
|
}
|
|
{^saverm$} {
|
|
if {[llength $args] > 1} {
|
|
set errormsg "Unexpected number of args for 'saverm' command"
|
|
} else {
|
|
eval cmdModuleSaverm $args
|
|
}
|
|
}
|
|
{^saveshow$} {
|
|
if {[llength $args] > 1} {
|
|
set errormsg "Unexpected number of args for 'saveshow' command"
|
|
} else {
|
|
eval cmdModuleSaveshow $args
|
|
}
|
|
}
|
|
{^savelist$} {
|
|
if {[llength $args] != 0} {
|
|
set errormsg "Unexpected number of args for 'savelist' command"
|
|
} else {
|
|
cmdModuleSavelist
|
|
}
|
|
}
|
|
{^init(a|lo)} {
|
|
if {[llength $args] == 0} {
|
|
set errormsg "Unexpected number of args for 'initadd' command"
|
|
} else {
|
|
eval cmdModuleInit add $args
|
|
}
|
|
}
|
|
{^initp} {
|
|
if {[llength $args] == 0} {
|
|
set errormsg "Unexpected number of args for 'initprepend' command"
|
|
} else {
|
|
eval cmdModuleInit prepend $args
|
|
}
|
|
}
|
|
{^initsw} {
|
|
if {[llength $args] != 2} {
|
|
set errormsg "Unexpected number of args for 'initswitch' command"
|
|
} else {
|
|
eval cmdModuleInit switch $args
|
|
}
|
|
}
|
|
{^init(rm|unlo)$} {
|
|
if {[llength $args] == 0} {
|
|
set errormsg "Unexpected number of args for 'initrm' command"
|
|
} else {
|
|
eval cmdModuleInit rm $args
|
|
}
|
|
}
|
|
{^initl} {
|
|
if {[llength $args] != 0} {
|
|
set errormsg "Unexpected number of args for 'initlist' command"
|
|
} else {
|
|
eval cmdModuleInit list $args
|
|
}
|
|
}
|
|
{^initclear$} {
|
|
if {[llength $args] != 0} {
|
|
set errormsg "Unexpected number of args for 'initclear' command"
|
|
} else {
|
|
eval cmdModuleInit clear $args
|
|
}
|
|
}
|
|
{^autoinit$} {
|
|
if {$topcall} {
|
|
if {[llength $args] != 0} {
|
|
set errormsg "Unexpected number of args for 'autoinit' command"
|
|
} else {
|
|
cmdModuleAutoinit
|
|
}
|
|
} else {
|
|
# autoinit cannot be called elsewhere than from top level
|
|
set errormsg "${msgprefix}Command '$command' not supported"
|
|
}
|
|
}
|
|
{^($|help)} {
|
|
if {$topcall} {
|
|
pushCommandName "help"
|
|
eval cmdModuleHelp $args
|
|
popCommandName
|
|
if {[llength $args] != 0} {
|
|
}
|
|
} else {
|
|
# help cannot be called elsewhere than from top level
|
|
set errormsg "${msgprefix}Command '$command' not supported"
|
|
}
|
|
}
|
|
{^test$} {
|
|
if {[llength $args] == 0} {
|
|
set errormsg "Unexpected number of args for 'test' command"
|
|
} else {
|
|
pushCommandName "test"
|
|
eval cmdModuleTest $args
|
|
popCommandName
|
|
}
|
|
}
|
|
{^(prepend|append|remove)-path$} {
|
|
if {$topcall} {
|
|
if {[llength $args] < 2 || [llength $args] > 4} {
|
|
set errormsg "Unexpected number of args for '$command' command"
|
|
} else {
|
|
eval cmdModuleResurface $command $args
|
|
}
|
|
} else {
|
|
# no call other than from top level not to conflict with modulefile
|
|
# specific Tcl commands
|
|
set errormsg "${msgprefix}Command '$command' not supported"
|
|
}
|
|
}
|
|
{^is-(loaded|saved|used)$} {
|
|
if {$topcall} {
|
|
eval cmdModuleResurface $command $args
|
|
} else {
|
|
# no call other than from top level not to conflict with modulefile
|
|
# specific Tcl commands
|
|
set errormsg "${msgprefix}Command '$command' not supported"
|
|
}
|
|
}
|
|
{^is-avail$} {
|
|
if {$topcall} {
|
|
if {[llength $args] == 0} {
|
|
set errormsg "Unexpected number of args for '$command' command"
|
|
} else {
|
|
eval cmdModuleResurface $command $args
|
|
}
|
|
} else {
|
|
# no call other than from top level not to conflict with modulefile
|
|
# specific Tcl commands
|
|
set errormsg "${msgprefix}Command '$command' not supported"
|
|
}
|
|
}
|
|
{info-loaded} {
|
|
if {$topcall} {
|
|
if {[llength $args] != 1} {
|
|
set errormsg "Unexpected number of args for '$command' command"
|
|
} else {
|
|
eval cmdModuleResurface module-info loaded $args
|
|
}
|
|
} else {
|
|
# no call other than from top level not to conflict with modulefile
|
|
# specific Tcl commands
|
|
set errormsg "${msgprefix}Command '$command' not supported"
|
|
}
|
|
}
|
|
. {
|
|
set errormsg "${msgprefix}Invalid command '$command'"
|
|
}
|
|
}
|
|
|
|
# if an error need to be raised, proceed differently depending of
|
|
# call level: if called from top level render errors then raise error
|
|
# elsewhere call is made from a modulefile or modulerc and error
|
|
# will be managed from execute-modulefile or execute-modulerc
|
|
if {[info exists errormsg]} {
|
|
if {$topcall} {
|
|
reportErrorAndExit "$errormsg\nTry 'module --help'\
|
|
for more information."
|
|
} else {
|
|
error "$errormsg"
|
|
}
|
|
# if called from top level render settings if any
|
|
} elseif {$topcall} {
|
|
renderSettings
|
|
}
|
|
|
|
return {}
|
|
}
|
|
|
|
proc setenv {var val} {
|
|
global g_stateEnvVars env
|
|
|
|
set mode [currentMode]
|
|
|
|
reportDebug "setenv: ($var,$val) mode = $mode"
|
|
|
|
if {$mode eq "load"} {
|
|
set env($var) $val
|
|
set g_stateEnvVars($var) "new"
|
|
# clean any previously defined reference counter array
|
|
set sharevar "${var}_modshare"
|
|
if {[info exists env($sharevar)]} {
|
|
unset-env $sharevar
|
|
set g_stateEnvVars($sharevar) "del"
|
|
}
|
|
}\
|
|
elseif {$mode eq "unload"} {
|
|
# Don't unset-env here ... it breaks modulefiles
|
|
# that use env(var) is later in the modulefile
|
|
#unset-env $var
|
|
set g_stateEnvVars($var) "del"
|
|
}\
|
|
elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
# Let display set the variable for later use in the display
|
|
# but don't commit it to the env
|
|
set env($var) $val
|
|
report "setenv\t\t$var\t$val"
|
|
}
|
|
return {}
|
|
}
|
|
|
|
proc getenv {var} {
|
|
set mode [currentMode]
|
|
|
|
reportDebug "getenv: ($var) mode = $mode"
|
|
|
|
if {$mode eq "load" || $mode eq "unload"} {
|
|
if {[info exists ::env($var)]} {
|
|
return $::env($var)
|
|
} else {
|
|
return "_UNDEFINED_"
|
|
}
|
|
}\
|
|
elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
return "\$$var"
|
|
}
|
|
return {}
|
|
}
|
|
|
|
proc unsetenv {var {val {}}} {
|
|
global g_stateEnvVars env
|
|
|
|
set mode [currentMode]
|
|
|
|
reportDebug "unsetenv: ($var,$val) mode = $mode"
|
|
|
|
if {$mode eq "load"} {
|
|
if {[info exists env($var)]} {
|
|
unset-env $var
|
|
}
|
|
set g_stateEnvVars($var) "del"
|
|
# clean any existing reference counter array
|
|
set sharevar "${var}_modshare"
|
|
if {[info exists env($sharevar)]} {
|
|
unset-env $sharevar
|
|
set g_stateEnvVars($sharevar) "del"
|
|
}
|
|
}\
|
|
elseif {$mode eq "unload"} {
|
|
if {$val ne ""} {
|
|
set env($var) $val
|
|
set g_stateEnvVars($var) "new"
|
|
} else {
|
|
set g_stateEnvVars($var) "del"
|
|
}
|
|
}\
|
|
elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
if {$val ne ""} {
|
|
report "unsetenv\t$var\t$val"
|
|
} else {
|
|
report "unsetenv\t$var"
|
|
}
|
|
}
|
|
return {}
|
|
}
|
|
|
|
proc chdir {dir} {
|
|
global g_changeDir
|
|
set mode [currentMode]
|
|
set currentModule [currentModuleName]
|
|
|
|
reportDebug "chdir: ($dir) mode = $mode"
|
|
|
|
if {$mode eq "load"} {
|
|
if {[file exists $dir] && [file isdirectory $dir]} {
|
|
set g_changeDir $dir
|
|
} else {
|
|
# report issue but does not treat it as an error to have the
|
|
# same behavior as C-version
|
|
reportWarning "Cannot chdir to '$dir' for '$currentModule'"
|
|
}
|
|
} elseif {$mode eq "unload"} {
|
|
# No operation here unable to undo a syscall.
|
|
} elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "chdir\t\t$dir"
|
|
}
|
|
|
|
return {}
|
|
}
|
|
|
|
# superseed exit command to handle it if called within a modulefile
|
|
# rather than exiting the whole process
|
|
proc exitModfileCmd {{code 0}} {
|
|
global g_inhibit_interp
|
|
set mode [currentMode]
|
|
|
|
reportDebug "exit: ($code)"
|
|
|
|
if {$mode eq "load"} {
|
|
reportDebug "exit: Inhibit next modulefile interpretations"
|
|
set g_inhibit_interp 1
|
|
}
|
|
|
|
# break to gently end interpretation of current modulefile
|
|
return -code break
|
|
}
|
|
|
|
# enables slave interp to return ModulesVersion value to the master interp
|
|
proc setModulesVersion {val} {
|
|
global ModulesVersion
|
|
|
|
set ModulesVersion $val
|
|
}
|
|
|
|
# supersede puts command to catch content sent to stdout/stderr within
|
|
# modulefile in order to correctly send stderr content (if a pager has been
|
|
# enabled) or postpone content channel send after rendering on stdout the
|
|
# relative environment changes required by the modulefile
|
|
proc putsModfileCmd {args} {
|
|
global g_stdoutPuts
|
|
|
|
reportDebug "puts: ($args)"
|
|
|
|
# determine if puts call targets the stdout or stderr channel
|
|
switch -- [llength $args] {
|
|
{1} {
|
|
set deferPuts 1
|
|
}
|
|
{2} {
|
|
switch -- [lindex $args 0] {
|
|
{-nonewline} - {stdout} {
|
|
set deferPuts 1
|
|
}
|
|
{stderr} {
|
|
set reportArgs [list [lindex $args 1]]
|
|
}
|
|
}
|
|
}
|
|
{3} {
|
|
if {[lindex $args 0] eq "-nonewline"} {
|
|
switch -- [lindex $args 1] {
|
|
{stdout} {
|
|
set deferPuts 1
|
|
}
|
|
{stderr} {
|
|
set reportArgs [list [lindex $args 2] 1]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# defer puts if it targets stdout (see renderSettings)
|
|
if {[info exists deferPuts]} {
|
|
lappend g_stdoutPuts $args
|
|
# if it targets stderr call report, which knows what channel to use
|
|
} elseif {[info exists reportArgs]} {
|
|
eval report $reportArgs
|
|
# pass to real puts command if not related to stdout or bad call
|
|
} else {
|
|
eval puts $args
|
|
}
|
|
}
|
|
|
|
########################################################################
|
|
# path fiddling
|
|
#
|
|
proc getReferenceCountArray {var separator} {
|
|
global env g_force g_def_separator g_debug
|
|
|
|
reportDebug "getReferenceCountArray: ($var, $separator)"
|
|
|
|
set sharevar "${var}_modshare"
|
|
set modshareok 1
|
|
if {[info exists env($sharevar)]} {
|
|
if {[info exists env($var)]} {
|
|
set modsharelist [psplit $env($sharevar) $g_def_separator]
|
|
set temp [expr {[llength $modsharelist] % 2}]
|
|
|
|
if {$temp == 0} {
|
|
array set countarr $modsharelist
|
|
|
|
# sanity check the modshare list
|
|
array set fixers {}
|
|
array set usagearr {}
|
|
|
|
foreach dir [split $env($var) $separator] {
|
|
set usagearr($dir) 1
|
|
}
|
|
foreach path [array names countarr] {
|
|
if {! [info exists usagearr($path)]} {
|
|
unset countarr($path)
|
|
set fixers($path) 1
|
|
}
|
|
}
|
|
|
|
foreach path [array names usagearr] {
|
|
if {! [info exists countarr($path)]} {
|
|
# if no ref count found for a path, assume it has a ref
|
|
# count of 1 to be able to unload it easily if needed
|
|
set countarr($path) 1
|
|
}
|
|
}
|
|
|
|
if {! $g_force} {
|
|
if {[array size fixers]} {
|
|
reportWarning "\$$var does not agree with\
|
|
\$${var}_modshare counter. The following\
|
|
directories' usage counters were adjusted to match.\
|
|
Note that this may mean that module unloading may\
|
|
not work correctly."
|
|
foreach dir [array names fixers] {
|
|
report " $dir" -nonewline
|
|
}
|
|
report ""
|
|
}
|
|
}
|
|
} else {
|
|
# sharevar was corrupted, odd number of elements.
|
|
set modshareok 0
|
|
}
|
|
} else {
|
|
reportWarning "$sharevar exists ( $env($sharevar) ), but $var\
|
|
doesn't. Environment is corrupted."
|
|
set modshareok 0
|
|
}
|
|
} else {
|
|
set modshareok 0
|
|
}
|
|
|
|
if {$modshareok == 0 && [info exists env($var)]} {
|
|
array set countarr {}
|
|
foreach dir [split $env($var) $separator] {
|
|
set countarr($dir) 1
|
|
}
|
|
}
|
|
return [array get countarr]
|
|
}
|
|
|
|
|
|
proc unload-path {var path separator} {
|
|
global g_stateEnvVars env g_force g_def_separator
|
|
|
|
array set countarr [getReferenceCountArray $var $separator]
|
|
|
|
reportDebug "unload-path: ($var, $path, $separator)"
|
|
|
|
# Don't worry about dealing with this variable if it is already scheduled
|
|
# for deletion
|
|
if {[info exists g_stateEnvVars($var)] && $g_stateEnvVars($var) eq "del"} {
|
|
return {}
|
|
}
|
|
|
|
# enable removal of an empty path
|
|
if {$path eq ""} {
|
|
set path $separator
|
|
# raise error on removal attempt of a path equals to separator
|
|
} elseif {$path eq $separator} {
|
|
error "unload-path cannot handle path equals to separator string"
|
|
}
|
|
|
|
foreach dir [split $path $separator] {
|
|
set doit 0
|
|
|
|
if {[info exists countarr($dir)]} {
|
|
incr countarr($dir) -1
|
|
if {$countarr($dir) <= 0} {
|
|
set doit 1
|
|
unset countarr($dir)
|
|
}
|
|
} else {
|
|
set doit 1
|
|
}
|
|
|
|
if {$doit || $g_force} {
|
|
if {[info exists env($var)]} {
|
|
set dirs [split $env($var) $separator]
|
|
set newpath ""
|
|
foreach elem $dirs {
|
|
if {$elem ne $dir} {
|
|
lappend newpath $elem
|
|
}
|
|
}
|
|
if {$newpath eq ""} {
|
|
unset-env $var
|
|
set g_stateEnvVars($var) "del"
|
|
} else {
|
|
set env($var) [join $newpath $separator]
|
|
set g_stateEnvVars($var) "new"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
set sharevar "${var}_modshare"
|
|
if {[array size countarr] > 0} {
|
|
set env($sharevar) [pjoin [array get countarr] $g_def_separator]
|
|
set g_stateEnvVars($sharevar) "new"
|
|
} else {
|
|
unset-env $sharevar
|
|
set g_stateEnvVars($sharevar) "del"
|
|
}
|
|
return {}
|
|
}
|
|
|
|
proc add-path {var path pos separator} {
|
|
global env g_stateEnvVars g_def_separator
|
|
|
|
reportDebug "add-path: ($var, $path, $separator)"
|
|
|
|
set sharevar "${var}_modshare"
|
|
array set countarr [getReferenceCountArray $var $separator]
|
|
|
|
# enable add of an empty path
|
|
if {$path eq ""} {
|
|
set path $separator
|
|
# raise error on removal attempt of a path equals to separator
|
|
} elseif {$path eq $separator} {
|
|
error "add-path cannot handle path equals to separator string"
|
|
}
|
|
|
|
if {$pos eq "prepend"} {
|
|
set pathelems [lreverse [split $path $separator]]
|
|
} else {
|
|
set pathelems [split $path $separator]
|
|
}
|
|
foreach dir $pathelems {
|
|
if {[info exists countarr($dir)]} {
|
|
# already see $dir in $var"
|
|
incr countarr($dir)
|
|
} else {
|
|
if {[info exists env($var)] && $env($var) ne ""} {
|
|
if {$pos eq "prepend"} {
|
|
set env($var) "$dir$separator$env($var)"
|
|
}\
|
|
elseif {$pos eq "append"} {
|
|
set env($var) "$env($var)$separator$dir"
|
|
} else {
|
|
error "add-path doesn't support $pos"
|
|
}
|
|
} else {
|
|
set env($var) "$dir"
|
|
}
|
|
set countarr($dir) 1
|
|
}
|
|
reportDebug "add-path: env($var) = $env($var)"
|
|
}
|
|
|
|
set env($sharevar) [pjoin [array get countarr] $g_def_separator]
|
|
set g_stateEnvVars($var) "new"
|
|
set g_stateEnvVars($sharevar) "new"
|
|
return {}
|
|
}
|
|
|
|
proc prepend-path {var path args} {
|
|
global g_def_separator
|
|
|
|
set mode [currentMode]
|
|
|
|
reportDebug "prepend-path: ($var, $path, $args) mode=$mode"
|
|
|
|
if {($var eq "--delim") || ($var eq "-d") || ($var eq "-delim")} {
|
|
set separator $path
|
|
set var [lindex $args 0]
|
|
set path [lindex $args 1]
|
|
} else {
|
|
set separator $g_def_separator
|
|
}
|
|
|
|
if {$mode eq "load"} {
|
|
add-path $var $path "prepend" $separator
|
|
}\
|
|
elseif {$mode eq "unload"} {
|
|
unload-path $var $path $separator
|
|
}\
|
|
elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "prepend-path\t$var\t$path"
|
|
}
|
|
|
|
return {}
|
|
}
|
|
|
|
|
|
proc append-path {var path args} {
|
|
global g_def_separator
|
|
|
|
set mode [currentMode]
|
|
|
|
reportDebug "append-path: ($var, $path, $args) mode=$mode"
|
|
|
|
if {($var eq "--delim") || ($var eq "-d") || ($var eq "-delim")} {
|
|
set separator $path
|
|
set var [lindex $args 0]
|
|
set path [lindex $args 1]
|
|
} else {
|
|
set separator $g_def_separator
|
|
}
|
|
|
|
if {$mode eq "load"} {
|
|
add-path $var $path "append" $separator
|
|
}\
|
|
elseif {$mode eq "unload"} {
|
|
unload-path $var $path $separator
|
|
}\
|
|
elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "append-path\t$var\t$path"
|
|
}
|
|
|
|
return {}
|
|
}
|
|
|
|
proc remove-path {var path args} {
|
|
global g_def_separator
|
|
|
|
set mode [currentMode]
|
|
|
|
reportDebug "remove-path: ($var, $path, $args) mode=$mode"
|
|
|
|
if {($var eq "--delim") || ($var eq "-d") || ($var eq "-delim")} {
|
|
set separator $path
|
|
set var [lindex $args 0]
|
|
set path [lindex $args 1]
|
|
} else {
|
|
set separator $g_def_separator
|
|
}
|
|
|
|
if {$mode eq "load"} {
|
|
unload-path $var $path $separator
|
|
}\
|
|
elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "remove-path\t$var\t$path"
|
|
}
|
|
return {}
|
|
}
|
|
|
|
proc set-alias {alias what} {
|
|
global g_Aliases g_stateAliases
|
|
set mode [currentMode]
|
|
|
|
reportDebug "set-alias: ($alias, $what) mode=$mode"
|
|
if {$mode eq "load"} {
|
|
set g_Aliases($alias) $what
|
|
set g_stateAliases($alias) "new"
|
|
}\
|
|
elseif {$mode eq "unload"} {
|
|
set g_Aliases($alias) {}
|
|
set g_stateAliases($alias) "del"
|
|
}\
|
|
elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "set-alias\t$alias\t$what"
|
|
}
|
|
|
|
return {}
|
|
}
|
|
|
|
proc unset-alias {alias} {
|
|
global g_Aliases g_stateAliases
|
|
|
|
set mode [currentMode]
|
|
|
|
reportDebug "unset-alias: ($alias) mode=$mode"
|
|
if {$mode eq "load"} {
|
|
set g_Aliases($alias) {}
|
|
set g_stateAliases($alias) "del"
|
|
}\
|
|
elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "unset-alias\t$alias"
|
|
}
|
|
|
|
return {}
|
|
}
|
|
|
|
proc is-loaded {args} {
|
|
reportDebug "is-loaded: $args"
|
|
|
|
foreach mod $args {
|
|
if {[getLoadedMatchingName $mod "returnfirst"] ne ""} {
|
|
return 1
|
|
}
|
|
}
|
|
# is something loaded whatever it is?
|
|
if {[llength $args] == 0 && [llength [getLoadedModuleList]] > 0} {
|
|
return 1
|
|
} else {
|
|
return 0
|
|
}
|
|
}
|
|
|
|
proc conflict {args} {
|
|
set mode [currentMode]
|
|
set currentModule [currentModuleName]
|
|
|
|
reportDebug "conflict: ($args) mode = $mode"
|
|
|
|
if {$mode eq "load"} {
|
|
foreach mod $args {
|
|
# If the current module is already loaded, we can proceed
|
|
if {![is-loaded $currentModule]} {
|
|
# otherwise if the conflict module is loaded, we cannot
|
|
if {[is-loaded $mod]} {
|
|
set errMsg "WARNING: $currentModule cannot be loaded due\
|
|
to a conflict."
|
|
set errMsg "$errMsg\nHINT: Might try \"module unload\
|
|
$mod\" first."
|
|
error $errMsg
|
|
}
|
|
}
|
|
}
|
|
}\
|
|
elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "conflict\t$args"
|
|
}
|
|
|
|
return {}
|
|
}
|
|
|
|
proc prereq {args} {
|
|
set mode [currentMode]
|
|
set currentModule [currentModuleName]
|
|
|
|
reportDebug "prereq: ($args) mode = $mode"
|
|
|
|
if {$mode eq "load"} {
|
|
if {![eval is-loaded $args]} {
|
|
set errMsg "WARNING: $currentModule cannot be loaded due to\
|
|
missing prereq."
|
|
# adapt error message when multiple modules are specified
|
|
if {[llength $args] > 1} {
|
|
set errMsg "$errMsg\nHINT: at least one of the following\
|
|
modules must be loaded first: $args"
|
|
} else {
|
|
set errMsg "$errMsg\nHINT: the following module must be\
|
|
loaded first: $args"
|
|
}
|
|
error $errMsg
|
|
}
|
|
}\
|
|
elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "prereq\t\t$args"
|
|
}
|
|
|
|
return {}
|
|
}
|
|
|
|
proc x-resource {resource {value {}}} {
|
|
global g_newXResources g_delXResources env
|
|
|
|
set mode [currentMode]
|
|
|
|
reportDebug "x-resource: ($resource, $value)"
|
|
|
|
# sometimes x-resource value may be provided within resource name
|
|
# as the "x-resource {Ileaf.popup.saveUnder: True}" example provided
|
|
# in manpage. so here is an attempt to extract real resource name and
|
|
# value from resource argument
|
|
if {[string length $value] == 0 && ![file exists $resource]} {
|
|
# look first for a space character as delimiter, then for a colon
|
|
set sepapos [string first " " $resource]
|
|
if { $sepapos == -1 } {
|
|
set sepapos [string first ":" $resource]
|
|
}
|
|
|
|
if { $sepapos > -1 } {
|
|
set value [string range $resource [expr {$sepapos + 1}] end]
|
|
set resource [string range $resource 0 [expr {$sepapos - 1}]]
|
|
reportDebug "x-resource: corrected ($resource, $value)"
|
|
} else {
|
|
# if not a file and no value provided x-resource cannot be
|
|
# recorded as it will produce an error when passed to xrdb
|
|
reportWarning "x-resource $resource is not a valid string or file"
|
|
return {}
|
|
}
|
|
}
|
|
|
|
# check current environment can handle X11 resource edition elsewhere exit
|
|
if {($mode eq "load" || $mode eq "unload") &&\
|
|
[catch {runCommand xrdb -query} errMsg]} {
|
|
error "WARNING: X11 resources cannot be edited, issue spotted\n$errMsg"
|
|
}
|
|
|
|
# if a resource does hold an empty value in g_newXResources or
|
|
# g_delXResources arrays, it means this is a resource file to parse
|
|
if {$mode eq "load"} {
|
|
set g_newXResources($resource) $value
|
|
}\
|
|
elseif {$mode eq "unload"} {
|
|
set g_delXResources($resource) $value
|
|
}\
|
|
elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
report "x-resource\t$resource\t$value"
|
|
}
|
|
|
|
return {}
|
|
}
|
|
|
|
proc uname {what} {
|
|
global unameCache tcl_platform
|
|
set result {}
|
|
|
|
reportDebug "uname: called: $what"
|
|
|
|
if {! [info exists unameCache($what)]} {
|
|
switch -- $what {
|
|
{sysname} {
|
|
set result $tcl_platform(os)
|
|
}
|
|
{machine} {
|
|
set result $tcl_platform(machine)
|
|
}
|
|
{nodename} - {node} {
|
|
set result [runCommand uname -n]
|
|
}
|
|
{release} {
|
|
set result $tcl_platform(osVersion)
|
|
}
|
|
{domain} {
|
|
set result [runCommand domainname]
|
|
}
|
|
{version} {
|
|
set result [runCommand uname -v]
|
|
}
|
|
default {
|
|
error "uname $what not supported"
|
|
}
|
|
}
|
|
set unameCache($what) $result
|
|
}
|
|
|
|
return $unameCache($what)
|
|
}
|
|
|
|
proc system {mycmd args} {
|
|
reportDebug "system: $mycmd $args"
|
|
|
|
set mode [currentMode]
|
|
set status {}
|
|
|
|
if {$mode eq "load" || $mode eq "unload"} {
|
|
if {[catch {exec >&@stderr $mycmd $args}]} {
|
|
# non-zero exit status, get it:
|
|
set status [lindex $::errorCode 2]
|
|
} else {
|
|
# exit status was 0
|
|
set status 0
|
|
}
|
|
} elseif {$mode eq "display" && !$::g_inhibit_dispreport} {
|
|
if {[llength $args] == 0} {
|
|
report "system\t\t$mycmd"
|
|
} else {
|
|
report "system\t\t$mycmd $args"
|
|
}
|
|
}
|
|
|
|
return $status
|
|
}
|
|
|
|
# test at least one of the collections passed as argument exists
|
|
proc is-saved {args} {
|
|
reportDebug "is-saved: $args"
|
|
|
|
foreach coll $args {
|
|
lassign [getCollectionFilename $coll] collfile colldesc
|
|
if {[file exists $collfile]} {
|
|
return 1
|
|
}
|
|
}
|
|
# is something saved whatever it is?
|
|
if {[llength $args] == 0 && [llength [findCollections]] > 0} {
|
|
return 1
|
|
} else {
|
|
return 0
|
|
}
|
|
}
|
|
|
|
# test at least one of the directories passed as argument is set in MODULEPATH
|
|
proc is-used {args} {
|
|
reportDebug "is-used: $args"
|
|
|
|
set modpathlist [getModulePathList]
|
|
foreach path $args {
|
|
# transform given path in an absolute path which should have been
|
|
# registered in the MODULEPATH env var.
|
|
set abspath [getAbsolutePath $path]
|
|
if {[lsearch -exact $modpathlist $path] >= 0 ||\
|
|
[lsearch -exact $modpathlist $abspath] >= 0} {
|
|
return 1
|
|
}
|
|
}
|
|
# is something used whatever it is?
|
|
if {[llength $args] == 0 && [llength $modpathlist] > 0} {
|
|
return 1
|
|
} else {
|
|
return 0
|
|
}
|
|
}
|
|
|
|
# test at least one of the modulefiles passed as argument exists
|
|
proc is-avail {args} {
|
|
reportDebug "is-avail: $args"
|
|
set ret 0
|
|
|
|
# disable error reporting to avoid modulefile errors
|
|
# to pollute result. Only if not already inhibited
|
|
set alreadyinhibit [isErrorReportInhibited]
|
|
if {!$alreadyinhibit} {
|
|
inhibitErrorReport
|
|
}
|
|
|
|
foreach mod $args {
|
|
lassign [getPathToModule $mod] modfile modname
|
|
if {$modfile ne ""} {
|
|
set ret 1
|
|
break
|
|
}
|
|
}
|
|
|
|
# re-enable only is it was disabled from this procedure
|
|
if {!$alreadyinhibit} {
|
|
reenableErrorReport
|
|
}
|
|
return $ret
|
|
}
|
|
|
|
########################################################################
|
|
# internal module procedures
|
|
#
|
|
set g_modeStack {}
|
|
|
|
proc currentMode {} {
|
|
global g_modeStack
|
|
|
|
return [lindex $g_modeStack end]
|
|
}
|
|
|
|
proc pushMode {mode} {
|
|
global g_modeStack
|
|
|
|
lappend g_modeStack $mode
|
|
}
|
|
|
|
proc popMode {} {
|
|
global g_modeStack
|
|
|
|
set g_modeStack [lrange $g_modeStack 0 end-1]
|
|
}
|
|
|
|
set g_moduleNameStack {}
|
|
|
|
proc currentModuleName {} {
|
|
global g_moduleNameStack
|
|
|
|
return [lindex $g_moduleNameStack end]
|
|
}
|
|
|
|
proc pushModuleName {moduleName} {
|
|
global g_moduleNameStack
|
|
|
|
lappend g_moduleNameStack $moduleName
|
|
}
|
|
|
|
proc popModuleName {} {
|
|
global g_moduleNameStack
|
|
|
|
set g_moduleNameStack [lrange $g_moduleNameStack 0 end-1]
|
|
}
|
|
|
|
set g_specifiedNameStack {}
|
|
|
|
proc currentSpecifiedName {} {
|
|
global g_specifiedNameStack
|
|
|
|
return [lindex $g_specifiedNameStack end]
|
|
}
|
|
|
|
proc pushSpecifiedName {specifiedName} {
|
|
global g_specifiedNameStack
|
|
|
|
lappend g_specifiedNameStack $specifiedName
|
|
}
|
|
|
|
proc popSpecifiedName {} {
|
|
global g_specifiedNameStack
|
|
|
|
set g_specifiedNameStack [lrange $g_specifiedNameStack 0 end-1]
|
|
}
|
|
|
|
set g_commandNameStack {}
|
|
|
|
proc currentCommandName {} {
|
|
global g_commandNameStack
|
|
|
|
return [lindex $g_commandNameStack end]
|
|
}
|
|
|
|
proc pushCommandName {commandName} {
|
|
global g_commandNameStack
|
|
|
|
lappend g_commandNameStack $commandName
|
|
}
|
|
|
|
proc popCommandName {} {
|
|
global g_commandNameStack
|
|
|
|
set g_commandNameStack [lrange $g_commandNameStack 0 end-1]
|
|
}
|
|
|
|
|
|
# return list of loaded modules by parsing LOADEDMODULES env variable
|
|
proc getLoadedModuleList {} {
|
|
global env g_def_separator
|
|
|
|
if {[info exists env(LOADEDMODULES)]} {
|
|
return [split $env(LOADEDMODULES) $g_def_separator]
|
|
} else {
|
|
return {}
|
|
}
|
|
}
|
|
|
|
# return list of loaded module files by parsing _LMFILES_ env variable
|
|
proc getLoadedModuleFileList {} {
|
|
global env g_def_separator
|
|
|
|
if {[info exists env(_LMFILES_)]} {
|
|
return [split $env(_LMFILES_) $g_def_separator]
|
|
} else {
|
|
return {}
|
|
}
|
|
}
|
|
|
|
# return list of module paths by parsing MODULEPATH env variable
|
|
# behavior param enables to exit in error when no MODULEPATH env variable
|
|
# is set. by default an empty list is returned if no MODULEPATH set
|
|
proc getModulePathList {{behavior "returnempty"}} {
|
|
global env g_def_separator
|
|
|
|
if {[info exists env(MODULEPATH)]} {
|
|
return [split $env(MODULEPATH) $g_def_separator]
|
|
} elseif {$behavior eq "exiterronundef"} {
|
|
reportErrorAndExit "No module path defined"
|
|
} else {
|
|
return {}
|
|
}
|
|
}
|
|
|
|
# test if two modules share the same root name
|
|
proc isSameModuleRoot {mod1 mod2} {
|
|
set mod1split [split $mod1 "/"]
|
|
set mod2split [split $mod2 "/"]
|
|
|
|
return [expr {[lindex $mod1split 0] eq [lindex $mod2split 0]}]
|
|
}
|
|
|
|
# test if one element in module name has a leading "dot" making this module
|
|
# a hidden module
|
|
proc isModuleHidden {mod} {
|
|
foreach elt [split $mod "/"] {
|
|
if {[string index $elt 0] eq "."} {
|
|
return 1
|
|
}
|
|
}
|
|
return 0
|
|
}
|
|
|
|
# check if module name is specified as a full pathname (not a name relative
|
|
# to a modulepath)
|
|
proc isModuleFullPath {mod} {
|
|
if {[regexp {^(|\.|\.\.)/} $mod]} {
|
|
return 1
|
|
} else {
|
|
return 0
|
|
}
|
|
}
|
|
|
|
# Return the full pathname and modulename to the module.
|
|
# Resolve aliases and default versions if the module name is something like
|
|
# "name/version" or just "name" (find default version).
|
|
proc getPathToModule {mod {indir {}} {look_loaded "no"} {excdir {}}} {
|
|
global g_loadedModules
|
|
|
|
if {$mod eq ""} {
|
|
return [list "" 0]
|
|
}
|
|
|
|
reportDebug "getPathToModule: finding '$mod' in '$indir' (excdir='')"
|
|
|
|
# try first to look at loaded modules if enabled to find maching module
|
|
# or to find a closest match (used when switching with single name arg)
|
|
if {($look_loaded eq "match" && [set lm [getLoadedMatchingName\
|
|
$mod]] ne "") || ($look_loaded eq "close" && [set lm\
|
|
[getLoadedWithClosestName $mod]] ne "")} {
|
|
set retlist [list $g_loadedModules($lm) $lm]
|
|
# Check for $mod specified as a full pathname
|
|
} elseif {[isModuleFullPath $mod]} {
|
|
set mod [getAbsolutePath $mod]
|
|
# note that a raw filename as an argument returns the full
|
|
# path as the module name
|
|
lassign [checkValidModule $mod] check_valid check_msg
|
|
switch -- $check_valid {
|
|
{true} {
|
|
set retlist [list $mod $mod]
|
|
}
|
|
{invalid} - {accesserr} {
|
|
set retlist [list "" $mod $check_valid $check_msg $mod]
|
|
}
|
|
}
|
|
} else {
|
|
if {$indir ne ""} {
|
|
set dir_list $indir
|
|
} else {
|
|
set dir_list [getModulePathList "exiterronundef"]
|
|
}
|
|
# remove excluded directories (already searched)
|
|
foreach dir $excdir {
|
|
set dir_list [replaceFromList $dir_list $dir]
|
|
}
|
|
|
|
# modparent is the the modulename minus the module version.
|
|
lassign [getModuleNameVersion $mod] mod modparent modversion
|
|
set modroot [lindex [split $mod "/"] 0]
|
|
# determine if we need to get hidden modules
|
|
set fetch_hidden [isModuleHidden $mod]
|
|
|
|
# Now search for $mod in module paths
|
|
foreach dir $dir_list {
|
|
# get list of modules related to the root of searched module to get
|
|
# in one call a complete list of any module kind (file, alias, etc)
|
|
# related to search to be able to then determine in this proc the
|
|
# correct module to return without restarting new searches
|
|
array unset mod_list
|
|
array set mod_list [getModules $dir $modroot 0 "rc_defs_included"\
|
|
$fetch_hidden]
|
|
|
|
set prevmod ""
|
|
set mod_res ""
|
|
# loop to resolve correct modulefile in case specified mod is a
|
|
# directory that should be analyzed to get default mod in it
|
|
while {$prevmod ne $mod} {
|
|
set prevmod $mod
|
|
|
|
if {[info exists mod_list($mod)]} {
|
|
switch -- [lindex $mod_list($mod) 0] {
|
|
{alias} - {version} {
|
|
set newmod [resolveModuleVersionOrAlias $mod]
|
|
# continue search on newmod if module from same root and
|
|
# not hidden (if hidden search disabled) as mod_list
|
|
# already contains everything related to this root module
|
|
if {[isSameModuleRoot $mod $newmod] && ($fetch_hidden ||\
|
|
![isModuleHidden $newmod])} {
|
|
set mod $newmod
|
|
# indicate an alias or a symbol was solved
|
|
set mod_res $newmod
|
|
# elsewhere restart search on new modulename, constrained
|
|
# to specified dir if set
|
|
} else {
|
|
return [getPathToModule $newmod $indir]
|
|
}
|
|
}
|
|
{directory} {
|
|
# Move to default element in directory
|
|
set mod "$mod/[lindex $mod_list($mod) 1]"
|
|
}
|
|
{modulefile} {
|
|
# If mod was a file in this path, return that file
|
|
set retlist [list "$dir/$mod" $mod]
|
|
}
|
|
{invalid} - {accesserr} {
|
|
# may found mod but issue, so end search with error
|
|
set retlist [concat [list "" $mod] $mod_list($mod)]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
# break loop if found something (valid or invalid module)
|
|
# elsewhere go to next path
|
|
if {[info exists retlist]} {
|
|
break
|
|
# found nothing after solving a matching alias or symbol
|
|
} elseif {$mod_res eq $mod} {
|
|
lappend excdir $dir
|
|
# look for this name in the other module paths, so restart
|
|
# directory search from first dir in list to ensure precedence
|
|
return [getPathToModule $mod $indir "no" $excdir]
|
|
}
|
|
}
|
|
}
|
|
|
|
# set result if nothing found
|
|
if {![info exists retlist]} {
|
|
set retlist [list "" $mod "none" "Unable to locate a modulefile for\
|
|
'$mod'"]
|
|
}
|
|
if {[lindex $retlist 0] ne ""} {
|
|
reportDebug "getPathToModule: found '[lindex $retlist 0]' as\
|
|
'[lindex $retlist 1]'"
|
|
} else {
|
|
eval reportIssue [lrange $retlist 2 4]
|
|
}
|
|
return $retlist
|
|
}
|
|
|
|
# return the currently loaded module whose name is the closest to the
|
|
# name passed as argument. if no loaded module match at least one part
|
|
# of the passed name, an empty string is returned.
|
|
proc getLoadedWithClosestName {name} {
|
|
set ret ""
|
|
set retmax 0
|
|
|
|
if {[isModuleFullPath $name]} {
|
|
set fullname [getAbsolutePath $name]
|
|
# if module is passed as full modulefile path name, get corresponding
|
|
# short name from used modulepaths
|
|
if {[set shortname [findModuleNameFromModulefile $fullname]] ne ""} {
|
|
set namesplit [split $shortname "/"]
|
|
# or look at lmfile names to return the eventual exact match
|
|
} else {
|
|
global g_loadedModuleFiles
|
|
# if module is loaded with its full path name loadedmodules entry is
|
|
# equivalent to _lmfiles_ corresponding entry so only check _lmfiles_
|
|
if {[info exists g_loadedModuleFiles($fullname)]} {
|
|
set ret $g_loadedModuleFiles($fullname)
|
|
}
|
|
}
|
|
} else {
|
|
set namesplit [split $name "/"]
|
|
}
|
|
|
|
if {[info exists namesplit]} {
|
|
# compare name to each currently loaded module name
|
|
foreach mod [getLoadedModuleList] {
|
|
# if module loaded as fullpath but test name not, try to get loaded
|
|
# mod short name (with currently used modulepaths) to compare it
|
|
if {[isModuleFullPath $mod] && [set modname\
|
|
[findModuleNameFromModulefile $mod]] ne ""} {
|
|
set modsplit [split $modname "/"]
|
|
} else {
|
|
set modsplit [split $mod "/"]
|
|
}
|
|
|
|
# min expr function is not supported in Tcl8.4 and earlier
|
|
if {[llength $namesplit] < [llength $modsplit]} {
|
|
set imax [llength $namesplit]
|
|
} else {
|
|
set imax [llength $modsplit]
|
|
}
|
|
|
|
# compare each element of the name to find closest answer
|
|
# in case of equality, last loaded module will be returned as it
|
|
# overwrites previously found value
|
|
for {set i 0} {$i < $imax} {incr i} {
|
|
if {[lindex $modsplit $i] eq [lindex $namesplit $i]} {
|
|
if {$i >= $retmax} {
|
|
set retmax $i
|
|
set ret $mod
|
|
}
|
|
} else {
|
|
# end of match, go next mod
|
|
break
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
reportDebug "getLoadedWithClosestName: '$ret' closest to '$name'"
|
|
|
|
return $ret
|
|
}
|
|
|
|
# return the currently loaded module whose name is equal or include the name
|
|
# passed as argument. if no loaded module match, an empty string is returned.
|
|
proc getLoadedMatchingName {name {behavior "returnlast"}} {
|
|
set ret {}
|
|
set retmax 0
|
|
|
|
# if module is passed as full modulefile path name, look at lmfile names
|
|
# to return the eventual exact match
|
|
if {[isModuleFullPath $name]} {
|
|
global g_loadedModuleFiles
|
|
set mod [getAbsolutePath $name]
|
|
# if module is loaded with its full path name loadedmodules entry is
|
|
# equivalent to _lmfiles_ corresponding entry so only check _lmfiles_
|
|
if {[info exists g_loadedModuleFiles($mod)]} {
|
|
set ret $g_loadedModuleFiles($mod)
|
|
}
|
|
} else {
|
|
# compare name to each currently loaded module name, if multiple mod
|
|
# match name:
|
|
foreach mod [getLoadedModuleList] {
|
|
# if module loaded as fullpath but test name not, try to get loaded
|
|
# mod short name (with currently used modulepaths) to compare it
|
|
if {[isModuleFullPath $mod] && [set modname\
|
|
[findModuleNameFromModulefile $mod]] ne ""} {
|
|
set matchmod "$modname/"
|
|
} else {
|
|
set matchmod $mod
|
|
}
|
|
if {[string first "$name/" "$matchmod/"] == 0} {
|
|
switch -- $behavior {
|
|
{returnlast} {
|
|
# the last loaded module will be returned
|
|
set ret $mod
|
|
}
|
|
{returnfirst} {
|
|
# the first loaded module will be returned
|
|
set ret $mod
|
|
break
|
|
}
|
|
{returnall} {
|
|
# all loaded modules will be returned
|
|
lappend ret $mod
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
reportDebug "getLoadedMatchingName: '$ret' matches '$name'"
|
|
|
|
return $ret
|
|
}
|
|
|
|
proc runModulerc {} {
|
|
# Runs the global RC files if they exist
|
|
global env
|
|
global g_moduleAlias g_rcAlias g_moduleVersion g_rcVersion
|
|
set rclist {}
|
|
|
|
reportDebug "runModulerc: running..."
|
|
|
|
if {[info exists env(MODULERCFILE)]} {
|
|
# if MODULERCFILE is a dir, look at a modulerc file in it
|
|
if {[file isdirectory $env(MODULERCFILE)]\
|
|
&& [file isfile "$env(MODULERCFILE)/modulerc"]} {
|
|
lappend rclist "$env(MODULERCFILE)/modulerc"
|
|
} elseif {[file isfile $env(MODULERCFILE)]} {
|
|
lappend rclist $env(MODULERCFILE)
|
|
}
|
|
}
|
|
if {[info exists env(MODULESHOME)] && $env(MODULESHOME) ne ""\
|
|
&& [file isfile "$env(MODULESHOME)/etc/rc"]} {
|
|
lappend rclist "$env(MODULESHOME)/etc/rc"
|
|
}
|
|
if {[info exists env(HOME)] && [file isfile "$env(HOME)/.modulerc"]} {
|
|
lappend rclist "$env(HOME)/.modulerc"
|
|
}
|
|
|
|
foreach rc $rclist {
|
|
if {[file readable $rc]} {
|
|
reportDebug "runModulerc: Executing $rc"
|
|
cmdModuleSource "$rc"
|
|
}
|
|
}
|
|
|
|
# identify alias or symbolic version set in these global RC files to be
|
|
# able to include them or not in output or resolution processes
|
|
array set g_rcAlias [array get g_moduleAlias]
|
|
array set g_rcVersion [array get g_moduleVersion]
|
|
}
|
|
|
|
# manage settings to save as a stack to have a separate set of settings
|
|
# for each module loaded or unloaded in order to be able to restore the
|
|
# correct set in case of failure
|
|
proc pushSettings {} {
|
|
foreach var {env g_Aliases g_stateEnvVars g_stateAliases g_newXResource\
|
|
g_delXResource} {
|
|
eval "global g_SAVE_$var $var"
|
|
eval "lappend g_SAVE_$var \[array get $var\]"
|
|
}
|
|
}
|
|
|
|
proc popSettings {} {
|
|
foreach var {env g_Aliases g_stateEnvVars g_stateAliases g_newXResource\
|
|
g_delXResource} {
|
|
eval "global g_SAVE_$var"
|
|
eval "set g_SAVE_$var \[lrange \$g_SAVE_$var 0 end-1\]"
|
|
}
|
|
}
|
|
|
|
proc restoreSettings {} {
|
|
foreach var {env g_Aliases g_stateEnvVars g_stateAliases g_newXResource\
|
|
g_delXResource} {
|
|
eval "global g_SAVE_$var $var"
|
|
# clear current $var arrays
|
|
if {[info exists $var]} {
|
|
eval "unset $var; array set $var {}"
|
|
}
|
|
eval "array set $var \[lindex \$g_SAVE_$var end\]"
|
|
}
|
|
}
|
|
|
|
proc renderSettings {} {
|
|
global env g_Aliases g_shellType g_shell
|
|
global g_stateEnvVars g_stateAliases
|
|
global g_newXResources g_delXResources
|
|
global g_changeDir g_stdoutPuts error_count g_return_false g_return_text
|
|
global g_autoInit CSH_LIMIT cwd
|
|
|
|
reportDebug "renderSettings: called."
|
|
|
|
# required to work on cygwin, shouldn't hurt real linux
|
|
fconfigure stdout -translation lf
|
|
|
|
# preliminaries if there is stuff to render
|
|
if {$g_autoInit || [array size g_stateEnvVars] > 0 ||\
|
|
[array size g_stateAliases] > 0 || [array size g_newXResources] > 0 ||\
|
|
[array size g_delXResources] > 0 || [info exists g_changeDir] ||\
|
|
[info exists g_stdoutPuts] || [info exists g_return_text]} {
|
|
switch -- $g_shellType {
|
|
{python} {
|
|
puts stdout "import os"
|
|
}
|
|
}
|
|
set has_rendered 1
|
|
} else {
|
|
set has_rendered 0
|
|
}
|
|
|
|
if {$g_autoInit} {
|
|
renderAutoinit
|
|
}
|
|
|
|
# new environment variables
|
|
foreach var [array names g_stateEnvVars] {
|
|
if {$g_stateEnvVars($var) eq "new"} {
|
|
switch -- $g_shellType {
|
|
{csh} {
|
|
set val [charEscaped $env($var)]
|
|
# csh barfs on long env vars
|
|
if {$g_shell eq "csh" && [string length $val] >\
|
|
$CSH_LIMIT} {
|
|
if {$var eq "PATH"} {
|
|
reportWarning "PATH exceeds $CSH_LIMIT characters,\
|
|
truncating and appending /usr/bin:/bin ..."
|
|
set val [string range $val 0 [expr {$CSH_LIMIT\
|
|
- 1}]]:/usr/bin:/bin
|
|
} else {
|
|
reportWarning "$var exceeds $CSH_LIMIT characters,\
|
|
truncating..."
|
|
set val [string range $val 0 [expr {$CSH_LIMIT\
|
|
- 1}]]
|
|
}
|
|
}
|
|
puts stdout "setenv $var $val;"
|
|
}
|
|
{sh} {
|
|
puts stdout "$var=[charEscaped $env($var)];\
|
|
export $var;"
|
|
}
|
|
{fish} {
|
|
set val [charEscaped $env($var)]
|
|
# fish shell has special treatment for PATH variable
|
|
# so its value should be provided as a list separated
|
|
# by spaces not by semi-colons
|
|
if {$var eq "PATH"} {
|
|
regsub -all ":" $val " " val
|
|
}
|
|
puts stdout "set -xg $var $val;"
|
|
}
|
|
{tcl} {
|
|
set val [charEscaped $env($var) \"]
|
|
puts stdout "set env($var) \"$val\";"
|
|
}
|
|
{perl} {
|
|
set val [charEscaped $env($var) \']
|
|
puts stdout "\$ENV{'$var'} = '$val';"
|
|
}
|
|
{python} {
|
|
set val [charEscaped $env($var) \']
|
|
puts stdout "os.environ\['$var'\] = '$val'"
|
|
}
|
|
{ruby} {
|
|
set val [charEscaped $env($var) \']
|
|
puts stdout "ENV\['$var'\] = '$val'"
|
|
}
|
|
{lisp} {
|
|
set val [charEscaped $env($var) \"]
|
|
puts stdout "(setenv \"$var\" \"$val\")"
|
|
}
|
|
{cmake} {
|
|
set val [charEscaped $env($var) \"]
|
|
puts stdout "set(ENV{$var} \"$val\")"
|
|
}
|
|
{r} {
|
|
set val [charEscaped $env($var) \']
|
|
puts stdout "Sys.setenv('$var'='$val')"
|
|
}
|
|
{cmd} {
|
|
set val $env($var)
|
|
puts stdout "set $var=$val"
|
|
}
|
|
}
|
|
} elseif {$g_stateEnvVars($var) eq "del"} {
|
|
switch -- $g_shellType {
|
|
{csh} {
|
|
puts stdout "unsetenv $var;"
|
|
}
|
|
{sh} {
|
|
puts stdout "unset $var;"
|
|
}
|
|
{fish} {
|
|
puts stdout "set -e $var;"
|
|
}
|
|
{tcl} {
|
|
puts stdout "catch {unset env($var)};"
|
|
}
|
|
{cmd} {
|
|
puts stdout "set $var="
|
|
}
|
|
{perl} {
|
|
puts stdout "delete \$ENV{'$var'};"
|
|
}
|
|
{python} {
|
|
puts stdout "os.environ\['$var'\] = ''"
|
|
puts stdout "del os.environ\['$var'\]"
|
|
}
|
|
{ruby} {
|
|
puts stdout "ENV\['$var'\] = nil"
|
|
}
|
|
{lisp} {
|
|
puts stdout "(setenv \"$var\" nil)"
|
|
}
|
|
{cmake} {
|
|
puts stdout "unset(ENV{$var})"
|
|
}
|
|
{r} {
|
|
puts stdout "Sys.unsetenv('$var')"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
foreach var [array names g_stateAliases] {
|
|
if {$g_stateAliases($var) eq "new"} {
|
|
switch -- $g_shellType {
|
|
{csh} {
|
|
# set val [charEscaped $g_Aliases($var)]
|
|
set val $g_Aliases($var)
|
|
# Convert $n -> \!\!:n
|
|
regsub -all {\$([0-9]+)} $val {\\!\\!:\1} val
|
|
# Convert $* -> \!*
|
|
regsub -all {\$\*} $val {\\!*} val
|
|
puts stdout "alias $var '$val';"
|
|
}
|
|
{sh} {
|
|
set val $g_Aliases($var)
|
|
puts stdout "alias $var='$val';"
|
|
}
|
|
{fish} {
|
|
set val $g_Aliases($var)
|
|
puts stdout "alias $var '$val';"
|
|
}
|
|
}
|
|
} elseif {$g_stateAliases($var) eq "del"} {
|
|
switch -- $g_shellType {
|
|
{csh} {
|
|
puts stdout "unalias $var;"
|
|
}
|
|
{sh} {
|
|
puts stdout "unalias $var;"
|
|
}
|
|
{fish} {
|
|
puts stdout "functions -e $var;"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# preliminaries for x-resources stuff
|
|
if {[array size g_newXResources] > 0 || [array size g_delXResources] > 0} {
|
|
switch -- $g_shellType {
|
|
{python} {
|
|
puts stdout "import subprocess"
|
|
}
|
|
{ruby} {
|
|
puts stdout "require 'open3'"
|
|
}
|
|
}
|
|
}
|
|
|
|
# new x resources
|
|
if {[array size g_newXResources] > 0} {
|
|
# xrdb executable has already be verified in x-resource
|
|
set xrdb [getCommandPath "xrdb"]
|
|
foreach var [array names g_newXResources] {
|
|
set val $g_newXResources($var)
|
|
# empty val means that var is a file to parse
|
|
if {$val eq ""} {
|
|
switch -- $g_shellType {
|
|
{sh} - {csh} - {fish} {
|
|
puts stdout "$xrdb -merge $var;"
|
|
}
|
|
{tcl} {
|
|
puts stdout "exec $xrdb -merge $var;"
|
|
}
|
|
{perl} {
|
|
puts stdout "system(\"$xrdb -merge $var\");"
|
|
}
|
|
{python} {
|
|
set var [charEscaped $var \']
|
|
puts stdout "subprocess.Popen(\['$xrdb',\
|
|
'-merge', '$var'\])"
|
|
}
|
|
{ruby} {
|
|
set var [charEscaped $var \']
|
|
puts stdout "Open3.popen2('$xrdb -merge $var')"
|
|
}
|
|
{lisp} {
|
|
puts stdout "(shell-command-to-string \"$xrdb\
|
|
-merge $var\")"
|
|
}
|
|
{cmake} {
|
|
puts stdout "execute_process(COMMAND $xrdb -merge $var)"
|
|
}
|
|
{r} {
|
|
set var [charEscaped $var \']
|
|
puts stdout "system('$xrdb -merge $var')"
|
|
}
|
|
}
|
|
} else {
|
|
switch -- $g_shellType {
|
|
{sh} - {csh} - {fish} {
|
|
set var [charEscaped $var \"]
|
|
set val [charEscaped $val \"]
|
|
puts stdout "echo \"$var: $val\" | $xrdb -merge;"
|
|
}
|
|
{tcl} {
|
|
puts stdout "set XRDBPIPE \[open \"|$xrdb -merge\" r+\];"
|
|
set var [charEscaped $var \"]
|
|
set val [charEscaped $val \"]
|
|
puts stdout "puts \$XRDBPIPE \"$var: $val\";"
|
|
puts stdout "close \$XRDBPIPE;"
|
|
puts stdout "unset XRDBPIPE;"
|
|
}
|
|
{perl} {
|
|
puts stdout "open(XRDBPIPE, \"|$xrdb -merge\");"
|
|
set var [charEscaped $var \"]
|
|
set val [charEscaped $val \"]
|
|
puts stdout "print XRDBPIPE \"$var: $val\\n\";"
|
|
puts stdout "close XRDBPIPE;"
|
|
}
|
|
{python} {
|
|
set var [charEscaped $var \']
|
|
set val [charEscaped $val \']
|
|
puts stdout "subprocess.Popen(\['$xrdb', '-merge'\],\
|
|
stdin=subprocess.PIPE).communicate(input='$var:\
|
|
$val\\n')"
|
|
}
|
|
{ruby} {
|
|
set var [charEscaped $var \']
|
|
set val [charEscaped $val \']
|
|
puts stdout "Open3.popen2('$xrdb -merge') {|i,o,t| i.puts\
|
|
'$var: $val'}"
|
|
}
|
|
{lisp} {
|
|
puts stdout "(shell-command-to-string \"echo $var:\
|
|
$val | $xrdb -merge\")"
|
|
}
|
|
{cmake} {
|
|
set var [charEscaped $var \"]
|
|
set val [charEscaped $val \"]
|
|
puts stdout "execute_process(COMMAND echo \"$var: $val\"\
|
|
COMMAND $xrdb -merge)"
|
|
}
|
|
{r} {
|
|
set var [charEscaped $var \']
|
|
set val [charEscaped $val \']
|
|
puts stdout "system('$xrdb -merge', input='$var: $val')"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
if {[array size g_delXResources] > 0} {
|
|
set xrdb [getCommandPath "xrdb"]
|
|
set xres_to_del {}
|
|
foreach var [array names g_delXResources] {
|
|
# empty val means that var is a file to parse
|
|
if {$g_delXResources($var) eq ""} {
|
|
# xresource file has to be parsed to find what resources
|
|
# are declared there and need to be unset
|
|
foreach fline [split [exec $xrdb -n load $var] "\n"] {
|
|
lappend xres_to_del [lindex [split $fline ":"] 0]
|
|
}
|
|
} else {
|
|
lappend xres_to_del $var
|
|
}
|
|
}
|
|
|
|
# xresource strings are unset by emptying their value since there
|
|
# is no command of xrdb that can properly remove one property
|
|
switch -- $g_shellType {
|
|
{sh} - {csh} - {fish} {
|
|
foreach var $xres_to_del {
|
|
puts stdout "echo \"$var:\" | $xrdb -merge;"
|
|
}
|
|
}
|
|
{tcl} {
|
|
foreach var $xres_to_del {
|
|
puts stdout "set XRDBPIPE \[open \"|$xrdb -merge\" r+\];"
|
|
set var [charEscaped $var \"]
|
|
puts stdout "puts \$XRDBPIPE \"$var:\";"
|
|
puts stdout "close \$XRDBPIPE;"
|
|
puts stdout "unset XRDBPIPE;"
|
|
}
|
|
}
|
|
{perl} {
|
|
foreach var $xres_to_del {
|
|
puts stdout "open(XRDBPIPE, \"|$xrdb -merge\");"
|
|
set var [charEscaped $var \"]
|
|
puts stdout "print XRDBPIPE \"$var:\\n\";"
|
|
puts stdout "close XRDBPIPE;"
|
|
}
|
|
}
|
|
{python} {
|
|
foreach var $xres_to_del {
|
|
set var [charEscaped $var \']
|
|
puts stdout "subprocess.Popen(\['$xrdb', '-merge'\],\
|
|
stdin=subprocess.PIPE).communicate(input='$var:\\n')"
|
|
}
|
|
}
|
|
{ruby} {
|
|
foreach var $xres_to_del {
|
|
set var [charEscaped $var \']
|
|
puts stdout "Open3.popen2('$xrdb -merge') {|i,o,t| i.puts\
|
|
'$var:'}"
|
|
}
|
|
}
|
|
{lisp} {
|
|
foreach var $xres_to_del {
|
|
puts stdout "(shell-command-to-string \"echo $var: |\
|
|
$xrdb -merge\")"
|
|
}
|
|
}
|
|
{cmake} {
|
|
foreach var $xres_to_del {
|
|
set var [charEscaped $var \"]
|
|
puts stdout "execute_process(COMMAND echo \"$var:\"\
|
|
COMMAND $xrdb -merge)"
|
|
}
|
|
}
|
|
{r} {
|
|
foreach var $xres_to_del {
|
|
set var [charEscaped $var \']
|
|
puts stdout "system('$xrdb -merge', input='$var:')"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
if {[info exists g_changeDir]} {
|
|
switch -- $g_shellType {
|
|
{sh} - {csh} - {fish} {
|
|
puts stdout "cd '$g_changeDir';"
|
|
}
|
|
{tcl} {
|
|
puts stdout "cd \"$g_changeDir\";"
|
|
}
|
|
{perl} {
|
|
puts stdout "chdir '$g_changeDir';"
|
|
}
|
|
{python} {
|
|
puts stdout "os.chdir('$g_changeDir')"
|
|
}
|
|
{ruby} {
|
|
puts stdout "Dir.chdir('$g_changeDir')"
|
|
}
|
|
{lisp} {
|
|
puts stdout "(shell-command-to-string \"cd '$g_changeDir'\")"
|
|
}
|
|
{r} {
|
|
puts stdout "setwd('$g_changeDir')"
|
|
}
|
|
}
|
|
# cannot change current directory of cmake "shell"
|
|
}
|
|
|
|
# send content deferred during modulefile interpretation
|
|
if {[info exists g_stdoutPuts]} {
|
|
foreach putsArgs $g_stdoutPuts {
|
|
eval puts $putsArgs
|
|
# check if a finishing newline will be needed after content sent
|
|
if {[lindex $putsArgs 0] eq "-nonewline"} {
|
|
set needPutsNl 1
|
|
} else {
|
|
set needPutsNl 0
|
|
}
|
|
}
|
|
if {$needPutsNl} {
|
|
puts stdout ""
|
|
}
|
|
}
|
|
|
|
# return text value if defined even if error happened
|
|
if {[info exists g_return_text]} {
|
|
reportDebug "renderSettings: text value should be returned."
|
|
renderText $g_return_text
|
|
} elseif {$error_count > 0} {
|
|
reportDebug "renderSettings: $error_count error(s) detected."
|
|
renderFalse
|
|
} elseif {$g_return_false} {
|
|
reportDebug "renderSettings: false value should be returned."
|
|
renderFalse
|
|
} elseif {$has_rendered} {
|
|
# finish with true statement if something has been put
|
|
renderTrue
|
|
}
|
|
}
|
|
|
|
proc renderAutoinit {} {
|
|
global argv0 g_shellType g_shell
|
|
|
|
reportDebug "renderAutoinit: called."
|
|
|
|
# automatically detect which tclsh should be used for
|
|
# future module commands
|
|
set tclshbin [info nameofexecutable]
|
|
|
|
# ensure script path is absolute
|
|
set argv0 [getAbsolutePath $argv0]
|
|
|
|
switch -- $g_shellType {
|
|
{csh} {
|
|
set pre_hi {set _histchars = $histchars; unset histchars;}
|
|
set post_hi {set histchars = $_histchars; unset _histchars;}
|
|
set pre_pr {set _prompt="$prompt"; set prompt="";}
|
|
set post_pr {set prompt="$_prompt"; unset _prompt;}
|
|
set eval_cmd "eval `$tclshbin $argv0 $g_shell \\!*`;"
|
|
set pre_ex {set _exit="$status";}
|
|
set post_ex {test 0 = $_exit}
|
|
|
|
set fdef "if ( \$?histchars && \$?prompt )\
|
|
alias module '$pre_hi $pre_pr $eval_cmd $pre_ex $post_hi $post_pr $post_ex' ;
|
|
if ( \$?histchars && ! \$?prompt )\
|
|
alias module '$pre_hi $eval_cmd $pre_ex $post_hi $post_ex' ;
|
|
if ( ! \$?histchars && \$?prompt )\
|
|
alias module '$pre_pr $eval_cmd $pre_ex $post_pr $post_ex' ;
|
|
if ( ! \$?histchars && ! \$?prompt ) alias module '$eval_cmd' ;"
|
|
}
|
|
{sh} {
|
|
# adapt shell function to define local variable, as 'typeset' is
|
|
# not known by dash and 'local' is not known by ksh
|
|
if {$g_shell eq "sh"} {
|
|
set locf "local"
|
|
} else {
|
|
set locf "typeset"
|
|
}
|
|
# on zsh, word splitting should be enabled explicitly
|
|
if {$g_shell eq "zsh"} {
|
|
set wsplit "="
|
|
} else {
|
|
set wsplit ""
|
|
}
|
|
# only redirect module from stderr to stdout when session is
|
|
# attached to a terminal to avoid breaking non-terminal session
|
|
# (scp, sftp, etc)
|
|
if {[isStderrTty]} {
|
|
set fname "_moduleraw"
|
|
} else {
|
|
set fname "module"
|
|
}
|
|
# build quarantine mechanism in module function
|
|
# an empty runtime variable is set even if no corresponding
|
|
# MODULES_RUNENV_* variable found, as var cannot be unset on
|
|
# modified environment command-line
|
|
set fdef "${fname}() {
|
|
if \[ \"\$MODULES_SILENT_SHELL_DEBUG\" = '1' \]; then
|
|
case \"$-\" in
|
|
*v*x*) set +vx; $locf _mlshdbg='vx' ;;
|
|
*v*) set +v; $locf _mlshdbg='v' ;;
|
|
*x*) set +x; $locf _mlshdbg='x' ;;
|
|
*) $locf _mlshdbg='' ;;
|
|
esac;
|
|
fi;
|
|
$locf _mlre=''; $locf _mlv; $locf _mlrv;
|
|
if \[ -n \"\${IFS+x}\" \]; then
|
|
$locf _mlIFS=\$IFS;
|
|
fi;
|
|
IFS=' ';
|
|
for _mlv in \${${wsplit}MODULES_RUN_QUARANTINE}; do"
|
|
append fdef {
|
|
if [ "${_mlv}" = "${_mlv##*[!A-Za-z0-9_]}" -a "${_mlv}" = "${_mlv#[0-9]}" ]; then
|
|
if [ -n "`eval 'echo ${'$_mlv'+x}'`" ]; then
|
|
_mlre="${_mlre}${_mlv}_modquar='`eval 'echo ${'$_mlv'}'`' ";
|
|
fi;
|
|
_mlrv="MODULES_RUNENV_${_mlv}";
|
|
_mlre="${_mlre}${_mlv}='`eval 'echo ${'$_mlrv'}'`' ";
|
|
fi;
|
|
done;
|
|
if [ -n "$_mlre" ]; then
|
|
_mlre="eval ${_mlre}";
|
|
fi;}
|
|
append fdef "\n eval `\${${wsplit}_mlre}$tclshbin $argv0\
|
|
$g_shell \$*`;
|
|
$locf _mlstatus=\$?;\n"
|
|
append fdef { if [ -n "${_mlIFS+x}" ]; then
|
|
IFS=$_mlIFS;
|
|
else
|
|
unset IFS;
|
|
fi;
|
|
if [ -n "$_mlshdbg" ]; then
|
|
set -$_mlshdbg;
|
|
unset _mlshdbg;
|
|
fi;
|
|
return $_mlstatus;}
|
|
append fdef "\n};"
|
|
if {[isStderrTty]} {
|
|
append fdef "\nmodule() { _moduleraw \$* 2>&1; };"
|
|
}
|
|
}
|
|
{fish} {
|
|
if {[isStderrTty]} {
|
|
set fdef "function _moduleraw\n"
|
|
} else {
|
|
set fdef "function module\n"
|
|
}
|
|
append fdef { set -l _mlre ''; set -l _mlv; set -l _mlrv;
|
|
for _mlv in (string split ' ' $MODULES_RUN_QUARANTINE)
|
|
if string match -r '^[A-Za-z_][A-Za-z0-9_]*$' $_mlv >/dev/null
|
|
if set -q $_mlv
|
|
set _mlre $_mlre$_mlv"_modquar='$$_mlv' "
|
|
end
|
|
set _mlrv "MODULES_RUNENV_$_mlv"
|
|
set _mlre "$_mlre$_mlv='$$_mlrv' "
|
|
end
|
|
end
|
|
if [ -n "$_mlre" ]
|
|
set _mlre "env $_mlre"
|
|
end}
|
|
# use "| source -" rather than "eval" to be able
|
|
# to redirect stderr after stdout being evaluated
|
|
append fdef "\n eval \$_mlre $tclshbin $argv0 $g_shell \$argv\
|
|
| source -\n"
|
|
if {[isStderrTty]} {
|
|
append fdef {end
|
|
function module
|
|
_moduleraw $argv ^&1
|
|
end}
|
|
} else {
|
|
append fdef {end}
|
|
}
|
|
}
|
|
{tcl} {
|
|
set fdef "proc module {args} {\n"
|
|
append fdef { global env; set _mlre {};
|
|
if {[info exists env(MODULES_RUN_QUARANTINE)]} {
|
|
foreach _mlv [split $env(MODULES_RUN_QUARANTINE) " "] {
|
|
if {[regexp {^[A-Za-z_][A-Za-z0-9_]*$} $_mlv]} {
|
|
if {[info exists env($_mlv)]} {
|
|
lappend _mlre "${_mlv}_modquar=$env($_mlv)"
|
|
}
|
|
set _mlrv "MODULES_RUNENV_${_mlv}"
|
|
if {[info exists env($_mlrv)]} {
|
|
lappend _mlre "${_mlv}=$env($_mlrv)"
|
|
} else {
|
|
lappend _mlre "${_mlv}="
|
|
}
|
|
}
|
|
}
|
|
if {[llength $_mlre] > 0} {
|
|
set _mlre [linsert $_mlre 0 "env"]
|
|
}
|
|
}
|
|
set _mlstatus 1;}
|
|
append fdef "\n catch {eval exec \$_mlre \"$tclshbin\"\
|
|
\"$argv0\" \"$g_shell\" \$args 2>@stderr} script\n"
|
|
append fdef { eval $script;
|
|
return $_mlstatus}
|
|
append fdef "\n}"
|
|
}
|
|
{cmd} {
|
|
set fdef "start /b \%MODULESHOME\%/init/module.cmd %*"
|
|
}
|
|
{perl} {
|
|
set fdef "sub module {\n"
|
|
append fdef { my $_mlre = '';
|
|
if (defined $ENV{'MODULES_RUN_QUARANTINE'}) {
|
|
foreach my $_mlv (split(' ', $ENV{'MODULES_RUN_QUARANTINE'})) {
|
|
if ($_mlv =~ /^[A-Za-z_][A-Za-z0-9_]*$/) {
|
|
if (defined $ENV{$_mlv}) {
|
|
$_mlre .= "${_mlv}_modquar='$ENV{$_mlv}' ";
|
|
}
|
|
my $_mlrv = "MODULES_RUNENV_$_mlv";
|
|
$_mlre .= "$_mlv='$ENV{$_mlrv}' ";
|
|
}
|
|
}
|
|
if ($_mlre ne "") {
|
|
$_mlre = "env $_mlre";
|
|
}
|
|
}
|
|
my $_mlstatus = 1;}
|
|
append fdef "\n eval `\${_mlre}$tclshbin $argv0 perl @_`;\n"
|
|
append fdef { return $_mlstatus;}
|
|
append fdef "\n}"
|
|
}
|
|
{python} {
|
|
set fdef {import re, subprocess
|
|
def module(command, *arguments):
|
|
_mlre = os.environ.copy()
|
|
if 'MODULES_RUN_QUARANTINE' in os.environ:
|
|
for _mlv in os.environ['MODULES_RUN_QUARANTINE'].split():
|
|
if re.match('^[A-Za-z_][A-Za-z0-9_]*$', _mlv):
|
|
if _mlv in os.environ:
|
|
_mlre[_mlv + '_modquar'] = os.environ[_mlv]
|
|
_mlrv = 'MODULES_RUNENV_' + _mlv
|
|
if _mlrv in os.environ:
|
|
_mlre[_mlv] = os.environ[_mlrv]
|
|
else:
|
|
_mlre[_mlv] = ''
|
|
_mlstatus = True}
|
|
append fdef "\n exec(subprocess.Popen(\['$tclshbin',\
|
|
'$argv0', 'python', command\] +\
|
|
list(arguments),\
|
|
stdout=subprocess.PIPE, env=_mlre).communicate()\[0\])\n"
|
|
append fdef { return _mlstatus}
|
|
}
|
|
{ruby} {
|
|
set fdef {class ENVModule
|
|
def ENVModule.module(*args)
|
|
_mlre = ''
|
|
if ENV.has_key?('MODULES_RUN_QUARANTINE') then
|
|
ENV['MODULES_RUN_QUARANTINE'].split(' ').each do |_mlv|
|
|
if _mlv =~ /^[A-Za-z_][A-Za-z0-9_]*$/ then
|
|
if ENV.has_key?(_mlv) then
|
|
_mlre << _mlv + "_modquar='" + ENV[_mlv].to_s + "' "
|
|
end
|
|
_mlrv = 'MODULES_RUNENV_' + _mlv
|
|
_mlre << _mlv + "='" + ENV[_mlrv].to_s + "' "
|
|
end
|
|
end
|
|
unless _mlre.empty?
|
|
_mlre = 'env ' + _mlre
|
|
end
|
|
end
|
|
if args[0].kind_of?(Array) then
|
|
args = args[0].join(' ')
|
|
else
|
|
args = args.join(' ')
|
|
end
|
|
_mlstatus = true}
|
|
append fdef "\n eval `#{_mlre}$tclshbin $argv0 ruby #{args}`\n"
|
|
append fdef { return _mlstatus
|
|
end
|
|
end}
|
|
}
|
|
{lisp} {
|
|
reportErrorAndExit "lisp mode autoinit not yet implemented"
|
|
}
|
|
{cmake} {
|
|
set fdef {function(module)
|
|
set(_mlre "")
|
|
if(DEFINED ENV{MODULES_RUN_QUARANTINE})
|
|
string(REPLACE " " ";" _mlv_list "$ENV{MODULES_RUN_QUARANTINE}")
|
|
foreach(_mlv ${_mlv_list})
|
|
if(${_mlv} MATCHES "^[A-Za-z_][A-Za-z0-9_]*$")
|
|
if(DEFINED ENV{${_mlv}})
|
|
set(_mlre "${_mlre}${_mlv}_modquar=$ENV{${_mlv}};")
|
|
endif()
|
|
set(_mlrv "MODULES_RUNENV_${_mlv}")
|
|
set(_mlre "${_mlre}${_mlv}=$ENV{${_mlrv}};")
|
|
endif()
|
|
endforeach()
|
|
if (NOT "${_mlre}" STREQUAL "")
|
|
set(_mlre "env;${_mlre}")
|
|
endif()
|
|
endif()
|
|
set(_mlstatus TRUE)
|
|
execute_process(COMMAND mktemp -t moduleinit.cmake.XXXXXXXXXXXX
|
|
OUTPUT_VARIABLE tempfile_name)}
|
|
append fdef "\n execute_process(COMMAND \${_mlre} $tclshbin\
|
|
$argv0 cmake \${ARGV}\n"
|
|
append fdef { OUTPUT_FILE ${tempfile_name})
|
|
if(EXISTS ${tempfile_name})
|
|
include(${tempfile_name})
|
|
file(REMOVE ${tempfile_name})
|
|
endif()
|
|
set(module_result ${_mlstatus} PARENT_SCOPE)
|
|
endfunction(module)}
|
|
}
|
|
{r} {
|
|
set fdef "module <- function(...){\n"
|
|
append fdef { mlre <- ''
|
|
if (!is.na(Sys.getenv('MODULES_RUN_QUARANTINE', unset=NA))) {
|
|
for (mlv in strsplit(Sys.getenv('MODULES_RUN_QUARANTINE'), ' ')[[1]]) {
|
|
if (grepl('^[A-Za-z_][A-Za-z0-9_]*$', mlv)) {
|
|
if (!is.na(Sys.getenv(mlv, unset=NA))) {
|
|
mlre <- paste0(mlre, mlv, "_modquar='", Sys.getenv(mlv), "' ")
|
|
}
|
|
mlrv <- paste0('MODULES_RUNENV_', mlv)
|
|
mlre <- paste0(mlre, mlv, "='", Sys.getenv(mlrv), "' ")
|
|
}
|
|
}
|
|
if (mlre != '') {
|
|
mlre <- paste0('env ', mlre)
|
|
}
|
|
}
|
|
arglist <- as.list(match.call())
|
|
arglist[1] <- 'r'
|
|
args <- paste0(arglist, collapse=' ')}
|
|
append fdef "\n cmd <- paste(mlre, '$tclshbin', '$argv0', args,\
|
|
sep=' ')\n"
|
|
append fdef { mlstatus <- TRUE
|
|
hndl <- pipe(cmd)
|
|
eval(expr = parse(file=hndl))
|
|
close(hndl)
|
|
invisible(mlstatus)}
|
|
append fdef "\n}"
|
|
|
|
}
|
|
}
|
|
|
|
# output function definition
|
|
puts stdout $fdef
|
|
}
|
|
|
|
proc cacheCurrentModules {} {
|
|
global g_loadedModules g_loadedModuleFiles
|
|
|
|
reportDebug "cacheCurrentModules"
|
|
|
|
# mark specific as well as generic modules as loaded
|
|
set i 0
|
|
set filelist [getLoadedModuleFileList]
|
|
foreach mod [getLoadedModuleList] {
|
|
set g_loadedModules($mod) [lindex $filelist $i]
|
|
set g_loadedModuleFiles([lindex $filelist $i]) $mod
|
|
incr i
|
|
}
|
|
}
|
|
|
|
# This proc resolves module aliases or version aliases to the real module name
|
|
# and version.
|
|
proc resolveModuleVersionOrAlias {name} {
|
|
global g_moduleResolved
|
|
|
|
if {[info exists g_moduleResolved($name)]} {
|
|
set ret $g_moduleResolved($name)
|
|
} else {
|
|
set ret $name
|
|
}
|
|
|
|
reportDebug "resolveModuleVersionOrAlias: '$name' resolved to '$ret'"
|
|
|
|
return $ret
|
|
}
|
|
|
|
proc charEscaped {str {charlist { \\\t\{\}|<>!;#^$&*"'`()}}} {
|
|
return [regsub -all "\(\[$charlist\]\)" $str {\\\1}]
|
|
}
|
|
|
|
proc charUnescaped {str {charlist { \\\t\{\}|<>!;#^$&*"'`()}}} {
|
|
return [regsub -all "\\\\\(\[$charlist\]\)" $str {\1}]
|
|
}
|
|
|
|
# find command path and remember it
|
|
proc getCommandPath {cmd} {
|
|
return [lindex [auto_execok $cmd] 0]
|
|
}
|
|
|
|
# find then run command or raise error if command not found
|
|
proc runCommand {cmd args} {
|
|
set cmdpath [getCommandPath $cmd]
|
|
if {$cmdpath eq ""} {
|
|
error "WARNING: Command '$cmd' cannot be found"
|
|
} else {
|
|
return [eval exec $cmdpath $args]
|
|
}
|
|
}
|
|
|
|
proc getAbsolutePath {path} {
|
|
global cwd
|
|
# register pwd at first call
|
|
if {![info exists cwd]} {
|
|
set cwd [pwd]
|
|
}
|
|
|
|
set abslist {}
|
|
# get a first version of the absolute path by joining the current working
|
|
# directory to the given path. if given path is already absolute
|
|
# 'file join' will not break it as $cwd will be ignored as soon a
|
|
# beginning '/' character is found on $path. this first pass also clean
|
|
# extra '/' character. then each element of the path is analyzed to clear
|
|
# "." and ".." components.
|
|
foreach elt [file split [file join $cwd $path]] {
|
|
if {$elt eq ".."} {
|
|
# skip ".." element if it comes after root element, remove last
|
|
# element elsewhere
|
|
if {[llength $abslist] > 1} {
|
|
set abslist [lreplace $abslist end end]
|
|
}
|
|
# skip any "." element
|
|
} elseif {$elt ne "."} {
|
|
lappend abslist $elt
|
|
}
|
|
}
|
|
|
|
# return cleaned absolute path
|
|
return [eval file join $abslist]
|
|
}
|
|
|
|
# split string while ignore any separator character that is espaced
|
|
proc psplit {str sep} {
|
|
set previdx -1
|
|
set idx [string first $sep $str]
|
|
while {$idx != -1} {
|
|
# look ahead if found separator is escaped
|
|
if {[string index $str [expr {$idx-1}]] ne "\\"} {
|
|
# unescape any separator character when adding to list
|
|
lappend res [charUnescaped [string range $str [expr {$previdx+1}]\
|
|
[expr {$idx-1}]] $sep]
|
|
set previdx $idx
|
|
}
|
|
set idx [string first $sep $str [expr {$idx+1}]]
|
|
}
|
|
|
|
lappend res [charUnescaped [string range $str [expr {$previdx+1}] end]\
|
|
$sep]
|
|
|
|
return $res
|
|
}
|
|
|
|
# join list while escape any character equal to separator
|
|
proc pjoin {lst sep} {
|
|
set res ""
|
|
|
|
foreach elt $lst {
|
|
if {$res ne ""} {
|
|
append res $sep
|
|
}
|
|
# escape any separator character when adding to string
|
|
append res [charEscaped $elt $sep]
|
|
}
|
|
|
|
return $res
|
|
}
|
|
|
|
# provide a lreverse proc for Tcl8.4 and earlier
|
|
if {[info commands lreverse] eq ""} {
|
|
proc lreverse l {
|
|
set r {}
|
|
set i [llength $l]
|
|
while {[incr i -1] > 0} {
|
|
lappend r [lindex $l $i]
|
|
}
|
|
lappend r [lindex $l 0]
|
|
}
|
|
}
|
|
|
|
# provide a lassign proc for Tcl8.4 and earlier
|
|
if {[info commands lassign] eq ""} {
|
|
proc lassign {values args} {
|
|
uplevel 1 [list foreach $args [linsert $values end {}] break]
|
|
lrange $values [llength $args] end
|
|
}
|
|
}
|
|
|
|
proc replaceFromList {list1 item {item2 {}}} {
|
|
while {[set xi [lsearch -exact $list1 $item]] >= 0} {
|
|
if {[string length $item2] == 0} {
|
|
set list1 [lreplace $list1 $xi $xi]
|
|
} else {
|
|
set list1 [lreplace $list1 $xi $xi $item2]
|
|
}
|
|
}
|
|
|
|
return $list1
|
|
}
|
|
|
|
proc parseAccessIssue {modfile} {
|
|
global errorCode
|
|
|
|
# retrieve and return access issue message
|
|
if {[regexp {POSIX .* \{(.*)\}$} $errorCode match errMsg]} {
|
|
return "[string totitle $errMsg] on '$modfile'"
|
|
} else {
|
|
return "Cannot access '$modfile'"
|
|
}
|
|
}
|
|
|
|
proc checkValidModule {modfile} {
|
|
reportDebug "checkValidModule: $modfile"
|
|
|
|
# Check for valid module
|
|
if {[catch {
|
|
set fid [open $modfile r]
|
|
set fheader [read $fid 8]
|
|
close $fid
|
|
}]} {
|
|
set check_valid "accesserr"
|
|
set check_msg [parseAccessIssue $modfile]
|
|
} else {
|
|
if {$fheader eq "\#%Module"} {
|
|
set check_valid "true"
|
|
set check_msg ""
|
|
} else {
|
|
set check_valid "invalid"
|
|
set check_msg "Magic cookie '#%Module' missing"
|
|
}
|
|
}
|
|
|
|
return [list $check_valid $check_msg]
|
|
}
|
|
|
|
proc readModuleContent {modfile {report_read_issue 0} {must_have_cookie 1}} {
|
|
reportDebug "readModuleContent: $modfile"
|
|
|
|
# read file
|
|
if {[catch {
|
|
set fid [open $modfile r]
|
|
set fdata [read $fid]
|
|
close $fid
|
|
} errMsg ]} {
|
|
if {$report_read_issue} {
|
|
reportError [parseAccessIssue $modfile]
|
|
}
|
|
return {}
|
|
}
|
|
|
|
# check module validity if magic cookie is mandatory
|
|
if {[string first "\#%Module" $fdata] == 0 || !$must_have_cookie} {
|
|
return $fdata
|
|
} else {
|
|
reportInternalBug "Magic cookie '#%Module' missing" $modfile
|
|
return {}
|
|
}
|
|
}
|
|
|
|
# If given module maps to default or other symbolic versions, a list of
|
|
# those versions is returned. This takes module/version as an argument.
|
|
proc getVersAliasList {mod} {
|
|
global g_symbolHash
|
|
|
|
if {[info exists g_symbolHash($mod)]} {
|
|
set tag_list $g_symbolHash($mod)
|
|
} else {
|
|
set tag_list {}
|
|
}
|
|
|
|
reportDebug "getVersAliasList: '$mod' has tag list '$tag_list'"
|
|
|
|
return $tag_list
|
|
}
|
|
|
|
# finds all module-related files matching mod in the module path dir
|
|
proc findModules {dir {mod {}} {fetch_mtime 0} {fetch_hidden 0}} {
|
|
global ignoreDir
|
|
|
|
reportDebug "findModules: finding '$mod' in $dir\
|
|
(fetch_mtime=$fetch_mtime, fetch_hidden=$fetch_hidden)"
|
|
|
|
# use catch protection to handle non-readable and non-existent dir
|
|
if {[catch {
|
|
# On Cygwin, glob may change the $dir path if there are symlinks
|
|
# involved. So it is safest to reglob the $dir.
|
|
# example:
|
|
# [glob /home/stuff] -> "//homeserver/users0/stuff"
|
|
set dir [glob $dir]
|
|
set full_list [glob -nocomplain "$dir/$mod"]
|
|
}]} {
|
|
return {}
|
|
}
|
|
|
|
# remove trailing / needed on some platforms
|
|
regsub {\/$} $full_list {} full_list
|
|
|
|
array set mod_list {}
|
|
for {set i 0} {$i < [llength $full_list]} {incr i 1} {
|
|
set element [lindex $full_list $i]
|
|
set tag_list {}
|
|
|
|
# Cygwin TCL likes to append ".lnk" to the end of symbolic links.
|
|
# This is not necessary and pollutes the module names, so let's
|
|
# trim it off.
|
|
if { [isWin] } {
|
|
regsub {\.lnk$} $element {} element
|
|
}
|
|
|
|
set tail [file tail $element]
|
|
set modulename [getModuleNameFromModulepath $element $dir]
|
|
set add_ref_to_parent 0
|
|
if {[file isdirectory $element]} {
|
|
if {![info exists ignoreDir($tail)]} {
|
|
# try then catch any issue rather than test before trying
|
|
# workaround 'glob -nocomplain' which does not return permission
|
|
# error on Tcl 8.4, so we need to avoid registering issue if
|
|
# raised error is about a no match
|
|
set treat_dir 1
|
|
if {[catch {set elt_list [glob "$element/*"]} errMsg]} {
|
|
if {$errMsg eq "no files matched glob pattern\
|
|
\"$element/*\""} {
|
|
set elt_list {}
|
|
} else {
|
|
set mod_list($modulename) [list "accesserr"\
|
|
[parseAccessIssue $element] $element]
|
|
set treat_dir 0
|
|
}
|
|
}
|
|
if {$treat_dir} {
|
|
set mod_list($modulename) [list "directory"]
|
|
# Add each element in the current directory to the list
|
|
if {[file readable $element/.modulerc]} {
|
|
lappend full_list $element/.modulerc
|
|
}
|
|
if {[file readable $element/.version]} {
|
|
lappend full_list $element/.version
|
|
}
|
|
if {[llength $elt_list] > 0} {
|
|
set full_list [concat $full_list $elt_list]
|
|
}
|
|
# search for hidden files if asked
|
|
if {$fetch_hidden} {
|
|
foreach elt [glob -nocomplain -types hidden -directory\
|
|
$element -tails "*"] {
|
|
switch -- $elt {
|
|
{.modulerc} - {.version} - {.} - {..} { }
|
|
default {
|
|
lappend full_list $element/$elt
|
|
set hidden_list($element/$elt) 1
|
|
}
|
|
}
|
|
}
|
|
}
|
|
set add_ref_to_parent 1
|
|
}
|
|
}
|
|
} else {
|
|
switch -glob -- $tail {
|
|
{.modulerc} {
|
|
set mod_list($modulename) [list "modulerc"]
|
|
}
|
|
{.version} {
|
|
set mod_list($modulename) [list "modulerc"]
|
|
}
|
|
{*~} - {*,v} - {\#*\#} { }
|
|
default {
|
|
lassign [checkValidModule $element] check_valid check_msg
|
|
switch -- $check_valid {
|
|
{true} {
|
|
if {$fetch_mtime} {
|
|
set mtime [file mtime $element]
|
|
} else {
|
|
set mtime {}
|
|
}
|
|
set mod_list($modulename) [list "modulefile" $mtime]
|
|
# if modfile hidden, do not reference it in parent list
|
|
if {$fetch_hidden && [info exists\
|
|
hidden_list($element)]} {
|
|
set add_ref_to_parent 0
|
|
} else {
|
|
set add_ref_to_parent 1
|
|
}
|
|
}
|
|
default {
|
|
# register check error and relative message to get it in
|
|
# case of direct access of this module element, but no
|
|
# registering in parent directory structure as element
|
|
# is not valid
|
|
set mod_list($modulename) [list $check_valid $check_msg\
|
|
$element]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# add reference to parent structure
|
|
if {$add_ref_to_parent} {
|
|
set parentname [file dirname $modulename]
|
|
if {[info exists mod_list($parentname)]} {
|
|
lappend mod_list($parentname) $tail
|
|
}
|
|
}
|
|
}
|
|
|
|
reportDebug "findModules: found [array names mod_list]"
|
|
|
|
return [array get mod_list]
|
|
}
|
|
|
|
proc getModules {dir {mod {}} {fetch_mtime 0} {search {}} {fetch_hidden 0}} {
|
|
global ModulesCurrentModulefile
|
|
global g_sourceAlias g_sourceVersion g_resolvedPath
|
|
global g_rcAlias g_moduleAlias g_rcVersion g_moduleVersion
|
|
|
|
reportDebug "getModules: get '$mod' in $dir (fetch_mtime=$fetch_mtime,\
|
|
search=$search, fetch_hidden=$fetch_hidden)"
|
|
|
|
# if search for global or user rc alias only, no dir lookup is performed
|
|
# and aliases from g_rcAlias are returned
|
|
if {[lsearch -exact $search "rc_alias_only"] >= 0} {
|
|
set add_rc_defs 1
|
|
array set found_list {}
|
|
} else {
|
|
# find modules by searching with first path element if mod is a deep
|
|
# modulefile (elt1/etl2/vers) in order to catch all .modulerc and
|
|
# .version files of module-related parent directories in case we need
|
|
# to translate an alias or a version
|
|
set parentlist [split $mod "/"]
|
|
set findmod [lindex $parentlist 0]
|
|
# if searched mod is an empty or flat element append wildcard character
|
|
# to match anything starting with mod
|
|
if {[lsearch -exact $search "wild"] >= 0 &&\
|
|
[llength $parentlist] <= 1} {
|
|
append findmod "*"
|
|
}
|
|
# add alias/version definitions from global or user rc to result
|
|
if {[lsearch -exact $search "rc_defs_included"] >= 0} {
|
|
set add_rc_defs 1
|
|
} else {
|
|
set add_rc_defs 0
|
|
}
|
|
if {!$fetch_hidden} {
|
|
set fetch_hidden [isModuleHidden $mod]
|
|
reportDebug "getModules: is '$mod' requiring hidden search\
|
|
($fetch_hidden)"
|
|
}
|
|
array set found_list [findModules $dir $findmod $fetch_mtime\
|
|
$fetch_hidden]
|
|
}
|
|
|
|
array set dir_list {}
|
|
array set mod_list {}
|
|
foreach elt [lsort [array names found_list]] {
|
|
if {[lindex $found_list($elt) 0] eq "modulerc"} {
|
|
# push name to be found by module-alias and version
|
|
pushSpecifiedName $elt
|
|
pushModuleName $elt
|
|
# set is needed for execute-modulerc
|
|
set ModulesCurrentModulefile $dir/$elt
|
|
execute-modulerc $ModulesCurrentModulefile
|
|
popModuleName
|
|
popSpecifiedName
|
|
# add other entry kind to the result list
|
|
} elseif {[string match $mod* $elt]} {
|
|
set mod_list($elt) $found_list($elt)
|
|
# list dirs to rework their definition at the end
|
|
if {[lindex $found_list($elt) 0] eq "directory"} {
|
|
set dir_list($elt) 1
|
|
}
|
|
}
|
|
}
|
|
|
|
# add versions found when parsing .version or .modulerc files in this
|
|
# directory (skip versions not registered from this directory except if
|
|
# global or user rc definitions should be included)) if they match passed
|
|
# $mod (as for regular modulefiles)
|
|
foreach vers [array names g_moduleVersion -glob $mod*] {
|
|
set versmod $g_moduleVersion($vers)
|
|
if {($dir ne "" && [string first "$dir/" $g_sourceVersion($vers)] == 0)\
|
|
|| ($add_rc_defs && [info exists g_rcVersion($vers)])} {
|
|
set mod_list($vers) [list "version" $versmod]
|
|
}
|
|
# no reference add to parent directory structure as versions are virtual
|
|
|
|
# add the target of symbolic versions found when parsing .version or
|
|
# .modulerc files if these symbols match passed $mod (as for regular
|
|
# modulefiles). modulefile target of these version symbol should have
|
|
# been found previously to be added
|
|
if {![info exists mod_list($versmod)]} {
|
|
# exception made to hidden modulefile target which should not be
|
|
# found previously as not searched (except if we already look for
|
|
# hidden modules). in case symbolic version matches passed $mod
|
|
# look for this hidden target
|
|
if {$mod eq $vers && !$fetch_hidden && [isModuleHidden $versmod]} {
|
|
array set found_list [findModules $dir $versmod $fetch_mtime 1]
|
|
}
|
|
|
|
# symbolic version targets a modulefile most of the time
|
|
if {[info exists found_list($versmod)]} {
|
|
set mod_list($versmod) $found_list($versmod)
|
|
# but sometimes they may target an alias
|
|
} elseif {[info exists g_moduleAlias($versmod)]} {
|
|
lappend matching_versalias $versmod
|
|
}
|
|
}
|
|
}
|
|
|
|
# add aliases found when parsing .version or .modulerc files in this
|
|
# directory (skip aliases not registered from this directory except if
|
|
# global or user rc definitions should be included) if they match passed
|
|
# $mod (as for regular modulefiles) or if a symbolic versions targeting
|
|
# alias match passed $mod
|
|
set matching_alias [array names g_moduleAlias -glob $mod*]
|
|
if {[info exists matching_versalias]} {
|
|
foreach versalias $matching_versalias {
|
|
if {[lsearch -exact $matching_alias $versalias] == -1} {
|
|
lappend matching_alias $versalias
|
|
}
|
|
}
|
|
}
|
|
foreach alias $matching_alias {
|
|
if {($dir ne "" && [string first "$dir/" $g_sourceAlias($alias)] == 0)\
|
|
|| ($add_rc_defs && [info exists g_rcAlias($alias)])} {
|
|
set mod_list($alias) [list "alias" $g_moduleAlias($alias)]
|
|
|
|
# in case alias overwrites a directory definition
|
|
if {[info exists dir_list($alias)]} {
|
|
unset dir_list($alias)
|
|
}
|
|
|
|
# add reference to this alias version in parent structure
|
|
set parentname [file dirname $alias]
|
|
if {[info exists mod_list($parentname)]} {
|
|
lappend mod_list($parentname) [file tail $alias]
|
|
}
|
|
}
|
|
}
|
|
|
|
# work on directories integrated in the result list by registering
|
|
# default element in this dir and list of all child elements dictionary
|
|
# sorted, so last element in dir is also last element in this list
|
|
# this treatment happen at the end to find all directory entries in
|
|
# result list (alias included)
|
|
foreach dir [lsort [array names dir_list]] {
|
|
set elt_list [lsort -dictionary [lrange $mod_list($dir) 1 end]]
|
|
# remove dir from list if it is empty
|
|
if {[llength $elt_list] == 0} {
|
|
unset mod_list($dir)
|
|
# rework upper directories content if registered
|
|
while {[set par_dir [file dirname $dir]] ne "."\
|
|
&& [info exists mod_list($par_dir)]} {
|
|
set dir_name [file tail $dir]
|
|
set dir $par_dir
|
|
# get upper dir content without empty dir (as dir_list is sorted
|
|
# parent dir information have already been consolidated)
|
|
set elt_list [lsearch -all -inline -not -exact [lrange\
|
|
$mod_list($dir) 2 end] $dir_name]
|
|
# remove also parent dir if it becomes empty
|
|
if {[llength $elt_list] == 0} {
|
|
unset mod_list($dir)
|
|
} else {
|
|
# change default by last element if empty dir was default
|
|
set dfl_elt [lindex $mod_list($dir) 1]
|
|
if {$dfl_elt eq $dir_name} {
|
|
set dfl_elt [lindex $elt_list end]
|
|
}
|
|
set mod_list($dir) [concat [list "directory" $dfl_elt]\
|
|
$elt_list]
|
|
# no need to update upper directory as this one persists
|
|
break
|
|
}
|
|
}
|
|
} else {
|
|
# get default element (defined or implicit)
|
|
if {[info exists g_resolvedPath($dir)]} {
|
|
set dfl_elt [file tail $g_resolvedPath($dir)]
|
|
} else {
|
|
set dfl_elt [lindex $elt_list end]
|
|
}
|
|
set mod_list($dir) [concat [list "directory" $dfl_elt] $elt_list]
|
|
}
|
|
}
|
|
|
|
reportDebug "getModules: got [array names mod_list]"
|
|
|
|
return [array get mod_list]
|
|
}
|
|
|
|
# Finds all module versions for mod in the module path dir
|
|
proc listModules {dir mod {show_flags {1}} {filter {}} {search "wild"}} {
|
|
global ignoreDir ModulesCurrentModulefile
|
|
global flag_default_mf flag_default_dir show_modtimes
|
|
|
|
reportDebug "listModules: get '$mod' in $dir\
|
|
(show_flags=$show_flags, filter=$filter, search=$search)"
|
|
|
|
# report flags for directories and modulefiles depending on show_flags
|
|
# procedure argument and global variables
|
|
if {$show_flags && $flag_default_mf} {
|
|
set show_flags_mf 1
|
|
} else {
|
|
set show_flags_mf 0
|
|
}
|
|
if {$show_flags && $flag_default_dir} {
|
|
set show_flags_dir 1
|
|
} else {
|
|
set show_flags_dir 0
|
|
}
|
|
if {$show_flags && $show_modtimes} {
|
|
set show_mtime 1
|
|
} else {
|
|
set show_mtime 0
|
|
}
|
|
|
|
# get module list
|
|
# as we treat a full directory content do not exit on an error
|
|
# raised from one modulerc file
|
|
array set mod_list [getModules $dir $mod $show_mtime $search]
|
|
|
|
# prepare results for display
|
|
set clean_list {}
|
|
foreach elt [array names mod_list] {
|
|
set elt_type [lindex $mod_list($elt) 0]
|
|
|
|
set add_to_clean_list 1
|
|
if {$filter ne ""} {
|
|
# only analyze directories or modulefile at the root in case of
|
|
# result filtering. depending on filter kind the selection of the
|
|
# modulefile to display will be made using the definition
|
|
# information of its upper directory
|
|
if {$elt_type eq "directory"} {
|
|
switch -- $filter {
|
|
{onlydefaults} {
|
|
set elt_vers [lindex $mod_list($elt) 1]
|
|
}
|
|
{onlylatest} {
|
|
set elt_vers [lindex $mod_list($elt) end]
|
|
}
|
|
}
|
|
# switch to selected modulefile to display
|
|
append elt "/$elt_vers"
|
|
# verify it exists elsewhere skip result for this directory
|
|
if {![info exists mod_list($elt)]} {
|
|
continue
|
|
}
|
|
set elt_type [lindex $mod_list($elt) 0]
|
|
# skip if directory selected, will be looked at in a next round
|
|
if {$elt_type eq "directory"} {
|
|
set add_to_clean_list 0
|
|
}
|
|
} elseif {[file dirname $elt] ne "."} {
|
|
set add_to_clean_list 0
|
|
}
|
|
|
|
if {$add_to_clean_list} {
|
|
set tag_list [getVersAliasList $elt]
|
|
}
|
|
} else {
|
|
set tag_list [getVersAliasList $elt]
|
|
# do not add a dir if it does not hold tags
|
|
if {$elt_type eq "directory" && [llength $tag_list] == 0} {
|
|
set add_to_clean_list 0
|
|
}
|
|
}
|
|
|
|
if {$add_to_clean_list} {
|
|
switch -- $elt_type {
|
|
{directory} {
|
|
if {$show_flags_dir} {
|
|
if {$show_mtime} {
|
|
lappend clean_list [format "%-40s%-20s" $elt\
|
|
[join $tag_list ":"]]
|
|
} else {
|
|
lappend clean_list [join [list $elt "("\
|
|
[join $tag_list ":"] ")"] {}]
|
|
}
|
|
} else {
|
|
lappend clean_list $elt
|
|
}
|
|
}
|
|
{modulefile} {
|
|
if {$show_mtime} {
|
|
# add to display file modification time in addition
|
|
# to potential tags
|
|
lappend clean_list [format "%-40s%-20s%19s" $elt\
|
|
[join $tag_list ":"]\
|
|
[clock format [lindex $mod_list($elt) 1]\
|
|
-format "%Y/%m/%d %H:%M:%S"]]
|
|
} elseif {$show_flags_mf && [llength $tag_list] > 0} {
|
|
lappend clean_list [join [list $elt "("\
|
|
[join $tag_list ":"] ")"] {}]
|
|
} else {
|
|
lappend clean_list $elt
|
|
}
|
|
}
|
|
{alias} {
|
|
if {$show_mtime} {
|
|
lappend clean_list [format "%-40s%-20s"\
|
|
"$elt -> [lindex $mod_list($elt) 1]"\
|
|
[join $tag_list ":"]]
|
|
} elseif {$show_flags_mf} {
|
|
lappend tag_list "@"
|
|
lappend clean_list [join [list $elt "("\
|
|
[join $tag_list ":"] ")"] {}]
|
|
} else {
|
|
lappend clean_list $elt
|
|
}
|
|
}
|
|
}
|
|
# ignore "version" entries as symbolic version are treated
|
|
# along to their relative modulefile not independently
|
|
}
|
|
}
|
|
|
|
# always dictionary-sort results
|
|
set clean_list [lsort -dictionary $clean_list]
|
|
reportDebug "listModules: Returning $clean_list"
|
|
|
|
return $clean_list
|
|
}
|
|
|
|
proc showModulePath {} {
|
|
reportDebug "showModulePath"
|
|
|
|
set modpathlist [getModulePathList]
|
|
if {[llength $modpathlist] > 0} {
|
|
report "Search path for module files (in search order):"
|
|
foreach path $modpathlist {
|
|
report " $path"
|
|
}
|
|
} else {
|
|
reportWarning "No directories on module search path"
|
|
}
|
|
}
|
|
|
|
proc displayTableHeader {args} {
|
|
set first 1
|
|
foreach title $args {
|
|
if {$first} {
|
|
set first 0
|
|
if {[llength $args] > 2} {
|
|
set col_len 39
|
|
} else {
|
|
set col_len 59
|
|
}
|
|
} else {
|
|
set col_len 19
|
|
}
|
|
|
|
set col "- $title "
|
|
append col [string repeat {-} [expr {$col_len - [string length $col]}]]
|
|
lappend col_list $col
|
|
}
|
|
|
|
report [join $col_list "."]
|
|
}
|
|
|
|
proc displaySeparatorLine {{title {}}} {
|
|
|
|
if {$title eq ""} {
|
|
report "[string repeat {-} 67]"
|
|
} else {
|
|
set tty_cols [getTtyColumns]
|
|
set len [string length $title]
|
|
# max expr function is not supported in Tcl8.4 and earlier
|
|
if {[set lrep [expr {($tty_cols - $len - 2)/2}]] < 1} {
|
|
set lrep 1
|
|
}
|
|
if {[set rrep [expr {$tty_cols - $len - 2 - $lrep}]] < 1} {
|
|
set rrep 1
|
|
}
|
|
report "[string repeat {-} $lrep] $title [string repeat {-} $rrep]"
|
|
}
|
|
}
|
|
|
|
# get a list of elements and print them in a column or in a
|
|
# one-per-line fashion
|
|
proc displayElementList {header hstyle one_per_line display_idx args} {
|
|
global g_eltlist_disp
|
|
|
|
set elt_cnt [llength $args]
|
|
reportDebug "displayElementList: header=$header, hstyle=$hstyle,\
|
|
elt_cnt=$elt_cnt, one_per_line=$one_per_line, display_idx=$display_idx"
|
|
|
|
# display header if any provided
|
|
if {$header ne "noheader"} {
|
|
# if list already displayed, separate with a blank line before header
|
|
if {![info exists g_eltlist_disp]} {
|
|
set g_eltlist_disp 1
|
|
} else {
|
|
report ""
|
|
}
|
|
|
|
if {$hstyle eq "sepline"} {
|
|
displaySeparatorLine $header
|
|
} else {
|
|
report "$header:"
|
|
}
|
|
}
|
|
|
|
# end proc if no element are to print
|
|
if {$elt_cnt == 0} {
|
|
return
|
|
}
|
|
|
|
# display one element per line
|
|
if {$one_per_line} {
|
|
if {$display_idx} {
|
|
set idx 1
|
|
foreach elt $args {
|
|
report [format "%2d) %s " $idx $elt]
|
|
incr idx
|
|
}
|
|
} else {
|
|
foreach elt $args {
|
|
report $elt
|
|
}
|
|
}
|
|
# elsewhere display elements in columns
|
|
} else {
|
|
if {$display_idx} {
|
|
# save room for numbers and spacing: 2 digits + ) + space
|
|
set elt_prefix_len 4
|
|
} else {
|
|
set elt_prefix_len 0
|
|
}
|
|
# save room for two spaces after element
|
|
set elt_suffix_len 2
|
|
|
|
# compute rows*cols grid size with optimized column number
|
|
# the size of each column is computed to display as much column
|
|
# as possible on each line
|
|
set max_len 0
|
|
foreach arg $args {
|
|
lappend elt_len [set len [expr {[string length $arg] +\
|
|
$elt_suffix_len}]]
|
|
if {$len > $max_len} {
|
|
set max_len $len
|
|
}
|
|
}
|
|
|
|
set tty_cols [getTtyColumns]
|
|
# find valid grid by starting with non-optimized solution where each
|
|
# column length is equal to the length of the biggest element to display
|
|
set cur_cols [expr {int($tty_cols / $max_len)}]
|
|
# when display is found too short to display even one column
|
|
if {$cur_cols == 0} {
|
|
set cols 1
|
|
set rows $elt_cnt
|
|
array set col_width [list 0 $max_len]
|
|
} else {
|
|
set cols 0
|
|
}
|
|
set last_round 0
|
|
set restart_loop 0
|
|
while {$cur_cols > $cols} {
|
|
if {!$restart_loop} {
|
|
if {$last_round} {
|
|
incr cur_rows
|
|
} else {
|
|
set cur_rows [expr {int(ceil(double($elt_cnt) / $cur_cols))}]
|
|
}
|
|
for {set i 0} {$i < $cur_cols} {incr i} {
|
|
set cur_col_width($i) 0
|
|
}
|
|
for {set i 0} {$i < $cur_rows} {incr i} {
|
|
set row_width($i) 0
|
|
}
|
|
set istart 0
|
|
} else {
|
|
set istart [expr {$col * $cur_rows}]
|
|
# only remove width of elements from current col
|
|
for {set row 0} {$row < ($i % $cur_rows)} {incr row} {
|
|
incr row_width($row) -[expr {$pre_col_width + $elt_prefix_len}]
|
|
}
|
|
}
|
|
set restart_loop 0
|
|
for {set i $istart} {$i < $elt_cnt} {incr i} {
|
|
set col [expr {int($i / $cur_rows)}]
|
|
set row [expr {$i % $cur_rows}]
|
|
# restart loop if a column width change
|
|
if {[lindex $elt_len $i] > $cur_col_width($col)} {
|
|
set pre_col_width $cur_col_width($col)
|
|
set cur_col_width($col) [lindex $elt_len $i]
|
|
set restart_loop 1
|
|
break
|
|
}
|
|
# end search of maximum number of columns if computed row width
|
|
# is larger than terminal width
|
|
if {[incr row_width($row) +[expr {$cur_col_width($col) \
|
|
+ $elt_prefix_len}]] > $tty_cols} {
|
|
# start last optimization pass by increasing row number until
|
|
# reaching number used for previous column number, by doing so
|
|
# this number of column may pass in terminal width, if not
|
|
# fallback to previous number of column
|
|
if {$last_round && $cur_rows == $rows} {
|
|
incr cur_cols -1
|
|
} else {
|
|
set last_round 1
|
|
}
|
|
break
|
|
}
|
|
}
|
|
# went through all elements without reaching terminal width limit so
|
|
# this number of column solution is valid, try next with a greater
|
|
# column number
|
|
if {$i == $elt_cnt} {
|
|
set cols $cur_cols
|
|
set rows $cur_rows
|
|
array set col_width [array get cur_col_width]
|
|
# number of column is fixed if last optimization round has started
|
|
# reach end also if there is only one row of results
|
|
if {!$last_round && $rows > 1} {
|
|
incr cur_cols
|
|
}
|
|
}
|
|
|
|
}
|
|
reportDebug "displayElementList: list=$args"
|
|
reportDebug "displayElementList: rows/cols=$rows/$cols,\
|
|
lastcol_item_cnt=[expr {int($elt_cnt % $rows)}]"
|
|
|
|
for {set row 0} {$row < $rows} {incr row} {
|
|
for {set col 0} {$col < $cols} {incr col} {
|
|
set index [expr {$col * $rows + $row}]
|
|
if {$index < $elt_cnt} {
|
|
if {$display_idx} {
|
|
append displist [format "%2d) %-$col_width($col)s"\
|
|
[expr {$index +1}] [lindex $args $index]]
|
|
} else {
|
|
append displist [format "%-$col_width($col)s"\
|
|
[lindex $args $index]]
|
|
}
|
|
}
|
|
}
|
|
append displist "\n"
|
|
}
|
|
report "$displist" -nonewline
|
|
}
|
|
}
|
|
|
|
# build list of what to undo then do to move
|
|
# from an initial list to a target list
|
|
proc getMovementBetweenList {from to} {
|
|
reportDebug "getMovementBetweenList: from($from) to($to)"
|
|
|
|
set undo {}
|
|
set do {}
|
|
|
|
# determine what element to undo then do
|
|
# to restore a target list from a current list
|
|
# with preservation of the element order
|
|
if {[llength $to] > [llength $from]} {
|
|
set imax [llength $to]
|
|
} else {
|
|
set imax [llength $from]
|
|
}
|
|
set list_equal 1
|
|
for {set i 0} {$i < $imax} {incr i} {
|
|
set to_obj [lindex $to $i]
|
|
set from_obj [lindex $from $i]
|
|
|
|
if {$to_obj ne $from_obj} {
|
|
set list_equal 0
|
|
}
|
|
if {$list_equal == 0} {
|
|
if {$to_obj ne ""} {
|
|
lappend do $to_obj
|
|
}
|
|
if {$from_obj ne ""} {
|
|
lappend undo $from_obj
|
|
}
|
|
}
|
|
}
|
|
|
|
return [list $undo $do]
|
|
}
|
|
|
|
# build list of currently loaded modules where modulename
|
|
# is registered minus module version if loaded version is
|
|
# the default one. a helper list may be provided and looked
|
|
# at if no module path is set
|
|
proc getSimplifiedLoadedModuleList {{helper_raw_list {}}\
|
|
{helper_list {}}} {
|
|
reportDebug "getSimplifiedLoadedModuleList"
|
|
|
|
set curr_mod_list {}
|
|
set modpathlist [getModulePathList]
|
|
foreach mod [getLoadedModuleList] {
|
|
if {[string length $mod] > 0} {
|
|
set modparent [file dirname $mod]
|
|
if {$modparent eq "."} {
|
|
lappend curr_mod_list $mod
|
|
} elseif {[llength $modpathlist] > 0} {
|
|
# fetch all module version available
|
|
set modlist {}
|
|
foreach dir $modpathlist {
|
|
if {[file isdirectory $dir]} {
|
|
set modlist [listModules $dir $modparent 0 "onlydefaults"]
|
|
# quit loop if result found
|
|
if {[llength $modlist] > 0} {
|
|
break
|
|
}
|
|
}
|
|
}
|
|
# check if loaded version is default
|
|
if {[lsearch -exact $modlist $mod] >-1 } {
|
|
lappend curr_mod_list $modparent
|
|
} else {
|
|
lappend curr_mod_list $mod
|
|
}
|
|
} else {
|
|
# if no path set currently, cannot search for all
|
|
# available version so use helper lists if provided
|
|
set helper_idx [lsearch -exact $helper_raw_list $mod]
|
|
if {$helper_idx == -1} {
|
|
lappend curr_mod_list $mod
|
|
} else {
|
|
# if mod found in a previous LOADEDMODULES list use
|
|
# simplified version of this module found in relative
|
|
# helper list (previously computed simplified list)
|
|
lappend curr_mod_list [lindex $helper_list $helper_idx]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
return $curr_mod_list
|
|
}
|
|
|
|
# get collection target currently set if any.
|
|
# a target is a domain on which a collection is only valid.
|
|
# when a target is set, only the collections made for that target
|
|
# will be available to list and restore, and saving will register
|
|
# the target footprint
|
|
proc getCollectionTarget {} {
|
|
global env
|
|
|
|
if {[info exists env(MODULES_COLLECTION_TARGET)]} {
|
|
return $env(MODULES_COLLECTION_TARGET)
|
|
} else {
|
|
return ""
|
|
}
|
|
}
|
|
|
|
# should modulefile version be pinned when saving collection?
|
|
proc pinVersionInCollection {} {
|
|
global env
|
|
|
|
if {[info exists env(MODULES_COLLECTION_PIN_VERSION)] &&\
|
|
$env(MODULES_COLLECTION_PIN_VERSION) eq "1"} {
|
|
return 1
|
|
} else {
|
|
return 0
|
|
}
|
|
}
|
|
|
|
# return saved collections found in user directory which corresponds to
|
|
# enabled collection target if any set.
|
|
proc findCollections {} {
|
|
global env
|
|
|
|
set coll_search "$env(HOME)/.module/*"
|
|
|
|
# find saved collections (matching target suffix)
|
|
set colltarget [getCollectionTarget]
|
|
if {$colltarget ne ""} {
|
|
append coll_search ".$colltarget"
|
|
}
|
|
|
|
# workaround 'glob -nocomplain' which does not return permission
|
|
# error on Tcl 8.4, so we need to avoid raising error if no match
|
|
if {[catch {set coll_list [glob $coll_search]} errMsg ]} {
|
|
if {$errMsg eq "no files matched glob pattern \"$coll_search\""} {
|
|
set coll_list {}
|
|
} else {
|
|
reportErrorAndExit "Cannot access collection directory.\n$errMsg"
|
|
}
|
|
}
|
|
|
|
return $coll_list
|
|
}
|
|
|
|
# get filename corresponding to collection name provided as argument.
|
|
# name provided may already be a file name. collection description name
|
|
# (with target info if any) is returned along with collection filename
|
|
proc getCollectionFilename {coll} {
|
|
global env
|
|
|
|
# initialize description with collection name
|
|
set colldesc $coll
|
|
|
|
# is collection a filepath
|
|
if {[string first "/" $coll] > -1} {
|
|
# collection target has no influence when
|
|
# collection is specified as a filepath
|
|
set collfile "$coll"
|
|
# elsewhere collection is a name
|
|
} elseif {[info exists env(HOME)]} {
|
|
set collfile "$env(HOME)/.module/$coll"
|
|
# if a target is set, append the suffix corresponding
|
|
# to this target to the collection file name
|
|
set colltarget [getCollectionTarget]
|
|
if {$colltarget ne ""} {
|
|
append collfile ".$colltarget"
|
|
# add knowledge of collection target on description
|
|
append colldesc " (for target \"$colltarget\")"
|
|
}
|
|
} else {
|
|
reportErrorAndExit "HOME not defined"
|
|
}
|
|
|
|
return [list $collfile $colldesc]
|
|
}
|
|
|
|
# generate collection content based on provided path and module lists
|
|
proc formatCollectionContent {path_list mod_list} {
|
|
set content ""
|
|
|
|
# start collection content with modulepaths
|
|
foreach path $path_list {
|
|
# 'module use' prepends paths by default so we clarify
|
|
# path order here with --append flag
|
|
append content "module use --append $path" "\n"
|
|
}
|
|
|
|
# then add modules
|
|
foreach mod $mod_list {
|
|
append content "module load $mod" "\n"
|
|
}
|
|
|
|
return $content
|
|
}
|
|
|
|
# read given collection file and return the path and module lists it defines
|
|
proc readCollectionContent {collfile colldesc} {
|
|
# init lists (maybe coll does not set mod to load)
|
|
set path_list {}
|
|
set mod_list {}
|
|
|
|
# read file
|
|
if {[catch {
|
|
set fid [open $collfile r]
|
|
set fdata [split [read $fid] "\n"]
|
|
close $fid
|
|
} errMsg ]} {
|
|
reportErrorAndExit "Collection $colldesc cannot be read.\n$errMsg"
|
|
}
|
|
|
|
# analyze collection content
|
|
foreach fline $fdata {
|
|
if {[regexp {module use (.*)$} $fline match patharg] == 1} {
|
|
# paths are appended by default
|
|
set stuff_path "append"
|
|
# manage with "split" multiple paths and path options
|
|
# specified on single line, for instance:
|
|
# module use --append path1 path2 path3
|
|
foreach path [split $patharg] {
|
|
# following path is asked to be appended
|
|
if {($path eq "--append") || ($path eq "-a")\
|
|
|| ($path eq "-append")} {
|
|
set stuff_path "append"
|
|
# following path is asked to be prepended
|
|
# collection generated with 'save' does not prepend
|
|
} elseif {($path eq "--prepend") || ($path eq "-p")\
|
|
|| ($path eq "-prepend")} {
|
|
set stuff_path "prepend"
|
|
} else {
|
|
# ensure given path is absolute to be able to correctly
|
|
# compare with paths registered in MODULEPATH
|
|
set path [getAbsolutePath $path]
|
|
# add path to end of list
|
|
if {$stuff_path eq "append"} {
|
|
lappend path_list $path
|
|
# insert path to first position
|
|
} else {
|
|
set path_list [linsert $path_list 0 $path]
|
|
}
|
|
}
|
|
}
|
|
} elseif {[regexp {module load (.*)$} $fline match modarg] == 1} {
|
|
# manage multiple modules specified on a
|
|
# single line with "split", for instance:
|
|
# module load mod1 mod2 mod3
|
|
set mod_list [concat $mod_list [split $modarg]]
|
|
}
|
|
}
|
|
|
|
return [list $path_list $mod_list]
|
|
}
|
|
|
|
|
|
########################################################################
|
|
# command line commands
|
|
#
|
|
proc cmdModuleList {} {
|
|
global show_oneperline show_modtimes
|
|
global g_loadedModules
|
|
|
|
set loadedmodlist [getLoadedModuleList]
|
|
|
|
if {[llength $loadedmodlist] == 0} {
|
|
report "No Modulefiles Currently Loaded."
|
|
} else {
|
|
set list {}
|
|
if {$show_modtimes} {
|
|
displayTableHeader "Package" "Versions" "Last mod."
|
|
}
|
|
report "Currently Loaded Modulefiles:"
|
|
set display_list {}
|
|
if {$show_modtimes || $show_oneperline} {
|
|
set display_idx 0
|
|
set one_per_line 1
|
|
} else {
|
|
set display_idx 1
|
|
set one_per_line 0
|
|
}
|
|
|
|
foreach mod $loadedmodlist {
|
|
if {[string length $mod] > 0} {
|
|
if {$show_oneperline} {
|
|
lappend display_list $mod
|
|
} else {
|
|
# skip rc find and execution if mod is registered as full path
|
|
if {[isModuleFullPath $mod]} {
|
|
set mtime [file mtime $mod]
|
|
set tag_list {}
|
|
} else {
|
|
# call getModules to find and execute rc files for this mod
|
|
set dir [getModulepathFromModuleName $g_loadedModules($mod)\
|
|
$mod]
|
|
array set mod_list [getModules $dir $mod $show_modtimes]
|
|
set mtime [lindex $mod_list($mod) 1]
|
|
set tag_list [getVersAliasList $mod]
|
|
}
|
|
|
|
if {$show_modtimes} {
|
|
# add to display file modification time in addition
|
|
# to potential tags
|
|
lappend display_list [format "%-40s%-20s%19s" $mod\
|
|
[join $tag_list ":"]\
|
|
[clock format $mtime -format "%Y/%m/%d %H:%M:%S"]]
|
|
} else {
|
|
if {[llength $tag_list]} {
|
|
append mod "(" [join $tag_list ":"] ")"
|
|
}
|
|
lappend display_list $mod
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
eval displayElementList "noheader" "{}" $one_per_line $display_idx\
|
|
$display_list
|
|
}
|
|
}
|
|
|
|
proc cmdModuleDisplay {args} {
|
|
reportDebug "cmdModuleDisplay: displaying $args"
|
|
|
|
pushMode "display"
|
|
set first_report 1
|
|
foreach mod $args {
|
|
lassign [getPathToModule $mod] modfile modname
|
|
if {$modfile ne ""} {
|
|
pushSpecifiedName $mod
|
|
pushModuleName $modname
|
|
# only one separator lines between 2 modules
|
|
if {$first_report} {
|
|
displaySeparatorLine
|
|
set first_report 0
|
|
}
|
|
report "$modfile:\n"
|
|
execute-modulefile $modfile
|
|
popModuleName
|
|
popSpecifiedName
|
|
displaySeparatorLine
|
|
}
|
|
}
|
|
popMode
|
|
}
|
|
|
|
proc cmdModulePaths {mod} {
|
|
global g_return_text
|
|
|
|
reportDebug "cmdModulePaths: ($mod)"
|
|
|
|
set dir_list [getModulePathList "exiterronundef"]
|
|
foreach dir $dir_list {
|
|
array unset mod_list
|
|
array set mod_list [getModules $dir $mod 0 "rc_defs_included"]
|
|
|
|
# prepare list of dirs for alias/symbol target search, will first search
|
|
# in currently looked dir, then in other dirs following precedence order
|
|
set target_dir_list [concat [list $dir] [replaceFromList $dir_list\
|
|
$dir]]
|
|
|
|
# build list of modulefile to print
|
|
foreach elt [array names mod_list] {
|
|
switch -- [lindex $mod_list($elt) 0] {
|
|
{modulefile} {
|
|
lappend g_return_text $dir/$elt
|
|
}
|
|
{alias} - {version} {
|
|
# resolve alias target
|
|
set aliastarget [lindex $mod_list($elt) 1]
|
|
lassign [getPathToModule $aliastarget $target_dir_list]\
|
|
modfile modname
|
|
# add module target as result instead of alias
|
|
if {$modfile ne "" && ![info exists mod_list($modname)]} {
|
|
lappend g_return_text $modfile
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# sort results if any and remove duplicates
|
|
if {[info exists g_return_text]} {
|
|
set g_return_text [lsort -dictionary -unique $g_return_text]
|
|
} else {
|
|
# set empty value to return empty if no result
|
|
set g_return_text ""
|
|
}
|
|
}
|
|
|
|
proc cmdModulePath {mod} {
|
|
global g_return_text
|
|
|
|
reportDebug "cmdModulePath: ($mod)"
|
|
lassign [getPathToModule $mod] modfile modname
|
|
# if no result set empty value to return empty
|
|
set g_return_text $modfile
|
|
}
|
|
|
|
proc cmdModuleWhatIs {{mod {}}} {
|
|
cmdModuleSearch $mod {}
|
|
}
|
|
|
|
proc cmdModuleApropos {{search {}}} {
|
|
cmdModuleSearch {} $search
|
|
}
|
|
|
|
proc cmdModuleSearch {{mod {}} {search {}}} {
|
|
global g_whatis g_inhibit_errreport
|
|
|
|
reportDebug "cmdModuleSearch: ($mod, $search)"
|
|
|
|
# disable error reporting to avoid modulefile errors
|
|
# to mix with valid search results
|
|
inhibitErrorReport
|
|
|
|
lappend searchmod "rc_defs_included"
|
|
if {$mod eq ""} {
|
|
lappend searchmod "wild"
|
|
}
|
|
set foundmod 0
|
|
pushMode "whatis"
|
|
set dir_list [getModulePathList "exiterronundef"]
|
|
foreach dir $dir_list {
|
|
array unset mod_list
|
|
array set mod_list [getModules $dir $mod 0 $searchmod]
|
|
array unset interp_list
|
|
array set interp_list {}
|
|
|
|
# build list of modulefile to interpret
|
|
foreach elt [array names mod_list] {
|
|
switch -- [lindex $mod_list($elt) 0] {
|
|
{modulefile} {
|
|
set interp_list($elt) $dir/$elt
|
|
# register module name in a global list (shared across
|
|
# modulepaths) to get hints when solving aliases/version
|
|
set full_list($elt) 1
|
|
}
|
|
{alias} - {version} {
|
|
# resolve alias target
|
|
set elt_target [lindex $mod_list($elt) 1]
|
|
if {![info exists full_list($elt_target)]} {
|
|
lassign [getPathToModule $elt_target $dir]\
|
|
modfile modname issuetype issuemsg
|
|
# add module target as result instead of alias
|
|
if {$modfile ne "" && ![info exists mod_list($modname)]} {
|
|
set interp_list($modname) $modfile
|
|
set full_list($modname) 1
|
|
} elseif {$modfile eq ""} {
|
|
# if module target not found in current modulepath add to
|
|
# list for global search after initial modulepath lookup
|
|
if {[string first "Unable to locate" $issuemsg] == 0} {
|
|
set extra_search($modname) [list $dir [expr {$elt eq\
|
|
$mod}]]
|
|
# register resolution error if alias name matches search
|
|
} elseif {$elt eq $mod} {
|
|
set err_list($modname) [list $issuetype $issuemsg]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
{invalid} - {accesserr} {
|
|
# register any error occuring on element matching search
|
|
if {$elt eq $mod} {
|
|
set err_list($elt) $mod_list($elt)
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# in case during modulepath lookup we find an alias target we were
|
|
# looking for in previous modulepath, remove this element from global
|
|
# search list
|
|
foreach elt [array names extra_search] {
|
|
if {[info exists full_list($elt)]} {
|
|
unset extra_search($elt)
|
|
}
|
|
}
|
|
|
|
# save results from this modulepath for interpretation step as there
|
|
# is an extra round of search to match missing alias target, we cannot
|
|
# process modulefiles found immediately
|
|
if {[array size interp_list] > 0} {
|
|
set interp_save($dir) [array get interp_list]
|
|
}
|
|
}
|
|
|
|
# find target of aliases in all modulepath except the one already tried
|
|
foreach elt [array names extra_search] {
|
|
lassign [getPathToModule $elt "" "no" [lindex $extra_search($elt) 0]]\
|
|
modfile modname issuetype issuemsg issuefile
|
|
# found target so append it to results in corresponding modulepath
|
|
if {$modfile ne ""} {
|
|
set dir [getModulepathFromModuleName $modfile $modname]
|
|
array unset interp_list
|
|
if {[info exists interp_save($dir)]} {
|
|
array set interp_list $interp_save($dir)
|
|
}
|
|
set interp_list($modname) $modfile
|
|
set interp_save($dir) [array get interp_list]
|
|
# register resolution error if primal alias name matches search
|
|
} elseif {$modfile eq "" && [lindex $extra_search($elt) 1]} {
|
|
set err_list($modname) [list $issuetype $issuemsg $issuefile]
|
|
}
|
|
}
|
|
|
|
# interpret all modulefile we got for each modulepath
|
|
foreach dir $dir_list {
|
|
if {[info exists interp_save($dir)]} {
|
|
array unset interp_list
|
|
array set interp_list $interp_save($dir)
|
|
set foundmod 1
|
|
set display_list {}
|
|
# interpret every modulefiles obtained to get their whatis text
|
|
foreach elt [lsort -dictionary [array names interp_list]] {
|
|
set g_whatis {}
|
|
pushSpecifiedName $elt
|
|
pushModuleName $elt
|
|
execute-modulefile $interp_list($elt)
|
|
popModuleName
|
|
popSpecifiedName
|
|
|
|
# treat whatis as a multi-line text
|
|
if {$search eq "" || [regexp -nocase $search $g_whatis]} {
|
|
foreach line $g_whatis {
|
|
lappend display_list [format "%20s: %s" $elt $line]
|
|
}
|
|
}
|
|
}
|
|
|
|
if {[llength $display_list] > 0} {
|
|
eval displayElementList $dir "sepline" 1 0 $display_list
|
|
}
|
|
}
|
|
}
|
|
popMode
|
|
|
|
reenableErrorReport
|
|
|
|
# report errors if a modulefile was searched but not found
|
|
if {$mod ne "" && !$foundmod} {
|
|
# no error registered means nothing was found to match search
|
|
if {![array exists err_list]} {
|
|
set err_list($mod) [list "none" "Unable to locate a modulefile for\
|
|
'$mod'"]
|
|
}
|
|
foreach elt [array names err_list] {
|
|
eval reportIssue $err_list($elt)
|
|
}
|
|
}
|
|
}
|
|
|
|
proc cmdModuleSwitch {old {new {}}} {
|
|
# if a single name is provided it matches for the module to load and in
|
|
# this case the module to unload is searched to find the closest match
|
|
# (loaded module that shares at least the same root name)
|
|
if {$new eq ""} {
|
|
set new $old
|
|
set unload_match "close"
|
|
} else {
|
|
set unload_match "match"
|
|
}
|
|
|
|
reportDebug "cmdModuleSwitch: old='$old' new='$new'"
|
|
|
|
# attempt load only if unload succeed
|
|
if {![cmdModuleUnload $unload_match $old]} {
|
|
cmdModuleLoad $new
|
|
}
|
|
}
|
|
|
|
proc cmdModuleSave {{coll {}}} {
|
|
# default collection used if no name provided
|
|
if {$coll eq ""} {
|
|
set coll "default"
|
|
}
|
|
reportDebug "cmdModuleSave: $coll"
|
|
|
|
# format collection content, version number of modulefile are saved if
|
|
# version pinning is enabled
|
|
if {[pinVersionInCollection]} {
|
|
set curr_mod_list [getLoadedModuleList]
|
|
} else {
|
|
set curr_mod_list [getSimplifiedLoadedModuleList]
|
|
}
|
|
set save [formatCollectionContent [getModulePathList] $curr_mod_list]
|
|
|
|
if { [string length $save] == 0} {
|
|
reportErrorAndExit "Nothing to save in a collection"
|
|
}
|
|
|
|
# get coresponding filename and its directory
|
|
lassign [getCollectionFilename $coll] collfile colldesc
|
|
set colldir [file dirname $collfile]
|
|
|
|
if {![file exists $colldir]} {
|
|
reportDebug "cmdModuleSave: Creating $colldir"
|
|
file mkdir $colldir
|
|
} elseif {![file isdirectory $colldir]} {
|
|
reportErrorAndExit "$colldir exists but is not a directory"
|
|
}
|
|
|
|
reportDebug "cmdModuleSave: Saving $collfile"
|
|
|
|
if {[catch {
|
|
set fid [open $collfile w]
|
|
puts $fid $save
|
|
close $fid
|
|
} errMsg ]} {
|
|
reportErrorAndExit "Collection $colldesc cannot be saved.\n$errMsg"
|
|
}
|
|
}
|
|
|
|
proc cmdModuleRestore {{coll {}}} {
|
|
# default collection used if no name provided
|
|
if {$coll eq ""} {
|
|
set coll "default"
|
|
}
|
|
reportDebug "cmdModuleRestore: $coll"
|
|
|
|
# get coresponding filename
|
|
lassign [getCollectionFilename $coll] collfile colldesc
|
|
|
|
if {![file exists $collfile]} {
|
|
reportErrorAndExit "Collection $colldesc cannot be found"
|
|
}
|
|
|
|
# read collection
|
|
lassign [readCollectionContent $collfile $colldesc] coll_path_list\
|
|
coll_mod_list
|
|
|
|
# collection should at least define a path
|
|
if {[llength $coll_path_list] == 0} {
|
|
reportErrorAndExit "$colldesc is not a valid collection"
|
|
}
|
|
|
|
# fetch what is currently loaded
|
|
set curr_path_list [getModulePathList]
|
|
# get current loaded module list in simplified and raw versions
|
|
# these lists may be used later on, see below
|
|
set curr_mod_list_raw [getLoadedModuleList]
|
|
set curr_mod_list [getSimplifiedLoadedModuleList]
|
|
|
|
# determine what module to unload to restore collection
|
|
# from current situation with preservation of the load order
|
|
lassign [getMovementBetweenList $curr_mod_list $coll_mod_list] \
|
|
mod_to_unload mod_to_load
|
|
# determine unload movement with raw loaded list in case versions are
|
|
# pinning in saved collection
|
|
lassign [getMovementBetweenList $curr_mod_list_raw $coll_mod_list] \
|
|
mod_to_unload_raw mod_to_load_raw
|
|
if {[llength $mod_to_unload] > [llength $mod_to_unload_raw]} {
|
|
set mod_to_unload $mod_to_unload_raw
|
|
}
|
|
|
|
# proceed as well for modulepath
|
|
lassign [getMovementBetweenList $curr_path_list $coll_path_list] \
|
|
path_to_unuse path_to_use
|
|
|
|
# unload modules
|
|
if {[llength $mod_to_unload] > 0} {
|
|
eval cmdModuleUnload "match" [lreverse $mod_to_unload]
|
|
}
|
|
# unuse paths
|
|
if {[llength $path_to_unuse] > 0} {
|
|
eval cmdModuleUnuse [lreverse $path_to_unuse]
|
|
}
|
|
|
|
# since unloading a module may unload other modules or
|
|
# paths, what to load/use has to be determined after
|
|
# the undo phase, so current situation is fetched again
|
|
set curr_path_list [getModulePathList]
|
|
|
|
# here we may be in a situation were no more path is left
|
|
# in module path, so we cannot easily compute the simplified loaded
|
|
# module list. so we provide two helper lists: simplified and raw
|
|
# versions of the loaded module list computed before starting to
|
|
# unload modules. these helper lists may help to learn the
|
|
# simplified counterpart of a loaded module if it was already loaded
|
|
# before starting to unload modules
|
|
set curr_mod_list [getSimplifiedLoadedModuleList\
|
|
$curr_mod_list_raw $curr_mod_list]
|
|
set curr_mod_list_raw [getLoadedModuleList]
|
|
|
|
# determine what module to load to restore collection
|
|
# from current situation with preservation of the load order
|
|
lassign [getMovementBetweenList $curr_mod_list $coll_mod_list] \
|
|
mod_to_unload mod_to_load
|
|
# determine load movement with raw loaded list in case versions are
|
|
# pinning in saved collection
|
|
lassign [getMovementBetweenList $curr_mod_list_raw $coll_mod_list] \
|
|
mod_to_unload_raw mod_to_load_raw
|
|
if {[llength $mod_to_load] > [llength $mod_to_load_raw]} {
|
|
set mod_to_load $mod_to_load_raw
|
|
}
|
|
|
|
# proceed as well for modulepath
|
|
lassign [getMovementBetweenList $curr_path_list $coll_path_list] \
|
|
path_to_unuse path_to_use
|
|
|
|
# use paths
|
|
if {[llength $path_to_use] > 0} {
|
|
# always append path here to guaranty the order
|
|
# computed above in the movement lists
|
|
eval cmdModuleUse --append $path_to_use
|
|
}
|
|
|
|
# load modules
|
|
if {[llength $mod_to_load] > 0} {
|
|
eval cmdModuleLoad $mod_to_load
|
|
}
|
|
}
|
|
|
|
proc cmdModuleSaverm {{coll {}}} {
|
|
# default collection used if no name provided
|
|
if {$coll eq ""} {
|
|
set coll "default"
|
|
}
|
|
reportDebug "cmdModuleSaverm: $coll"
|
|
|
|
# avoid to remove any kind of file with this command
|
|
if {[string first "/" $coll] > -1} {
|
|
reportErrorAndExit "Command does not remove collection specified as\
|
|
filepath"
|
|
}
|
|
|
|
# get coresponding filename
|
|
lassign [getCollectionFilename $coll] collfile colldesc
|
|
|
|
if {![file exists $collfile]} {
|
|
reportErrorAndExit "Collection $colldesc cannot be found"
|
|
}
|
|
|
|
# attempt to delete specified colletion
|
|
if {[catch {
|
|
file delete $collfile
|
|
} errMsg ]} {
|
|
reportErrorAndExit "Collection $colldesc cannot be removed.\n$errMsg"
|
|
}
|
|
}
|
|
|
|
proc cmdModuleSaveshow {{coll {}}} {
|
|
# default collection used if no name provided
|
|
if {$coll eq ""} {
|
|
set coll "default"
|
|
}
|
|
reportDebug "cmdModuleSaveshow: $coll"
|
|
|
|
# get coresponding filename
|
|
lassign [getCollectionFilename $coll] collfile colldesc
|
|
|
|
if {![file exists $collfile]} {
|
|
reportErrorAndExit "Collection $colldesc cannot be found"
|
|
}
|
|
|
|
# read collection
|
|
lassign [readCollectionContent $collfile $colldesc] coll_path_list\
|
|
coll_mod_list
|
|
|
|
# collection should at least define a path
|
|
if {[llength $coll_path_list] == 0} {
|
|
reportErrorAndExit "$colldesc is not a valid collection"
|
|
}
|
|
|
|
displaySeparatorLine
|
|
report "$collfile:\n"
|
|
report [formatCollectionContent $coll_path_list $coll_mod_list]
|
|
displaySeparatorLine
|
|
}
|
|
|
|
proc cmdModuleSavelist {} {
|
|
global show_oneperline show_modtimes
|
|
|
|
# if a target is set, only list collection matching this
|
|
# target (means having target as suffix in their name)
|
|
set colltarget [getCollectionTarget]
|
|
if {$colltarget ne ""} {
|
|
set suffix ".$colltarget"
|
|
set targetdesc " (for target \"$colltarget\")"
|
|
} else {
|
|
set suffix ""
|
|
set targetdesc ""
|
|
}
|
|
|
|
reportDebug "cmdModuleSavelist: list collections for target\
|
|
\"$colltarget\""
|
|
|
|
set coll_list [findCollections]
|
|
|
|
if { [llength $coll_list] == 0} {
|
|
report "No named collection$targetdesc."
|
|
} else {
|
|
set list {}
|
|
if {$show_modtimes} {
|
|
displayTableHeader "Collection" "Last mod."
|
|
}
|
|
report "Named collection list$targetdesc:"
|
|
set display_list {}
|
|
if {$show_modtimes || $show_oneperline} {
|
|
set display_idx 0
|
|
set one_per_line 1
|
|
} else {
|
|
set display_idx 1
|
|
set one_per_line 0
|
|
}
|
|
|
|
foreach coll [lsort -dictionary $coll_list] {
|
|
# remove target suffix from names to display
|
|
regsub "$suffix$" [file tail $coll] {} mod
|
|
|
|
if {[string length $mod] > 0} {
|
|
if {$show_modtimes} {
|
|
set filetime [clock format [file mtime $coll]\
|
|
-format "%Y/%m/%d %H:%M:%S"]
|
|
lappend display_list [format "%-60s%19s" $mod $filetime]
|
|
} else {
|
|
lappend display_list $mod
|
|
}
|
|
}
|
|
}
|
|
|
|
eval displayElementList "noheader" "{}" $one_per_line $display_idx\
|
|
$display_list
|
|
}
|
|
}
|
|
|
|
|
|
proc cmdModuleSource {args} {
|
|
reportDebug "cmdModuleSource: $args"
|
|
foreach file $args {
|
|
if {[file exists $file]} {
|
|
pushMode "load"
|
|
pushSpecifiedName $file
|
|
pushModuleName $file
|
|
# relax constraint of having a magic cookie at the start of the
|
|
# modulefile to execute as sourced files may need more flexibility
|
|
# as they may be managed outside of the modulefile environment like
|
|
# the initialization modulerc file
|
|
execute-modulefile $file 0
|
|
popModuleName
|
|
popSpecifiedName
|
|
popMode
|
|
} else {
|
|
reportErrorAndExit "File $file does not exist"
|
|
}
|
|
}
|
|
}
|
|
|
|
proc cmdModuleUnsource {args} {
|
|
reportDebug "cmdModuleUnsource: $args"
|
|
foreach file $args {
|
|
if {[file exists $file]} {
|
|
pushMode "unload"
|
|
pushSpecifiedName $file
|
|
pushModuleName $file
|
|
# relax constraint of having a magic cookie at the start of the
|
|
# modulefile to execute as sourced files may need more flexibility
|
|
# as they may be managed outside of the modulefile environment like
|
|
# the initialization modulerc file
|
|
execute-modulefile $file 0
|
|
popModuleName
|
|
popSpecifiedName
|
|
popMode
|
|
} else {
|
|
reportErrorAndExit "File $file does not exist"
|
|
}
|
|
}
|
|
}
|
|
|
|
proc cmdModuleLoad {args} {
|
|
global g_loadedModules g_force
|
|
global ModulesCurrentModulefile
|
|
|
|
reportDebug "cmdModuleLoad: loading $args"
|
|
|
|
set ret 0
|
|
pushMode "load"
|
|
foreach mod $args {
|
|
lassign [getPathToModule $mod] modfile modname
|
|
if {$modfile ne ""} {
|
|
# check if passed modname correspond to an already loaded modfile
|
|
# and get its loaded name (in case it has been loaded as full path)
|
|
set loadedmodname [getLoadedMatchingName $modname]
|
|
if {$loadedmodname ne ""} {
|
|
set modname $loadedmodname
|
|
}
|
|
|
|
set currentModule $modname
|
|
set ModulesCurrentModulefile $modfile
|
|
|
|
if {$g_force || ! [info exists g_loadedModules($currentModule)]} {
|
|
pushSpecifiedName $mod
|
|
pushModuleName $currentModule
|
|
pushSettings
|
|
|
|
if {[execute-modulefile $modfile]} {
|
|
restoreSettings
|
|
set ret 1
|
|
} else {
|
|
append-path LOADEDMODULES $currentModule
|
|
append-path _LMFILES_ $modfile
|
|
set g_loadedModules($currentModule) $modfile
|
|
}
|
|
|
|
popSettings
|
|
popModuleName
|
|
popSpecifiedName
|
|
} else {
|
|
reportDebug "cmdModuleLoad: $modname ($modfile) already loaded"
|
|
}
|
|
} else {
|
|
set ret 1
|
|
}
|
|
}
|
|
popMode
|
|
|
|
return $ret
|
|
}
|
|
|
|
proc cmdModuleUnload {match args} {
|
|
global g_loadedModules
|
|
global ModulesCurrentModulefile g_def_separator
|
|
|
|
reportDebug "cmdModuleUnload: unloading $args (match=$match)"
|
|
|
|
set ret 0
|
|
pushMode "unload"
|
|
foreach mod $args {
|
|
# resolve by also looking at matching loaded module
|
|
lassign [getPathToModule $mod {} $match] modfile modname
|
|
if {$modfile ne ""} {
|
|
set currentModule $modname
|
|
set ModulesCurrentModulefile $modfile
|
|
|
|
if {[info exists g_loadedModules($currentModule)]} {
|
|
pushSpecifiedName $mod
|
|
pushModuleName $currentModule
|
|
pushSettings
|
|
|
|
if {[execute-modulefile $modfile]} {
|
|
restoreSettings
|
|
set ret 1
|
|
} else {
|
|
unload-path LOADEDMODULES $currentModule\
|
|
$g_def_separator
|
|
unload-path _LMFILES_ $modfile $g_def_separator
|
|
unset g_loadedModules($currentModule)
|
|
}
|
|
|
|
popSettings
|
|
popModuleName
|
|
popSpecifiedName
|
|
} else {
|
|
reportDebug "cmdModuleUnload: $modname ($modfile) is not loaded"
|
|
}
|
|
} else {
|
|
set ret 1
|
|
}
|
|
}
|
|
popMode
|
|
|
|
return $ret
|
|
}
|
|
|
|
proc cmdModulePurge {} {
|
|
reportDebug "cmdModulePurge"
|
|
|
|
eval cmdModuleUnload "match" [lreverse [getLoadedModuleList]]
|
|
}
|
|
|
|
proc cmdModuleReload {} {
|
|
reportDebug "cmdModuleReload"
|
|
|
|
set list [getLoadedModuleList]
|
|
set rlist [lreverse $list]
|
|
foreach mod $rlist {
|
|
cmdModuleUnload "match" $mod
|
|
}
|
|
foreach mod $list {
|
|
cmdModuleLoad $mod
|
|
}
|
|
}
|
|
|
|
proc cmdModuleAliases {} {
|
|
global g_moduleAlias g_moduleVersion
|
|
|
|
# disable error reporting to avoid modulefile errors
|
|
# to mix with avail results
|
|
inhibitErrorReport
|
|
|
|
# parse paths to fill g_moduleAlias and g_moduleVersion
|
|
foreach dir [getModulePathList "exiterronundef"] {
|
|
getModules $dir "" 0 ""
|
|
}
|
|
|
|
reenableErrorReport
|
|
|
|
set display_list {}
|
|
foreach name [lsort -dictionary [array names g_moduleAlias]] {
|
|
lappend display_list "$name -> $g_moduleAlias($name)"
|
|
}
|
|
if {[llength $display_list] > 0} {
|
|
eval displayElementList "Aliases" "sepline" 1 0 $display_list
|
|
}
|
|
|
|
set display_list {}
|
|
foreach name [lsort -dictionary [array names g_moduleVersion]] {
|
|
lappend display_list "$name -> $g_moduleVersion($name)"
|
|
}
|
|
if {[llength $display_list] > 0} {
|
|
eval displayElementList "Versions" "sepline" 1 0 $display_list
|
|
}
|
|
}
|
|
|
|
proc cmdModuleAvail {{mod {*}}} {
|
|
global show_oneperline show_modtimes show_filter
|
|
|
|
if {$show_modtimes || $show_oneperline} {
|
|
set one_per_line 1
|
|
set hstyle "terse"
|
|
set theader_shown 0
|
|
set theader_cols [list "Package/Alias" "Versions" "Last mod."]
|
|
} else {
|
|
set one_per_line 0
|
|
set hstyle "sepline"
|
|
}
|
|
|
|
# disable error reporting to avoid modulefile errors
|
|
# to mix with avail results
|
|
inhibitErrorReport
|
|
|
|
|
|
# look if aliases have been defined in the global or user-specific
|
|
# modulerc and display them if any in a dedicated list
|
|
set display_list [listModules "" "$mod" 1 $show_filter "rc_alias_only"]
|
|
if {[llength $display_list] > 0} {
|
|
if {$show_modtimes && !$theader_shown} {
|
|
set theader_shown 1
|
|
eval displayTableHeader $theader_cols
|
|
}
|
|
eval displayElementList "{global/user modulerc}" $hstyle $one_per_line\
|
|
0 $display_list
|
|
}
|
|
|
|
foreach dir [getModulePathList "exiterronundef"] {
|
|
set display_list [listModules "$dir" "$mod" 1 $show_filter]
|
|
if {[llength $display_list] > 0} {
|
|
if {$show_modtimes && !$theader_shown} {
|
|
set theader_shown 1
|
|
eval displayTableHeader $theader_cols
|
|
}
|
|
eval displayElementList $dir $hstyle $one_per_line 0 $display_list
|
|
}
|
|
}
|
|
|
|
reenableErrorReport
|
|
}
|
|
|
|
proc cmdModuleUse {args} {
|
|
global g_def_separator
|
|
|
|
reportDebug "cmdModuleUse: $args"
|
|
|
|
if {$args eq ""} {
|
|
showModulePath
|
|
} else {
|
|
set stuff_path "prepend"
|
|
foreach path $args {
|
|
if {($path eq "--append") ||($path eq "-a") ||($path eq\
|
|
"-append")} {
|
|
set stuff_path "append"
|
|
}\
|
|
elseif {($path eq "--prepend") ||($path eq "-p") ||($path eq\
|
|
"-prepend")} {
|
|
set stuff_path "prepend"
|
|
}\
|
|
elseif {[file isdirectory $path]} {
|
|
# tranform given path in an absolute path to avoid dependency to
|
|
# the current work directory.
|
|
set path [getAbsolutePath $path]
|
|
|
|
reportDebug "cmdModuleUse: calling add-path \
|
|
MODULEPATH $path $stuff_path $g_def_separator"
|
|
|
|
pushMode "load"
|
|
catch {
|
|
add-path MODULEPATH $path $stuff_path $g_def_separator
|
|
}
|
|
|
|
popMode
|
|
} else {
|
|
reportError "Directory '$path' not found"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc cmdModuleUnuse {args} {
|
|
global g_def_separator
|
|
|
|
reportDebug "cmdModuleUnuse: $args"
|
|
if {$args eq ""} {
|
|
showModulePath
|
|
} else {
|
|
foreach path $args {
|
|
# get current module path list
|
|
if {![info exists modpathlist]} {
|
|
set modpathlist [getModulePathList]
|
|
}
|
|
|
|
# transform given path in an absolute path which should have been
|
|
# registered in the MODULEPATH env var. however for compatibility
|
|
# with previous behavior where relative paths were registered in
|
|
# MODULEPATH given path is first checked against current path list
|
|
set abspath [getAbsolutePath $path]
|
|
if {[lsearch -exact $modpathlist $path] >= 0} {
|
|
set unusepath $path
|
|
} elseif {[lsearch -exact $modpathlist $abspath] >= 0} {
|
|
set unusepath $abspath
|
|
} else {
|
|
set unusepath ""
|
|
}
|
|
|
|
if {$unusepath ne ""} {
|
|
reportDebug "calling unload-path MODULEPATH $unusepath\
|
|
$g_def_separator"
|
|
|
|
pushMode "unload"
|
|
|
|
catch {
|
|
unload-path MODULEPATH $unusepath $g_def_separator
|
|
}
|
|
popMode
|
|
|
|
# refresh path list after unload
|
|
set modpathlist [getModulePathList]
|
|
if {[lsearch -exact $modpathlist $unusepath] >= 0} {
|
|
reportWarning "Did not unuse $unusepath"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc cmdModuleAutoinit {} {
|
|
global g_autoInit argv0 env
|
|
|
|
reportDebug "cmdModuleAutoinit:"
|
|
|
|
# flag to make renderSettings define the module command
|
|
set g_autoInit 1
|
|
|
|
# initialize env variables around module command
|
|
pushMode "load"
|
|
|
|
# default MODULESHOME
|
|
setenv MODULESHOME "@prefix@"
|
|
|
|
# initialize default MODULEPATH and LOADEDMODULES
|
|
if {![info exists env(MODULEPATH)] || $env(MODULEPATH) eq ""} {
|
|
# set modpaths defined in .modulespath config file if it exists
|
|
if {[file readable "@initdir@/.modulespath"]} {
|
|
set fid [open "@initdir@/.modulespath" r]
|
|
set fdata [split [read $fid] "\n"]
|
|
close $fid
|
|
foreach fline $fdata {
|
|
if {[regexp {^\s*(.*?)[\s#].*$} $fline match patharg] == 1\
|
|
&& $patharg ne ""} {
|
|
eval cmdModuleUse --append [split $patharg ":"]
|
|
}
|
|
}
|
|
} else {
|
|
setenv MODULEPATH ""
|
|
}
|
|
}
|
|
if {![info exists env(LOADEDMODULES)]} {
|
|
setenv LOADEDMODULES ""
|
|
}
|
|
|
|
# source initialization modulerc if any and if no env already initialized
|
|
if {$env(MODULEPATH) eq "" && $env(LOADEDMODULES) eq ""\
|
|
&& [file exists "@initdir@/modulerc"]} {
|
|
cmdModuleSource "@initdir@/modulerc"
|
|
}
|
|
|
|
popMode
|
|
}
|
|
|
|
proc cmdModuleInit {args} {
|
|
global g_shell env
|
|
|
|
set init_cmd [lindex $args 0]
|
|
set init_list [lrange $args 1 end]
|
|
set notdone 1
|
|
set nomatch 1
|
|
|
|
reportDebug "cmdModuleInit: $args"
|
|
|
|
# Define startup files for each shell
|
|
set files(csh) [list ".modules" ".cshrc" ".cshrc_variables" ".login"]
|
|
set files(tcsh) [list ".modules" ".tcshrc" ".cshrc" ".cshrc_variables"\
|
|
".login"]
|
|
set files(sh) [list ".modules" ".bash_profile" ".bash_login" ".profile"\
|
|
".bashrc"]
|
|
set files(bash) $files(sh)
|
|
set files(ksh) $files(sh)
|
|
set files(fish) [list ".modules" ".config/fish/config.fish"]
|
|
set files(zsh) [list ".modules" ".zshrc" ".zshenv" ".zlogin"]
|
|
|
|
# Process startup files for this shell
|
|
set current_files $files($g_shell)
|
|
foreach filename $current_files {
|
|
if {$notdone} {
|
|
set filepath $env(HOME)
|
|
append filepath "/" $filename
|
|
|
|
reportDebug "cmdModuleInit: Looking at $filepath"
|
|
if {[file readable $filepath] && [file isfile $filepath]} {
|
|
set newinit {}
|
|
set thismatch 0
|
|
set fid [open $filepath r]
|
|
|
|
while {[gets $fid curline] >= 0} {
|
|
# Find module load/add command in startup file
|
|
set comments {}
|
|
if {$notdone && [regexp {^([ \t]*module[ \t]+(load|add)[\
|
|
\t]*)(.*)} $curline match cmd subcmd modules]} {
|
|
set nomatch 0
|
|
set thismatch 1
|
|
regexp {([ \t]*\#.+)} $modules match comments
|
|
regsub {\#.+} $modules {} modules
|
|
|
|
# remove existing references to the named module from
|
|
# the list Change the module command line to reflect the
|
|
# given command
|
|
switch -- $init_cmd {
|
|
{list} {
|
|
if {![info exists notheader]} {
|
|
report "$g_shell initialization file\
|
|
\$HOME/$filename loads modules:"
|
|
set notheader 0
|
|
}
|
|
report "\t$modules"
|
|
}
|
|
{add} {
|
|
foreach newmodule $init_list {
|
|
set modules [replaceFromList $modules $newmodule]
|
|
}
|
|
lappend newinit "$cmd$modules $init_list$comments"
|
|
# delete new modules in potential next lines
|
|
set init_cmd "rm"
|
|
}
|
|
{prepend} {
|
|
foreach newmodule $init_list {
|
|
set modules [replaceFromList $modules $newmodule]
|
|
}
|
|
lappend newinit "$cmd$init_list $modules$comments"
|
|
# delete new modules in potential next lines
|
|
set init_cmd "rm"
|
|
}
|
|
{rm} {
|
|
set oldmodcount [llength $modules]
|
|
foreach oldmodule $init_list {
|
|
set modules [replaceFromList $modules $oldmodule]
|
|
}
|
|
set modcount [llength $modules]
|
|
if {$modcount > 0} {
|
|
lappend newinit "$cmd$modules$comments"
|
|
} else {
|
|
lappend newinit [string trim $cmd]
|
|
}
|
|
if {$oldmodcount > $modcount} {
|
|
set notdone 0
|
|
}
|
|
}
|
|
{switch} {
|
|
set oldmodule [lindex $init_list 0]
|
|
set newmodule [lindex $init_list 1]
|
|
set newmodules [replaceFromList $modules\
|
|
$oldmodule $newmodule]
|
|
lappend newinit "$cmd$newmodules$comments"
|
|
if {"$modules" ne "$newmodules"} {
|
|
set notdone 0
|
|
}
|
|
}
|
|
{clear} {
|
|
lappend newinit [string trim $cmd]
|
|
}
|
|
}
|
|
} else {
|
|
# copy the line from the old file to the new
|
|
lappend newinit $curline
|
|
}
|
|
}
|
|
|
|
close $fid
|
|
|
|
if {$init_cmd ne "list" && $thismatch} {
|
|
reportDebug "cmdModuleInit: Writing $filepath"
|
|
if {[catch {
|
|
set fid [open $filepath w]
|
|
puts $fid [join $newinit "\n"]
|
|
close $fid
|
|
} errMsg ]} {
|
|
reportErrorAndExit "Init file $filepath cannot be\
|
|
written.\n$errMsg"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# quit in error if command was not performed due to no match
|
|
if {$nomatch && $init_cmd ne "list"} {
|
|
reportErrorAndExit "Cannot find a 'module load' command in any of the\
|
|
'$g_shell' startup files"
|
|
}
|
|
}
|
|
|
|
# provide access to modulefile specific commands from the command-line, making
|
|
# them standing as a module sub-command (see module procedure)
|
|
proc cmdModuleResurface {cmd args} {
|
|
global g_return_false g_return_text
|
|
|
|
reportDebug "cmdModuleResurface: cmd='$cmd', args='$args'"
|
|
|
|
pushMode "load"
|
|
pushCommandName $cmd
|
|
|
|
# run modulefile command and get its result
|
|
set res [eval $cmd $args]
|
|
|
|
# register result depending of return kind (false or text)
|
|
switch -- $cmd {
|
|
{module-info} {
|
|
set g_return_text $res
|
|
}
|
|
default {
|
|
if {$res == 0} {
|
|
# render false if command returned false
|
|
set g_return_false 1
|
|
}
|
|
}
|
|
}
|
|
popCommandName
|
|
popMode
|
|
}
|
|
|
|
proc cmdModuleTest {args} {
|
|
reportDebug "cmdModuleTest: testing $args"
|
|
|
|
pushMode "test"
|
|
set first_report 1
|
|
foreach mod $args {
|
|
lassign [getPathToModule $mod] modfile modname
|
|
if {$modfile ne ""} {
|
|
pushSpecifiedName $mod
|
|
pushModuleName $modname
|
|
# only one separator lines between 2 modules
|
|
if {$first_report} {
|
|
displaySeparatorLine
|
|
set first_report 0
|
|
}
|
|
report "Module Specific Test for $modfile:\n"
|
|
execute-modulefile $modfile
|
|
popModuleName
|
|
popSpecifiedName
|
|
displaySeparatorLine
|
|
}
|
|
}
|
|
popMode
|
|
}
|
|
|
|
proc cmdModuleHelp {args} {
|
|
pushMode "help"
|
|
set first_report 1
|
|
foreach arg $args {
|
|
if {$arg ne ""} {
|
|
lassign [getPathToModule $arg] modfile modname
|
|
|
|
if {$modfile ne ""} {
|
|
pushSpecifiedName $arg
|
|
pushModuleName $modname
|
|
# only one separator lines between 2 modules
|
|
if {$first_report} {
|
|
displaySeparatorLine
|
|
set first_report 0
|
|
}
|
|
report "Module Specific Help for $modfile:\n"
|
|
execute-modulefile $modfile
|
|
popModuleName
|
|
popSpecifiedName
|
|
displaySeparatorLine
|
|
}
|
|
}
|
|
}
|
|
popMode
|
|
if {[llength $args] == 0} {
|
|
reportVersion
|
|
report {Usage: module [options] [command] [args ...]
|
|
|
|
Loading / Unloading commands:
|
|
add | load modulefile [...] Load modulefile(s)
|
|
rm | unload modulefile [...] Remove modulefile(s)
|
|
purge Unload all loaded modulefiles
|
|
reload | refresh Unload then load all loaded modulefiles
|
|
switch | swap [mod1] mod2 Unload mod1 and load mod2
|
|
|
|
Listing / Searching commands:
|
|
list [-t|-l] List loaded modules
|
|
avail [-d|-L] [-t|-l] [mod ...] List all or matching available modules
|
|
aliases List all module aliases
|
|
whatis [modulefile ...] Print whatis information of modulefile(s)
|
|
apropos | keyword | search str Search all name and whatis containing str
|
|
is-loaded [modulefile ...] Test if any of the modulefile(s) are loaded
|
|
is-avail modulefile [...] Is any of the modulefile(s) available
|
|
info-loaded modulefile Get full name of matching loaded module(s)
|
|
|
|
Collection of modules handling commands:
|
|
save [collection|file] Save current module list to collection
|
|
restore [collection|file] Restore module list from collection or file
|
|
saverm [collection] Remove saved collection
|
|
saveshow [collection|file] Display information about collection
|
|
savelist [-t|-l] List all saved collections
|
|
is-saved [collection ...] Test if any of the collection(s) exists
|
|
|
|
Shell's initialization files handling commands:
|
|
initlist List all modules loaded from init file
|
|
initadd modulefile [...] Add modulefile to shell init file
|
|
initrm modulefile [...] Remove modulefile from shell init file
|
|
initprepend modulefile [...] Add to beginning of list in init file
|
|
initswitch mod1 mod2 Switch mod1 with mod2 from init file
|
|
initclear Clear all modulefiles from init file
|
|
|
|
Environment direct handling commands:
|
|
prepend-path [-d c] var value Prepend value to environment variable
|
|
append-path [-d c] var value Append value to environment variable
|
|
remove-path [-d c] var value Remove value from environment variable
|
|
|
|
Other commands:
|
|
help [modulefile ...] Print this or modulefile(s) help info
|
|
display | show modulefile [...] Display information about modulefile(s)
|
|
test [modulefile ...] Test modulefile(s)
|
|
use [-a|-p] dir [...] Add dir(s) to MODULEPATH variable
|
|
unuse dir [...] Remove dir(s) from MODULEPATH variable
|
|
is-used [dir ...] Is any of the dir(s) enabled in MODULEPATH
|
|
path modulefile Print modulefile path
|
|
paths modulefile Print path of matching available modules
|
|
source scriptfile [...] Execute scriptfile(s)
|
|
|
|
Switches:
|
|
-t | --terse Display output in terse format
|
|
-l | --long Display output in long format
|
|
-d | --default Only show default versions available
|
|
-L | --latest Only show latest versions available
|
|
-a | --append Append directory to MODULEPATH
|
|
-p | --prepend Prepend directory to MODULEPATH
|
|
|
|
Options:
|
|
-h | --help This usage info
|
|
-V | --version Module version
|
|
-D | --debug Enable debug messages
|
|
--paginate Pipe mesg output into a pager if stream attached to terminal
|
|
--no-pager Do not pipe message output into a pager}
|
|
}
|
|
}
|
|
|
|
########################################################################
|
|
# main program
|
|
|
|
# needed on a gentoo system. Shouldn't hurt since it is
|
|
# supposed to be the default behavior
|
|
fconfigure stderr -translation auto
|
|
|
|
if {[catch {
|
|
# parse all command-line arguments before doing any action, no output is
|
|
# made during argument parse to wait for potential paging to be setup
|
|
set show_help 0
|
|
set show_version 0
|
|
set argerrmsgs {}
|
|
set argwarnmsgs {}
|
|
set argdebugmsgs [list "CALLING $argv0 $argv"]
|
|
|
|
# Parse shell
|
|
set g_shell [lindex $argv 0]
|
|
switch -- $g_shell {
|
|
{sh} - {bash} - {ksh} - {zsh} {
|
|
set g_shellType sh
|
|
}
|
|
{csh} - {tcsh} {
|
|
set g_shellType csh
|
|
}
|
|
{fish} - {cmd} - {tcl} - {perl} - {python} - {ruby} - {lisp} - {cmake}\
|
|
- {r} {
|
|
set g_shellType $g_shell
|
|
}
|
|
default {
|
|
lappend argerrmsgs "Unknown shell type \'($g_shell)\'"
|
|
}
|
|
}
|
|
|
|
# extract options and command switches from other args
|
|
set otherargv {}
|
|
set ddelimarg 0
|
|
foreach arg [lrange $argv 1 end] {
|
|
if {[info exists ignore_next_arg]} {
|
|
unset ignore_next_arg
|
|
} else {
|
|
switch -glob -- $arg {
|
|
{-D} - {--debug} {
|
|
set g_debug 1
|
|
}
|
|
{--help} - {-h} {
|
|
set show_help 1
|
|
}
|
|
{-V} - {--version} {
|
|
set show_version 1
|
|
}
|
|
{--paginate} {
|
|
set asked_pager 1
|
|
}
|
|
{--no-pager} {
|
|
set asked_pager 0
|
|
}
|
|
{-t} - {--terse} {
|
|
set show_oneperline 1
|
|
set show_modtimes 0
|
|
}
|
|
{-l} - {--long} {
|
|
set show_modtimes 1
|
|
set show_oneperline 0
|
|
}
|
|
{-d} - {--default} {
|
|
# in case of *-path command, -d means --delim
|
|
if {$arg eq "-d" && $ddelimarg} {
|
|
lappend otherargv $arg
|
|
} else {
|
|
set show_filter "onlydefaults"
|
|
}
|
|
}
|
|
{-L} - {--latest} {
|
|
set show_filter "onlylatest"
|
|
}
|
|
{-a} - {--append} - {-append} - {-p} - {--prepend} - {-prepend} \
|
|
- {--delim} - {-delim} - {--delim=*} - {-delim=*} {
|
|
# command-specific switches interpreted later on
|
|
lappend otherargv $arg
|
|
}
|
|
{append-path} - {prepend-path} - {remove-path} {
|
|
# detect *-path commands to say -d means --delim, not --default
|
|
set ddelimarg 1
|
|
lappend otherargv $arg
|
|
}
|
|
{-f} - {--force} - {--human} - {-v} - {--verbose} - {-s} -\
|
|
{--silent} - {-c} - {--create} - {-i} - {--icase} -\
|
|
{--userlvl=*} {
|
|
# ignore C-version specific option, no error only warning
|
|
lappend argwarnmsgs "Unsupported option '$arg'"
|
|
}
|
|
{-u} - {--userlvl} {
|
|
lappend argwarnmsgs "Unsupported option '$arg'"
|
|
# also ignore argument value
|
|
set ignore_next_arg 1
|
|
}
|
|
{-*} {
|
|
lappend argerrmsgs "Invalid option '$arg'\nTry\
|
|
'module --help' for more information."
|
|
}
|
|
default {
|
|
lappend otherargv $arg
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# now options are known so first message output will be able to start
|
|
# pager if enabled. 'for' is used instead of foreach since msg list
|
|
# will be updated from initPager procedure.
|
|
for {set i 0} {$i < [llength $argdebugmsgs]} {incr i 1} {
|
|
reportDebug [lindex $argdebugmsgs $i]
|
|
}
|
|
|
|
# display first error message and exit if any
|
|
if {[llength $argerrmsgs] > 0} {
|
|
reportErrorAndExit [lindex $argerrmsgs 0]
|
|
}
|
|
foreach argmsg $argwarnmsgs {
|
|
reportWarning $argmsg
|
|
}
|
|
|
|
# put back quarantine variables in env, if quarantine mechanism supported
|
|
if {[info exists env(MODULES_RUN_QUARANTINE)] && $g_shellType ne "csh"} {
|
|
foreach var [split $env(MODULES_RUN_QUARANTINE) " "] {
|
|
# check variable name is valid
|
|
if {[regexp {^[A-Za-z_][A-Za-z0-9_]*$} $var]} {
|
|
set quarvar "${var}_modquar"
|
|
# put back value
|
|
if {[info exists env($quarvar)]} {
|
|
reportDebug "Release '$var' environment variable from\
|
|
quarantine ($env($quarvar))"
|
|
set env($var) $env($quarvar)
|
|
unset env($quarvar)
|
|
# or unset env var if no value found in quarantine
|
|
} elseif {[info exists env($var)]} {
|
|
reportDebug "Unset '$var' environment variable after\
|
|
quarantine"
|
|
unset env($var)
|
|
}
|
|
} elseif {[string length $var] > 0} {
|
|
reportWarning "Bad variable name set in MODULES_RUN_QUARANTINE\
|
|
($var)"
|
|
}
|
|
}
|
|
}
|
|
|
|
if {$show_help} {
|
|
cmdModuleHelp
|
|
cleanupAndExit 0
|
|
}
|
|
if {$show_version} {
|
|
reportVersion
|
|
cleanupAndExit 0
|
|
}
|
|
|
|
set command [lindex $otherargv 0]
|
|
# default command is help if none supplied
|
|
if {$command eq ""} {
|
|
set command "help"
|
|
}
|
|
set otherargv [lreplace $otherargv 0 0]
|
|
|
|
cacheCurrentModules
|
|
|
|
# Find and execute any .modulerc file found in the module directories
|
|
# defined in env(MODULESPATH)
|
|
runModulerc
|
|
|
|
# eval needed to pass otherargv as list to module proc
|
|
eval module $command $otherargv
|
|
} errMsg ]} {
|
|
# no use of reportError here to get independent from any
|
|
# previous error report inhibition
|
|
report "ERROR: $errMsg"
|
|
cleanupAndExit 1
|
|
}
|
|
|
|
cleanupAndExit 0
|
|
|
|
# ;;; Local Variables: ***
|
|
# ;;; mode:tcl ***
|
|
# ;;; End: ***
|
|
# vim:set tabstop=3 shiftwidth=3 expandtab autoindent:
|