[Modules] pure TCL implementation of module...

[Mark L. <la...@mi...>]

I don't know why this wasn't tried earlier! I rewrote 'modules' as a pure TCL
script. Advantages:

(1) faster
(2) no compiling needed
(3) easier to maintain, no porting needed to other machines
(4) smaller code (1 file!)


Can anyone explain to me if there is any reason at all to continue with the c
based module command? This script only took me 6 hours to write, and as far as
I can tell, it is much faster than the c based version (3).

I only implemented the stuff that I care about, so none of the 'initload' stuff
is in there. Basically just 'load, unload, switch, list, display and use'.
Also, the module repository is not hierarchical, but I don't see a need for
that. Also, I haven't tested it much for csh, but I'm sure it only requires a
little hacking. And you should not be using csh anyways. :)

-Mark



#!/usr/local/bin/tclsh
########################################################################
#
# This is a pure TCL implementation of the module command


########################################################################
# commands run from inside a module file
#

set ignoreDir(CVS) 1

proc module-info {what {more {}}} {
    global g_mode g_currentModule

    switch $what {
	"name" {
	    return $g_currentModule
	}
	"mode" {
	    if {$more != ""} {
		if {$g_mode == $more} {
		    return 1
		} else {
		    return 0
		}
	    } else {
		return $g_mode
	    }
	}
	default {
	    error "module-info $what not supported"
	}
    }
}

proc module-whatis {message} {
    if {$g_mode == "display"} {
	puts stderr "module-whatis\t$message"
    }
}

proc module {command args} {
    global g_mode

    switch $command {
	load {
	    if {$g_mode == "load"} {
		cmdModuleLoad $args
	    } elseif {$g_mode == "unload"} {
		cmdModuleUnload $args
	    } elseif {$g_mode == "display"} {
		puts stderr "module load $args"
	    }
	}
	default {
	    error "module $command not understood"
	}
    }
}

proc setenv {var val} {
    global g_newEnvVars g_delEnvVars env g_mode

    if {$g_mode == "load"} {
	set env($var) $val
	set g_newEnvVars($var) $val
    } elseif {$g_mode == "unload"} {
	if [info exists env($var)] {
	    unset env($var)
	}
	set g_delEnvVars($var) 1
    } elseif {$g_mode == "display"} {
	puts stderr "setenv\t$var\t$val"
    }
}

proc unsetenv {var} {
    global g_delEnvVars env g_mode
    
    if {$g_mode == "load"} {
	if [info exists env($var)] {
	    unset env($var)
	}
	set g_delEnvVars($var) 1
    } elseif {$g_mode == "display"} {
	puts stderr "unsetenv\t$var"
    }
}

proc unload-path {var dir} {
    global g_newEnvVars g_delEnvVars env

    if [info exists env($var)] {
	set dirs [split $env($var) ":"]
	set newpath ""
	foreach elem $dirs {
	    if {$elem != $dir} {
		lappend newpath $elem
	    }
	}
	if {$newpath == ""} {
	    unset env($var)
	    set g_delEnvVars($var) 1
	} else {
	    set env($var) [join $newpath ":"]
	    set g_newEnvVars($var) $env($var)
	}
    }
}

proc prepend-path {var dir} {
    global g_newEnvVars env g_mode

    if {$g_mode == "load"} {
	if [info exists env($var)] {
	    set env($var) "$dir:$env($var)"
	} else {
	    set env($var) "$dir"
	}
	set g_newEnvVars($var) $env($var)
    } elseif {$g_mode == "unload"} {
	unload-path $var $dir
    } elseif {$g_mode == "display"} {
	puts stderr "prepend-path\t$var\t$dir"
    }
}

proc append-path {var dir} {
    global g_newEnvVars env g_mode

    if {$g_mode == "load"} {
	if [info exists env($var)] {
	    set env($var) "$env($var):$dir"
	} else {
	    set env($var) "$dir"
	}
	set g_newEnvVars($var) $env($var)
    } elseif {$g_mode == "unload"} {
	unload-path $var $dir
    } elseif {$g_mode == "display"} {
	puts stderr "append-path\t$var\t$dir"
    }
}

proc set-alias {alias what} {
    global g_newAliases g_delAliases g_mode

    if {$g_mode == "load"} {
	set g_newAliases($alias) $what
    } elseif {$g_mode == "unload"} {
	set g_delAliases($alias) $what
    } elseif {$g_mode == "display"} {
	puts stderr "alias\t$alias\t$what"
    }
}


