From f84981d4c111852b1e1adb804bdfbe4cb2d43b3a Mon Sep 17 00:00:00 2001 From: Achim Gsell Date: Thu, 15 Feb 2018 17:47:12 +0100 Subject: [PATCH] Pmodules/modulecmd.tcl.in - use new Tcl implementation of Modules. --- Pmodules/modulecmd.tcl.in | 6958 +++++++++++++++++++++++++++++++++++++ 1 file changed, 6958 insertions(+) create mode 100755 Pmodules/modulecmd.tcl.in diff --git a/Pmodules/modulecmd.tcl.in b/Pmodules/modulecmd.tcl.in new file mode 100755 index 0000000..c56532a --- /dev/null +++ b/Pmodules/modulecmd.tcl.in @@ -0,0 +1,6958 @@ +#!@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-2018 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 . + +########################################################################## + +# +# 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_init_errreport 0 ;# Start with error report locked before opts parsed +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 + +set g_siteconfig "@etcdir@/siteconfig.tcl" ;# Site configuration + +# BEGIN: Pmodules extension +set PREFIX "prefix" +set name "name" +set version "version" +set group "group" +set g_url "g_url" +set g_license "g_license" +set g_maintainer "g_maintainer" +set g_help "g_help" +set g_whatis "g_whatis" + +######################################################################## +# +# P m o d u l e s procedures +# + +# +# :TODO: +# switch/swap +# unload modules if parent removed +# + +if {[info exists env(PMODULES_DEBUG)] && $env(PMODULES_DEBUG)} { + proc debug {msg} { + set level [expr [info level] -2] + set r [catch {info level ${level}} e] + if {$r} { + set caller "" + } else { + set caller [lindex [split [info level [expr [info level] - 3]]] 0] + } + puts -nonewline stderr "${caller}: " + puts stderr ${msg} + } +} else { + proc debug {msg} {} +} + +proc procExists p { + return uplevel 1 [expr {[llength [info procs $p]] > 0}] +} + +proc module-addgroup { group } { + global env + global name + global version + + reportDebug "called with arg $group, mode is \"[module-info mode]\"" + set Implementation [file join {*}$::implementation] + + set GROUP [string toupper $group] + regsub -- "-" ${GROUP} "_" GROUP + setenv ${GROUP} $name + setenv ${GROUP}_VERSION $version + + set ::${group} $name + set ::${group}_version $version + + if { [module-info mode load] } { + reportDebug "mode is load" + + set dir $::PmodulesRoot/$group/$::PmodulesModulfilesDir/$Implementation + append-path MODULEPATH $dir + append-path PMODULES_USED_GROUPS $group + reportDebug "mode=load: new MODULEPATH=$env(MODULEPATH)" + reportDebug "mode=load: new PMODULES_USED_GROUPS=$env(PMODULES_USED_GROUPS)" + } elseif { [module-info mode unload] } { + set GROUP [string toupper $group] + reportDebug "remove hierarchical group '${GROUP}'" + + if { [info exists env(PMODULES_LOADED_${GROUP})] } { + reportDebug "unloading orphan modules" + set modules [split $env(PMODULES_LOADED_${GROUP}) ":"] + foreach m ${modules} { + if { ${m} == "999999999" } { + continue + } + if { [is-loaded ${m}] } { + reportDebug "unloading: $m" + module unload ${m} + } + } + } else { + reportDebug "no orphan modules to unload" + } + reportDebug "mode=remove: $env(MODULEPATH)" + set dir $::PmodulesRoot/$group/$::PmodulesModulfilesDir/$Implementation + remove-path MODULEPATH $dir + remove-path PMODULES_USED_GROUPS $group + } + if { [module-info mode switch2] } { + reportDebug "mode=switch2" + set dir $::PmodulesRoot/$group/$::PmodulesModulfilesDir/[module-info name] + append-path MODULEPATH $dir + append-path PMODULES_USED_GROUPS ${group} + } +} + +proc set-family { group } { + module-addgroup $group +} + +proc _pmodules_update_loaded_modules { group name version } { + if { ${group} == "999999999" } { + return + } + set GROUP [string toupper $group] + reportDebug "${GROUP} $name/$version" + append-path PMODULES_LOADED_${GROUP} "$name/$version" + remove-path PMODULES_LOADED_${GROUP} "999999999" +} + +# +# load dependencies, but do *not* unload dependencies +# +proc _pmodules_load_dependencies { fname } { + if { ! [ file exists ${fname} ] } { + return + } + if { ! [module-info mode load] } { + return + } + reportDebug "load dependencies from: ${fname}" + # Slurp up the data file + set fp [open ${fname} r] + set file_data [read ${fp}] + close ${fp} + set data [split ${file_data} "\n"] + foreach line ${data} { + reportDebug "MODULEPATH=$::env(MODULEPATH)" + set module_name [string trim $line] + if { ${module_name} == "#" || ${module_name} == "" } { + continue + } + if { [is-loaded ${module_name}] } { + reportDebug "module already loaded: ${module_name}" + continue + } + reportDebug "module load: ${module_name}" + module load ${module_name} + } +} + +proc lreverse_n { list n } { + set res {} + set i [expr [llength $list] - $n] + while {$i >= 0} { + lappend res {*}[lrange $list $i [expr $i+$n-1]] + incr i -$n + } + set res +} + +# +# set standard environment variables +# +proc _pmodules_setenv { PREFIX name version } { + # + # Hack for supporting legacy modules + if { "${::group}" == "Legacy" } { + reportDebug "this is a legacy module..." + return + } + + reportDebug "PREFIX = $PREFIX" + + set NAME [string toupper $name] + regsub -- "-" ${NAME} "_" NAME + + if { ! [info exist ::dont-setenv] } { + set ::dont-setenv {} + } + + if { ${version} != "" } { + if { [lsearch ${::dont-setenv} "${NAME}_VERSION"] == -1 } { + setenv ${NAME}_VERSION $version + } + } + + if { [file isdirectory "$PREFIX"] } { + if { [lsearch ${::dont-setenv} "${NAME}_PREFIX"] == -1 } { + setenv ${NAME}_PREFIX $PREFIX + } + if { [lsearch ${::dont-setenv} "${NAME}_DIR"] == -1 } { + setenv ${NAME}_DIR $PREFIX + } + if { [lsearch ${::dont-setenv} "${NAME}_HOME"] == -1 } { + setenv ${NAME}_HOME $PREFIX + } + } else { + reportDebug "$PREFIX is not a directory" + } + + if { [file isdirectory "$PREFIX/bin"] } { + if { [lsearch ${::dont-setenv} "PATH"] == -1 } { + prepend-path PATH $PREFIX/bin + } + } + + if { [file isdirectory "$PREFIX/sbin"] } { + if { [lsearch ${::dont-setenv} "PATH"] == -1 } { + prepend-path PATH $PREFIX/sbin + } + } + + if { [file isdirectory "$PREFIX/share/man"] } { + if { [lsearch ${::dont-setenv} "MANPATH"] == -1 } { + prepend-path MANPATH $PREFIX/share/man + } + } + + # set various environment variables - as long as they are not blacklisted + reportDebug "prepend to include paths" + if { [file isdirectory "$PREFIX/include"] } { + if { [lsearch ${::dont-setenv} "C_INCLUDE_PATH"] == -1 } { + prepend-path C_INCLUDE_PATH $PREFIX/include + } + if { [lsearch ${::dont-setenv} "CPLUS_INCLUDE_PATH"] == -1 } { + prepend-path CPLUS_INCLUDE_PATH $PREFIX/include + } + if { [lsearch ${::dont-setenv} "${NAME}_INCLUDE_DIR"] == -1 } { + setenv ${NAME}_INCLUDE_DIR $PREFIX/include + } + } + + reportDebug "prepend to library paths" + if { [file isdirectory "$PREFIX/lib"] } { + if { [lsearch ${::dont-setenv} "LIBRARY_PATH"] == -1 } { + prepend-path LIBRARY_PATH $PREFIX/lib + } + if { [lsearch ${::dont-setenv} "LD_LIBRARY_PATH"] == -1 } { + prepend-path LD_LIBRARY_PATH $PREFIX/lib + } + if { [lsearch ${::dont-setenv} "${NAME}_LIBRARY_DIR"] == -1 } { + setenv ${NAME}_LIBRARY_DIR $PREFIX/lib + } + } + + reportDebug "prepend to library paths (64bit)" + if { [file isdirectory "$PREFIX/lib64"] } { + if { [lsearch ${::dont-setenv} "LIBRARY_PATH"] == -1 } { + prepend-path LIBRARY_PATH $PREFIX/lib64 + } + if { [lsearch ${::dont-setenv} "LD_LIBRARY_PATH"] == -1 } { + prepend-path LD_LIBRARY_PATH $PREFIX/lib64 + } + if { [lsearch ${::dont-setenv} "${NAME}_LIBRARY_DIR"] == -1 } { + setenv ${NAME}_LIBRARY_DIR $PREFIX/lib64 + } + } +} + +# +# intialize global vars +# Modulefile is something like +# +# ${PMODULES_ROOT}/group/${PMODULES_MODULEFILES_DIR}/name/version +# or +# ${PMODULES_ROOT}/group/${PMODULES_MODULEFILES_DIR}/X1/Y1/name/version +# or +# ${PMODULES_ROOT}/group/${PMODULES_MODULEFILES_DIR}/X1/Y1//X2/Y2/name/version +# +proc _init_global_vars { prefixVN } { + global group + global name + global version + global implementation + upvar 1 $prefixVN PREFIX # prefix of package + + reportDebug "$::ModulesCurrentModulefile" + set ::PmodulesRoot $::env(PMODULES_ROOT) + set ::PmodulesModulfilesDir $::env(PMODULES_MODULEFILES_DIR) + set modulefile [file split $::ModulesCurrentModulefile] + set pmodules_root [file split $::PmodulesRoot] + set pmodules_root_num_dirs [llength $pmodules_root] + + set modulefile_root [file join {*}[lrange $modulefile 0 [expr $pmodules_root_num_dirs - 1]]] + if { $::PmodulesRoot != $modulefile_root } { + reportDebug "stop sourcing: ${::PmodulesRoot} != $modulefile_root" + return + } + reportDebug "modulefile is inside our root" + set rel_modulefile [lrange $modulefile [llength $pmodules_root] end] + set group [lindex $rel_modulefile 0] + set name [lindex $modulefile end-1] + set version [lindex $modulefile end] + set implementation [lrange $rel_modulefile 2 end] + set prefix "$pmodules_root $group [lreverse_n $implementation 2]" + set PREFIX [file join {*}$prefix] + + reportDebug "PREFIX=$PREFIX" + reportDebug "group of module $name: $group" +} + +proc _pmodules_output_message { fname } { + if { [ file exists "${fname}" ] } { + set fp [open "${fname}" r] + set info_text [read $fp] + close $fp + puts stderr ${info_text} + } +} + +if { [info exists ::whatis] } { + module-whatis "$whatis" +} + + +# +# we cannot load another module with the same name +# +#conflict $name + +#if { [module-info mode load] } { +# debug "${name}/${version}: loading ... " +# _pmodules_output_message "${PREFIX}/.info" +#} + + +# END: Pmodules extension + +# 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" + } elseif {!$::g_init_errreport} { + # save message if report is not currently initialized as we do not + # know yet if debug mode is enabled or not + lappend ::errreport_buffer [list "reportDebug" $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} { + if {$::g_init_errreport} { + raiseErrorCount + renderFalse + error "$message" + } else { + # save message if report is not yet initialized + lappend ::errreport_buffer [list "reportErrorAndExit" $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 reportfd + + if {$::g_init_errreport} { + # protect from issue with fd, just ignore it + catch { + if {$nonewline ne ""} { + puts -nonewline $reportfd "$message" + } else { + puts $reportfd "$message" + } + } + } else { + # save message if report is not yet initialized + lappend ::errreport_buffer [list "report" $message $nonewline] + } +} + +# 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 +} + +# init error report and output buffered messages +proc initErrorReport {} { + # setup message paging if enabled + initPager + + set ::g_init_errreport 1 + + # now error report is init output every message saved in buffer + foreach errreport $::errreport_buffer { + eval $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 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)]} { + reportDebug "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 "" + } + + reportDebug "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} { + reportDebug "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]} { + reportWarning $errMsg + } + } else { + reportDebug "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 g_modfileUntrackVars g_modfileAliases + # BEGIN Pmodules extensions + global PREFIX + global name + global version + global group + global g_url + global g_license + global g_maintainer + global g_help + global g_whatis + # END Pmodules extensions + + pushModuleFile $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] + + # BEGIN Pmodules extensions + array set g_modfileUntrackVars [list \ + name 1 \ + version 1 \ + group 1 \ + whatis 1 \ + g_url 1 \ + g_license 1 \ + g_maintainer 1 \ + g_help 1] + # END Pmodules extensions + + # 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-virtual module-virtual 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] + + # BEGIN Pmodules extensions + array set g_modfileAliases [ list \ + reportDebug reportDebug \ + _init_global_vars _init_global_vars \ + _pmodules_setenv _pmodules_setenv \ + _pmodules_update_loaded_modules _pmodules_update_loaded_modules \ + debug debug \ + module-url module-url \ + module-license module-license \ + module-maintainer module-maintainer \ + module-help module-help \ + module-addgroup module-addgroup \ + set-family set-family \ + output-help output-help ] + # END Pmodules extensions + + } + + # 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 \ + PREFIX, group, g_url, g_license, g_maintainer, g_help, g_whatis} + 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 + + # BEGIN Pmodules extension + reportDebug "set PREFIX" + _init_global_vars PREFIX + reportDebug "PREFIX after _init_global_vars: $PREFIX" + interp eval $itrp set PREFIX $PREFIX + interp eval $itrp set name $name + interp eval $itrp set version $version + interp eval $itrp set group $group + interp eval $itrp set g_url $g_url + interp eval $itrp set g_license $g_license + interp eval $itrp set g_maintainer $g_maintainer + interp eval $itrp set g_help $g_help + interp eval $itrp set g_whatis $g_whatis + + set errorVal [interp eval $itrp { + set modcontent [readModuleContent $ModulesCurrentModulefile 1\ + $must_have_cookie] + if {$modcontent eq ""} { + return 1 + } + info script $ModulesCurrentModulefile + + # BEGIN Pmodules extensions + _pmodules_setenv ${PREFIX} ${name} ${version} + _pmodules_update_loaded_modules ${group} ${name} ${version} + + proc ModulesHelp { } { + output-help + } + # END Pmodules extensions + + # 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 + } + }] + + popModuleFile + + reportDebug "Exiting $modfile" + return $errorVal +} + +# BEGIN Pmodules extensions +proc module-url { url } { + set ::g_url ${url} +} + +proc module-license { license } { + set ::g_license ${license} +} + +proc module-maintainer { maintainer } { + set ::g_maintainer ${maintainer} +} + +proc module-help { help } { + set ::g_help ${help} +} + +proc output-help { } { + if { [info exists ::g_whatis] } { + report "${::g_whatis}" + } + if { [info exists ::version] } { + report "Version: ${::version}" + } + if { [info exists ::g_url] } { + report "Homepage: ${::g_url}" + } + if { [info exists ::g_license] } { + report "License: ${::g_license}" + } + if { [info exists ::g_maintainer] } { + report "Maintainer: ${::g_maintainer}" + } + if { [info exists ::g_help] } { + report "${::g_help}\n" + } +} +# END Pmodules extension + +# 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 g_modrcUntrackVars g_modrcAliases + + reportDebug "execute-modulerc: $modfile" + + pushModuleFile $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-virtual module-virtual 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 + + popModuleFile + + 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" + if {[llength $dumpVars($var)] > 1} { + # restore value as list + $itrp eval set ::$var [list $dumpVars($var)] + } else { + $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 +# + +# 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 {} +} + +# convert environment variable references in string to their values +# every local variable is prefixed by '0' to ensure they will not be +# overwritten through variable reference resolution process +proc resolvStringWithEnv {0str} { + global env + + # fetch variable references in string + set 0match_list [regexp -all -inline {\$[{]?([A-Za-z_][A-Za-z0-9_]*)[}]?}\ + ${0str}] + if {[llength ${0match_list}] > 0} { + # put in local scope every environment variable referred in string + for {set 0i 1} {${0i} < [llength ${0match_list}]} {incr 0i 2} { + set 0varname [lindex ${0match_list} ${0i}] + if {![info exists ${0varname}]} { + if {[info exists env(${0varname})]} { + set ${0varname} $env(${0varname}) + } else { + set ${0varname} "" + } + } + } + # resolv variable reference with values (now in local scope) + set 0res [subst -nobackslashes -nocommands ${0str}] + } else { + set 0res ${0str} + } + + reportDebug "resolvStringWithEnv: '${0str}' resolved to '${0res}'" + + return ${0res} +} + +# deduce modulepath from modulefile and module name +proc getModulepathFromModuleName {modfile modname} { + return [string range $modfile 0 end-[string length "/$modname"]] +} + +# deduce module name from modulefile and modulepath +proc getModuleNameFromModulepath {modfile modpath} { + return [string range $modfile [string length "$modpath/"] end] +} + +# extract module name from modulefile and currently enabled modulepaths +proc findModuleNameFromModulefile {modfile} { + set ret "" + + foreach modpath [getModulePathList] { + if {[string first "$modpath/" "$modfile/"] == 0} { + set ret [getModuleNameFromModulepath $modfile $modpath] + break + } + } + return $ret +} + +# extract modulepath from modulefile and currently enabled modulepaths +proc findModulepathFromModulefile {modfile} { + set ret "" + + foreach modpath [getModulePathList] { + if {[string first "$modpath/" "$modfile/"] == 0} { + set ret $modpath + break + } + } + return $ret +} + +# Determine with a name provided as argument the corresponding module name, +# version and name/version. Module name is guessed from current module name +# when shorthand version notation is used. Both name and version are guessed +# from current module if name provided is empty. If 'name_relative_tocur' is +# enabled then name argument may be interpreted as a name relative to the +# current modulefile directory (useful for module-version and module-alias +# for instance). +proc getModuleNameVersion {{name {}} {name_relative_tocur 0}} { + set curmod [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-virtual {args} { + global g_moduleVirtual + global g_sourceVirtual ModulesCurrentModulefile + + lassign [getModuleNameVersion [lindex $args 0]] mod + set modfile [getAbsolutePath [lindex $args 1]] + + reportDebug "module-virtual: $mod = $modfile" + + set g_moduleVirtual($mod) $modfile + set g_sourceVirtual($mod) $ModulesCurrentModulefile + + if {[currentMode] eq "display" && !$::g_inhibit_dispreport} { + report "module-virtual\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} { + 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 + + 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 {} + + # do not skip a bare empty path entry that can also be found in + # reference counter array (sometimes var is cleared by setting it + # empty not unsetting it, ignore var in this case) + if {$env($var) eq "" && [info exists countarr()]} { + set usagearr() 1 + } else { + 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 + } + } + + set count_list [array get countarr] + reportDebug "getReferenceCountArray: (var=$var, delim=$separator) got\ + '$count_list'" + + return $count_list +} + + +proc unload-path {args} { + global g_stateEnvVars env g_force g_def_separator + + reportDebug "unload-path: ($args)" + + lassign [eval parsePathCommandArgs "unload-path" $args] separator\ + allow_dup idx_val var path_list + + array set countarr [getReferenceCountArray $var $separator] + + # Don't worry about dealing with this variable if it is already scheduled + # for deletion + if {[info exists g_stateEnvVars($var)] && $g_stateEnvVars($var) eq "del"} { + return {} + } + + # save initial variable content to match index arguments + if {[info exists env($var)]} { + set dir_list [split $env($var) $separator] + # detect if empty env value means empty path entry + if {[llength $dir_list] == 0 && [info exists countarr()]} { + lappend dir_list {} + } + } else { + set dir_list [list] + } + + # build list of index to remove from variable + set del_idx_list [list] + foreach dir $path_list { + # retrieve dir value if working on an index list + if {$idx_val} { + set idx $dir + # go to next index if this one is not part of the existing range + # needed to distinguish an empty value to an out-of-bound value + if {$idx < 0 || $idx >= [llength $dir_list]} { + continue + } else { + set dir [lindex $dir_list $idx] + } + } + + # update reference counter array + if {[info exists countarr($dir)]} { + incr countarr($dir) -1 + set newcount $countarr($dir) + if {$countarr($dir) <= 0} { + unset countarr($dir) + } + } else { + set newcount 0 + } + + # get all entry indexes corresponding to dir + set found_idx_list [lsearch -all -exact $dir_list $dir] + + # remove all found entries + if {$g_force || $newcount <= 0} { + # only remove passed position in --index mode + if {$idx_val} { + lappend del_idx_list $idx + } else { + set del_idx_list [concat $del_idx_list $found_idx_list] + } + # if multiple entries found remove the extra entries compared to new + # reference counter + } elseif {[llength $found_idx_list] > $newcount} { + # only remove passed position in --index mode + if {$idx_val} { + lappend del_idx_list $idx + } else { + # delete extra entries, starting from end of the list (on a path + # variable, entries at the end have less priority than those at + # the start) + set del_idx_list [concat $del_idx_list [lrange $found_idx_list\ + $newcount end]] + } + } + } + + # update variable if some element need to be removed + if {[llength $del_idx_list] > 0} { + set del_idx_list [lsort -integer -unique $del_idx_list] + set newpath [list] + set nbelem [llength $dir_list] + # rebuild list of element without indexes set for deletion + for {set i 0} {$i < $nbelem} {incr i} { + if {[lsearch -exact $del_idx_list $i] == -1} { + lappend newpath [lindex $dir_list $i] + } + } + } else { + set newpath $dir_list + } + + # set env variable and corresponding reference counter in any case + if {[llength $newpath] == 0} { + unset-env $var + 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 {pos args} { + global env g_stateEnvVars g_def_separator + + reportDebug "add-path: ($args) pos=$pos" + + lassign [eval parsePathCommandArgs "add-path" $args] separator allow_dup\ + idx_val var path_list + + set sharevar "${var}_modshare" + array set countarr [getReferenceCountArray $var $separator] + + if {$pos eq "prepend"} { + set path_list [lreverse $path_list] + } + + foreach dir $path_list { + if {![info exists countarr($dir)] || $allow_dup} { + # ignore env var set empty if no empty entry found in reference + # counter array (sometimes var is cleared by setting it empty not + # unsetting it) + if {[info exists env($var)] && ($env($var) ne "" ||\ + [info exists countarr()])} { + if {$pos eq "prepend"} { + set env($var) "$dir$separator$env($var)" + } else { + set env($var) "$env($var)$separator$dir" + } + } else { + set env($var) "$dir" + } + } + if {[info exists countarr($dir)]} { + incr countarr($dir) + } else { + 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 {} +} + +# analyze argument list passed to a path command to set default value or raise +# error in case some attributes are missing +proc parsePathCommandArgs {cmd args} { + global g_def_separator + + # parse argument list + set next_is_delim 0 + set allow_dup 0 + set idx_val 0 + foreach arg $args { + switch -glob -- $arg { + {--index} { + if {$cmd eq "add-path"} { + reportWarning "--index option has no effect on $cmd" + } else { + set idx_val 1 + } + } + {--duplicates} { + if {$cmd eq "unload-path"} { + reportWarning "--duplicates option has no effect on $cmd" + } else { + set allow_dup 1 + } + } + {-d} - {-delim} - {--delim} { + set next_is_delim 1 + } + {--delim=*} { + set delim [string range $arg 8 end] + } + default { + if {$next_is_delim} { + set delim $arg + set next_is_delim 0 + } elseif {![info exists var]} { + set var $arg + } else { + # set multiple passed values in a list + lappend val_raw_list $arg + } + } + } + } + + # adapt with default value or raise error if some arguments are missing + if {![info exists delim]} { + set delim $g_def_separator + } elseif {$delim eq ""} { + error "$cmd should get a non-empty path delimiter" + } + if {![info exists var]} { + error "$cmd should get an environment variable name" + } elseif {$var eq ""} { + error "$cmd should get a valid environment variable name" + } + if {![info exists val_raw_list]} { + error "$cmd should get a value for environment variable $var" + } + + # set list of value to add + set val_list [list] + foreach val $val_raw_list { + # check passed indexes are numbers + if {$idx_val && ![string is integer -strict $val]} { + error "$cmd should get valid number as index value" + } + + switch -- $val \ + {} { + # add empty entry in list + lappend val_list {} + } \ + $delim { + error "$cmd cannot handle path equals to separator string" + } \ + default { + # split passed value with delimiter + set val_list [concat $val_list [split $val $delim]] + } + } + + reportDebug "parsePathCommandArgs: (delim=$delim, allow_dup=$allow_dup,\ + idx_val=$idx_val, var=$var, val=$val_list, nbval=[llength $val_list])" + + return [list $delim $allow_dup $idx_val $var $val_list] +} + +proc prepend-path {args} { + set mode [currentMode] + + reportDebug "prepend-path: ($args) mode=$mode" + + if {$mode eq "load"} { + eval add-path "prepend" $args + }\ + elseif {$mode eq "unload"} { + eval unload-path $args + }\ + elseif {$mode eq "display" && !$::g_inhibit_dispreport} { + report "prepend-path\t$args" + } + + return {} +} + +proc append-path {args} { + set mode [currentMode] + + reportDebug "append-path: ($args) mode=$mode" + + if {$mode eq "load"} { + eval add-path "append" $args + }\ + elseif {$mode eq "unload"} { + eval unload-path $args + }\ + elseif {$mode eq "display" && !$::g_inhibit_dispreport} { + report "append-path\t$args" + } + + return {} +} + +proc remove-path {args} { + set mode [currentMode] + + reportDebug "remove-path: ($args) mode=$mode" + + if {$mode eq "load"} { + eval unload-path $args + }\ + elseif {$mode eq "display" && !$::g_inhibit_dispreport} { + report "remove-path\t$args" + } + 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_moduleFileStack {} + +proc pushModuleFile {modfile} { + global g_moduleFileStack ModulesCurrentModulefile + + lappend g_moduleFileStack $modfile + set ModulesCurrentModulefile $modfile +} + +proc popModuleFile {} { + global g_moduleFileStack ModulesCurrentModulefile + + set g_moduleFileStack [lrange $g_moduleFileStack 0 end-1] + set ModulesCurrentModulefile [lindex $g_moduleFileStack end] +} + +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 +# resolv_var param tells if environement variable references in path elements +# should be resolved or passed as-is in result list +proc getModulePathList {{behavior "returnempty"} {resolv_var 1}} { + global env g_def_separator + + if {[info exists env(MODULEPATH)]} { + set modpathlist [split $env(MODULEPATH) $g_def_separator] + if {$resolv_var && [llength $modpathlist] > 0} { + foreach modpath $modpathlist { + lappend resmodpathlist [resolvStringWithEnv $modpath] + } + return $resmodpathlist + } else { + return $modpathlist + } + } 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 + } +} + +# check if a module corresponds to a virtual module (module name +# does not corresponds to end of the modulefile name) +proc isModuleVirtual {mod modfile} { + if {[string first $mod $modfile end-[string length $mod]] == -1} { + 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] + } + {virtual} { + # return virtual name with file it targets + set retlist [list [lindex $mod_list($mod) 2] $mod] + } + {invalid} - {accesserr} { + # may found mod but issue, so end search with error + set retlist [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_loadedModules g_loadedModuleFiles + # module may be loaded with its full path name + if {[info exists g_loadedModules($fullname)]} { + set ret $fullname + # or name corresponds to the _lmfiles_ entry of a virtual modules in + # which case lastly loaded virtual module is returned + } elseif {[info exists g_loadedModuleFiles($fullname)]} { + set ret [lindex $g_loadedModuleFiles($fullname) end] + } + } + } 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)]} { + # a loaded modfile may correspond to multiple loaded virtual modules + switch -- $behavior { + {returnlast} { + # the last loaded module will be returned + set ret [lindex $g_loadedModuleFiles($mod) end] + } + {returnfirst} { + # the first loaded module will be returned + set ret [lindex $g_loadedModuleFiles($mod) 0] + } + {returnall} { + # all loaded modules will be returned + 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 + global g_moduleVirtual g_rcVirtual + 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 {[file isfile "@prefix@/etc/rc"]} { + lappend rclist "@prefix@/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] + array set g_rcVirtual [array get g_moduleVirtual] +} + +# 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 + + 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 $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 + OUTPUT_STRIP_TRAILING_WHITESPACE)} + 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] + # a loaded modfile may correspond to multiple loaded virtual modules + lappend 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 ModulesCurrentModulefile + + # currently executing a modulefile or rc, so get the directory of this file + if {$ModulesCurrentModulefile ne ""} { + set curdir [file dirname $ModulesCurrentModulefile] + # elsewhere get module command current working directory + } else { + # register pwd at first call + if {![info exists cwd]} { + set cwd [pwd] + } + set curdir $cwd + } + + set abslist {} + # get a first version of the absolute path by joining the current working + # directory to the given path. if given path is already absolute + # 'file join' will not break it as $curdir will be ignored as soon a + # beginning '/' character is found on $path. this first pass also clean + # extra '/' character. then each element of the path is analyzed to clear + # "." and ".." components. + foreach elt [file split [file join $curdir $path]] { + if {$elt eq ".."} { + # skip ".." element if it comes after root element, remove last + # element elsewhere + if {[llength $abslist] > 1} { + set abslist [lreplace $abslist end end] + } + # skip any "." element + } elseif {$elt ne "."} { + lappend abslist $elt + } + } + + # 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 { + # preserve empty entries + if {[info exists not_first]} { + append res $sep + } else { + set not_first 1 + } + # escape any separator character when adding to string + append res [charEscaped $elt $sep] + } + + return $res +} + +# 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} { + global g_modfileValid + + reportDebug "checkValidModule: $modfile" + + # use cached result + if {[info exists g_modfileValid($modfile)]} { + return $g_modfileValid($modfile) + } else { + # 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" + } + } + + # cache result at first query + return [set g_modfileValid($modfile) [list $check_valid $check_msg]] + } +} + +# get file modification time, cache it at first query, use cache afterward +proc getFileMtime {fpath} { + global g_fileMtime + + if {[info exists g_fileMtime($fpath)]} { + return $g_fileMtime($fpath) + } else { + return [set g_fileMtime($fpath) [file mtime $fpath]] + } +} + +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 [getFileMtime $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_sourceVirtual g_resolvedPath + global g_rcAlias g_moduleAlias g_rcVersion g_moduleVersion + global g_rcVirtual g_moduleVirtual + + 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 + execute-modulerc $dir/$elt + 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 + # or a virtual module + } elseif {[info exists g_moduleVirtual($versmod)]} { + lappend matching_versvirt $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] + } else { + # add reference to orphan list if dir does not exist may be added + # below if dir is virtually set by a virtual deep module + lappend orphan_list($parentname) [file tail $alias] + } + } + } + + # add virtual mods found when parsing .version or .modulerc files in this + # directory (skip virtual mods not registered from this directory except if + # global or user rc definitions should be included) if they match passed + # $mod (as for regular modulefiles) or if a symbolic versions targeting + # virtual mod match passed $mod + set matching_virtual [array names g_moduleVirtual -glob $mod*] + if {[info exists matching_versvirt]} { + foreach versvirt $matching_versvirt { + if {[lsearch -exact $matching_virtual $versvirt] == -1} { + lappend matching_virtual $versvirt + } + } + } + foreach virt $matching_virtual { + if {($dir ne "" && [string first "$dir/" $g_sourceVirtual($virt)] == 0)\ + || ($add_rc_defs && [info exists g_rcVirtual($virt)])} { + lassign [checkValidModule $g_moduleVirtual($virt)] check_valid\ + check_msg + switch -- $check_valid { + {true} { + if {$fetch_mtime} { + set mtime [getFileMtime $g_moduleVirtual($virt)] + } else { + set mtime {} + } + # set mtime at index 1 like a modulefile entry + set mod_list($virt) [list "virtual" $mtime\ + $g_moduleVirtual($virt)] + + 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($virt) [list $check_valid $check_msg\ + $g_moduleVirtual($virt)] + + # no reference to parent list + set add_ref_to_parent 0 + } + } + + # in case virtual mod overwrites a directory definition + if {[info exists dir_list($virt)]} { + unset dir_list($virt) + } + + # add reference to this virtual mod in parent structure + if {$add_ref_to_parent} { + set parentname [file dirname $virt] + set elt [file tail $virt] + + # initialize virtual parent structure if it does not exist + if {![info exists mod_list($parentname)]} { + # loop until reaching an existing or a top entry + while {![info exists mod_list($parentname)]\ + && $parentname ne "."} { + # create virtual directory entry + set mod_list($parentname) [list "directory" $elt] + set dir_list($parentname) 1 + + set elt [file tail $parentname] + set parentname [file dirname $parentname] + } + # add reference to reached existing entry + if {[info exists mod_list($parentname)]} { + lappend mod_list($parentname) $elt + } + } else { + lappend mod_list($parentname) $elt + } + } + } + } + + # integrate aliases defined in orphan directories if these dirs have been + # virtually created by a virtual module reference + foreach dir [array names orphan_list] { + if {[info exists mod_list($dir)]} { + set mod_list($dir) [concat $mod_list($dir) $orphan_list($dir)] + } + } + + # 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 and virtual 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 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} - {virtual} { + 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 [getFileMtime $mod] + set tag_list {} + # or if loaded module is a virtual module + } elseif {[isModuleVirtual $mod $g_loadedModules($mod)]} { + set mtime [getFileMtime $g_loadedModules($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 + } + {virtual} { + lappend g_return_text [lindex $mod_list($elt) 2] + } + {alias} - {version} { + # resolve alias target + set aliastarget [lindex $mod_list($elt) 1] + lassign [getPathToModule $aliastarget $target_dir_list]\ + 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 g_sourceVirtual + + 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 + } + {virtual} { + set interp_list($elt) [lindex $mod_list($elt) 2] + 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 ""} { + # get belonging modulepath dir depending of module kind + if {[isModuleVirtual $modname $modfile]} { + set dir [findModulepathFromModulefile $g_sourceVirtual($modname)] + } else { + 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 "returnempty" 0]\ + $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 "returnempty" 0] + # 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 "returnempty" 0] + + # 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 [getFileMtime $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 fpath $args { + set absfpath [getAbsolutePath $fpath] + if {$fpath eq ""} { + reportErrorAndExit "File name empty" + } elseif {[file exists $absfpath]} { + pushMode "load" + pushSpecifiedName $absfpath + pushModuleName $absfpath + # 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 $absfpath 0 + popModuleName + popSpecifiedName + popMode + } else { + reportErrorAndExit "File $fpath does not exist" + } + } +} + +proc cmdModuleUnsource {args} { + reportDebug "cmdModuleUnsource: $args" + foreach fpath $args { + set absfpath [getAbsolutePath $fpath] + if {$fpath eq ""} { + reportErrorAndExit "File name empty" + } elseif {[file exists $absfpath]} { + pushMode "unload" + pushSpecifiedName $absfpath + pushModuleName $absfpath + # 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 $absfpath 0 + popModuleName + popSpecifiedName + popMode + } else { + reportErrorAndExit "File $fpath does not exist" + } + } +} + +proc cmdModuleLoad {args} { + global g_loadedModules g_loadedModuleFiles g_force + + 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 + + if {$g_force || ! [info exists g_loadedModules($currentModule)]} { + pushSpecifiedName $mod + pushModuleName $currentModule + pushSettings + + if {[execute-modulefile $modfile]} { + restoreSettings + set ret 1 + } else { + add-path "append" LOADEDMODULES $currentModule + # allow duplicate modfile entries for virtual modules + add-path "append" --duplicates _LMFILES_ $modfile + # update cache arrays + set g_loadedModules($currentModule) $modfile + lappend g_loadedModuleFiles($modfile) $currentModule + } + + popSettings + popModuleName + popSpecifiedName + } else { + reportDebug "cmdModuleLoad: $modname ($modfile) already loaded" + } + } else { + set ret 1 + } + } + popMode + + return $ret +} + +proc cmdModuleUnload {match args} { + global g_loadedModules g_loadedModuleFiles + + 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 + + if {[info exists g_loadedModules($currentModule)]} { + pushSpecifiedName $mod + pushModuleName $currentModule + pushSettings + + if {[execute-modulefile $modfile]} { + restoreSettings + set ret 1 + } else { + # get module position in loaded list to remove corresponding + # loaded modulefile (entry at same position in _LMFILES_) + set lmidx [lsearch -exact [getLoadedModuleList] $currentModule] + unload-path LOADEDMODULES $currentModule + unload-path --index _LMFILES_ $lmidx + # update cache arrays + unset g_loadedModules($currentModule) + if {[llength $g_loadedModuleFiles($modfile)] == 1} { + unset g_loadedModuleFiles($modfile) + } else { + set g_loadedModuleFiles($modfile) [replaceFromList\ + $g_loadedModuleFiles($modfile) $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} { + reportDebug "cmdModuleUse: $args" + + if {$args eq ""} { + showModulePath + } else { + set pos "prepend" + foreach path $args { + switch -- $path { + {-a} - {--append} - {-append} { + set pos "append" + } + {-p} - {--prepend} - {-prepend} { + set pos "prepend" + } + {} { + reportError "Directory name empty" + } + default { + # tranform given path in an absolute path to avoid + # dependency to the current work directory. + set path [getAbsolutePath $path] + if {[file isdirectory [resolvStringWithEnv $path]]} { + pushMode "load" + catch { + add-path $pos MODULEPATH $path + } + popMode + } else { + reportError "Directory '$path' not found" + } + } + } + } + } +} + +proc cmdModuleUnuse {args} { + reportDebug "cmdModuleUnuse: $args" + + if {$args eq ""} { + showModulePath + } else { + foreach path $args { + # get current module path list + if {![info exists modpathlist]} { + set modpathlist [getModulePathList "returnempty" 0] + } + + # 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 ""} { + pushMode "unload" + catch { + unload-path MODULEPATH $unusepath + } + popMode + + # refresh path list after unload + set modpathlist [getModulePathList "returnempty" 0] + 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@" + + # register command location + setenv MODULES_CMD [getAbsolutePath $argv0] + + # define current Modules version if versioning enabled + @VERSIONING@if {![info exists env(MODULE_VERSION)]} { + @VERSIONING@ setenv MODULE_VERSION "@MODULES_RELEASE@@MODULES_BUILD@" + @VERSIONING@ setenv MODULE_VERSION_STACK "@MODULES_RELEASE@@MODULES_BUILD@" + @VERSIONING@} + + # 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 ":"] + } + } + } + + if {![info exists env(MODULEPATH)]} { + 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 + if {[catch {eval $cmd $args} res]} { + # report error if any and return false + reportError $res + } else { + # 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 val [...] Prepend value to environment variable + append-path [-d c] var val [...] Append value to environment variable + remove-path [-d c] var val [...] Remove value from environment variable + +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 + reportDebug "CALLING $argv0 $argv" + + # source site configuration script if any + if {[file readable $g_siteconfig]} { + reportDebug "Source site configuration ($g_siteconfig)" + if {[catch {source $g_siteconfig} errMsg]} { + reportErrorAndExit "Site configuration source failed\n$errMsg" + } + } + + # 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 { + reportErrorAndExit "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=*} \ + - {--duplicates} - {--index} { + # 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 + reportWarning "Unsupported option '$arg'" + } + {-u} - {--userlvl} { + reportWarning "Unsupported option '$arg'" + # also ignore argument value + set ignore_next_arg 1 + } + {-*} { + reportErrorAndExit "Invalid option '$arg'\nTry\ + 'module --help' for more information." + } + default { + lappend otherargv $arg + } + } + } + } + + # now options are known initialize error report (start pager if enabled) + initErrorReport + + # 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 + + # no modulefile is currently being interpreted + pushModuleFile {} + + # 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: