#!/usr/bin/env tclsh

#

# MB, make bench between modulecmd versions

# Copyright (C) 2019-2025 Xavier Delaruelle

#

# This program is free software: you can redistribute it and/or modify

# it under the terms of the GNU General Public License as published by

# the Free Software Foundation, either version 2 of the License, or

# (at your option) any later version.

#

# This program is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

# GNU General Public License for more details.

#

# You should have received a copy of the GNU General Public License

# along with this program. If not, see <http://www.gnu.org/licenses/>.

##########################################################################

proc reportUsage {} {

puts "Usage: $::argv0 \[options\] \[bench|profile\] \[test...\]

Make bench between modulecmd versions

Available tests:

help, avail, avail_cache, avail2, avail2_cache, avail3, avail3_cache,

avail4, avail4_cache, whatis, whatis_cache, whatis2, whatis2_cache,

whatis3, whatis3_cache, apropos, load, load_cache, load2, load2_cache,

list, list2, purge, unload

(all tests selected by default)

Modes:

bench Report command execution time

profile Report top 10 procedure calls

Options:

-h, --help Show this help message and exit

--with-lmod=<path>

Compare exec time against specified Lmod command

Examples:

$::argv0

$::argv0 profile

$::argv0 load unload list

$::argv0 --with-lmod=/path/to/lmod/libexec/lmod"

}

proc sgr {sgrcode str} {

return "\033\[${sgrcode}m$str\033\[0m"

}

proc reportError {str} {

puts stderr "[sgr {1;31} ERROR]: $str"

}

proc reportErrorAndExit {str} {

reportError $str

exit 1

}

proc reportWarning {str} {

puts stderr "[sgr {1;33} WARNING]: $str"

}

set benchrep 20

set profprocnb 20

set curdir [pwd]

set lmod_compat_test_list [list help avail4 avail4_cache load2 load2_cache\

list2 purge]

# time test run for a given modulecmd version

proc bench {tag args} {

##nagelfar ignore #2 Badly formed if statement

set cmd_list [if {$tag eq {lmod}} {list $::lmod_cmd} {list\

./modulecmd.$tag}]

return [expr {round([lindex [split [time {catch {exec {*}$cmd_list sh\

{*}$args >>& /dev/null}} $::benchrep]] 0] / 1000)}]

}

# profile given modulecmd version test run

proc profile {tag args} {

return [exec script/mlprof report$::profprocnb $tag {*}$args]

}

# procedures to create cache file in modulepaths prior tests and remove them

# after tests

proc module_cache_create {tag} {

exec ./modulecmd.$tag sh --silent cachebuild

}

proc module_cache_delete {tag} {

exec ./modulecmd.$tag sh --silent cacheclear

}

# run test for each modulecmd version

proc runtest {mode test} {

# is test a cache-enabled version of another test

if {[set idx [string first _cache $test]] > -1} {

set eff_test [string range $test 0 $idx-1]

set use_cache 1

} else {

set eff_test $test

set use_cache 0

}

# set environment for test (based on effective test config)

if {[info exists ::testenvlist($eff_test)]} {

foreach {var val} $::testenvlist($eff_test) {

set ::env($var) $val

}

}

if {[info exists ::testsubcmdlist($eff_test)]} {

lappend cmdlist $::testsubcmdlist($eff_test)

} else {

lappend cmdlist $eff_test

}

if {[info exists ::testarglist($eff_test)]} {

set cmdlist [concat $cmdlist $::testarglist($eff_test)]

}

foreach tag $::taglist {

# set Lmod-specific environment and options

if {$tag eq {lmod}} {

set lmod_test ${test}_lmod

if {[info exists ::testenvlist($lmod_test)]} {

foreach {var val} $::testenvlist($lmod_test) {

set ::env($var) $val

}

}

if {[info exists ::testoptlist($lmod_test)]} {

set cmdlist [concat $::testoptlist($lmod_test) $cmdlist]

}

}

# run test if tag version is compatible with it

if {[info exists ::testcompatlist($test)] && [string match {v[0-9]*}\

$tag] && "v$::testcompatlist($test)" ne $tag && [lindex [lsort\

-dictionary [list v$::testcompatlist($test) $tag]] 0] eq $tag} {

if {$mode eq {bench}} {

set res -

} else {

set res [list - 0 0]

for {set i 0} {$i < $::profprocnb} {incr i 1} {

lappend res - 0 0

}

}

} else {

if {$use_cache} {

if {$tag eq {lmod}} {

exec $::lmod_cmd sh avail >>& /dev/null

} else {

module_cache_create $tag

}

}

set res [$mode $tag {*}$cmdlist]

if {$use_cache} {

if {$tag eq {lmod}} {

catch {file delete {*}[glob\

$::env(HOME)/.cache/lmod/spiderT.*]}

} else {

module_cache_delete $tag

}

}

}

lappend ::testres($test) $tag $res

# clean Lmod-specific environment

if {$tag eq {lmod}} {

if {[info exists ::testenvlist($lmod_test)]} {

foreach {var val} $::testenvlist($lmod_test) {

unset ::env($var)

}

}

}

}

# clean test environment

if {[info exists ::testenvlist($eff_test)]} {

foreach {var val} $::testenvlist($eff_test) {

unset ::env($var)

}

}

}