proc conflict {args} {
    global g_loadedModules g_loadedModulesGeneric g_mode g_currentModule

    if {$g_mode == "load"} {
	foreach conflict $args {
	    set mod [file dirname $conflict]
#puts stderr "mod=$mod"
	    if {$mod == "."} {
		if { [info exists g_loadedModulesGeneric($conflict) ] } {
		    set x $conflict/$g_loadedModulesGeneric($conflict)
		    if { $x != $g_currentModule } {
			error "Conflict with loaded module $x \nHINT: Do 'module unload $x' and then try again."
		    }
		}
	    } else {
		if { [info exists g_loadedModules($conflict)] &&
		     $conflict != $g_currentModule } {
		    error "Conflict ($g_currentModule) with loaded module: $conflict"
		}
	    }
	}
    } elseif {$g_mode == "display"} {
	puts stderr "conflict\t$args"
    }
}

proc x-resource {resource {value {_FILE_}}} {
    global g_newXResources g_delXResources g_mode
    
    if {$g_mode == "load"} {
	set g_newXResources($resource) $value
    } elseif {$g_mode =="unload"} {
	set g_delXResources($resource) 1
    } elseif {$g_mode == "display"} {
	puts stderr "x-resource\t$resource\$val"
    }
}

proc uname {what} {
    global unameCache
    if { ! [info exists unameCache($what)] } {
	switch $what {
	    sysname {
		catch { exec uname -s } result
	    }
	    machine {
		catch { exec uname -p } result
	    }
	    node {
		catch { exec uname -n } result
	    }
	    default {
		error "uname setting $what not implemented"
	    }
	}
	set unameCache($what) $result
    }
    
    return $unameCache($what)
}

########################################################################
# internal module procedures

proc getPathToModule {mod} {
    global env g_currentModule g_loadedModulesGeneric

    if [info exists env(MODULEPATH)] {
	foreach dir [split $env(MODULEPATH) ":"] {
	    set path "$dir/$mod"
	    if [file exists $path] {
		if [file readable $path] {
		    if [file isdirectory $path] {
			if [info exists g_loadedModulesGeneric($mod)] {
			    set ModulesVersion $g_loadedModulesGeneric($mod)
			} elseif [file exists "$path/.version"] {
			    source "$path/.version"
			} else {
			    set ModulesVersion [file tail [lindex [glob "$path/*"] 0]]
			}
			set path "$path/$ModulesVersion"
			set mod "$mod/$ModulesVersion"
		    }
		    
		    if [file isfile $path] {
			set g_currentModule $mod
			return $path
		    }
		} else {
		    error "$path not readable"
		}
	    }
	}
	error "Module $mod not found on \$MODULEPATH.\nHINT: Use 'module use ...' to add to search path."
    } else {
	error "\$MODULEPATH not defined"
    }
}

