diff --git a/scripts/Bootstrap/Pmodules/modulecmd.tcl b/scripts/Bootstrap/Pmodules/modulecmd.tcl new file mode 100755 index 0000000..20ef41a --- /dev/null +++ b/scripts/Bootstrap/Pmodules/modulecmd.tcl @@ -0,0 +1,3230 @@ +#!/bin/sh +# \ +type tclsh 1>/dev/null 2>&1 && exec tclsh "$0" "$@" +# \ +[ -x /usr/local/bin/tclsh ] && exec /usr/local/bin/tclsh "$0" "$@" +# \ +[ -x /usr/bin/tclsh ] && exec /usr/bin/tclsh "$0" "$@" +# \ +[ -x /bin/tclsh ] && exec /bin/tclsh "$0" "$@" +# \ +echo "FATAL: module: Could not find tclsh in \$PATH or in standard directories" >&2; exit 1 + +######################################################################## +# This is a pure TCL implementation of the module command +# to initialize the module environment, either +# - one of the scripts from the init directory should be sourced, or just +# - eval `/some-path/tclsh modulecmd.tcl MYSHELL autoinit` +# in both cases the path to tclsh is remembered and used furtheron +######################################################################## +# +# Some Global Variables..... +# +regsub {\$[^:]+:\s*(\S+)\s*\$} {$Revision: 1.147 $} {\1}\ + MODULES_CURRENT_VERSION +set g_debug 1 ;# Set to 1 to enable debugging +set error_count 0 ;# Start with 0 errors +set g_autoInit 0 +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 + +# Used to tell if a machine is running Windows or not +proc isWin {} { + global tcl_platform + + if { $tcl_platform(platform) == "windows" } { + return 1 + } else { + return 0 + } +} + +# +# Set Default Path separator +# +if { [isWin] } { + set g_def_separator "\;" +} else { + set g_def_separator ":" +} + +# Dynamic columns +set DEF_COLUMNS 80 ;# Default size of columns for formatting +if {[catch {exec stty size} stty_size] == 0 && $stty_size != ""} { + set DEF_COLUMNS [lindex $stty_size 1] +} + +# 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 + +# +# Info, Warnings and Error message handling. +# +proc reportWarning {message {nonewline ""}} { + if {$nonewline != ""} { + puts -nonewline stderr "$message" + } else { + puts stderr "$message" + } +} + +proc reportInternalBug {message} { + global contact + + puts stderr "Module ERROR: $message\nPlease contact: $contact" +} + +proc report {message {nonewline ""}} { + if {$nonewline != ""} { + puts -nonewline stderr "$message" + } else { + puts stderr "$message" + } +} + +######################################################################## +# Use a slave TCL interpreter to execute modulefiles +# + +proc unset-env {var} { + global env g_debug + + if {[info exists env($var)]} { + if {$g_debug} { + report "DEBUG unset-env: $var" + } + unset env($var) + } +} + +proc execute-modulefile {modfile {_help ""}} { + global g_debug + global ModulesCurrentModulefile + set ModulesCurrentModulefile $modfile + + if {$g_debug} { + report "DEBUG execute-modulefile: Starting $modfile" + } + set slave __[currentModuleName] + if {![interp exists $slave]} { + interp create $slave + interp alias $slave setenv {} setenv + interp alias $slave unsetenv {} unsetenv + interp alias $slave getenv {} getenv + interp alias $slave system {} system + interp alias $slave append-path {} append-path + interp alias $slave prepend-path {} prepend-path + interp alias $slave remove-path {} remove-path + interp alias $slave prereq {} prereq + interp alias $slave conflict {} conflict + interp alias $slave is-loaded {} is-loaded + interp alias $slave module {} module + interp alias $slave module-info {} module-info + interp alias $slave module-whatis {} module-whatis + interp alias $slave set-alias {} set-alias + interp alias $slave unset-alias {} unset-alias + interp alias $slave uname {} uname + interp alias $slave x-resource {} x-resource + interp alias $slave module-version {} module-version + interp alias $slave module-alias {} module-alias + interp alias $slave reportInternalBug {} reportInternalBug + interp alias $slave reportWarning {} reportWarning + interp alias $slave report {} report + interp alias $slave isWin {} isWin + + interp eval $slave {global ModulesCurrentModulefile g_debug} + interp eval $slave [list "set" "ModulesCurrentModulefile" $modfile] + interp eval $slave [list "set" "g_debug" $g_debug] + interp eval $slave [list "set" "_help" $_help] + + } + set errorVal [interp eval $slave { + if {$g_debug} { + report "Sourcing $ModulesCurrentModulefile" + } + set sourceFailed [catch {source $ModulesCurrentModulefile} errorMsg] + if {$_help != ""} { + if {[info procs "ModulesHelp"] == "ModulesHelp"} { + ModulesHelp + } else { + reportWarning "Unable to find ModulesHelp in\ + $ModulesCurrentModulefile." + } + set sourceFailed 0 + } + if {$sourceFailed} { + if {$errorMsg == "" && $errorInfo == ""} { + unset errorMsg + return 1 + } elseif [regexp "^WARNING" $errorMsg] { + reportWarning $errorMsg + return 1 + } else { + global errorInfo + reportInternalBug "ERROR occurred in file\ + $ModulesCurrentModulefile:$errorInfo" + exit 1 + } + } else { + unset errorMsg + return 0 + } + }] + interp delete $slave + if {$g_debug} { + report "DEBUG Exiting $modfile" + } + return $errorVal +} + +# Smaller subset than main module load... This function runs modulerc and\ + .version files +proc execute-modulerc {modfile} { + global g_rcfilesSourced + global g_debug g_moduleDefault + global ModulesCurrentModulefile + + + if {$g_debug} { + report "DEBUG execute-modulerc: $modfile" + } + + set ModulesCurrentModulefile $modfile + + if {![checkValidModule $modfile]} { + reportInternalBug "+(0):ERROR:0: Magic cookie '#%Module' missing in\ + '$modfile'" + return "" + } + + set modparent [file dirname $modfile] + + if {![info exists g_rcfilesSourced($modfile)]} { + if {$g_debug} { + report "DEBUG execute-modulerc: sourcing rc $modfile" + } + set slave __.modulerc + if {![interp exists $slave]} { + interp create $slave + interp alias $slave uname {} uname + interp alias $slave system {} system + interp alias $slave module-version {} module-version + interp alias $slave module-alias {} module-alias + interp alias $slave module {} module + interp alias $slave reportInternalBug {} reportInternalBug + + interp eval $slave {global ModulesCurrentModulefile g_debug} + interp eval $slave [list "global" "ModulesVersion"] + interp eval $slave [list "set" "ModulesCurrentModulefile" $modfile] + interp eval $slave [list "set" "g_debug" $g_debug] + interp eval $slave {set ModulesVersion {}} + } + set ModulesVersion [interp eval $slave { + if [catch {source $ModulesCurrentModulefile} errorMsg] { + global errorInfo + reportInternalBug "occurred in file\ + $ModulesCurrentModulefile:$errorInfo" + exit 1 + }\ + elseif [info exists ModulesVersion] { + return $ModulesVersion + } else { + return {} + } + }] + interp delete $slave + + if {[file tail $modfile] == ".version"} { + # only set g_moduleDefault if .version file, + # otherwise any modulerc settings ala "module-version /xxx default" + # would get overwritten + set g_moduleDefault($modparent) $ModulesVersion + } + + if {$g_debug} { + report "DEBUG execute-version: Setting g_moduleDefault($modparent)\ + $ModulesVersion" + } + + # Keep track of rc files we already sourced so we don't run them again + set g_rcfilesSourced($modfile) $ModulesVersion + } + return $g_rcfilesSourced($modfile) +} + + +######################################################################## +# commands run from inside a module file +# +set ModulesCurrentModulefile {} + +proc module-info {what {more {}}} { + global g_shellType g_shell g_debug tcl_platform + global g_moduleAlias g_symbolHash g_versionHash + + set mode [currentMode] + + if {$g_debug} { + report "DEBUG module-info: $what $more mode=$mode" + } + + switch -- $what { + "mode" { + if {$more != ""} { + if {$mode == $more} { + return 1 + } else { + return 0 + } + } else { + return $mode + } + } + "name" - + "specified" { + return [currentModuleName] + } + "shell" { + return $g_shell + } + "flags" { + return 0 + } + "shelltype" { + return $g_shellType + } + "user" { + return $tcl_platform(user) + } + "alias" { + if {[info exists g_moduleAlias($more)]} { + return $g_moduleAlias($more) + } else { + return {} + } + } + "trace" { + return {} + } + "tracepat" { + return {} + } + "symbols" { + if {[regexp {^\/} $more]} { + set tmp [currentModuleName] + set tmp [file dirname $tmp] + set more "${tmp}$more" + } + if {[info exists g_symbolHash($more)]} { + return $g_symbolHash($more) + } else { + return {} + } + } + "version" { + if {[regexp {^\/} $more]} { + set tmp [currentModuleName] + set tmp [file dirname $tmp] + set more "${tmp}$more" + } + if {[info exists g_versionHash($more)]} { + return $g_versionHash($more) + } else { + return {} + } + } + default { + error "module-info $what not supported" + return {} + } + } +} + +proc module-whatis {message} { + global g_whatis g_debug + + set mode [currentMode] + + if {$g_debug} { + report "DEBUG module-whatis: $message mode=$mode" + } + + if {$mode == "display"} { + report "module-whatis\t$message" + }\ + elseif {$mode == "whatis"} { + set g_whatis $message + } + return {} +} + +# Specifies a default or alias version for a module that points to an +# existing module version Note that the C version stores aliases and +# defaults 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 g_versionHash + global g_moduleDefault + global g_debug + global ModulesCurrentModulefile + + if {$g_debug} { + report "DEBUG module-version: executing module-version $args" + } + set module_name [lindex $args 0] + + # Check for shorthand notation of just a version "/version". Base is + # implied by current dir prepend the current directory to module_name + if {[regexp {^\/} $module_name]} { + set base [file dirname $ModulesCurrentModulefile] + set module_name "${base}$module_name" + } + + foreach version [lrange $args 1 end] { + + set base [file dirname $module_name] + set aliasversion [file tail $module_name] + + if {$base != ""} { + if {[string match $version "default"]} { + # If we see more than one default for the same module, just\ + keep the first + if {![info exists g_moduleDefault($base)]} { + set g_moduleDefault($base) $aliasversion + if {$g_debug} { + report "DEBUG module-version: default $base\ + =$aliasversion" + } + } + } else { + set aliasversion "$base/$version" + if {$g_debug} { + report "DEBUG module-version: alias $aliasversion =\ + $module_name" + } + set g_moduleVersion($aliasversion) $module_name + + if {[info exists g_versionHash($module_name)]} { + # don't add duplicates + if {[lsearch -exact $g_versionHash($module_name)\ + $aliasversion] < 0} { + set tmplist $g_versionHash($module_name) + set tmplist [linsert $tmplist end $aliasversion] + set g_versionHash($module_name) $tmplist + } + } else { + set g_versionHash($module_name) $aliasversion + } + } + + + if {$g_debug} { + report "DEBUG module-version: $aliasversion = $module_name" + } + } else { + error "module-version: module argument for default must not be\ + fully version qualified" + } + } + if {[string match [currentMode] "display"]} { + report "module-version\t$args" + } + return {} +} + + +proc module-alias {args} { + global g_moduleAlias + global ModulesCurrentModulefile + global g_debug + + set alias [lindex $args 0] + set module_file [lindex $args 1] + + if {$g_debug} { + report "DEBUG module-alias: $alias = $module_file" + } + + set g_moduleAlias($alias) $module_file + + if {[info exists g_aliasHash($module_file)]} { + set tmplist $g_aliasHash($module_file) + set tmplist [linsert $tmplist end $alias] + set g_aliasHash($module_file) $tmplist + } else { + set g_aliasHash($module_file) $alias + } + + if {[string match [currentMode] "display"]} { + report "module-alias\t$args" + } + + + return {} +} + + +proc module {command args} { + set mode [currentMode] + global g_debug + + # Resolve any module aliases + if {$g_debug} { + report "DEBUG module: Resolving $args" + } + set args [resolveModuleVersionOrAlias $args] + if {$g_debug} { + report "DEBUG module: Resolved to $args" + } + + switch -- $command { + add - lo - + load { + if {$mode == "load"} { + eval cmdModuleLoad $args + }\ + elseif {$mode == "unload"} { + eval cmdModuleUnload $args + }\ + elseif {$mode == "display"} { + report "module load\t$args" + } + } + rm - unlo - + unload { + if {$mode == "load"} { + eval cmdModuleUnload $args + }\ + elseif {$mode == "unload"} { + eval cmdModuleUnload $args + }\ + elseif {$mode == "display"} { + report "module unload\t$args" + } + } + reload { + cmdModuleReload + } + use { + eval cmdModuleUse $args + } + unuse { + eval cmdModuleUnuse $args + } + source { + eval cmdModuleSource $args + } + switch - + swap { + eval cmdModuleSwitch $args + } + display - dis - + show { + eval cmdModuleDisplay $args + } + avail - av { + if {$args != ""} { + foreach arg $args { + cmdModuleAvail $arg + } + } else { + cmdModuleAvail + # Not sure if this should be a part of cmdModuleAvail or not + cmdModuleAliases + } + } + aliases - al { + cmdModuleAliases + } + path { + eval cmdModulePath $args + } + paths { + eval cmdModulePaths $args + } + list { + cmdModuleList + } + whatis { + if {$args != ""} { + foreach arg $args { + cmdModuleWhatIs $arg + } + } else { + cmdModuleWhatIs + } + } + apropos - search - + keyword { + eval cmdModuleApropos $args + } + purge { + eval cmdModulePurge + } + initadd { + eval cmdModuleInit add $args + } + initprepend { + eval cmdModuleInit prepend $args + } + initrm { + eval cmdModuleInit rm $args + } + initlist { + eval cmdModuleInit list $args + } + initclear { + eval cmdModuleInit clear $args + } + default { + error "module $command not understood" + } + } + return {} +} + +proc setenv {var val} { + global g_stateEnvVars env g_debug + set mode [currentMode] + + if {$g_debug} { + report "DEBUG setenv: ($var,$val) mode = $mode" + } + + if {$mode == "load"} { + set env($var) $val + set g_stateEnvVars($var) "new" + }\ + elseif {$mode == "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 == "display"} { + # Let display set the variable for later use in the display + # but don't commit it to the env + set env($var) $val + set g_stateEnvVars($var) "nop" + report "setenv\t\t$var\t$val" + } + return {} +} + +proc getenv {var} { + global g_debug + set mode [currentMode] + + if {$g_debug} { + report "DEBUG getenv: ($var) mode = $mode" + } + + if {$mode == "load" || $mode == "unload"} { + if {[info exists env($var)]} { + return $::env($var) + } else { + return "_UNDEFINED_" + } + }\ + elseif {$mode == "display"} { + return "\$$var" + } + return {} +} + +proc unsetenv {var {val {}}} { + global g_stateEnvVars env g_debug + set mode [currentMode] + + if {$g_debug} { + report "DEBUG unsetenv: ($var,$val) mode = $mode" + } + + if {$mode == "load"} { + if {[info exists env($var)]} { + unset-env $var + } + set g_stateEnvVars($var) "del" + }\ + elseif {$mode == "unload"} { + if {$val != ""} { + set env($var) $val + set g_stateEnvVars($var) "new" + } + }\ + elseif {$mode == "display"} { + report "unsetenv\t\t$var" + } + return {} +} + +######################################################################## +# path fiddling + +proc getReferenceCountArray {var separator} { + global env g_force g_def_separator g_debug + + if {$g_debug} { + report "DEBUG getReferenceCountArray: ($var, $separator)" + } + + set sharevar "${var}_modshare" + set modshareok 1 + if {[info exists env($sharevar)]} { + if {[info exists env($var)]} { + set modsharelist [split $env($sharevar) $g_def_separator] + set temp [expr {[llength $modsharelist] % 2}] + if {$temp == 0} { + array set countarr $modsharelist + + # sanity check the modshare list + array set fixers {} + array set usagearr {} + foreach dir [split $env($var) $separator] { + set usagearr($dir) 1 + } + foreach path [array names countarr] { + if {! [info exists usagearr($path)]} { + unset countarr($path) + set fixers($path) 1 + } + } + + foreach path [array names usagearr] { + if {! [info exists countarr($path)]} { + set countarr($path) 999999999 + } + } + + if {! $g_force} { + if {[array size fixers]} { + reportWarning "WARNING: \$$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] { + reportWarning " $dir" -nonewline + } + reportWarning "" + } + } + + } else { + # sharevar was corrupted, odd number of elements. + set modshareok 0 + } + } else { + if {$g_debug} { + reportWarning "WARNING: module: $sharevar exists (\ + $env($sharevar) ), but $var doesn't. Environment is corrupted." + } + set modshareok 0 + } + } else { + set modshareok 0 + } + + if {$modshareok == 0 && [info exists env($var)]} { + array set countarr {} + foreach dir [split $env($var) $separator] { + set countarr($dir) 1 + } + } + return [array get countarr] +} + + +proc unload-path {var path separator} { + global g_stateEnvVars env g_force g_def_separator g_debug + + array set countarr [getReferenceCountArray $var $separator] + + if {$g_debug} { + report "DEBUG unload-path: ($var, $path, $separator)" + } + + # Don't worry about dealing with this variable if it is already scheduled\ + for deletion + if {[info exists g_stateEnvVars($var)] && $g_stateEnvVars($var) == "del"} { + return {} + } + + foreach dir [split $path $separator] { + set doit 0 + + if {[info exists countarr($dir)]} { + incr countarr($dir) -1 + if {$countarr($dir) <= 0} { + set doit 1 + unset countarr($dir) + } + } else { + set doit 1 + } + + if {$doit || $g_force} { + if {[info exists env($var)]} { + set dirs [split $env($var) $separator] + set newpath "" + foreach elem $dirs { + if {$elem != $dir} { + lappend newpath $elem + } + } + if {$newpath == ""} { + 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) [join [array get countarr] $g_def_separator] + set g_stateEnvVars($sharevar) "new" + } else { + unset-env $sharevar + set g_stateEnvVars($sharevar) "del" + } + return {} +} + +proc add-path {var path pos separator} { + global env g_stateEnvVars g_def_separator g_debug + + if {$g_debug} { + report "DEBUG add-path: ($var, $path, $separator)" + } + + set sharevar "${var}_modshare" + array set countarr [getReferenceCountArray $var $separator] + + if {$pos == "prepend"} { + set pathelems [reverseList [split $path $separator]] + } else { + set pathelems [split $path $separator] + } + foreach dir $pathelems { + if {[info exists countarr($dir)]} { + # already see $dir in $var" + incr countarr($dir) + } else { + if {[info exists env($var)]} { + if {$pos == "prepend"} { + set env($var) "$dir$separator$env($var)" + }\ + elseif {$pos == "append"} { + set env($var) "$env($var)$separator$dir" + } else { + error "add-path doesn't support $pos" + } + } else { + set env($var) "$dir" + } + set countarr($dir) 1 + } + if {$g_debug} { + report "DEBUG add-path: env($var) = $env($var)" + } + } + + + set env($sharevar) [join [array get countarr] $g_def_separator] + set g_stateEnvVars($var) "new" + set g_stateEnvVars($sharevar) "new" + return {} +} + +proc prepend-path {var path args} { + global g_def_separator g_debug + + set mode [currentMode] + + if {$g_debug} { + report "DEBUG prepend-path: ($var, $path, $args) mode=$mode" + } + + if {[string match $var "-delim"]} { + set separator $path + set var [lindex $args 0] + set path [lindex $args 1] + } else { + set separator $g_def_separator + } + + if {$mode == "load"} { + add-path $var $path "prepend" $separator + } elseif {$mode == "unload"} { + unload-path $var $path $separator + } elseif {$mode == "display"} { + report "prepend-path\t$var\t$path" + } + return {} +} + + +proc append-path {var path args} { + global g_def_separator g_debug + + set mode [currentMode] + + if {$g_debug} { + report "DEBUG append-path: ($var, $path, $args) mode=$mode" + } + + if {[string match $var "-delim"]} { + set separator $path + set var [lindex $args 0] + set path [lindex $args 1] + } else { + set separator $g_def_separator + } + + if {$mode == "load"} { + add-path $var $path "append" $separator + } elseif {$mode == "unload"} { + unload-path $var $path $separator + } elseif {$mode == "display"} { + report "append-path\t$var\t$path" + } + return {} +} + +proc remove-path {var path args} { + global g_def_separator g_debug + + set mode [currentMode] + + if {$g_debug} { + report "DEBUG remove-path: ($var, $path, $args) mode=$mode" + } + + if {[string match $var "-delim"]} { + set separator $path + set var [lindex $args 0] + set path [lindex $args 1] + } else { + set separator $g_def_separator + } + + if {$mode == "load"} { + unload-path $var $path $separator + }\ + elseif {$mode == "display"} { + report "remove-path\t$var\t$path" + } + return {} +} + +proc set-alias {alias what} { + global g_Aliases g_stateAliases g_debug + set mode [currentMode] + + if {$g_debug} { + report "DEBUG set-alias: ($alias, $what) mode=$mode" + } + if {$mode == "load"} { + set g_Aliases($alias) $what + set g_stateAliases($alias) "new" + }\ + elseif {$mode == "unload"} { + set g_Aliases($alias) {} + set g_stateAliases($alias) "del" + }\ + elseif {$mode == "display"} { + report "set-alias\t$alias\t$what" + } + return {} +} + + +proc unset-alias {alias} { + global g_Aliases g_stateAliases g_debug + set mode [currentMode] + + if {$g_debug} { + report "DEBUG unset-alias: ($alias) mode=$mode" + } + if {$mode == "load"} { + set g_Aliases($alias) {} + set g_stateAliases($alias) "del" + }\ + elseif {$mode == "display"} { + report "unset-alias\t$alias" + } + return {} +} + +proc is-loaded {modulelist} { + global env g_def_separator g_debug + + if {$g_debug} { + report "DEBUG is-loaded: $modulelist" + } + + if {[llength $modulelist] > 0} { + if {[info exists env(LOADEDMODULES)]} { + foreach arg $modulelist { + set arg "$arg/" + foreach mod [split $env(LOADEDMODULES) $g_def_separator] { + set mod "$mod/" + if {[string first $arg $mod] == 0} { + return 1 + } + } + } + return 0 + } else { + return 0 + } + } + return 1 +} + + +proc conflict {args} { + global ModulesCurrentModulefile g_debug + set mode [currentMode] + set currentModule [currentModuleName] + + if {$g_debug} { + report "DEBUG conflict: ($args) mode = $mode" + } + + if {$mode == "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 == "display"} { + report "conflict\t$args" + } + return {} +} + +proc prereq {args} { + global g_debug + set mode [currentMode] + set currentModule [currentModuleName] + + if {$g_debug} { + report "DEBUG prereq: ($args) mode = $mode" + } + + if {$mode == "load"} { + if {![is-loaded $args]} { + set errMsg "WARNING: $currentModule cannot be loaded due to\ + missing prereq." + set errMsg "$errMsg\nHINT: the following modules must be loaded\ + first: $args" + error $errMsg + } + }\ + elseif {$mode == "display"} { + report "prereq\t\t$args" + } + return {} +} + +proc x-resource {resource {value {}}} { + global g_newXResources g_delXResources g_debug + set mode [currentMode] + + if {$g_debug} { + report "DEBUG x-resource: ($resource, $value)" + } + + if {$mode == "load"} { + set g_newXResources($resource) $value + }\ + elseif {$mode =="unload"} { + set g_delXResources($resource) 1 + }\ + elseif {$mode == "display"} { + report "x-resource\t$resource\t$value" + } + return {} +} + +proc uname {what} { + global unameCache tcl_platform g_debug + set result {} + + if {$g_debug} { + report "DEBUG 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 [info hostname] + } + release { + # on ubuntu get the CODENAME of the Distribution + if { [file isfile /etc/lsb-release]} { + set fd [open "/etc/lsb-release" "r"] + set a [read $fd] + regexp -nocase {DISTRIB_CODENAME=(\S+)(.*)} $a matched res end + set result $res + } else { + set result $tcl_platform(osVersion) + } + } + domain { + set result [exec /bin/domainname] + } + version { + set result [exec /bin/uname -v] + } + default { + error "uname $what not supported" + } + } + set unameCache($what) $result + } + + return $unameCache($what) +} + +######################################################################## +# internal module procedures + +set g_modeStack {} + +proc isRelease {rel} { + switch -- $rel { + unstable - + stable - + deprecated { + return 1 + } + default { + return 0 + } + } + return 0 +} + +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 +} + + +proc getInstallPrefix {mod} { + global g_debug env + + if { $g_debug } { + report "DEBUG: get intall prefix of $mod" + } + set psi_prefix [file split $env(PSI_PREFIX)] + set modulefile [file split $mod] + + # return, if module is not in $env(PSI_PREFIX) + set module_prefix [file join {*}[lrange ${modulefile} 0 [llength ${psi_prefix}]-1]] + if { $env(PSI_PREFIX) != ${module_prefix} } { + if { $g_debug } { + report "DEBUG: not in our root" + } + set result "" + } else { + set MODULE_ROOT_PATH $env(PSI_PREFIX)/$env(PSI_MODULES_ROOT) + set module_root_path [file split ${MODULE_ROOT_PATH}] + set len [llength $module_root_path] + + set name [lindex $modulefile end-1] + set version [lindex $modulefile end] + set family [lrange $modulefile $len $len] + + set prefix "$psi_prefix $family [lreverse_n [lrange $modulefile $len end] 2]" + set result [file join {*}$prefix] + } + set result +} + +proc currentMode {} { + global g_modeStack + + set mode [lindex $g_modeStack end] + return $mode +} + +proc pushMode {mode} { + global g_modeStack + + lappend g_modeStack $mode +} + +proc popMode {} { + global g_modeStack + + set len [llength $g_modeStack] + set len [expr {$len - 2}] + set g_modeStack [lrange $g_modeStack 0 $len] +} + + +set g_moduleNameStack {} + +proc currentModuleName {} { + global g_moduleNameStack + + set moduleName [lindex $g_moduleNameStack end] + return $moduleName +} + +proc pushModuleName {moduleName} { + global g_moduleNameStack + + lappend g_moduleNameStack $moduleName +} + +proc popModuleName {} { + global g_moduleNameStack + + set len [llength $g_moduleNameStack] + set len [expr {$len - 2}] + set g_moduleNameStack [lrange $g_moduleNameStack 0 $len] +} + + +# 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 {separator {}}} { + global env g_loadedModulesGeneric + global g_moduleAlias g_moduleVersion + global g_debug g_def_separator + global ModulesCurrentModulefile flag_default_mf flag_default_dir + + set retlist "" + + if {$mod == ""} { + return "" + } + + if {$separator == "" } { + set separator $g_def_separator + } + + if {$g_debug} { + report "DEBUG getPathToModule: Finding $mod" + } + + # Check for aliases +# This is already done at the root level so why do it again? +# set newmod [resolveModuleVersionOrAlias $mod] +# if {$newmod != $mod} { +# # Alias before ModulesVersion +# return [getPathToModule $newmod] +# } + + # Check for $mod specified as a full pathname + if {[string match {/*} $mod]} { + if {[file exists $mod]} { + if {[file readable $mod]} { + if {[file isfile $mod]} { + # note that a raw filename as an argument returns the full\ + path as the module name + if {[checkValidModule $mod]} { + return [list $mod $mod] + } else { + report "+(0):ERROR:0: Unable to locate a modulefile\ + for '$mod'" + return "" + } + } + } + } + }\ + elseif {[info exists env(MODULEPATH)]} { + # Now search for $mod in MODULEPATH + foreach dir [split $env(MODULEPATH) $separator] { + set path "$dir/$mod" + + # modparent is the the modulename minus the module version. + set modparent [file dirname $mod] + set modversion [file tail $mod] + # If $mod was specified without a version (no "/") then mod is\ + really modparent + if {$modparent == "."} { + set modparent $mod + } + set modparentpath "$dir/$modparent" + + + # Search the modparent directory for .modulerc files in case we\ + need to translate an alias + if {[file isdirectory $modparentpath]} { + # Execute any modulerc for this module + if {[file exists "$modparentpath/.modulerc"]} { + if {$g_debug} { + report "DEBUG getPathToModule: Found\ + $modparentpath/.modulerc" + } + execute-modulerc $modparentpath/.modulerc + } + # Check for an alias + set newmod [resolveModuleVersionOrAlias $mod] + if {$newmod != $mod} { + # Alias before ModulesVersion + return [getPathToModule $newmod] + } + } + + # Now check if the mod specified is a file or a directory + if {[file readable $path]} { + # If a directory, return the default if a .version file is + # present or return the last file within the dir + if {[file isdirectory $path]} { + set ModulesVersion "" + # Not an alias or version alias - check for a .version\ + file or find the default file + if {[info exists g_loadedModulesGeneric($mod)]} { + set ModulesVersion $g_loadedModulesGeneric($mod) + }\ + elseif {[file exists "$path/.version"] && ![file readable\ + "$path/.modulerc"]} { + # .version files aren't read if .modulerc present + if {$g_debug} { + report "DEBUG getPathToModule: Found $path/.version" + } + set ModulesVersion [execute-modulerc "$path/.version"] + } + + + # Try for the last file in directory if no luck so far + if {$ModulesVersion == ""} { + set modlist [listModules $path "" 0 "-dictionary" 0 0] + set ModulesVersion [lindex $modlist end] + if {$g_debug} { + report "DEBUG getPathToModule: Found\ + $ModulesVersion in $path" + } + } + + + if {$ModulesVersion != ""} { + # The path to the module file + set verspath "$path/$ModulesVersion" + # The modulename (name + version) + set versmod "$mod/$ModulesVersion" + set retlist [list $verspath $versmod] + } + } else { + # If mod was a file in this path, try and return that file + set retlist [list $path $mod] + } + + # We may have a winner, check validity of result + if {[llength $retlist] == 2} { + # Check to see if we've found only a directory. If so,\ + keep looking + if {[file isdirectory [lindex $retlist 0]]} { + set retlist [getPathToModule [lindex $retlist 1]] + } + + if {! [checkValidModule [lindex $retlist 0]]} { + set path [lindex $retlist 0] + } else { + return $retlist + } + } + } + # File wasn't readable, go to next path + } + # End of of foreach loop + report "+(0):ERROR:0: Unable to locate a modulefile for '$mod'" + return "" + } else { + error "\$MODULEPATH not defined" + return "" + } +} + +proc runModulerc {} { + # Runs the global RC files if they exist + global env g_debug + + if {$g_debug} { + report "DEBUG runModulerc: running..." + report "DEBUG runModulerc: env MODULESHOME = $env(MODULESHOME)" + report "DEBUG runModulerc: env HOME = $env(HOME)" + } + if {[info exists env(MODULERCFILE)]} { + if {[file readable $env(MODULERCFILE)]} { + if {$g_debug} { + report "DEBUG runModulerc: Executing $env(MODULERCFILE)" + } + cmdModuleSource $env(MODULERCFILE) + } + } + if {[info exists env(MODULESHOME)]} { + if {[file readable "$env(MODULESHOME)/etc/rc"]} { + if {$g_debug} { + report "DEBUG runModulerc: Executing $env(MODULESHOME)/etc/rc" + } + cmdModuleSource "$env(MODULESHOME)/etc/rc" + } + } + if {[info exists env(HOME)]} { + if {[file readable "$env(HOME)/.modulerc"]} { + if {$g_debug} { + report "DEBUG runModulerc: Executing $env(HOME)/.modulerc" + } + cmdModuleSource "$env(HOME)/.modulerc" + } + } +} + +proc saveSettings {} { + foreach var {env g_Aliases g_stateEnvVars g_stateAliases g_newXResource\ + g_delXResource} { + eval "global g_SAVE_$var $var" + eval "array set g_SAVE_$var \[array get $var\]" + } +} + +proc restoreSettings {} { + foreach var {env g_Aliases g_stateEnvVars g_stateAliases g_newXResource\ + g_delXResource} { + eval "global g_SAVE_$var $var" + eval "array set $var \[array get g_SAVE_$var\]" + } +} + +proc renderSettings {} { + global env g_Aliases g_shellType g_shell + global g_stateEnvVars g_stateAliases + global g_newXResources g_delXResources + global g_pathList g_systemList error_count + global g_autoInit CSH_LIMIT g_debug + + if {$g_debug} { + report "DEBUG renderSettings: called." + } + + set iattempt 0 + + # required to work on cygwin, shouldn't hurt real linux + fconfigure stdout -translation lf + + # preliminaries + + switch -- $g_shellType { + python { + puts stdout "import os" + } + } + + if {$g_autoInit} { + global argv0 + + # automatically detect which tclsh should be used for future module commands + set tclshbin [info nameofexecutable] + + # add cwd if not absolute script path + if {! [regexp {^/} $argv0]} { + set pwd [exec pwd] + set argv0 "$pwd/$argv0" + } + + set env(MODULESHOME) [file dirname $argv0] + set g_stateEnvVars(MODULESHOME) "new" + + switch -- $g_shellType { + csh { + puts stdout "if ( \$?histchars ) then" + puts stdout " set _histchars = \$histchars" + puts stdout " if (\$?prompt) then" + puts stdout " alias module 'unset histchars;set\ + _prompt=\"\$prompt\";eval `'$tclshbin' '$argv0' '$g_shell' \\!*`;set\ + histchars = \$_histchars; set prompt=\"\$_prompt\";unset\ + _prompt'" + puts stdout " else" + puts stdout " alias module 'unset histchars;eval `'$tclshbin' '$argv0'\ + '$g_shell' \\!*`;set histchars = \$_histchars'" + puts stdout " endif" + puts stdout "else" + puts stdout " if (\$?prompt) then" + puts stdout " alias module 'set _prompt=\"\$prompt\";set\ + prompt=\"\";eval `'$tclshbin' '$argv0' '$g_shell' \\!*`;set\ + prompt=\"\$_prompt\";unset _prompt'" + puts stdout " else" + puts stdout " alias module 'eval `'$tclshbin' '$argv0' '$g_shell' \\!*`'" + puts stdout " endif" + puts stdout "endif" + } + sh { + puts stdout "module () { eval `'$tclshbin' '$argv0' '$g_shell' \$*`; } ;" + } + cmd { + puts stdout "start /b \%MODULESHOME\%/init/module.cmd %*" + } + perl { + puts stdout "sub module {" + puts stdout " eval `$tclshbin \$ENV{\'MODULESHOME\'}/modulecmd.tcl perl @_`;" + puts stdout " if(\$@) {" + puts stdout " use Carp;" + puts stdout " confess \"module-error: \$@\n\";" + puts stdout " }" + puts stdout " return 1;" + puts stdout "}" + } + python { + puts stdout "import subprocess" + puts stdout "def module(command, *arguments):" + puts stdout " exec subprocess.Popen(\['$tclshbin', '$argv0', 'python', command\] \ + list(arguments), stdout=subprcess.PIPE).communicate()\[0\]" + } + lisp { + error "ERROR: XXX lisp mode autoinit not yet implemented" + } + } + + if {[file exists "$env(MODULESHOME)/modulerc"]} { + cmdModuleSource "$env(MODULESHOME)/modulerc" + } + if {[file exists "$env(MODULESHOME)/init/modulerc"]} { + cmdModuleSource "$env(MODULESHOME)/init/modulerc" + } + } + + + # new environment variables + foreach var [array names g_stateEnvVars] { + if {$g_stateEnvVars($var) == "new"} { + switch -- $g_shellType { + csh { + set val [multiEscaped $env($var)] + # csh barfs on long env vars + if {$g_shell == "csh" && [string length $val] >\ + $CSH_LIMIT} { + if {$var == "PATH"} { + reportWarning "WARNING: module: 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 "WARNING: module: $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=[multiEscaped $env($var)]; export $var;" + } + perl { + set val [doubleQuoteEscaped $env($var)] + set val [atSymbolEscaped $env($var)] + puts stdout "\$ENV{\'$var\'} = \'$val\';" + } + python { + set val [singleQuoteEscaped $env($var)] + puts stdout "os.environ\['$var'\] = '$val'" + } + lisp { + set val [doubleQuoteEscaped $env($var)] + puts stdout "(setenv \"$var\" \"$val\")" + } + cmd { + set val $env($var) + puts stdout "set $var=$val" + } + } + } elseif {$g_stateEnvVars($var) == "del"} { + switch -- $g_shellType { + csh { + puts stdout "unsetenv $var;" + } + sh { + puts stdout "unset $var;" + } + cmd { + puts stdout "set $var=" + } + perl { + puts stdout "delete \$ENV{\'$var\'};" + } + python { + puts stdout "os.environ\['$var'\] = ''" + puts stdout "del os.environ\['$var'\]" + } + lisp { + puts stdout "(setenv \"$var\" nil)" + } + } + } + } + + foreach var [array names g_stateAliases] { + if {$g_stateAliases($var) == "new"} { + switch -- $g_shellType { + csh { + # set val [multiEscaped $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\';" + } + } + } elseif {$g_stateAliases($var) == "del"} { + switch -- $g_shellType { + csh { + puts stdout "unalias $var;" + } + sh { + puts stdout "unalias $var;" + } + } + } + } + + # new x resources + if {[array size g_newXResources] > 0} { + set xrdb [findExecutable "xrdb"] + foreach var [array names g_newXResources] { + set val $g_newXResources($var) + if {$val == ""} { + switch -regexp -- $g_shellType { + {^(csh|sh)$} { + if {[file exists $var]} { + puts stdout "$xrdb -merge $var;" + } else { + puts stdout "$xrdb -merge < 0} { + set xrdb [findExecutable "xrdb"] + foreach var [array names g_delXResources] { + if {$val == ""} { + # do nothing + } else { + puts stdout "xrdb -remove < 0} { + reportWarning "ERROR: $error_count error(s) detected." + switch -- $g_shellType { + csh { + puts stdout "/bin/false;" + } + sh { + puts stdout "/bin/false;" + } + cmd { + # nothing needed, reserve for future cygwin, MKS, etc + } + perl { + puts stdout "die \"modulefile.tcl: $error_count error(s)\ + detected!\\n\"" + } + python { + puts stdout "raise RuntimeError, 'modulefile.tcl: $error_count error(s) detected!'" + } + lisp { + puts stdout "(error \"modulefile.tcl: $error_count error(s)\ + detected!\")" + } + } + set nop 0 + } else { + switch -- $g_shellType { + perl { + puts stdout "1;" + } + } + } + + + if {$nop} { + # nothing written! + switch -- $g_shellType { + csh { + puts "/bin/true;" + } + sh { + puts "/bin/true;" + } + cmd { + # nothing needed, reserve for future cygwin, MKS, etc + } + perl { + puts "1;" + } + python { + # this is not correct + puts "" + } + lisp { + puts "t" + } + } + } else { + } +} + +proc cacheCurrentModules {{separator {}}} { + global g_loadedModules g_loadedModulesGeneric env g_def_separator g_debug + + + if {$g_debug} { + report "DEBUG cacheCurrentModules: ($separator)" + } + + if {$separator == "" } { + set separator $g_def_separator + } + + # mark specific as well as generic modules as loaded + if {[info exists env(LOADEDMODULES)]} { + foreach mod [split $env(LOADEDMODULES) $separator] { + set g_loadedModules($mod) 1 + set g_loadedModulesGeneric([file dirname $mod]) [file tail $mod] + } + } +} + +# This proc resolves module aliases or version aliases to the real module name\ + and version +proc resolveModuleVersionOrAlias {names} { + global g_moduleVersion g_moduleDefault g_moduleAlias g_debug + + if {$g_debug} { + report "DEBUG resolveModuleVersionOrAlias: Resolving $names" + } + set ret_list {} + + foreach name $names { + # Chop off (default) if it exists + set x [expr {[string length $name] - 9}] + if {($x > 0) &&([string range $name $x end] == "\(default\)")} { + set name [string range $name 0 [expr {$x -1}]] + if {$g_debug} { + report "DEBUG resolveModuleVersionOrAlias: trimming name =\ + \"$name\"" + } + } + if {[info exists g_moduleAlias($name)]} { + # if the alias is another alias, we need to resolve it + if {$g_debug} { + report "DEBUG resolveModuleVersionOrAlias: $name is an alias" + } + set ret_list [linsert $ret_list end\ + [resolveModuleVersionOrAlias $g_moduleAlias($name)]] + }\ + elseif {[info exists g_moduleVersion($name)]} { + # if the pseudo version is an alias, we need to resolve it + if {$g_debug} { + report "DEBUG resolveModuleVersionOrAlias: $name is a version\ + alias" + } + set ret_list [linsert $ret_list end\ + [resolveModuleVersionOrAlias $g_moduleVersion($name)]] + }\ + elseif {[info exists g_moduleDefault($name)]} { + # if the default is an alias, we need to resolve it + if {$g_debug} { + report "DEBUG resolveModuleVersionOrAlias: found a default for\ + $name" + } + set ret_list [linsert $ret_list end [resolveModuleVersionOrAlias\ + "$name/$g_moduleDefault($name)"]] + } else { + if {$g_debug} { + report "DEBUG resolveModuleVersionOrAlias: $name is nothing\ + special" + } + set ret_list [linsert $ret_list end $name] + } + } + if {$g_debug} { + report "DEBUG resolveModuleVersionOrAlias: Resolved to $ret_list" + } + return $ret_list +} + +proc spaceEscaped {text} { + regsub -all " " $text "\\ " regsub_tmpstrg + return $regsub_tmpstrg +} + +proc multiEscaped {text} { + regsub -all {([ \\\t\{\}|<>!;#^$&*"'`()])} $text {\\\1} regsub_tmpstrg + return $regsub_tmpstrg +} + +proc doubleQuoteEscaped {text} { + regsub -all "\"" $text "\\\"" regsub_tmpstrg + return $regsub_tmpstrg +} + +proc atSymbolEscaped {text} { + regsub -all "@" $text "\\@" regsub_tmpstrg + return $regsub_tmpstrg +} + +proc singleQuoteEscaped {text} { + regsub -all "\'" $text "\\\'" regsub_tmpstrg + return $regsub_tmpstrg +} + +proc findExecutable {cmd} { + foreach dir {/usr/X11R6/bin /usr/openwin/bin /usr/bin/X11} { + if {[file executable "$dir/$cmd"]} { + return "$dir/$cmd" + } + } + return $cmd +} + +proc reverseList {list} { + set newlist {} + + foreach item $list { + set newlist [linsert $newlist 0 $item] + } + return $newlist +} + +proc replaceFromList {list1 item {item2 {}}} { + set xi [lsearch -exact $list1 $item] + + while {$xi >= 0} { + if {[string length $item2] == 0} { + set list1 [lreplace $list1 $xi $xi] + } else { + set list1 [lreplace $list1 $xi $xi $item2] + } + set xi [lsearch -exact $list1 $item] + } + + return $list1 +} + +proc checkValidModule {modfile} { + global g_debug + + if {$g_debug} { + report "DEBUG checkValidModule: $modfile" + } + + # Check for valid module + if {![catch {open $modfile r} fileId]} { + gets $fileId first_line + close $fileId + if {[string first "\#%Module" $first_line] == 0} { + return 1 + } + } + return 0 +} + +# If given module maps to default or other version aliases, a list of +# those aliases is returned. This takes the full path to a module as +# an argument. +proc getVersAliasList {modulename} { + global g_versionHash g_moduleDefault g_debug + + if {$g_debug} { + report "DEBUG getVersAliasList: $modulename" + } + + set modparent [file dirname $modulename] + + set tag_list {} + if {[info exists g_versionHash($modulename)]} { + # remove module basenames to get just version names + foreach version $g_versionHash($modulename) { + set alias_tag [file tail $version] + set tag_list [linsert $tag_list end $alias_tag] + } + } + if {[info exists g_moduleDefault($modparent)]} { + set tmp_name "$modparent/$g_moduleDefault($modparent)" + if {$tmp_name == $modulename} { + set tag_list [linsert $tag_list end "default"] + } + } + return $tag_list +} + +# Finds all module versions for mod in the module path dir +proc listModules {dir mod {full_path 1} {sort_order {-dictionary}}\ + {flag_default_mf {1}} {flag_default_dir {1}}} { + global ignoreDir + global ModulesCurrentModulefile + global g_debug + global tcl_platform + global g_versionHash + global env + + # 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"] + + # remove trailing / needed on some platforms + regsub {\/$} $full_list {} full_list + + set clean_list {} + set ModulesVersion {} + 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 direlem [file dirname $element] + + set sstart [expr {[string length $dir] +1}] + set modulename [string range $element $sstart end] + + + if {[file isdirectory $element] && [file readable $element]} { + set ModulesVersion "" + + if {$g_debug} { + report "DEBUG listModules: found $element" + } + + if {![info exists ignoreDir($tail)]} { + # include .modulerc or if not present .version file + if {[file readable $element/.modulerc]} { + lappend full_list $element/.modulerc + } elseif {[file readable $element/.version]} { + lappend full_list $element/.version + } + # Add each element in the current directory to the list + foreach f [glob -nocomplain "$element/*"] { + lappend full_list $f + } + + # if element is directory AND default or a version alias, add\ + it to the list + set tag_list [getVersAliasList $element] + + set tag {} + if {[llength $tag_list]} { + append tag "(" [join $tag_list ":"] ")" + + if {$full_path} { + set mystr ${element} + } else { + set mystr ${modulename} + } + if {[file isdirectory ${element}]} { + if {$flag_default_dir} { + set mystr "$mystr$tag" + } + } elseif {$flag_default_mf} { + set mystr "$mystr$tag" + } + lappend clean_list $mystr + + } + + } + } else { + if {$g_debug} { + report "DEBUG listModules: checking $element ($modulename) dir=$flag_default_dir mf=$flag_default_mf" + } + switch -glob -- $tail { + {.modulerc} { + if {$flag_default_dir || $flag_default_mf} { + # set is needed for execute-modulerc + set ModulesCurrentModulefile $element + execute-modulerc $element + } + } + {.version} { + if {$flag_default_dir || $flag_default_mf} { + # set is needed for execute-modulerc + set ModulesCurrentModulefile $element + execute-modulerc "$element" + + if {$g_debug} { + report "DEBUG listModules: checking default $element" + } + } + } + {.*} - + {*~} - + {*,v} - + {\#*\#} { } + default { + if {![checkValidModule $element]} { + continue + } + set release "stable" + set prefix [getInstallPrefix $element] + if { [file readable $prefix/.release] } { + if {![catch {open $prefix/.release r} fileId]} { + gets $fileId first_line + close $fileId + set rel [string trim $first_line] + switch -- $rel { + stable - + unstable - + deprecated { + set release $rel + } + } + } + } + set regexp [subst {(^|\:)${release}(\:|$)}] + if {[info exists env(PSI_USED_RELEASES)] && [regexp $regexp $env(PSI_USED_RELEASES)]} { + set tag_list [getVersAliasList $element] + + set tag {} + if {[llength $tag_list]} { + append tag "(" [join $tag_list ":"] ")" + } + if {$full_path} { + set mystr ${element} + } else { + set mystr ${modulename} + } + if {[file isdirectory ${element}]} { + if {$flag_default_dir} { + set mystr "$mystr$tag" + } + } elseif {$flag_default_mf} { + set mystr "$mystr$tag" + } + lappend clean_list $mystr + } + } + } + } + } + if {$sort_order != {}} { + set clean_list [lsort $sort_order $clean_list] + } + if {$g_debug} { + report "DEBUG listModules: Returning $clean_list" + } + + return $clean_list +} + + +proc showModulePath {{separator {}}} { + global env g_def_separator g_debug + + if {$g_debug} { + report "DEBUG showModulePath: $separator" + } + + if {$separator == "" } { + set separator $g_def_separator + } + if {[info exists env(MODULEPATH)]} { + report "Search path for module files (in search order):" + foreach path [split $env(MODULEPATH) $separator] { + report " $path" + + } + } else { + reportWarning "WARNING: no directories on module search path" + } + +} + +######################################################################## +# command line commands + +proc cmdModuleList {{separator {}}} { + global env DEF_COLUMNS show_oneperline show_modtimes g_debug + global g_def_separator + + if {$separator == "" } { + set separator $g_def_separator + } + + if {[info exists env(LOADEDMODULES)]} { + set loaded $env(LOADEDMODULES) + } else { + set loaded "" + } + + if { [string length $loaded] == 0} { + report "No Modulefiles Currently Loaded." + } else { + set list {} + report "Currently Loaded Modulefiles:" + set max 0 + + foreach mod [split $loaded $separator] { + set len [string length $mod] + + if {$len > 0} { + + if {$show_oneperline} { + report $mod + }\ + elseif {$show_modtimes} { + set filetime [clock format [file mtime [lindex\ + [getPathToModule $mod] 0]] -format "%Y/%m/%b %H:%M:%S"] + report [format "%-50s%10s" $mod $filetime] + } else { + if {$len > $max} { + set max $len + } + # skip zero length module names + # call getPathToModule to find and execute .version and\ + .modulerc files for this module + getPathToModule $mod + set tag_list [getVersAliasList $mod] + + if {[llength $tag_list]} { + append mod "(" [join $tag_list $separator] ")" + # expand string length to include version alises + set len [string length $mod] + if {$len > $max} { + set max $len + } + } + + lappend list $mod + } + } + } + if {$show_oneperline ==0 && $show_modtimes == 0} { + # save room for numbers and spacing: 2 digits + ) + space + space + set cols [expr {int($DEF_COLUMNS/($max + 5))}] + # safety check to prevent divide by zero error below + if {$cols <= 0} { + set cols 1 + } + + set item_cnt [llength $list] + set rows [expr {int($item_cnt / $cols)}] + set lastrow_item_cnt [expr {int($item_cnt % $cols)}] + if {$lastrow_item_cnt > 0} { + incr rows + } + if {$g_debug} { + report "list = $list" + report "rows/cols = $rows/$cols, max = $max" + report "item_cnt = $item_cnt, lastrow_item_cnt =\ + $lastrow_item_cnt" + } + for {set row 0} {$row < $rows} {incr row} { + for {set col 0} {$col < $cols} {incr col} { + set index [expr {$col * $rows + $row}] + set mod [lindex $list $index] + + if {$mod != ""} { + set n [expr {$index +1}] + set mod [format "%2d) %-${max}s " $n $mod] + report $mod -nonewline + } + } + report "" + } + } + } +} + +proc cmdModuleDisplay {mod} { + global env tcl_version ModulesCurrentModulefile + + set modfile [getPathToModule $mod] + if {$modfile != ""} { + pushModuleName [lindex $modfile 1] + set modfile [lindex $modfile 0] + report\ + "-------------------------------------------------------------------" + report "$modfile:\n" + pushMode "display" + execute-modulefile $modfile + popMode + popModuleName + report\ + "-------------------------------------------------------------------" + } +} + +proc cmdModulePaths {mod {separator {}}} { + global env g_pathList flag_default_mf flag_default_dir g_def_separator g_debug + + if {$g_debug} { + report "DEBUG cmdModulePaths: ($mod, $separator)" + } + + if {$separator == "" } { + set separator $g_def_separator + } + + if {[catch { + foreach dir [split $env(MODULEPATH) $separator] { + if {[file isdirectory $dir]} { + foreach mod2 [listModules $dir $mod 0 "" $flag_default_mf\ + $flag_default_dir] { + lappend g_pathList $mod2 + } + } + } + } errMsg]} { + reportWarning "ERROR: module paths $mod failed. $errMsg" + } +} + +proc cmdModulePath {mod} { + global env g_pathList ModulesCurrentModulefile g_debug + + if {$g_debug} { + report "DEBUG cmdModulePath: ($mod)" + } + set modfile [getPathToModule $mod] + if {$modfile != ""} { + set modfile [lindex $modfile 0] + set ModulesCurrentModulefile $modfile + + set g_pathList $modfile + } +} + +proc cmdModuleWhatIs {{mod {}}} { + cmdModuleSearch $mod {} +} + +proc cmdModuleApropos {{search {}}} { + cmdModuleSearch {} $search +} + +proc cmdModuleSearch {{mod {}} {search {}}} { + global env tcl_version ModulesCurrentModulefile + global g_whatis g_def_separator g_debug + + + if {$g_debug} { + report "DEBUG cmdModuleSearch: ($mod, $search)" + } + if {$mod == ""} { + set mod "*" + } + foreach dir [split $env(MODULEPATH) $g_def_separator] { + if {[file isdirectory $dir]} { + report "----------- $dir ------------- " + set modlist [listModules $dir $mod 0 "" 0 0] + foreach mod2 $modlist { + set g_whatis "" + set modfile [getPathToModule $mod2] + if {$modfile != ""} { + pushMode "whatis" + pushModuleName [lindex $modfile 1] + set modfile [lindex $modfile 0] + execute-modulefile $modfile + popMode + popModuleName + if {$search =="" || [regexp -nocase $search $g_whatis]} { + report [format "%20s: %s" $mod2 $g_whatis] + } + } + } + } + } +} + +proc cmdModuleSwitch {old {new {}}} { + global env g_debug g_loadedModulesGeneric g_loadedModules + + if {$new == ""} { + set new $old + } elseif {[info exists g_loadedModules($new)]} { + set tmp $new + set new $old + set old $tmp + } + + if {![info exists g_loadedModules($old)] && + [info exists g_loadedModulesGeneric($old)]} { + set old "$old/$g_loadedModulesGeneric($old)" + } + + if {$g_debug} { + report "DEBUG cmdModuleSwitch: new=\"$new\" old=\"$old\"" + } + + cmdModuleUnload $old + cmdModuleLoad $new +} + +proc cmdModuleSource {args} { + global env tcl_version g_loadedModules g_loadedModulesGeneric g_force g_debug + + if {$g_debug} { + report "DEBUG cmdModuleSource: $args" + } + foreach file $args { + if {[file exists $file]} { + pushMode "load" + pushModuleName $file + execute-modulefile $file + popModuleName + popMode + } else { + error "File $file does not exist" + } + } +} + +proc cmdModuleLoad {args} { + global env g_loadedModules g_loadedModulesGeneric g_force + global ModulesCurrentModulefile + global g_debug + + if {$g_debug} { + report "DEBUG cmdModuleLoad: loading $args" + } + + foreach mod $args { + set modfile [getPathToModule $mod] + if {$modfile != ""} { + set currentModule [lindex $modfile 1] + set modfile [lindex $modfile 0] + set ModulesCurrentModulefile $modfile + + if {$g_force || ! [info exists g_loadedModules($currentModule)]} { + pushMode "load" + pushModuleName $currentModule + + saveSettings + if {[execute-modulefile $modfile]} { + restoreSettings + } else { + append-path LOADEDMODULES $currentModule + append-path _LMFILES_ $modfile + set g_loadedModules($currentModule) 1 + set genericModName [file dirname $mod] + + if {![info exists\ + g_loadedModulesGeneric($genericModName)]} { + set g_loadedModulesGeneric($genericModName) [file tail\ + $currentModule] + } + } + + popMode + popModuleName + } + } + } +} + +proc cmdModuleUnload {args} { + global tcl_version g_loadedModules g_loadedModulesGeneric + global ModulesCurrentModulefile g_debug g_def_separator + + if {$g_debug} { + report "DEBUG cmdModuleUnload: unloading $args" + } + + foreach mod $args { + if {[catch { + set modfile [getPathToModule $mod] + if {$modfile != ""} { + set currentModule [lindex $modfile 1] + set modfile [lindex $modfile 0] + set ModulesCurrentModulefile $modfile + + if {[info exists g_loadedModules($currentModule)]} { + pushMode "unload" + pushModuleName $currentModule + saveSettings + if {[execute-modulefile $modfile]} { + restoreSettings + } else { + unload-path LOADEDMODULES $currentModule $g_def_separator + unload-path _LMFILES_ $modfile $g_def_separator + unset g_loadedModules($currentModule) + if {[info exists g_loadedModulesGeneric([file dirname\ + $currentModule])]} { + unset g_loadedModulesGeneric([file dirname\ + $currentModule]) + } + } + + popMode + popModuleName + } + } else { + if {[info exists g_loadedModulesGeneric($mod)]} { + set mod "$mod/$g_loadedModulesGeneric($mod)" + } + unload-path LOADEDMODULES $mod $g_def_separator + unload-path _LMFILES_ $modfile $g_def_separator + if {[info exists g_loadedModules($mod)]} { + unset g_loadedModules($mod) + } + if {[info exists g_loadedModulesGeneric([file dirname $mod])]} { + unset g_loadedModulesGeneric([file dirname $mod]) + } + } + } errMsg ]} { + reportWarning "ERROR: module: module unload $mod failed.\n$errMsg" + } + } +} + + +proc cmdModulePurge {{separator {}}} { + global env g_def_separator g_debug + + if {$g_debug} { + report "DEBUG cmdModulePurge: $separator" + } + if {$separator == "" } { + set separator $g_def_separator + } + + if {[info exists env(LOADEDMODULES)]} { + set list [split $env(LOADEDMODULES) $separator] + eval cmdModuleUnload [reverseList $list] + } +} + + +proc cmdModuleReload {{separator {}}} { + global env g_def_separator g_debug + + if {$g_debug} { + report "DEBUG cmdModuleReload: $separator" + } + + if {$separator == "" } { + set separator $g_def_separator + } + + if {[info exists env(LOADEDMODULES)]} { + set list [split $env(LOADEDMODULES) $separator] + set rlist [reverseList $list] + foreach mod $rlist { + cmdModuleUnload $mod + } + foreach mod $list { + cmdModuleLoad $mod + } + } +} + +proc cmdModuleAliases {} { + + global DEF_COLUMNS g_moduleAlias g_moduleVersion g_debug + + set label "Aliases" + set len [string length $label] + set lrep [expr {($DEF_COLUMNS - $len - 2)/2}] + set rrep [expr {$DEF_COLUMNS - $len - 2 - $lrep}] + + report "[string repeat {-} $lrep] $label [string repeat {-} $rrep]" + + foreach name [lsort -dictionary [array names g_moduleAlias]] { + report "$name -> $g_moduleAlias($name)" + } + + set label "Versions" + set len [string length $label] + set lrep [expr {($DEF_COLUMNS - $len - 2)/2}] + set rrep [expr {$DEF_COLUMNS - $len - 2 - $lrep}] + + report "[string repeat {-} $lrep] $label [string repeat {-} $rrep]" + + foreach name [lsort -dictionary [array names g_moduleVersion]] { + report "$name -> $g_moduleVersion($name)" + } +} + +proc system {mycmd args} { + global g_systemList g_debug + + if {$g_debug} { + report "DEBUG system: $mycmd $args" + } + set mode [currentMode] + set mycmd [join [concat $mycmd $args] " "] + + if {$mode == "load"} { + lappend g_systemList $mycmd + }\ + elseif {$mode == "unload"} { + # No operation here unable to undo a syscall. + }\ + elseif {$mode == "display"} { + report "system\t\t$mycmd" + } + return {} +} + +proc cmdModuleAvail {{mod {*}}} { + global env ignoreDir DEF_COLUMNS flag_default_mf flag_default_dir + global show_oneperline show_modtimes g_def_separator + + if {$show_modtimes} { + report "- Package -----------------------------.- Versions -.- Last\ + mod. ------" + } + + foreach dir [split $env(MODULEPATH) $g_def_separator] { + if {[file isdirectory "$dir"] && [file readable $dir]} { + set len [string length $dir] + set lrep [expr {($DEF_COLUMNS - $len - 2)/2}] + set rrep [expr {$DEF_COLUMNS - $len - 2 - $lrep}] + report "[string repeat {-} $lrep] $dir [string repeat {-} $rrep]" + set list [listModules "$dir" "$mod" 0 "" $flag_default_mf $flag_default_dir] + # sort names (sometimes? returned in the order as they were + # created on disk :-) + set list [lsort $list] + if {$show_modtimes} { + foreach i $list { + # don't change $i with the regsub - we need it + # to figure out the file time. + regsub {\(default\)} $i " (default)" i2 + set filetime [clock format [file mtime [lindex [getPathToModule $i] 0]] -format "%Y/%m/%b %H:%M:%S" ] + report [format "%-53s%10s" $i2 $filetime] + } + } elseif {$show_oneperline} { + foreach i $list { + regsub {\(default\)} $i " (default)" i2 + report "$i2" + } + } else { + set max 0 + foreach mod2 $list { + if {[string length $mod2] > $max} { + set max [string length $mod2] + } + } + incr max 1 + set cols [expr {int($DEF_COLUMNS / $max)}] + # safety check to prevent divide by zero error below + if {$cols <= 0} { + set cols 1 + } + + # There is no '{}' at the begining of this 'list' as there is\ + in cmd + # ModuleList - ? + set item_cnt [expr {[llength $list] - 0}] + set rows [expr {int($item_cnt / $cols)}] + set lastrow_item_cnt [expr {int($item_cnt % $cols)}] + if {$lastrow_item_cnt > 0} { + incr rows + } + for {set row 0} {$row < $rows} {incr row} { + for {set col 0} {$col < $cols} {incr col} { + set index [expr {$col * $rows + $row}] + set mod2 [lindex $list $index] + if {$mod2 != ""} { + set mod2 [format "%-${max}s" $mod2] + report $mod2 -nonewline + } + } + report "" + } + } + } + } +} + +proc cmdModuleUse {args} { + global env g_debug g_def_separator g_debug + + if {$g_debug} { + report "DEBUG cmdModuleUse: $args" + } + + if {$args == ""} { + showModulePath + return + } + set stuff_path "prepend" + foreach path $args { + if { [isRelease $path] } { + add-path PSI_USED_RELEASES $path $stuff_path $g_def_separator + } elseif {$path == ""} { + # Skip "holes" + } elseif {($path == "--append") ||($path == "-a") ||($path == "-append")} { + set stuff_path "append" + } elseif {($path == "--prepend") ||($path == "-p") ||($path == "-prepend")} { + set stuff_path "prepend" + } elseif {[file isdirectory $path]} { + if {$g_debug} { + report "DEBUG cmdModuleUse: calling add-path \ + MODULEPATH $path $stuff_path $g_def_separator" + } + + pushMode "load" + catch { + add-path MODULEPATH $path $stuff_path $g_def_separator + } + popMode + } else { + report "+(0):WARN:0: Directory '$path' not found" + } + } +} + +proc cmdModuleUnuse {args} { + global g_def_separator g_debug + + if {$g_debug} { + report "DEBUG cmdModuleUnuse: $args" + } + if {$args == ""} { + showModulePath + return + } + global env + foreach path $args { + regsub -all {\/} $path {\/} escpath + set regexp [subst {(^|\:)${escpath}(\:|$)}] + if { [isRelease $path] } { + set pathvar "PSI_USED_RELEASES" + } else { + set pathvar "MODULEPATH" + } + if {[info exists env($pathvar)] && [regexp $regexp $env($pathvar)]} { + set oldPATH $env($pathvar) + + if {$g_debug} { + report "calling unload-path $pathvar $path $g_def_separator" + } + + pushMode "unload" + catch { + unload-path $pathvar $path $g_def_separator + } + popMode + if {[info exists env($pathvar)] && $oldPATH == $env($pathvar)} { + reportWarning "WARNING: Did not unuse $path" + } + } + } +} + +proc cmdModuleDebug {{separator {}}} { + global env g_def_separator g_debug + + if {$g_debug} { + report "DEBUG cmdModuleDebug: $separator" + } + + if {$separator == "" } { + set separator $g_def_separator + } + + foreach var [array names env] { + array set countarr [getReferenceCountArray $var $separator] + + foreach path [array names countarr] { + report "$var\t$path\t$countarr($path)" + } + unset countarr + } + foreach dir [split $env(PATH) $separator] { + foreach file [glob -nocomplain -- "$dir/*"] { + if {[file executable $file]} { + set exec [file tail $file] + lappend execcount($exec) $file + } + } + } + foreach file [lsort -dictionary [array names execcount]] { + if {[llength $execcount($file)] > 1} { + report "$file:\t$execcount($file)" + } + } +} + +proc cmdModuleAutoinit {} { + global g_autoInit g_debug + + if {$g_debug} { + report "DEBUG cmdModuleAutoinit:" + } + set g_autoInit 1 +} + +proc cmdModuleInit {args} { + + global g_shell env g_debug + set moduleinit_cmd [lindex $args 0] + set notdone 1 + set notclear 1 + + if {$g_debug} { + report "DEBUG 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(zsh) [list ".modules" ".zshrc" ".zshenv" ".zlogin"] + + array set nargs { + list 0 + add 1 + load 1 + prepend 1 + rm 1 + unload 1 + switch 2 + clear 0 + } + + # Process startup files for this shell + set current_files $files($g_shell) + foreach filename $current_files { + if {$notdone && $notclear} { + set filepath $env(HOME) + append filepath "/" $filename + # create a new file to put the changes in + set newfilepath "$filepath-NEW" + + if {$g_debug} { + report "DEBUG Looking at: $filepath" + } + if {[file readable $filepath] && [file isfile $filepath]} { + set fid [open $filepath r] + + set temp [expr {[llength $args] -1}] + if {$temp != $nargs($moduleinit_cmd)} { + error "'module init$moduleinit_cmd' requires exactly\ + $nargs($moduleinit_cmd) arg(s)." + # cmdModuleHelp + exit -1 + } + + # Only open the new file if we are not doing "initlist" + if {[string compare $moduleinit_cmd "list"] != 0} { + set newfid [open $newfilepath w] + } + + 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]} { + 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 $moduleinit_cmd { + list { + report "$g_shell initialization file $filepath\ + loads modules: $modules" + } + add { + set newmodule [lindex $args 1] + set modules [replaceFromList $modules $newmodule] + append modules " $newmodule" + puts $newfid "$cmd$modules$comments" + set notdone 0 + } + prepend { + set newmodule [lindex $args 1] + set modules [replaceFromList $modules $newmodule] + set modules "$newmodule $modules" + puts $newfid "$cmd$modules$comments" + set notdone 0 + } + rm { + set oldmodule [lindex $args 1] + set modules [replaceFromList $modules $oldmodule] + if {[llength $modules] == 0} { + set modules "" + } + puts $newfid "$cmd$modules$comments" + set notdone 0 + } + switch { + set oldmodule [lindex $args 1] + set newmodule [lindex $args 2] + set modules [replaceFromList $modules\ + $oldmodule $newmodule] + puts $newfid "$cmd$modules$comments" + set notdone 0 + } + clear { + set modules "" + puts $newfid "$cmd$modules$comments" + set notclear 0 + } + default { + report "Command init$moduleinit_cmd not\ + recognized" + } + } + } else { + # copy the line from the old file to the new + if {[info exists newfid]} { + puts $newfid $curline + } + } + } + close $fid + if {[info exists newfid]} { + close $newfid + if {[catch {file copy -force $filepath $filepath-OLD}] !=\ + 0} { + report "Failed to back up original $filepath...exiting" + exit -1 + } + if {[catch {file copy -force $newfilepath $filepath}] !=\ + 0} { + report "Failed to write $filepath...exiting" + exit -1 + } + } + } + } + } +} + +proc cmdModuleHelp {args} { + global done MODULES_CURRENT_VERSION + + set done 0 + foreach arg $args { + if {$arg != ""} { + set modfile [getPathToModule $arg] + + if {$modfile != ""} { + pushModuleName [lindex $modfile 1] + set modfile [lindex $modfile 0] + report\ + "-------------------------------------------------------------------" + report "Module Specific Help for $modfile:\n" + set mode "Help" + execute-modulefile $modfile 1 + popMode + popModuleName + report\ + "-------------------------------------------------------------------" + } + set done 1 + } + } + if {$done == 0} { + report "Modules Release Tcl $MODULES_CURRENT_VERSION " 1 + report { Copyright GNU GPL v2 1991} + report {Usage: module [ command ]} + + report {Commands:} + report { list [switches] modulefile\ + [modulefile ...]} + report { display | show modulefile\ + [modulefile ...]} + report { add | load modulefile\ + [modulefile ...]} + report { purge | rm | unload modulefile\ + [modulefile ...]} + report { reload modulefile\ + [modulefile ...]} + report { switch | swap \ + [oldmodulefile] newmodulefile} + report { avail [switches] [modulefile\ + [modulefile ...]]} + report { aliases} + report { whatis [modulefile\ + [modulefile ...]]} + report { help [modulefile\ + [modulefile ...]]} + report { path modulefile} + report { paths modulefile} + report { initlist modulefile} + report { initadd modulefile} + report { initrm modulefile} + report { initclear modulefile} + report { initprepend modulefile} + report { use dir [dir ...]} + report { unuse dir [dir ...]} + report { source scriptfile} + report { apropos | keyword | search string} + report {Switches:} + report { -t terse format avail and list} + report { -l long format avail and list} + } +} + + +######################################################################## +# main program + +# needed on a gentoo system. Shouldn't hurt since it is +# supposed to be the default behavior +fconfigure stderr -translation auto + +if {$g_debug} { + report "CALLING $argv0 $argv" +} + +# Parse options +set opt [lindex $argv 1] +switch -regexp -- $opt { + {^(-deb|--deb)} { + + if {!$g_debug} { + report "CALLING $argv0 $argv" + } + + set g_debug 1 + report "DEBUG debug enabled" + + set argv [replaceFromList $argv $opt] + } + {^(--help|-h)} { + cmdModuleHelp + exit 0 + } + {^(-V|--ver)} { + report "Modules Release Tcl $MODULES_CURRENT_VERSION" + exit 0 + } + {^--} { + report "+(0):ERROR:0: Unrecognized option '$opt'" + exit -1 + } +} + +set g_shell [lindex $argv 0] +set command [lindex $argv 1] +set argv [lreplace $argv 0 1] + +switch -regexp -- $g_shell { + ^(sh|bash|ksh|zsh)$ { + set g_shellType sh + } + ^(cmd)$ { + set g_shellType cmd + } + ^(csh|tcsh)$ { + set g_shellType csh + } + ^(perl)$ { + set g_shellType perl + } + ^(python)$ { + set g_shellType python + } + ^(lisp)$ { + set g_shellType lisp + } + . { + error " +(0):ERROR:0: Unknown shell type \'($g_shell)\'" + } +} + +cacheCurrentModules + +# Find and execute any .modulerc file found in the module directories defined\ + in env(MODULESPATH) +runModulerc +# Resolve any aliased module names - safe to run nonmodule arguments +if {$g_debug} { + report "DEBUG Resolving $argv" +} + +if {[lsearch $argv "-t"] >= 0} { + set show_oneperline 1 + set argv [replaceFromList $argv "-t"] +} +if {[lsearch $argv "-l"] >= 0} { + set show_modtimes 1 + set argv [replaceFromList $argv "-l"] +} +set argv [resolveModuleVersionOrAlias $argv] +if {$g_debug} { + report "DEBUG Resolved $argv" +} + +if {[catch { + switch -regexp -- $command { + {^av} { + if {$argv != ""} { + foreach arg $argv { + cmdModuleAvail $arg + } + } else { + cmdModuleAvail + cmdModuleAliases + } + } + {^al} { + cmdModuleAliases + } + {^li} { + cmdModuleList + } + {^(di|show)} { + foreach arg $argv { + cmdModuleDisplay $arg + } + } + {^(add|lo)} { + eval cmdModuleLoad $argv + renderSettings + } + {^source} { + eval cmdModuleSource $argv + renderSettings + } + {^paths} { + # HMS: We probably don't need the eval + eval cmdModulePaths $argv + renderSettings + } + {^path} { + # HMS: We probably don't need the eval + eval cmdModulePath $argv + renderSettings + } + {^pu} { + cmdModulePurge + renderSettings + } + {^sw} { + eval cmdModuleSwitch $argv + renderSettings + } + {^(rm|unlo)} { + eval cmdModuleUnload $argv + renderSettings + } + {^use$} { + eval cmdModuleUse $argv + renderSettings + } + {^unuse$} { + eval cmdModuleUnuse $argv + renderSettings + } + {^wh} { + if {$argv != ""} { + foreach arg $argv { + cmdModuleWhatIs $arg + } + } else { + cmdModuleWhatIs + } + } + {^(apropos|search|keyword)$} { + eval cmdModuleApropos $argv + } + {^debug$} { + eval cmdModuleDebug + } + {^rel} { + cmdModuleReload + renderSettings + } + {^init(add|lo)$} { + eval cmdModuleInit add $argv + } + {^initprepend$} { + eval cmdModuleInit prepend $argv + } + {^initswitch$} { + eval cmdModuleInit switch $argv + } + {^init(rm|unlo)$} { + eval cmdModuleInit rm $argv + } + {^initlist$} { + eval cmdModuleInit list $argv + } + {^initclear$} { + eval cmdModuleInit clear $argv + } + {^autoinit$} { + cmdModuleAutoinit + renderSettings + } + {^($|help)} { + cmdModuleHelp $argv + } + . { + reportWarning "ERROR: command '$command' not recognized" + cmdModuleHelp $argv + } + } +} errMsg ]} { + reportWarning "ERROR: $errMsg" +} + +# ;;; Local Variables: *** +# ;;; mode:tcl *** +# ;;; tcl-indent-level: 4 *** +# ;;; tab-width: 8 *** +# ;;; End: ***