# parse arguments

set hintmsg "\n Try '$argv0 --help' for more information."

foreach arg $argv {

switch -glob -- $arg {

profile {

set mode profile

}

bench {

set mode bench

}

help - avail - avail_cache - avail2 - avail2_cache - avail3 -\

avail3_cache - avail4 - avail4_cache - whatis - whatis_cache -\

whatis2 - whatis2_cache - whatis3 - whatis3_cache - apropos - load -\

load_cache - load2 - load2_cache - list - list2 - purge - unload {

lappend testlist $arg

}

--with-lmod=* {

set lmod_cmd [string range $arg 12 end]

}

-h - --help {

reportUsage

exit 0

}

-* {

reportErrorAndExit "Invalid option '$arg'$hintmsg"

}

default {

reportErrorAndExit "Invalid test name '$arg'$hintmsg"

}

}

}

# check specified lmod command exists

if {[info exists lmod_cmd] && ![file executable $lmod_cmd]} {

reportErrorAndExit "Specified Lmod command is not executable"

}

# use default values if not set on command-line

if {![info exists mode]} {

set mode bench

}

if {[info exists lmod_cmd] && $mode ne {bench}} {

reportErrorAndExit "Only bench mode supported for Lmod comparison"

}

if {![info exists testlist]} {

if {[info exists lmod_cmd]} {

set testlist $lmod_compat_test_list

} else {

set testlist [list help avail avail_cache avail2 avail2_cache avail3\

avail3_cache avail4 avail4_cache whatis whatis_cache whatis2\

whatis2_cache whatis3 whatis3_cache apropos load load_cache load2\

load2_cache list list2 purge unload]

}

} elseif {[info exists lmod_cmd]} {

foreach test $testlist {

if {$test ni $lmod_compat_test_list} {

set hint_lmod_msg " Supported tests: $lmod_compat_test_list"

reportErrorAndExit "Unsupported test for Lmod\

comparison\n$hint_lmod_msg"

}

}

}

# fetch information from git repository to save workspace and get available

# modulecmd releases to compare. script will exit on first git command if it

# not called from a git repository

set headcommit [exec git rev-parse --short=8 HEAD]

array set headref_list [exec git show-ref --heads --abbrev=8]

set headref [expr {[info exists headref_list($headcommit)] ?\

[string range $headref_list($headcommit) 11 end] : $headcommit}]

set needstash [expr {[exec git status --porcelain --untracked-files=no] ne\

{}}]

# only keep last bugfix version of significant minor release

# drop releases older than 4.1 (or older than 4.5 if profile mode)

# drop several releases (to keep some old version in comparison)

# also drop alpha/beta releases

set exclvers_list [list v4.2 v4.4 v4.6 v4.8 v5.0 v5.2 v5.4 v5.5]

set exclbef [expr {$mode eq {profile} ? {4.5} : {4.1}}]

##nagelfar implicitvarcmd {source site.exp} install_tclsh

source site.exp

set selected_tcl_version [exec $install_tclsh << {puts [info tclversion]}]

if {[string compare $selected_tcl_version 9.0] >= 0} {

reportWarning "Tcl $selected_tcl_version is selected, exclude Modules\

versions <5.5"

set exclbef 5.5

}

array set tagarray [list]

foreach tag [exec git tag --list v*] {

if {[string compare $tag v$exclbef] == 1 && [string first alpha $tag] ==\

-1 && [string first beta $tag] == -1} {

set majmin [join [lrange [split $tag .] 0 1] .]

if {[lsearch -exact $exclvers_list $majmin] == -1 && (![info exists\

tagarray($majmin)] || [string compare $tag $tagarray($majmin)] ==\

1)} {

set tagarray($majmin) $tag

}

}

}

if {[info exists lmod_cmd]} {

# only compare Lmod with latest Modules

lappend taglist $headref lmod

} else {

foreach tag [lsort [array names tagarray]] {

lappend taglist $tagarray($tag)

}

lappend taglist $headref

}

# save workspace

if {$needstash} {

exec git stash

}

# check what tag need to be built

foreach tag $taglist {

if {$tag ne {lmod} && ![file exists modulecmd.$tag]} {

lappend tagtobuildlist $tag

}

}

# build modulecmd and associated libtclenvmodules for each tag