proc renderSettings {} {
    global g_newEnvVars g_newAliases g_shellType g_shell
    global g_delEnvVars g_delAliases
    global g_newXResources g_delXResources

    set iattempt 0
    set f ""
    while {$iattempt < 100 && $f == ""} {
	set tmpfile [format "/tmp/modulescript_%d_%d" [pid] $iattempt]
	set f [open  $tmpfile "w"]
	incr iattempt
    }
    
    if {$f == ""} {
	error "Could not open a temporary file in /tmp/modulescript_* !"
    } else {
	switch $g_shellType {
	    csh {
		foreach var [array names g_newEnvVars] {
		    set val [doubleQuoteEscaped $g_newEnvVars($var)]
		    puts $f "setenv $var \"$val\""
		}
		foreach var [array names g_newAliases] {
		    set val [doubleQuoteEscaped $g_newAliases($var)]
		    puts $f "alias $var \"$val\""
		}
		foreach var [array names g_delEnvVars] {
		    puts $f "unsetenv $var"
		}
		foreach var [array names g_delAliases] {
		    puts $f "unalias $var"
		}
		if {[array size g_newXResources] > 0} {
		    foreach var [array names g_newXResources] {
			set val $g_newXResources($var)
			if {$val == "_FILE_"} {
			    puts $f "xrdb -merge $var"
			} else {
			    puts $f "xrdb -merge <<EOF"
			    puts $f "$var: $val"
			    puts $f "EOF"
			}
		    }
		}
		if {[array size g_delXResources] > 0} {
		    foreach var [array names g_delXResources] {
			if {$val == "_FILE_"} {
			    # do nothing
			} else {
			    puts $f "xrdb -remove <<EOF"
			    puts $f "$var:"
			    puts $f "EOF"
			}
		    }
		}
		puts $f "/bin/rm -f $tmpfile"
	    }
	    sh {
		foreach var [array names g_newEnvVars] {
		    set val [doubleQuoteEscaped $g_newEnvVars($var)]
		    puts $f "$var=\"$val\"; export $var"
		}
		foreach var [array names g_newAliases] {
		    set val $g_newAliases($var)
		    puts $f "$var () {\n$val\n}"
		}
		foreach var [array names g_delEnvVars] {
		    puts $f "unset $var"
		}
		if {$g_shell == "zsh"} {
		    foreach var [array names g_delAliases] {
			puts $f "unfunction $var"
		    }
		} else {
		    foreach var [array names g_delAliases] {
			puts $f "unset $var"
		    }
		}
		if {[array size g_newXResources] > 0} {
		    foreach var [array names g_newXResources] {
			set val $g_newXResources($var)
			if {$val == "_FILE_"} {
			    puts $f "xrdb -merge $var"
			} else {
			    puts $f "xrdb -merge <<EOF"
			    puts $f "$var: $val"
			    puts $f "EOF"
			}
		    }
		}
		if {[array size g_delXResources] > 0} {
		    foreach var [array names g_delXResources] {
			if {$val == "_FILE_"} {
			    # do nothing
			} else {
			    puts $f "xrdb -remove <<EOF"
			    puts $f "$var:"
			    puts $f "EOF"
			}
		    }
		}
		puts $f "/bin/rm -f $tmpfile"
	    }
	    perl {
		foreach var [array names g_newEnvVars] {
		    set val [doubleQuoteEscaped $g_newEnvVars($var)]
		    puts $f "\$ENV{$var}=\"$val\";"
		}
		foreach var [array names g_delEnvVars] {
		    puts $f "delete \$ENV{$var};"
		}
		puts $f "unlink(\"$tmpfile\");"
	    }
	    default {
		error "shell $g_shellType not implemented"
	    }
	}
	close $f
	switch $g_shellType {
	    csh {
		puts "source $tmpfile"
	    }
	    sh {
		puts ". $tmpfile"
	    }
	    perl {
		puts "do \"$tmpfile\";"
	    }
	}
    }
}

proc cacheCurrentModules {} {
    global g_loadedModules g_loadedModulesGeneric env

# mark specific as well as generic modules as loaded
    if [info exists env(LOADEDMODULES)] {
	foreach mod [split $env(LOADEDMODULES) ":"] {
	    set g_loadedModules($mod) 1
	    set g_loadedModulesGeneric([file dirname $mod]) [file tail $mod]
	}
    }
}

proc spaceEscaped {text} {
    regsub -all " " $text "\\ " text
    return $text
}

proc doubleQuoteEscaped {text} {
    regsub -all "\"" $text "\\\"" text
    return $text
}

########################################################################
# command line commands

proc cmdModuleList {} {
    global g_mode
    set g_mode "display"

    global env
    if [info exists env(LOADEDMODULES)] {
	set list [split $env(LOADEDMODULES) ":"]
	set max 0
	foreach mod $list {
	    if {[string length $mod] > $max} {
		set max [string length $mod]
	    }
	}
# save room for numbers and spacing: 2 digits + ) + space
	incr max 4
	set cols [expr int(80/$max)]
	set lines [expr int(([llength $list] -1)/ $cols) +1]

	for {set i 0} { $i < $lines} {incr i} {
	    for {set col 0} {$col < $cols } { incr col} {
		set index [expr $col * $lines + $i]
		set mod [lindex $list $index]
		if {$mod != ""} {
		    set mod [format "%2d) %-${max}s" $index $mod]
		    puts -nonewline stderr $mod
		}
	    }
	    puts stderr ""
	}
    }
}

proc cmdModuleDisplay {mod} {
    global g_mode env tcl_version

    set g_mode "display"
    catch {
	set modfile [getPathToModule $mod]
	puts stderr "-------------------------------------------------------------------"
	puts stderr "$modfile:\n"
	source $modfile
	puts stderr "-------------------------------------------------------------------"
	set junk ""
    } errMsg
    if {$errMsg != ""} {
	puts stderr "ERROR: module display $mod failed. $errMsg"
    }
}

proc cmdModuleSwitch {old {new {}}} {
    if {$new == ""} {
	set new $old
	if {[file dirname $old] != "."} {
	    set old [file dirname $old]
	}
    }

    cmdModuleUnload $old
    cmdModuleLoad $new
}

proc cmdModuleLoad {args} {
    global g_mode g_currentModule env tcl_version g_loadedModules g_loadedModulesGeneric
 
    foreach mod $args {
	catch {
	    set modfile [getPathToModule $mod]
	    set currentModule $g_currentModule
	    set g_mode "load"
	    source $modfile
	    if { ! [ info exists g_loadedModules($currentModule)]} {
		append-path LOADEDMODULES $currentModule
		set g_loadedModules($currentModule) 1
		set g_loadedModulesGeneric([file dirname $mod]) [file tail $currentModule]
	    }
	    set junk ""
	} errMsg
	
        if {$errMsg != ""} {
	    puts stderr "ERROR: module load $mod failed. $errMsg"
	}
    }
}

proc cmdModuleUnload {args} {
    global g_mode g_currentModule env tcl_version g_loadedModules g_loadedModulesGeneric
 
    foreach mod $args {
	catch {
	    set modfile [getPathToModule $mod]
	    set currentModule $g_currentModule
	    if [ info exists g_loadedModules($currentModule)] {
		set g_mode "unload"
		source $modfile
		unload-path LOADEDMODULES $currentModule
		unset g_loadedModules($currentModule)
		if [info exists g_loadedModulesGeneric([file dirname $currentModule])] {
		    unset g_loadedModulesGeneric([file dirname $currentModule])
		}
	    }
	    set junk ""
	} errMsg
	if {$errMsg != ""} {
	    puts stderr "ERROR: module unload $mod failed. $errMsg"
	}
    }
}


proc cmdModulePurge {} {
    global env
    
    if [info exists env(LOADEDMODULES)] {
	set list [split $env(LOADEDMODULES) ":"] 
	eval cmdModuleUnload $list
    }
}


proc cmdModuleAvail { {mod {}}} {
    global g_mode env ignoreDir
    set g_mode "display"


    if {$mod == ""} {
	set mod  "*"
    }
    foreach dir [split $env(MODULEPATH) ":"] {
	if [file isdirectory $dir] {
	    array set availHash {}
	    puts stderr "---- $dir ---- "
	    cd $dir
 	    foreach file [glob -nocomplain "$mod/*"] {
		if { ! [info exists ignoreDir([file tail $file])]} {
		    # 		    puts stderr $file
		    set availHash($file) 1
		}
		#		if [file isfile $dir] {
		#		}
	    }
	    foreach mod2 [lsort [array names availHash]] {
		puts stderr $mod2
	    }
	}
    }
}

proc cmdModuleUse {args} {
    global g_mode
    set g_mode "load"
    foreach path $args {
	if [file isdirectory $path] {
	    prepend-path MODULEPATH $path
	} else {
	    error "Directory $path does not exist"
	}
    }
}

########################################################################
# main program

global g_shellType

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
    }
    ^(csh|tcsh)$ {
	set g_shellType csh
    }
    ^(perl)$ {
	set g_shellType perl
    }
    . {
	error "bad shell $g_shell"
    }
}

cacheCurrentModules

catch {
    switch $command {
	avail {
	    if {$argv != ""} {
		foreach arg $argv {
		    cmdModuleAvail $arg
		}
	    } else {
		cmdModuleAvail
	    }
	}
	list {
	cmdModuleList
	}
	display {
	    foreach arg $argv {
		cmdModuleDisplay $arg
	    }
	}
	load {
	    eval cmdModuleLoad $argv
	    renderSettings
	}
	purge {
	    cmdModulePurge
	    renderSettings
	}
	switch {
	    eval cmdModuleSwitch $argv
	    renderSettings
	}
	unload {
	    eval cmdModuleUnload $argv
	    renderSettings
	}
	use {
	    eval cmdModuleUse $argv
	    renderSettings
	}
	default {
	    puts stderr {
		ModulesTcl 0.9 (Copyright MIPS Technologies 2002):
		Available Commands and Usage:
		+ add|load              modulefile [modulefile ...]
		+ rm|unload             modulefile [modulefile ...]
		+ switch|swap           modulefile1 modulefile2
		+ display|show          modulefile [modulefile ...]
		+ avail                 [modulefile [modulefile ...]]
		+ use [-a|--append]     dir [dir ...]
		+ unuse                 dir [dir ...]
		+ update
		+ purge
		+ list
		+ clear
		+ help                  [modulefile [modulefile ...]]
		+ whatis                [modulefile [modulefile ...]]
		+ apropos|keyword       string
	    }
	}
	
    }
} errMsg

if {$errMsg != ""} {
    puts stderr "FINAL ERROR: $errMsg"
}