if {[info exists tagtobuildlist]} {

# clean current workspace to build clean configuration

catch {file delete modulecmd-test.tcl modulecmd.tcl\

lib/libtclenvmodules.so}

foreach tag $tagtobuildlist {

exec git checkout $tag 2>@1

set buildtarget [expr {[string index $tag 0] ne {v} || [string\

compare $tag v4.3] == 1 ? {modulecmd-test.tcl} : {modulecmd.tcl}}]

exec make SHLIB_SUFFIX=.so.$tag $buildtarget

file rename $buildtarget modulecmd.$tag

file attributes modulecmd.$tag -permissions ugo+x

if {[file exists lib/envmodules.c]} {

exec make lib/libtclenvmodules.so

file rename lib/libtclenvmodules.so lib/libtclenvmodules.so.$tag

}

}

}

# configure environment for tests

catch {unset env(LOADEDMODULES)}

catch {unset env(LOADEDMODULES_modshare)}

catch {unset env(_LMFILES_)}

catch {unset env(_LMFILES__modshare)}

catch {unset env(MODULEPATH_modshare)}

catch {unset env(__MODULES_SHARE_MODULEPATH)}

# define bench tests and their arguments and environment

set modpath $curdir/testsuite/modulefiles

array set testsubcmdlist [list avail2 avail avail3 avail avail4 avail whatis2\

whatis whatis3 whatis load2 load list2 list]

array set testarglist [list avail2 load whatis2 load load load/all unload\

load/all load2 R-bundle-Bioconductor/3.18-foss-2023a-R-4.3.2]

array set testoptlist [list avail4_lmod --ignore_cache load2_lmod\

--ignore_cache]

# load test environment recorded in external files

foreach testenv_file [glob $curdir/testsuite/mb/testenv_*] {

set test [string range [file tail $testenv_file] 8 end]

set fid [open $testenv_file]

foreach testenv_line [split [read $fid] \n] {

set resolved_line [string map [list {$modpath} $modpath] $testenv_line]

lappend testenvlist($test) {*}[split $resolved_line]

}

close $fid

}

# define env for tests reusing env of other tests

set testenvlist(avail2) $testenvlist(avail)

set testenvlist(avail4) $testenvlist(load2)

set testenvlist(whatis) $testenvlist(avail)

set testenvlist(whatis2) $testenvlist(avail)

set testenvlist(whatis3) $testenvlist(avail3)

set testenvlist(apropos) $testenvlist(avail)

set testenvlist(unload) $testenvlist(list)

set testenvlist(purge) $testenvlist(list2)

set testenvlist(purge_lmod) $testenvlist(list2_lmod)

# some tests have a minimum version requirement

array set testcompatlist [list avail3 4.6.0 whatis3 4.6.0 avail_cache 5.3.0\

avail2_cache 5.3.0 avail3_cache 5.3.0 whatis_cache 5.3.0 whatis2_cache\

5.3.0 whatis3_cache 5.3.0 load_cache 5.3.0 load2_cache 5.3.0]

# adapt output table to test mode

if {$mode eq {profile}} {

set collen 50

set colsep {---------------------------------------------------+}

} else {

set collen 9

set colsep {----------+}

}

set linesep --------------+[string repeat $colsep [llength $taglist]]

# output header

append tooutput [format "%13s |" {}]

foreach elt $taglist {

append tooutput [format "%${collen}s |" [string range $elt 0 7]]

}

append tooutput \n$linesep

puts $tooutput

# run each bench and output result

foreach test $testlist {

runtest $mode $test

if {$mode eq {profile}} {

set tooutput {}

set nbprofres [expr {$profprocnb + 1}]

for {set i 0} {$i < $nbprofres} {incr i 1} {

append tooutput [format "%13s |" [expr {$i == 0 ? $test : {}}]]

foreach {tag res} $::testres($test) {

set procname [lindex $res [expr {$i * 3}]]

if {[string length $procname] > 32} {

set procname "[string range $procname 0 28]..."

}

set nbcalls [lindex $res [expr {$i * 3 + 1}]]

set runtime [lindex $res [expr {$i * 3 + 2}]]

append tooutput [format "%32s: %7d %8d |" $procname $nbcalls\

$runtime]

}

append tooutput \n

}

append tooutput $linesep

} else {

set tooutput [format "%13s |" $test]

foreach {tag res} $::testres($test) {

append tooutput [format "%${collen}s |" $res]

}

}

puts $tooutput

}

# clean built files

foreach tag $taglist {

if {$tag ne {lmod}} {

catch {file delete modulecmd.$tag lib/libtclenvmodules.so.$tag}

}

}

catch {file delete tcl/mfinterp.tcl}

# restore workspace if saved

if {$needstash} {

exec git stash pop

}

# vim:set tabstop=3 shiftwidth=3 expandtab autoindent syntax=tcl: