1#!@TCLSHDIR@/tclsh 2# 3# MODULECMD.TCL, a pure TCL implementation of the module command 4# Copyright (C) 2002-2004 Mark Lakata 5# Copyright (C) 2004-2017 Kent Mein 6# Copyright (C) 2016-2020 Xavier Delaruelle 7# 8# This program is free software: you can redistribute it and/or modify 9# it under the terms of the GNU General Public License as published by 10# the Free Software Foundation, either version 2 of the License, or 11# (at your option) any later version. 12# 13# This program is distributed in the hope that it will be useful, 14# but WITHOUT ANY WARRANTY; without even the implied warranty of 15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16# GNU General Public License for more details. 17# 18# You should have received a copy of the GNU General Public License 19# along with this program. If not, see <http://www.gnu.org/licenses/>. 20 21########################################################################## 22 23 24# Runtime state properties (default value, proc to call to initialize state 25# value?) 26array set g_state_defs [list\ 27 autoinit {0}\ 28 clock_seconds {<undef> initStateClockSeconds}\ 29 cmdline {<undef>}\ 30 cwd {<undef>}\ 31 domainname {<undef> {runCommand domainname}}\ 32 error_count {0}\ 33 extra_siteconfig_loaded {0}\ 34 false_rendered {0}\ 35 force {0}\ 36 hiding_threshold {0}\ 37 inhibit_errreport {0}\ 38 inhibit_interp {0}\ 39 init_error_report {0}\ 40 is_stderr_tty {<undef> initStateIsStderrTty}\ 41 is_win {<undef> initStateIsWin}\ 42 kernelversion {<undef> {runCommand uname -v}}\ 43 lm_info_cached {0}\ 44 machine [list $::tcl_platform(machine)]\ 45 nodename {<undef> {runCommand uname -n}}\ 46 os [list $::tcl_platform(os)]\ 47 osversion [list $::tcl_platform(osVersion)]\ 48 paginate {<undef> initStatePaginate}\ 49 path_separator {<undef> initStatePathSeparator}\ 50 rc_loaded {<undef>}\ 51 report_format {plain}\ 52 report_sep_next {<undef>}\ 53 reportfd {stderr initStateReportfd}\ 54 return_false {0}\ 55 shell {<undef>}\ 56 shelltype {<undef>}\ 57 siteconfig_loaded {0}\ 58 sub1_separator {&}\ 59 sub2_separator {|}\ 60 subcmd {<undef>}\ 61 subcmd_args {<undef>}\ 62 tcl_ext_lib_loaded {0}\ 63 tcl_version [list [info patchlevel]]\ 64 tcl_version_lt85 {<undef> initStateTclVersionLt85}\ 65 term_columns {<undef> initStateTermColumns}\ 66 usergroups {<undef> initStateUsergroups}\ 67 username {<undef> initStateUsername}\ 68] 69 70# Configuration option properties (superseding environment variable, default 71# value, is configuration lockable to default value, valid value list?, 72# internal value representation?, proc to call to initialize option value 73array set g_config_defs [list\ 74 contact {MODULECONTACT root@localhost 0}\ 75 auto_handling {MODULES_AUTO_HANDLING @autohandling@ 0 {0 1}}\ 76 avail_indepth {MODULES_AVAIL_INDEPTH @availindepth@ 0 {0 1}}\ 77 avail_report_dir_sym {{} 1 0}\ 78 avail_report_mfile_sym {{} 1 0}\ 79 collection_pin_version {MODULES_COLLECTION_PIN_VERSION 0 0 {0 1}}\ 80 collection_target {MODULES_COLLECTION_TARGET <undef> 0}\ 81 color {MODULES_COLOR @color@ 0 {never auto always} {0 1 2} initConfColor}\ 82 colors {MODULES_COLORS {} 0 {} {} initConfColors}\ 83 csh_limit {{} 4000 0}\ 84 extra_siteconfig {MODULES_SITECONFIG <undef> 1 {}}\ 85 home {MODULESHOME @moduleshome@ 0}\ 86 icase {MODULES_ICASE @icase@ 0 {never search always}}\ 87 ignored_dirs {{} {CVS RCS SCCS .svn .git .SYNC .sos} 0}\ 88 locked_configs {{} {@lockedconfigs@} 0}\ 89 ml {MODULES_ML @ml@ 0 {0 1}}\ 90 nearly_forbidden_days {MODULES_NEARLY_FORBIDDEN_DAYS @nearlyforbiddendays@\ 91 0 integer}\ 92 pager {MODULES_PAGER {@pagercmd@} 0}\ 93 rcfile {MODULERCFILE <undef> 0}\ 94 run_quarantine {MODULES_RUN_QUARANTINE <undef> 0}\ 95 silent_shell_debug {MODULES_SILENT_SHELL_DEBUG <undef> 0 {0 1}}\ 96 siteconfig {{} @etcdir@/siteconfig.tcl 0}\ 97 tcl_ext_lib {{} {} 0 {} {} initConfTclExtLib}\ 98 term_background {MODULES_TERM_BACKGROUND @termbg@ 0 {dark light}}\ 99 unload_match_order {MODULES_UNLOAD_MATCH_ORDER @unloadmatchorder@ 0\ 100 {returnlast returnfirst}}\ 101 implicit_default {MODULES_IMPLICIT_DEFAULT @implicitdefault@ 1 {0 1}}\ 102 extended_default {MODULES_EXTENDED_DEFAULT @extendeddefault@ 0 {0 1}}\ 103 advanced_version_spec {MODULES_ADVANCED_VERSION_SPEC @advversspec@ 0 {0\ 104 1}}\ 105 search_match {MODULES_SEARCH_MATCH @searchmatch@ 0 {starts_with contains}}\ 106 set_shell_startup {MODULES_SET_SHELL_STARTUP @setshellstartup@ 0 {0 1}}\ 107 verbosity {MODULES_VERBOSITY @verbosity@ 0 {silent concise normal verbose\ 108 trace debug debug2}}\ 109 wa_277 {MODULES_WA_277 @wa277@ 0 {0 1}}\ 110] 111 112# Get state value 113proc getState {state {valifundef {}} {catchinitproc 0}} { 114 if {![info exists ::g_states($state)]} { 115 # fetch state properties (including its default value) 116 lassign $::g_state_defs($state) value initproclist 117 118 # call specific proc to initialize state if any 119 if {$initproclist ne {}} { 120 # catch init procedure error and report it as warning, so default 121 # value will get set for state 122 if {$catchinitproc} { 123 if {[catch {set value [eval $initproclist]} errMsg]} { 124 reportWarning $errMsg 125 } 126 } else { 127 set value [eval $initproclist] 128 } 129 # overriden value coming the command-line 130 } elseif {[info exists ::asked_$state]} { 131 set value [set ::asked_$state] 132 } 133 134 # return passed value if undefined and no value record 135 if {$value eq {<undef>}} { 136 set value $valifundef 137 } else { 138 setState $state $value 139 } 140 return $value 141 } else { 142 return $::g_states($state) 143 } 144} 145 146# Clear state 147proc unsetState {state} { 148 unset ::g_states($state) 149 reportDebug "$state unset" 150} 151 152# Set state value 153proc setState {state value} { 154 set ::g_states($state) $value 155 reportDebug "$state set to '$value'" 156} 157 158# Append each passed value to the existing state value list 159proc lappendState {state args} { 160 # retrieve current value through getState to initialize it if still undef 161 set value [getState $state] 162 eval appendNoDupToList value $args 163 setState $state $value 164} 165 166# Check if state has been defined 167proc isStateDefined {state} { 168 return [info exists ::g_states($state)] 169} 170 171# Check if state equals passed value 172proc isStateEqual {state value} { 173 return [expr {[getState $state] eq $value}] 174} 175 176proc isConfigLocked {option} { 177 return [expr {[lsearch -exact [getConf locked_configs] $option] != -1}] 178} 179 180# Get configuration option value 181proc getConf {option {valifundef {}}} { 182 if {![info exists ::g_configs($option)]} { 183 # fetch option properties (including its default value) 184 lassign $::g_config_defs($option) envvar value islockable validvallist\ 185 intvallist initproc 186 187 # ensure option is not locked before superseding its default value 188 if {!$islockable || ![isConfigLocked $option]} { 189 # call specific proc to initialize config option if any 190 if {$initproc ne {}} { 191 set value [$initproc $envvar $value $validvallist $intvallist] 192 } else { 193 # overriden value coming from environment 194 if {$envvar ne {} && [info exists ::env($envvar)]} { 195 # ignore non-valid values 196 if {[switch -- [llength $validvallist] { 197 0 {expr {1 == 1}} 198 1 {string is $validvallist -strict $::env($envvar)} 199 default {isInList $validvallist $::env($envvar)} 200 }]} { 201 set value $::env($envvar) 202 } 203 } 204 205 # overriden value coming the command-line 206 if {[info exists ::asked_$option]} { 207 set value [set ::asked_$option] 208 } 209 210 # convert value to its internal representation 211 if {[llength $intvallist] > 0} { 212 set value [lindex $intvallist [lsearch -exact $validvallist\ 213 $value]] 214 } 215 } 216 } 217 218 # return passed value if undefined and no value record 219 if {$value eq {<undef>}} { 220 set value $valifundef 221 } else { 222 setConf $option $value 223 } 224 return $value 225 } else { 226 return $::g_configs($option) 227 } 228} 229 230# Set configuration option value 231proc setConf {option value} { 232 set ::g_configs($option) $value 233 reportDebug "$option set to '$value'" 234} 235 236# Unset configuration option value if it is set 237proc unsetConf {option} { 238 if {[info exists ::g_configs($option)]} { 239 unset ::g_configs($option) 240 reportDebug "$option unset" 241 } 242} 243 244# Append each passed value to the existing config option value list 245proc lappendConf {option args} { 246 # retrieve current value through getConf to initialize it if still undef 247 set value [getConf $option] 248 eval appendNoDupToList value $args 249 setConf $option $value 250} 251 252# Source site config which can be used to define global procedures or 253# settings. We first look for the global siteconfig, then if an extra 254# siteconfig is defined and allowed, source that file if it exists 255proc sourceSiteConfig {} { 256 lappend siteconfiglist [getConf siteconfig] 257 for {set i 0} {$i < [llength $siteconfiglist]} {incr i} { 258 set siteconfig [lindex $siteconfiglist $i] 259 if {[file readable $siteconfig]} { 260 reportDebug "Source site configuration ($siteconfig)" 261 if {[catch {uplevel 1 source $siteconfig} errMsg]} { 262 set errMsg "Site configuration source failed\n" 263 # issue line number is lost due to uplevel use 264 append errMsg [formatErrStackTrace $::errorInfo $siteconfig {}] 265 reportErrorAndExit $errMsg 266 } 267 if {$siteconfig eq [getConf siteconfig]} { 268 setState siteconfig_loaded 1 269 } else { 270 setState extra_siteconfig_loaded 1 271 } 272 } 273 # check on extra_siteconfig after initial siteconfig loaded in case 274 # it inhibits this extra load 275 if {$siteconfig eq [getConf siteconfig] && [getConf\ 276 extra_siteconfig] ne {}} { 277 lappend siteconfiglist [getConf extra_siteconfig] 278 } 279 } 280} 281 282# Used to tell if a machine is running Windows or not 283proc initStateIsWin {} { 284 return [expr {$::tcl_platform(platform) eq {windows}}] 285} 286 287# Get default path separator 288proc initStatePathSeparator {} { 289 return [expr {[getState is_win] ? {;} : {:}}] 290} 291 292# Detect if terminal is attached to stderr message channel 293proc initStateIsStderrTty {} { 294 return [expr {![catch {fconfigure stderr -mode}]}] 295} 296 297# Determine if pagination need to be started 298proc initStatePaginate {} { 299 set pager [getConf pager] 300 # empty or 'cat' pager command means no-pager 301 set no_cmds [list {} cat] 302 # default pager enablement depends on pager command value 303 set paginate [notInList $no_cmds [file tail [lindex $pager 0]]] 304 305 # asked enablement could only nullify a previous asked disablement as it 306 # requires a valid pager command configuration, which by default enables 307 # pagination; some module command may also turn off pager; also if error 308 # stream is not attached to a terminal 309 if {$paginate && (([info exists ::asked_paginate] && !$::asked_paginate)\ 310 || [getState subcmd] eq {clear} || ([getState subcmd] eq {ml} &&\ 311 [lindex [getState subcmd_args] 0] eq {clear}) || ![getState\ 312 is_stderr_tty])} { 313 set paginate 0 314 } 315 316 return $paginate 317} 318 319# start pager pipe process with defined configuration 320proc initStateReportfd {} { 321 # get default value 322 lassign $::g_state_defs(reportfd) reportfd 323 324 # start pager at first call and only if enabled 325 if {[getState paginate]} { 326 if {[catch { 327 set reportfd [open "|[getConf pager] >@stderr 2>@stderr" w] 328 fconfigure $reportfd -buffering line -blocking 1 -buffersize 65536 329 } errMsg]} { 330 # silently set reportfd to its fallback value to process warn msg 331 set ::g_states(reportfd) $reportfd 332 reportWarning $errMsg 333 } 334 } 335 336 # startup content in case of structured output format (puts here rather 337 # calling report proc to avoid infinite reportfd init loop 338 if {[isStateEqual report_format json]} { 339 puts -nonewline $reportfd \{ 340 } 341 342 return $reportfd 343} 344 345# Provide columns number for output formatting 346proc initStateTermColumns {} { 347 # determine col number from tty capabilites 348 # tty info query depends on running OS 349 switch -- $::tcl_platform(os) { 350 SunOS { 351 catch {regexp {columns = (\d+);} [exec stty] match cols} errMsg 352 } 353 {Windows NT} { 354 catch {regexp {Columns:\s+(\d+)} [exec mode] match cols} errMsg 355 } 356 default { 357 catch {set cols [lindex [exec stty size] 1]} errMsg 358 } 359 } 360 # default size if tty cols cannot be found 361 return [expr {![info exists cols] || $cols eq {0} ? 80 : $cols}] 362} 363 364# Get all groups of user running modulecmd.tcl process 365proc __initStateUsergroups {} { 366 # ensure groups including space in their name (found on Cygwin/MSYS 367 # platforms) are correctly set as list element 368 if {[catch { 369 return [split [string range [runCommand id -G -n -z] 0 end-1] \0] 370 } errMsg]} { 371 # fallback if '-z' option is not supported 372 return [runCommand id -G -n] 373 } 374} 375 376# Get name of user running modulecmd.tcl process 377proc __initStateUsername {} { 378 return [runCommand id -u -n] 379} 380 381# Get Epoch time (number of seconds elapsed since Unix epoch) 382proc initStateClockSeconds {} { 383 return [clock seconds] 384} 385 386# Know if Tcl version is below 8.5.0 387proc initStateTclVersionLt85 {} { 388 return [expr {[compareVersion [getState tcl_version] 8.5.0] == -1}] 389} 390 391# Initialize Select Graphic Rendition table 392proc initConfColors {envvar value validvallist intvallist} { 393 # overriden value coming from environment 394 if {[info exists ::env($envvar)]} { 395 set colors_list $::env($envvar) 396 if {[catch { 397 # test overriden value could be set to a dummy array variable 398 array set test_colors [split $colors_list {:=}] 399 } errMsg ]} { 400 # report issue as a debug message rather warning to avoid 401 # disturbing user with a warning message in the middle of a 402 # useful output as this table will be initialized at first use 403 reportDebug "Ignore invalid value set in $envvar ($colors_list)" 404 unset colors_list 405 } 406 } 407 408 # if no valid override set use default color theme for terminal 409 # background color kind (light or dark) 410 if {![info exists colors_list]} { 411 if {[getConf term_background] eq {light}} { 412 set colors_list {@lightbgcolors@} 413 } else { 414 set colors_list {@darkbgcolors@} 415 } 416 if {[catch { 417 array set test_colors [split $colors_list {:=}] 418 } errMsg ]} { 419 reportDebug "Ignore invalid default [getConf term_background]\ 420 background colors ($colors_list)" 421 # define an empty list if no valid value set 422 set colors_list {} 423 } 424 } 425 426 # check each color defined and unset invalid codes 427 set value {} 428 foreach {elt col} [split $colors_list {:=}] { 429 if {![regexp {^[\d;]+$} $col]} { 430 reportDebug "Ignore invalid color code for '$elt' ($col)" 431 } else { 432 lappend value $elt=$col 433 } 434 } 435 set value [join $value :] 436 437 # set SGR table as an array to easily access rendition for each key 438 array unset ::g_colors 439 array set ::g_colors [split $value {:=}] 440 441 return $value 442} 443 444# Initialize color configuration value 445proc initConfColor {envvar value validvallist intvallist} { 446 # overriden value coming from environment via standard variable 447 # https://no-color.org/ and https://bixense.com/clicolors/ 448 if {[info exists ::env(NO_COLOR)]} { 449 set value never 450 } elseif {[info exists ::env(CLICOLOR)]} { 451 if {$::env(CLICOLOR) eq {0}} { 452 set value never 453 } else { 454 set value auto 455 } 456 } elseif {[info exists ::env(CLICOLOR_FORCE)] && $::env(CLICOLOR_FORCE)\ 457 ne {0}} { 458 set value always 459 } 460 461 # overriden value coming from environment via Modules-specific variable 462 if {$envvar ne {} && [info exists ::env($envvar)]} { 463 # ignore non-valid values 464 if {[llength $validvallist] == 0 || [isInList $validvallist\ 465 $::env($envvar)]} { 466 set value $::env($envvar) 467 } 468 } 469 470 # overriden value coming the command-line 471 if {[info exists ::asked_color]} { 472 set value [set ::asked_color] 473 } 474 475 # convert value to its internal representation 476 if {[llength $intvallist] > 0} { 477 set value [lindex $intvallist [lsearch -exact $validvallist $value]] 478 } 479 480 # disable color mode if no terminal attached except if 'always' asked 481 if {$value != 0 && (![getState is_stderr_tty] || $value == 2)} { 482 incr value -1 483 } 484 485 # initialize color theme if color mode enabled 486 getConf colors 487 488 return $value 489} 490 491# Initialize tcl_ext_lib configuration value 492proc initConfTclExtLib {envvar value validvallist intvallist} { 493 set libfile libtclenvmodules@SHLIB_SUFFIX@ 494 495 # determine lib directory 496 @notmultilibsupport@set libdir @libdir@ 497 @multilibsupport@switch -- [getState machine] { 498 @multilibsupport@ x86_64 - aarch64 - ppc64le - s390x { 499 @multilibsupport@ set libdirmain @libdir64@ 500 @multilibsupport@ set libdiralt @libdir32@ 501 @multilibsupport@ } 502 @multilibsupport@ default { 503 @multilibsupport@ set libdirmain @libdir32@ 504 @multilibsupport@ set libdiralt @libdir64@ 505 @multilibsupport@ } 506 @multilibsupport@} 507 @multilibsupport@# use alternative arch lib if available and not main one 508 @multilibsupport@if {![file exists [file join $libdirmain $libfile]] && [file exists [file\ 509 @multilibsupport@ join $libdiralt $libfile]]} { 510 @multilibsupport@ set libdir $libdiralt 511 @multilibsupport@} else { 512 @multilibsupport@ set libdir $libdirmain 513 @multilibsupport@} 514 515 return [file join $libdir $libfile] 516} 517 518# Is currently set verbosity level is equal or higher than level passed as arg 519proc isVerbosityLevel {name} { 520 return [expr {[lsearch -exact [lindex $::g_config_defs(verbosity) 3]\ 521 [getConf verbosity]] >= [lsearch -exact [lindex\ 522 $::g_config_defs(verbosity) 3] $name]}] 523} 524 525# Is match performed in a case sensitive or insensitive manner 526proc isIcase {} { 527 # depending on current sub-command, list values that equal to a case 528 # insensitive match enablement 529 lappend enabledValList always 530 if {[isInList [list avail whatis search paths] [currentCommandName]]} { 531 lappend enabledValList search 532 } 533 return [isInList $enabledValList [getConf icase]] 534} 535 536 537proc raiseErrorCount {} { 538 setState error_count [expr {[getState error_count] + 1}] 539} 540 541proc renderFalse {} { 542 if {[isStateDefined false_rendered]} { 543 reportDebug {false already rendered} 544 } elseif {[isStateDefined shelltype]} { 545 # setup flag to render only once 546 setState false_rendered 1 547 548 # render a false value most of the time through a variable assignement 549 # that will be looked at in the shell module function calling 550 # modulecmd.tcl to return in turns a boolean status. Except for python 551 # and cmake, the value assigned to variable is also returned as the 552 # entire rendering status 553 switch -- [getState shelltype] { 554 sh - csh - fish { 555 # no need to set a variable on real shells as last statement 556 # result can easily be checked 557 puts stdout {test 0 = 1;} 558 } 559 tcl { 560 puts stdout {set _mlstatus 0;} 561 } 562 cmd { 563 puts stdout {set errorlevel=1} 564 } 565 perl { 566 puts stdout {{ no strict 'vars'; $_mlstatus = 0; }} 567 } 568 python { 569 puts stdout {_mlstatus = False} 570 } 571 ruby { 572 puts stdout {_mlstatus = false} 573 } 574 lisp { 575 puts stdout {nil} 576 } 577 cmake { 578 puts stdout {set(_mlstatus FALSE)} 579 } 580 r { 581 puts stdout {mlstatus <- FALSE} 582 } 583 } 584 } 585} 586 587proc renderTrue {} { 588 reportDebug called. 589 590 # render a true value most of the time through a variable assignement that 591 # will be looked at in the shell module function calling modulecmd.tcl to 592 # return in turns a boolean status. Except for python and cmake, the 593 # value assigned to variable is also returned as the full rendering status 594 switch -- [getState shelltype] { 595 sh - csh - fish { 596 # no need to set a variable on real shells as last statement 597 # result can easily be checked 598 puts stdout {test 0;} 599 } 600 tcl { 601 puts stdout {set _mlstatus 1;} 602 } 603 cmd { 604 puts stdout {set errorlevel=0} 605 } 606 perl { 607 puts stdout {{ no strict 'vars'; $_mlstatus = 1; }} 608 } 609 python { 610 puts stdout {_mlstatus = True} 611 } 612 ruby { 613 puts stdout {_mlstatus = true} 614 } 615 lisp { 616 puts stdout {t} 617 } 618 cmake { 619 puts stdout {set(_mlstatus TRUE)} 620 } 621 r { 622 puts stdout {mlstatus <- TRUE} 623 } 624 } 625} 626 627proc renderText {text} { 628 reportDebug "called ($text)." 629 630 # render a text value most of the time through a variable assignement that 631 # will be looked at in the shell module function calling modulecmd.tcl to 632 # return in turns a string value. 633 switch -- [getState shelltype] { 634 sh - csh - fish { 635 foreach word $text { 636 # no need to set a variable on real shells, echoing text will make 637 # it available as result 638 puts stdout "echo '$word';" 639 } 640 } 641 tcl { 642 puts stdout "set _mlstatus \"$text\";" 643 } 644 cmd { 645 foreach word $text { 646 puts stdout "echo $word" 647 } 648 } 649 perl { 650 puts stdout "{ no strict 'vars'; \$_mlstatus = '$text'; }" 651 } 652 python { 653 puts stdout "_mlstatus = '$text'" 654 } 655 ruby { 656 puts stdout "_mlstatus = '$text'" 657 } 658 lisp { 659 puts stdout "(message \"$text\")" 660 } 661 cmake { 662 puts stdout "set(_mlstatus \"$text\")" 663 } 664 r { 665 puts stdout "mlstatus <- '$text'" 666 } 667 } 668} 669 670# 671# Debug, Info, Warnings and Error message handling. 672# 673 674# save message when report is not currently initialized as we do not 675# know yet if debug mode is enabled or not 676proc reportDebug {message {showcaller 1} {caller _undef_}} { 677 # get caller name 678 if {$caller eq {_undef_} && $showcaller} { 679 if {[info level] > 1} { 680 set caller [lindex [info level -1] 0] 681 } else { 682 set caller {} 683 } 684 } 685 lappend ::errreport_buffer [list reportDebug $message $showcaller $caller] 686} 687 688# regular procedure to use once error report is initialized 689proc __reportDebug {message {showcaller 1} {caller _undef_}} { 690 # display active interp details if not the main one 691 set prefix [currentDebugMsgPrefix] 692 # display caller name as prefix 693 if {$showcaller && $caller ne {} && ($caller ne {_undef_} || [info level]\ 694 > 1)} { 695 if {$caller eq {_undef_}} { 696 set caller [lindex [info level -1] 0] 697 } 698 append prefix "$caller: " 699 } 700 report [sgr db "DEBUG $prefix$message"] 0 1 701} 702 703# alternative procedure used when debug is disabled 704proc __reportDebugNop {args} {} 705 706proc reportWarning {message {recordtop 0}} { 707 reportError $message $recordtop WARNING wa 0 708} 709 710proc reportError {message {recordtop 0} {severity ERROR} {sgrkey er}\ 711 {raisecnt 1}} { 712 lappend ::errreport_buffer [list reportError $message $recordtop $severity\ 713 $sgrkey $raisecnt] 714} 715 716proc __reportError {message {recordtop 0} {severity ERROR} {sgrkey er}\ 717 {raisecnt 1}} { 718 # if report disabled, also disable error raise to get a coherent 719 # behavior (if no message printed, no error code change) 720 if {![getState inhibit_errreport]} { 721 if {$raisecnt} { 722 raiseErrorCount 723 } 724 set msgsgr "[sgr $sgrkey $severity]: $message" 725 # record message to report it later on if a record id is found 726 if {[currentMsgRecordId] ne {}} { 727 recordMessage $msgsgr $recordtop 728 # skip message report if silent 729 } elseif {[isVerbosityLevel concise]} { 730 # save error messages to render them all together in JSON format 731 if {[isStateEqual report_format json]} { 732 lappend ::g_report_erralist $severity $message 733 } else { 734 report $msgsgr 0 0 1 735 } 736 } 737 } 738} 739 740# throw known error (call error with 'known error' code) 741proc knerror {message {code MODULES_ERR_KNOWN}} { 742 error $message {} $code 743} 744 745# save message if report is not yet initialized 746proc reportErrorAndExit {message} { 747 lappend ::errreport_buffer [list reportErrorAndExit $message] 748} 749 750# regular procedure to use once error report is initialized 751proc __reportErrorAndExit {message} { 752 raiseErrorCount 753 renderFalse 754 error $message {} MODULES_ERR_RENDERED 755} 756 757proc reportInternalBug {message {modfile {}}} { 758 if {$modfile ne {}} { 759 append message "\nIn '$modfile'" 760 } 761 append message "\nPlease contact <[getConf contact]>" 762 reportError $message 0 {Module ERROR} me 763} 764 765proc reportInfo {message {title INFO}} { 766 if {[isVerbosityLevel normal]} { 767 # use reportError for conveniance but there is no error here 768 reportError $message 0 $title in 0 769 } 770} 771 772proc reportTrace {message {title TRACE}} { 773 if {[isVerbosityLevel trace]} { 774 # use reportError for conveniance but there is no error here 775 reportError [sgr tr $message] 0 $title tr 0 776 } 777} 778 779# trace procedure execution start 780proc reportTraceExecEnter {cmdstring op} { 781 set caller [expr {[info level] > 1 ? [lindex [info level -1] 0] : {}}] 782 reportDebug $cmdstring 1 $caller 783} 784 785# is currently active message record id at top level 786proc isMsgRecordIdTop {} { 787 return [expr {[llength $::g_msgRecordIdStack] eq 1}] 788} 789 790# record messages on the eventual additional module evaluations that have 791# occurred during the current evaluation 792proc reportModuleEval {} { 793 set evalid [currentEvalId] 794 array set contexttitle {conun {Unloading conflict} reqlo {Loading\ 795 requirement} depre {Reloading dependent} depun {Unloading dependent}\ 796 urequn {Unloading useless requirement}} 797 798 if {[info exists ::g_moduleEval($evalid)]} { 799 foreach contextevallist $::g_moduleEval($evalid) { 800 set modlist [lassign $contextevallist context] 801 # skip context with no description title 802 if {[info exists contexttitle($context)]} { 803 reportInfo [join $modlist] $contexttitle($context) 804 } 805 } 806 # purge list in case same evaluation is re-done afterward 807 unset ::g_moduleEval($evalid) 808 } 809} 810 811# render messages related to current record id under an header block 812proc reportMsgRecord {header} { 813 set recid [currentMsgRecordId] 814 if {[info exists ::g_msgRecord($recid)]} { 815 # skip message report if silent 816 if {[isVerbosityLevel concise]} { 817 set tty_cols [getState term_columns] 818 set padding { } 819 820 set dispmsg $header 821 foreach msg $::g_msgRecord($recid) { 822 # split lines if too large for terminal 823 set first 1 824 set max_idx [expr {$tty_cols - [string length $padding]}] 825 set linelist [list] 826 foreach line [split $msg \n] { 827 set lineadd {} 828 while {$lineadd ne $line} { 829 set line_max_idx $max_idx 830 # sgr tags consume no length 831 set eidx 0 832 while {[set sidx [string first "\033\[" $line $eidx]] !=\ 833 -1} { 834 set eidx [string first m $line $sidx] 835 incr line_max_idx [expr {1 + $eidx - $sidx}] 836 } 837 838 # no split if no whitespace found to slice 839 if {[string length $line] > $line_max_idx && [set cut_idx\ 840 [string last { } $line $line_max_idx]] != -1} { 841 set lineadd [string range $line 0 [expr {$cut_idx-1}]] 842 set line [string range $line [expr {$cut_idx+1}] end] 843 } else { 844 set lineadd $line 845 } 846 lappend linelist $lineadd 847 if {$first} { 848 set first 0 849 incr max_idx -[string length $padding] 850 } 851 } 852 } 853 854 # display each line 855 set first 1 856 foreach line $linelist { 857 append dispmsg \n 858 if {$first} { 859 set first 0 860 } else { 861 append dispmsg $padding 862 } 863 append dispmsg $padding$line 864 } 865 } 866 reportSeparateNextContent 867 report $dispmsg 868 reportSeparateNextContent 869 } 870 871 # purge message list in case same evaluation is re-done afterward 872 unset ::g_msgRecord($recid) 873 # report header if no other specific msg to output in verbose mode or in 874 # normal verbosity mode if currently processing a cmd which triggers 875 # multiple module evaluations that cannot be guessed by the user 876 } elseif {[isVerbosityLevel verbose] || ([isVerbosityLevel normal] && (\ 877 [ongoingCommandName restore] || [ongoingCommandName source]))} { 878 report $header 879 } 880} 881 882# separate next content produced if any 883proc reportSeparateNextContent {} { 884 lappend ::errreport_buffer [list reportSeparateNextContent] 885} 886 887# regular procedure to use once error report is initialized 888proc __reportSeparateNextContent {} { 889 # hold or apply 890 if {[isReportHeld]} { 891 lappend ::g_holdReport([currentReportHoldId]) [list\ 892 reportSeparateNextContent] 893 } else { 894 setState report_sep_next 1 895 } 896} 897 898# save message for block rendering 899proc recordMessage {message {recordtop 0}} { 900 lappend ::g_msgRecord([expr {$recordtop ? [topMsgRecordId] :\ 901 [currentMsgRecordId]}]) $message 902} 903 904# filter and format error stack trace to only report useful content 905proc formatErrStackTrace {errmsg loc {cmdlist {}}} { 906 set headstr "\n while executing\n" 907 set splitstr "\n invoked from within\n" 908 set splitstrlen [string length $splitstr] 909 set aftheadidx [string first $headstr $errmsg] 910 if {$aftheadidx != -1} { 911 incr aftheadidx [string length $headstr] 912 } 913 914 # get name of invalid command name to maintain it in error stack trace 915 if {[string equal -length 22 {invalid command name "} $errmsg]} { 916 set unkcmd [lindex [split [string range $errmsg 0 $aftheadidx] {"}] 1] 917 } else { 918 set unkcmd {} 919 } 920 921 # get list of modulecmd.tcl internal procedure to filter out from stack 922 # skip this when no interp command list is provided 923 if {[llength $cmdlist] > 0} { 924 lassign [getDiffBetweenList [concat [info commands] [info procs]]\ 925 $cmdlist] filtercmdlist keepcmdlist 926 } else { 927 set filtercmdlist {} 928 } 929 930 # define commands to filter out from bottom of stack 931 set filtercmdendlist [list {eval $modcontent} "source $loc" {uplevel 1\ 932 source $siteconfig}] 933 934 # filter out modulecmd internal references at beginning of stack 935 set internals 1 936 while {$internals && $aftheadidx != -1} { 937 # fetch erroneous command and its caller 938 set stackelt [string range $errmsg $aftheadidx [string first\ 939 $splitstr $errmsg $aftheadidx]] 940 lassign [split [lindex [split $stackelt {"}] 1]] cmd1 cmd2 941 set cmdcaller [lindex [split [string range $stackelt [string last\ 942 {(procedure } $stackelt] end] {"}] 1] 943 if {$cmd1 eq {eval}} { 944 set cmd1 $cmd2 945 } 946 947 # filter out stack element refering to or called by an unknown procedure 948 # (ie. a modulecmd.tcl internal procedure) 949 if {[string index $cmd1 0] ne {$} && $cmd1 ne $unkcmd && ([isInList\ 950 $filtercmdlist $cmdcaller] || [isInList $filtercmdlist $cmd1])} { 951 set errmsg [string replace $errmsg $aftheadidx [expr {[string first\ 952 $splitstr $errmsg] + $splitstrlen - 1}]] 953 } else { 954 set internals 0 955 } 956 } 957 958 # filter out modulecmd internal references at end of stack 959 set internals 1 960 while {$internals} { 961 set beffootidx [string last $splitstr $errmsg] 962 set stackelt [string range $errmsg $beffootidx end] 963 set cmd [lindex [split $stackelt {"}] 1] 964 965 if {[isInList $filtercmdendlist $cmd]} { 966 set errmsg [string replace $errmsg $beffootidx end] 967 } else { 968 set internals 0 969 } 970 } 971 972 # replace error location at end of stack 973 set lastnl [string last \n $errmsg] 974 set lastline [string range $errmsg [expr {$lastnl + 1}] end] 975 if {[string match { ("eval" body line*} $lastline]} { 976 set errmsg [string replace $errmsg $lastnl [expr {$lastnl + [string\ 977 length " (\"eval\" body line"]}] "\n (file \"$loc\" line"] 978 } elseif {![string match { (file *} $lastline]} { 979 # add error location at end of stack 980 append errmsg "\n (file \"$loc\")" 981 } 982 983 return $errmsg 984} 985 986# Select Graphic Rendition of a string with passed sgr key (if color enabled) 987proc sgr {sgrkey str} { 988 if {[getConf color] && [info exists ::g_colors($sgrkey)]} { 989 set sgrset $::g_colors($sgrkey) 990 # if render bold or faint just reset that attribute, not all 991 if {$sgrset == 1 || $sgrset == 2} { 992 set sgrreset 22 993 } else { 994 set sgrreset 0 995 } 996 set str "\033\[${sgrset}m$str\033\[${sgrreset}m" 997 } 998 return $str 999} 1000 1001# save message if report is not yet initialized 1002proc report {message {nonewline 0} {immed 0} {padnl 0}} { 1003 lappend ::errreport_buffer [list report $message $nonewline $immed $padnl] 1004} 1005 1006# regular procedure to use once error report is initialized 1007proc __report {message {nonewline 0} {immed 0} {padnl 0}} { 1008 # hold or print output 1009 if {!$immed && [isReportHeld]} { 1010 lappend ::g_holdReport([currentReportHoldId]) [list report $message\ 1011 $nonewline $immed $padnl] 1012 } else { 1013 # produce blank line prior message if asked to 1014 if {[isStateDefined reportfd] && [isStateDefined report_sep_next]} { 1015 unsetState report_sep_next 1016 report [expr {[isStateEqual report_format json] ? {,} : {}}] 1017 } 1018 # prefix msg lines after first one with 2 spaces 1019 if {$padnl} { 1020 set first 1 1021 foreach line [split $message \n] { 1022 if {$first} { 1023 set first 0 1024 } else { 1025 append padmsg "\n " 1026 } 1027 append padmsg $line 1028 } 1029 set message $padmsg 1030 } 1031 1032 # protect from issue with fd, just ignore it 1033 catch { 1034 if {$nonewline} { 1035 puts -nonewline [getState reportfd] $message 1036 } else { 1037 puts [getState reportfd] $message 1038 } 1039 } 1040 } 1041} 1042 1043# report error the correct way depending of its type 1044proc reportIssue {issuetype issuemsg {issuefile {}}} { 1045 switch -- $issuetype { 1046 invalid { 1047 reportInternalBug $issuemsg $issuefile 1048 } 1049 default { 1050 reportError $issuemsg 1051 } 1052 } 1053} 1054 1055# report defined command (used in display evaluation mode) 1056proc reportCmd {cmd args} { 1057 # use Tcl native string representation of list 1058 if {$cmd eq {-nativeargrep}} { 1059 set cmd [lindex $args 0] 1060 set cmdargs [lrange $args 1 end] 1061 } else { 1062 set cmdargs [listTo tcl $args 0] 1063 } 1064 set extratab [expr {[string length $cmd] < 8 ? "\t" : {}}] 1065 report [sgr cm $cmd]$extratab\t$cmdargs 1066 1067 # empty string returns if command result is another command input 1068 return {} 1069} 1070 1071# report defined command (called as an execution trace) 1072proc reportCmdTrace {cmdstring args} { 1073 eval reportCmd $cmdstring 1074} 1075 1076proc reportVersion {} { 1077 report {Modules Release @MODULES_RELEASE@@MODULES_BUILD@\ 1078 (@MODULES_BUILD_DATE@)} 1079} 1080 1081# disable error reporting (non-critical report only) unless debug enabled 1082proc inhibitErrorReport {} { 1083 if {![isVerbosityLevel trace]} { 1084 setState inhibit_errreport 1 1085 } 1086} 1087 1088# init error report and output buffered messages 1089proc initErrorReport {} { 1090 # ensure init is done only once 1091 if {![isStateDefined init_error_report]} { 1092 setState init_error_report 1 1093 1094 # ask for color init now as debug mode has already fire lines to render 1095 # and we want them to be reported first (not the color init lines) 1096 if {[isVerbosityLevel debug]} { 1097 getConf color 1098 } 1099 1100 # trigger pager start if something needs to be printed, to guaranty 1101 # reportDebug calls during pager start are processed in buffer mode 1102 if {[isVerbosityLevel debug]} { 1103 getState reportfd 1104 } 1105 1106 # replace report procedures used to bufferize messages until error 1107 # report being initialized by regular report procedures 1108 rename ::reportDebug {} 1109 if {[isVerbosityLevel debug]} { 1110 rename ::__reportDebug ::reportDebug 1111 } else { 1112 # set a disabled version if debug is disabled 1113 rename ::__reportDebugNop ::reportDebug 1114 } 1115 rename ::reportError {} 1116 rename ::__reportError ::reportError 1117 rename ::reportErrorAndExit {} 1118 rename ::__reportErrorAndExit ::reportErrorAndExit 1119 rename ::reportSeparateNextContent {} 1120 rename ::__reportSeparateNextContent ::reportSeparateNextContent 1121 rename ::report {} 1122 rename ::__report ::report 1123 1124 # trace each procedure call 1125 if {[isVerbosityLevel debug2]} { 1126 # exclude core procedure from tracing 1127 set excl_prc_list [list report reportDebug currentDebugMsgPrefix\ 1128 reportTraceExecEnter isInList notInList getState setState\ 1129 lappendState unsetState isStateDefined isStateEqual sgr getConf\ 1130 setConf unsetConf lappendConf] 1131 foreach prc [info procs] { 1132 if {[notInList $excl_prc_list $prc]} { 1133 trace add execution $prc enter reportTraceExecEnter 1134 } 1135 } 1136 } 1137 1138 # now error report is init output every message saved in buffer; first 1139 # message will trigger message paging configuration and startup unless 1140 # already done if debug mode enabled 1141 foreach errreport $::errreport_buffer { 1142 eval $errreport 1143 } 1144 } 1145} 1146 1147# drop or report held messages 1148proc releaseHeldReport {args} { 1149 foreach {holdid action} $args { 1150 if {[info exists ::g_holdReport($holdid)]} { 1151 if {$action eq {report}} { 1152 foreach repcall $::g_holdReport($holdid) { 1153 eval $repcall 1154 } 1155 } 1156 unset ::g_holdReport($holdid) 1157 } 1158 } 1159} 1160 1161# exit in a clean manner by closing interaction with external components 1162proc cleanupAndExit {code} { 1163 # finish output document if json format enabled 1164 if {[isStateEqual report_format json]} { 1165 # render error messages all together 1166 if {[info exists ::g_report_erralist]} { 1167 # ignite report first to get eventual error message from report 1168 # initialization in order 'foreach' got all messages prior firing 1169 report "\"errors\": \[" 1 1170 foreach {sev msg} $::g_report_erralist { 1171 # split message in lines 1172 lappend dispmsglist "\n{ \"severity\": \"$sev\", \"message\": \[\ 1173 \"[join [split [charEscaped $msg \"] \n] {", "}]\" \] }" 1174 } 1175 report "[join $dispmsglist ,] \]" 1176 } 1177 # inhibit next content separator if output is ending 1178 if {[isStateDefined report_sep_next]} { 1179 unsetState report_sep_next 1180 } 1181 report \} 1182 } 1183 1184 # close pager if enabled 1185 if {[isStateDefined reportfd] && ![isStateEqual reportfd stderr]} { 1186 catch {flush [getState reportfd]} 1187 catch {close [getState reportfd]} 1188 } 1189 1190 exit $code 1191} 1192 1193# helper procedures to format various messages 1194proc getHintUnFirstMsg {modlist} { 1195 return "HINT: Might try \"module unload [join $modlist]\" first." 1196} 1197 1198proc getHintLoFirstMsg {modlist} { 1199 if {[llength $modlist] > 1} { 1200 set oneof {at least one of } 1201 set mod modules 1202 } else { 1203 set oneof {} 1204 set mod module 1205 } 1206 return "HINT: ${oneof}the following $mod must be loaded first: $modlist" 1207} 1208 1209proc getErrConflictMsg {mod conlist} { 1210 return "$mod cannot be loaded due to a conflict.\n[getHintUnFirstMsg\ 1211 $conlist]" 1212} 1213 1214proc getErrPrereqMsg {mod prelist {load 1}} { 1215 lassign [if {$load} {list {} missing [getHintLoFirstMsg $prelist]}\ 1216 {list un a [getHintUnFirstMsg $prelist]}] un mis hintmsg 1217 return "$mod cannot be ${un}loaded due to $mis prereq.\n$hintmsg" 1218} 1219 1220proc getErrReqLoMsg {prelist} { 1221 return "Load of requirement '[join $prelist {' or '}]' failed" 1222} 1223 1224proc getReqNotLoadedMsg {prelist} { 1225 return "Requirement '[join $prelist {' or '}]' is not loaded" 1226} 1227 1228proc getDepLoadedMsg {prelist} { 1229 set is [expr {[llength $prelist] > 1 ? {are} : {is}}] 1230 return "Dependent '[join $prelist {' and '}]' $is loaded" 1231} 1232 1233proc getErrConUnMsg {conlist} { 1234 return "Unload of conflicting '[join $conlist {' and '}]' failed" 1235} 1236 1237proc getConIsLoadedMsg {conlist {loading 0}} { 1238 set is [expr {[llength $conlist] > 1 ? {are} : {is}}] 1239 set loaded [expr {$loading ? {loading} : {loaded}}] 1240 return "Conflicting '[join $conlist {' and '}]' $is $loaded" 1241} 1242 1243proc getForbiddenMsg {mod} { 1244 set msg "Access to module '$mod' is denied" 1245 set extramsg [getModuleTagProp $mod forbidden message] 1246 if {$extramsg ne {}} { 1247 append msg \n$extramsg 1248 } 1249 return $msg 1250} 1251 1252proc getNearlyForbiddenMsg {mod} { 1253 set after [getModuleTagProp $mod nearly-forbidden after] 1254 set msg "Access to module will be denied starting '$after'" 1255 set extramsg [getModuleTagProp $mod nearly-forbidden message] 1256 if {$extramsg ne {}} { 1257 append msg \n$extramsg 1258 } 1259 return $msg 1260} 1261 1262######################################################################## 1263# Use a subordinate Tcl interpreter to execute modulefiles 1264# 1265 1266# dummy proc to disable modulefile commands on some evaluation modes 1267proc nop {args} {} 1268 1269# dummy proc for commands available on other Modules flavor but not here 1270proc nimp {cmd args} { 1271 reportWarning "'$cmd' command not implemented" 1272} 1273 1274proc get-env {var {valifunset {}}} { 1275 # return current value if exists and not cleared 1276 if {[info exists ::env($var)] && ![info exists ::g_clearedEnvVars($var)]} { 1277 return $::env($var) 1278 } else { 1279 return $valifunset 1280 } 1281} 1282 1283proc set-env {var val} { 1284 set mode [currentMode] 1285 reportDebug "$var=$val" 1286 1287 # an empty string value means unsetting variable on Windows platform, so 1288 # call unset-env to ensure variable will not be seen defined yet raising 1289 # an error when trying to access it 1290 if {[getState is_win] && $val eq {}} { 1291 unset-env $var 1292 } else { 1293 interp-sync-env set $var $val 1294 1295 # variable is not cleared anymore if set again 1296 if {[info exists ::g_clearedEnvVars($var)]} { 1297 unset ::g_clearedEnvVars($var) 1298 } 1299 1300 # propagate variable setup to shell environment on load and unload mode 1301 if {$mode eq {load} || $mode eq {unload}} { 1302 set ::g_stateEnvVars($var) new 1303 } 1304 } 1305} 1306 1307proc reset-to-unset-env {var {val {}}} { 1308 interp-sync-env set $var $val 1309 # set var as cleared if val is empty 1310 if {$val eq {}} { 1311 set ::g_clearedEnvVars($var) 1 1312 } 1313} 1314 1315proc unset-env {var {internal 0} {val {}}} { 1316 set mode [currentMode] 1317 reportDebug "$var (internal=$internal, val=$val)" 1318 1319 # clear value instead of unset it not to break variable later reference 1320 # in modulefile. clear whether variable set or not to get a later usage 1321 # consistent behavior whatever env is setup 1322 if {!$internal} { 1323 reset-to-unset-env $var $val 1324 # internal variables (like ref counter var) are purely unset if they exists 1325 } elseif {[info exists ::env($var)]} { 1326 interp-sync-env unset $var 1327 set intwasset 1 1328 } 1329 1330 # propagate deletion in any case if variable is public and for internal 1331 # one only if variable was set 1332 if {($mode eq {load} || $mode eq {unload}) && (!$internal ||\ 1333 [info exists intwasset])} { 1334 set ::g_stateEnvVars($var) del 1335 } 1336} 1337 1338# synchronize environment variable change over all started sub interpreters 1339proc interp-sync-env {op var {val {}}} { 1340 set envvar ::env($var) 1341 1342 # apply operation to main interpreter 1343 switch -- $op { 1344 set { set $envvar $val } 1345 unset { unset $envvar } 1346 } 1347 1348 # apply operation to each sub-interpreters if not found autosynced 1349 if {[llength [interp slaves]] > 0} { 1350 reportDebug "$op var='$envvar', val='$val' on interp(s) [interp slaves]" 1351 1352 foreach itrp [interp slaves] { 1353 switch -- $op { 1354 set { 1355 # no value pre-check on Windows platform as an empty value set 1356 # means unsetting variable which lead querying value to error 1357 if {[getState is_win] || ![interp eval $itrp [list info exists\ 1358 $envvar]] || [interp eval $itrp [list set $envvar]] ne\ 1359 $val} { 1360 interp eval $itrp [list set $envvar $val] 1361 } 1362 } 1363 unset { 1364 if {[interp eval $itrp [list info exists $envvar]]} { 1365 interp eval $itrp [list unset $envvar] 1366 } 1367 } 1368 } 1369 } 1370 } 1371} 1372 1373# Initialize list of interp alias commands to define for given evaluation mode 1374proc initModfileModeAliases {mode aliasesVN aliasesPassArgVN tracesVN} { 1375 global g_modfilePerModeAliases 1376 upvar #0 $aliasesVN aliases 1377 upvar #0 $aliasesPassArgVN aliasesPassArg 1378 upvar #0 $tracesVN traces 1379 1380 if {![info exists g_modfilePerModeAliases]} { 1381 set ::g_modfileBaseAliases [list getenv getenv is-loaded is-loaded\ 1382 is-saved is-saved is-used is-used is-avail is-avail uname uname\ 1383 module-info module-info exit exitModfileCmd reportCmdTrace\ 1384 reportCmdTrace reportInternalBug reportInternalBug reportWarning\ 1385 reportWarning reportError reportError raiseErrorCount\ 1386 raiseErrorCount report report isVerbosityLevel isVerbosityLevel\ 1387 isWin initStateIsWin puts putsModfileCmd readModuleContent\ 1388 readModuleContent formatErrStackTrace formatErrStackTrace] 1389 1390 # list of alias commands whose target procedure is adapted according to 1391 # the evaluation mode 1392 set ::g_modfileEvalModes {load unload display help test whatis} 1393 array set g_modfilePerModeAliases { 1394append-path {append-path remove-path append-path append-path append-path edit-path-wh } 1395chdir {chdir nop reportCmd nop nop nop } 1396conflict {conflict nop reportCmd nop nop nop } 1397module {module module reportCmd nop nop nop } 1398module-alias {module-alias module-alias module-alias module-alias module-alias module-alias } 1399module-log {nimp nimp reportCmd nop nop nop } 1400module-trace {nimp nimp reportCmd nop nop nop } 1401module-user {nimp nimp reportCmd nop nop nop } 1402module-verbosity {nimp nimp reportCmd nop nop nop } 1403module-version {module-version module-version module-version module-version module-version module-version} 1404module-virtual {module-virtual module-virtual module-virtual module-virtual module-virtual module-virtual} 1405module-forbid {module-forbid module-forbid module-forbid module-forbid module-forbid module-forbid } 1406module-hide {module-hide module-hide module-hide module-hide module-hide module-hide } 1407module-whatis {nop nop reportCmd nop nop module-whatis } 1408prepend-path {prepend-path remove-path prepend-path prepend-path prepend-path edit-path-wh } 1409prereq {prereq nop reportCmd nop nop nop } 1410remove-path {remove-path remove-path-un remove-path remove-path remove-path edit-path-wh } 1411set-alias {set-alias set-alias-un reportCmd nop nop nop } 1412set-function {set-function set-function-un reportCmd nop nop nop } 1413setenv {setenv setenv-un setenv setenv setenv setenv-wh } 1414source-sh {source-sh source-sh-un source-sh-di nop nop nop } 1415system {system system reportCmd nop nop nop } 1416unset-alias {unset-alias nop reportCmd nop nop nop } 1417unset-function {unset-function nop reportCmd nop nop nop } 1418unsetenv {unsetenv unsetenv-un unsetenv unsetenv unsetenv setenv-wh } 1419x-resource {x-resource x-resource reportCmd nop nop nop } 1420 } 1421 } 1422 1423 # alias commands where interpreter ref should be passed as argument 1424 array set aliasesPassArg [list puts __itrp__] 1425 1426 # initialize list with all commands not dependent of the evaluation mode 1427 array set aliases $::g_modfileBaseAliases 1428 1429 # add alias commands whose target command vary depending on the eval mode 1430 set modeidx [lsearch -exact $::g_modfileEvalModes $mode] 1431 foreach alias [array names g_modfilePerModeAliases] { 1432 set aliastarget [set aliases($alias) [lindex\ 1433 $g_modfilePerModeAliases($alias) $modeidx]] 1434 # some target procedures need command name as first arg 1435 if {$aliastarget eq {reportCmd} || $aliastarget eq {nimp}} { 1436 set aliasesPassArg($alias) $alias 1437 # associate a trace command if per-mode alias command is not reportCmd 1438 # in display mode (except for source-sh) 1439 } elseif {$mode eq {display} && $alias ne {source-sh}} { 1440 set traces($alias) reportCmdTrace 1441 } 1442 } 1443} 1444 1445proc execute-modulefile {modfile modname modspec {must_have_cookie 1}} { 1446 pushModuleFile $modfile 1447 pushModuleName $modname 1448 pushSpecifiedName $modspec 1449 set mode [currentMode] 1450 pushDebugMsgPrefix [getEvalModuleStackDepth] $mode $modname 1451 1452 # skip modulefile if interpretation has been inhibited 1453 if {[getState inhibit_interp]} { 1454 reportDebug "skipping $modfile" 1455 return 1 1456 } 1457 1458 reportTrace "'$modfile' as '$modname'" {Evaluate modulefile} 1459 1460 # inform that access to module will be soon denied 1461 if {[isModuleTagged $modname nearly-forbidden]} { 1462 reportWarning [getNearlyForbiddenMsg $modname] 1463 } 1464 1465 if {![info exists ::g_modfileUntrackVars]} { 1466 # list variable that should not be tracked for saving 1467 array set ::g_modfileUntrackVars [list ModulesCurrentModulefile 1\ 1468 must_have_cookie 1 modcontent 1 env 1] 1469 1470 # commands that should be renamed before aliases setup 1471 array set ::g_modfileRenameCmds [list puts _puts] 1472 } 1473 # dedicate an interpreter per mode and per level of interpretation to have 1474 # a dedicated interpreter in case of cascaded multi-mode interpretations 1475 set itrp __modfile_${mode}_[getEvalModuleStackDepth] 1476 1477 # evaluation mode-specific configuration 1478 set dumpCommandsVN g_modfile${mode}Commands 1479 set aliasesVN g_modfile${mode}Aliases 1480 set aliasesPassArgVN g_modfile${mode}AliasesPassArg 1481 set tracesVN g_modfile${mode}Traces 1482 if {![info exists ::$aliasesVN]} { 1483 initModfileModeAliases $mode $aliasesVN $aliasesPassArgVN $tracesVN 1484 } 1485 1486 # create modulefile interpreter at first interpretation 1487 if {![interp exists $itrp]} { 1488 reportDebug "creating interp $itrp" 1489 interp create $itrp 1490 1491 # dump initial interpreter state to restore it before each modulefile 1492 # interpretation. use same dump state for all modes/levels 1493 if {![info exists ::g_modfileVars]} { 1494 dumpInterpState $itrp g_modfileVars g_modfileArrayVars\ 1495 g_modfileUntrackVars g_modfileProcs 1496 } 1497 1498 # interp has just been created 1499 set fresh 1 1500 } else { 1501 set fresh 0 1502 } 1503 1504 # reset interp state command before each interpretation 1505 resetInterpState $itrp $fresh g_modfileVars g_modfileArrayVars\ 1506 g_modfileUntrackVars g_modfileProcs $aliasesVN $aliasesPassArgVN\ 1507 $tracesVN g_modfileRenameCmds $dumpCommandsVN 1508 1509 # reset modulefile-specific variable before each interpretation 1510 interp eval $itrp set ::ModulesCurrentModulefile "{$modfile}" 1511 interp eval $itrp set must_have_cookie $must_have_cookie 1512 1513 set errorVal [interp eval $itrp { 1514 set modcontent [readModuleContent $::ModulesCurrentModulefile 1\ 1515 $must_have_cookie] 1516 if {$modcontent eq {}} { 1517 return 1 1518 } 1519 info script $::ModulesCurrentModulefile 1520 # eval then call for specific proc depending mode under same catch 1521 set sourceFailed [catch { 1522 eval $modcontent 1523 switch -- [module-info mode] { 1524 help { 1525 if {[info procs ModulesHelp] eq {ModulesHelp}} { 1526 ModulesHelp 1527 } else { 1528 reportWarning "Unable to find ModulesHelp in\ 1529 $::ModulesCurrentModulefile." 1530 } 1531 } 1532 display { 1533 if {[info procs ModulesDisplay] eq {ModulesDisplay}} { 1534 ModulesDisplay 1535 } 1536 } 1537 test { 1538 if {[info procs ModulesTest] eq {ModulesTest}} { 1539 if {[string is true -strict [ModulesTest]]} { 1540 report {Test result: PASS} 1541 } else { 1542 report {Test result: FAIL} 1543 raiseErrorCount 1544 } 1545 } else { 1546 reportWarning "Unable to find ModulesTest in\ 1547 $::ModulesCurrentModulefile." 1548 } 1549 } 1550 } 1551 } errorMsg] 1552 if {$sourceFailed} { 1553 # no error in case of "continue" command 1554 # catch continue even if called outside of a loop 1555 if {$errorMsg eq {invoked "continue" outside of a loop}\ 1556 || $sourceFailed == 4} { 1557 unset errorMsg 1558 return 0 1559 # catch break even if called outside of a loop 1560 } elseif {$errorMsg eq {invoked "break" outside of a loop}\ 1561 || ($errorMsg eq {} && (![info exists ::errorInfo]\ 1562 || $::errorInfo eq {}))} { 1563 unset errorMsg 1564 # report load/unload evaluation break if verbosity level >= normal 1565 if {([module-info mode load] || [module-info mode unload]) &&\ 1566 [isVerbosityLevel normal]} { 1567 reportError {Module evaluation aborted} 1568 } else { 1569 raiseErrorCount 1570 } 1571 return 1 1572 } elseif {$errorCode eq {MODULES_ERR_SUBFAILED}} { 1573 # error counter and message already handled, just return error 1574 return 1 1575 } elseif {$errorCode eq {MODULES_ERR_GLOBALTOP}} { 1576 reportError $errorMsg 1 1577 return 1 1578 } elseif {$errorCode eq {MODULES_ERR_GLOBAL}} { 1579 reportError $errorMsg 1580 return 1 1581 } else { 1582 # format stack trace to report modulefile information only 1583 reportInternalBug [formatErrStackTrace $::errorInfo\ 1584 $::ModulesCurrentModulefile [concat [info procs] [info\ 1585 commands]]] 1586 return 1 1587 } 1588 } else { 1589 unset errorMsg 1590 return 0 1591 } 1592 }] 1593 1594 reportDebug "exiting $modfile" 1595 popDebugMsgPrefix 1596 popSpecifiedName 1597 popModuleName 1598 popModuleFile 1599 1600 return $errorVal 1601} 1602 1603# Smaller subset than main module load... This function runs modulerc and 1604# .version files 1605proc execute-modulerc {modfile modname modspec} { 1606 pushModuleFile $modfile 1607 # push name to be found by module-alias and version 1608 pushModuleName $modname 1609 pushSpecifiedName $modspec 1610 set ::ModulesVersion {} 1611 pushDebugMsgPrefix [getEvalModuleStackDepth] $modname 1612 1613 if {![info exists ::g_modrcUntrackVars]} { 1614 # list variable that should not be tracked for saving 1615 array set ::g_modrcUntrackVars [list ModulesCurrentModulefile 1\ 1616 ModulesVersion 1 modcontent 1 env 1] 1617 1618 # commands that should be renamed before aliases setup 1619 array set ::g_modrcRenameCmds [list] 1620 1621 # list interpreter alias commands to define 1622 array set ::g_modrcAliases [list uname uname system system chdir\ 1623 nop is-loaded is-loaded module-version module-version module-alias\ 1624 module-alias module-virtual module-virtual module-forbid\ 1625 module-forbid module-hide module-hide module nop module-info\ 1626 module-info module-trace nop module-verbosity nop module-user nop\ 1627 module-log nop reportInternalBug reportInternalBug setModulesVersion\ 1628 setModulesVersion readModuleContent readModuleContent\ 1629 formatErrStackTrace formatErrStackTrace] 1630 1631 # alias commands where an argument should be passed 1632 array set ::g_modrcAliasesPassArg [list] 1633 1634 # trace commands that should be associated to aliases 1635 array set ::g_modrcAliasesTraces [list] 1636 } 1637 1638 # dedicate an interpreter per level of interpretation to have in case of 1639 # cascaded interpretations a specific interpreter per level 1640 set itrp __modrc_[getEvalModuleStackDepth] 1641 1642 reportTrace '$modfile' {Evaluate modulerc} 1643 # create modulerc interpreter at first interpretation 1644 if {![interp exists $itrp]} { 1645 reportDebug "creating interp $itrp" 1646 interp create $itrp 1647 1648 # dump initial interpreter state to restore it before each modulerc 1649 # interpreation. use same dump state for all levels 1650 if {![info exists ::g_modrcVars]} { 1651 dumpInterpState $itrp g_modrcVars g_modrcArrayVars\ 1652 g_modrcUntrackVars g_modrcProcs 1653 } 1654 1655 # interp has just been created 1656 set fresh 1 1657 } else { 1658 set fresh 0 1659 } 1660 1661 # reset interp state command before each interpretation 1662 resetInterpState $itrp $fresh g_modrcVars g_modrcArrayVars\ 1663 g_modrcUntrackVars g_modrcProcs g_modrcAliases g_modrcAliasesPassArg\ 1664 g_modrcAliasesTraces g_modrcRenameCmds g_modrcCommands 1665 1666 interp eval $itrp set ::ModulesCurrentModulefile "{$modfile}" 1667 interp eval $itrp {set ::ModulesVersion {}} 1668 1669 set errorVal [interp eval $itrp { 1670 set modcontent [readModuleContent $::ModulesCurrentModulefile] 1671 if {$modcontent eq {}} { 1672 # simply skip rc file, no exit on error here 1673 return 1 1674 } 1675 info script $::ModulesCurrentModulefile 1676 if [catch {eval $modcontent} errorMsg] { 1677 # format stack trace to report modulerc information only 1678 reportInternalBug [formatErrStackTrace $::errorInfo\ 1679 $::ModulesCurrentModulefile [concat [info procs] [info commands]]] 1680 return 1 1681 } else { 1682 # pass ModulesVersion value to main interp 1683 if {[info exists ::ModulesVersion]} { 1684 setModulesVersion $::ModulesVersion 1685 } 1686 return 0 1687 } 1688 }] 1689 1690 # default version set via ModulesVersion variable in .version file 1691 # override previously defined default version for modname 1692 lassign [getModuleNameVersion] mod modname modversion 1693 if {$modversion eq {.version} && $::ModulesVersion ne {}} { 1694 # ModulesVersion should target an element in current directory 1695 if {[string first / $::ModulesVersion] == -1} { 1696 setModuleResolution $modname/default $modname/$::ModulesVersion\ 1697 default 1698 } else { 1699 reportError "Invalid ModulesVersion '$::ModulesVersion' defined" 1700 } 1701 } 1702 1703 popDebugMsgPrefix 1704 popSpecifiedName 1705 popModuleName 1706 popModuleFile 1707 1708 return $::ModulesVersion 1709} 1710 1711# Save list of the defined procedure and the global variables with their 1712# associated values set in sub interpreter passed as argument. Global 1713# structures are used to save these information and the name of these 1714# structures are provided as argument. 1715proc dumpInterpState {itrp dumpVarsVN dumpArrayVarsVN untrackVarsVN\ 1716 dumpProcsVN} { 1717 upvar #0 $dumpVarsVN dumpVars 1718 upvar #0 $dumpArrayVarsVN dumpArrayVars 1719 upvar #0 $untrackVarsVN untrackVars 1720 upvar #0 $dumpProcsVN dumpProcs 1721 1722 regexp {^__[a-z]+} $itrp itrpkind 1723 # save name and value for any other global variables 1724 foreach var [$itrp eval {info globals}] { 1725 if {![info exists untrackVars($var)]} { 1726 reportDebug "saving for $itrpkind var $var" 1727 if {[$itrp eval array exists ::$var]} { 1728 set dumpVars($var) [$itrp eval array get ::$var] 1729 set dumpArrayVars($var) 1 1730 } else { 1731 set dumpVars($var) [$itrp eval set ::$var] 1732 } 1733 } 1734 } 1735 1736 # save name of every defined procedures 1737 foreach var [$itrp eval {info procs}] { 1738 set dumpProcs($var) 1 1739 } 1740 reportDebug "saving for $itrpkind proc list [array names dumpProcs]" 1741} 1742 1743# Define commands to be known by sub interpreter. 1744proc initInterpCommands {itrp fresh aliasesVN aliasesPassArgVN tracesVN\ 1745 renameCmdsVN} { 1746 upvar #0 $aliasesVN aliases 1747 upvar #0 $aliasesPassArgVN aliasesPassArg 1748 upvar #0 $tracesVN traces 1749 upvar #0 $renameCmdsVN renameCmds 1750 1751 # rename some commands on freshly created interp before aliases defined 1752 # below overwrite them 1753 if {$fresh} { 1754 foreach cmd [array names renameCmds] { 1755 $itrp eval rename $cmd $renameCmds($cmd) 1756 } 1757 } 1758 1759 # set interpreter alias commands each time to guaranty them being 1760 # defined and not overridden by modulefile or modulerc content 1761 foreach alias [array names aliases] { 1762 if {[info exists aliasesPassArg($alias)]} { 1763 set aliasarg $aliasesPassArg($alias) 1764 # pass current itrp reference on special keyword 1765 if {$aliasarg eq {__itrp__}} { 1766 set aliasarg $itrp 1767 } 1768 interp alias $itrp $alias {} $aliases($alias) $aliasarg 1769 } else { 1770 interp alias $itrp $alias {} $aliases($alias) 1771 } 1772 } 1773 1774 foreach alias [array names traces] { 1775 interp eval $itrp [list trace add execution $alias leave\ 1776 $traces($alias)] 1777 } 1778} 1779 1780# Restore initial setup of sub interpreter passed as argument based on 1781# global structure previously filled with initial list of defined procedure 1782# and values of global variable. 1783proc resetInterpState {itrp fresh dumpVarsVN dumpArrayVarsVN untrackVarsVN\ 1784 dumpProcsVN aliasesVN aliasesPassArgVN tracesVN renameCmdsVN\ 1785 dumpCommandsVN} { 1786 upvar #0 $dumpVarsVN dumpVars 1787 upvar #0 $dumpArrayVarsVN dumpArrayVars 1788 upvar #0 $untrackVarsVN untrackVars 1789 upvar #0 $dumpProcsVN dumpProcs 1790 upvar #0 $dumpCommandsVN dumpCommands 1791 1792 # look at list of defined procedures and delete those not part of the 1793 # initial state list. do not check if they have been altered as no vital 1794 # procedures lied there. note that if a Tcl command has been overridden 1795 # by a proc, it will be removed here and command will also disappear 1796 foreach var [$itrp eval {info procs}] { 1797 if {![info exists dumpProcs($var)]} { 1798 reportDebug "removing on $itrp proc $var" 1799 $itrp eval [list rename $var {}] 1800 } 1801 } 1802 1803 # rename some commands and set aliases on interpreter 1804 initInterpCommands $itrp $fresh $aliasesVN $aliasesPassArgVN $tracesVN\ 1805 $renameCmdsVN 1806 1807 # dump interpreter command list here on first time as aliases should be 1808 # set prior to be found on this list for correct match 1809 if {![info exists dumpCommands]} { 1810 set dumpCommands [$itrp eval {info commands}] 1811 reportDebug "saving for $itrp command list $dumpCommands" 1812 # if current interpreter command list does not match initial list it 1813 # means that at least one command has been altered so we need to recreate 1814 # interpreter to guaranty proper functioning 1815 } elseif {$dumpCommands ne [$itrp eval {info commands}]} { 1816 reportDebug "missing command(s), recreating interp $itrp" 1817 interp delete $itrp 1818 interp create $itrp 1819 initInterpCommands $itrp 1 $aliasesVN $aliasesPassArgVN $tracesVN\ 1820 $renameCmdsVN 1821 } 1822 1823 # check every global variables currently set and correct them to restore 1824 # initial interpreter state. work on variables at the very end to ensure 1825 # procedures and commands are correctly defined 1826 foreach var [$itrp eval {info globals}] { 1827 if {![info exists untrackVars($var)]} { 1828 if {![info exists dumpVars($var)]} { 1829 reportDebug "removing on $itrp var $var" 1830 $itrp eval unset ::$var 1831 } elseif {![info exists dumpArrayVars($var)]} { 1832 if {$dumpVars($var) ne [$itrp eval set ::$var]} { 1833 reportDebug "restoring on $itrp var $var" 1834 if {[llength $dumpVars($var)] > 1} { 1835 # restore value as list 1836 $itrp eval set ::$var [list $dumpVars($var)] 1837 } else { 1838 # brace value to be able to restore empty string 1839 $itrp eval set ::$var "{$dumpVars($var)}" 1840 } 1841 } 1842 } else { 1843 if {$dumpVars($var) ne [$itrp eval array get ::$var]} { 1844 reportDebug "restoring on $itrp var $var" 1845 $itrp eval array set ::$var [list $dumpVars($var)] 1846 } 1847 } 1848 } 1849 } 1850} 1851 1852######################################################################## 1853# commands run from inside a module file 1854# 1855 1856proc module-info {what {more {}}} { 1857 set mode [currentMode] 1858 1859 reportDebug "$what $more" 1860 1861 switch -- $what { 1862 mode { 1863 if {$more ne {}} { 1864 set command [currentCommandName] 1865 return [expr {$mode eq $more || ($more eq {remove} && $mode eq \ 1866 {unload}) || ($more eq {switch} && $command eq {switch})}] 1867 } else { 1868 return $mode 1869 } 1870 } 1871 command { 1872 set command [currentCommandName] 1873 if {$more eq {}} { 1874 return $command 1875 } else { 1876 return [expr {$command eq $more}] 1877 } 1878 } 1879 name { 1880 return [currentModuleName] 1881 } 1882 specified { 1883 return [currentSpecifiedName] 1884 } 1885 shell { 1886 if {$more ne {}} { 1887 return [expr {[getState shell] eq $more}] 1888 } else { 1889 return [getState shell] 1890 } 1891 } 1892 flags { 1893 # C-version specific option, not relevant for Tcl-version but return 1894 # a zero integer value to avoid breaking modulefiles using it 1895 return 0 1896 } 1897 shelltype { 1898 if {$more ne {}} { 1899 return [expr {[getState shelltype] eq $more}] 1900 } else { 1901 return [getState shelltype] 1902 } 1903 } 1904 user { 1905 # C-version specific option, not relevant for Tcl-version but return 1906 # an empty value or false to avoid breaking modulefiles using it 1907 if {$more ne {}} { 1908 return 0 1909 } else { 1910 return {} 1911 } 1912 } 1913 alias { 1914 set ret [resolveModuleVersionOrAlias $more [isIcase]] 1915 if {$ret ne $more} { 1916 return $ret 1917 } else { 1918 return {} 1919 } 1920 } 1921 trace { 1922 return {} 1923 } 1924 tracepat { 1925 return {} 1926 } 1927 type { 1928 return Tcl 1929 } 1930 symbols { 1931 lassign [getModuleNameVersion $more 1] mod modname modversion 1932 set tag_list [getVersAliasList $mod] 1933 # if querying special symbol "default" but nothing found registered 1934 # on it, look at symbol registered on bare module name in case there 1935 # are symbols registered on it but no default symbol set yet to link 1936 # to them 1937 if {[llength $tag_list] == 0 && $modversion eq {default}} { 1938 set tag_list [getVersAliasList $modname] 1939 } 1940 return [join $tag_list :] 1941 } 1942 version { 1943 lassign [getModuleNameVersion $more 1] mod 1944 return [resolveModuleVersionOrAlias $mod [isIcase]] 1945 } 1946 loaded { 1947 lassign [getModuleNameVersion $more 1] mod 1948 return [getLoadedMatchingName $mod returnall] 1949 } 1950 usergroups { 1951 if {[getState is_win]} { 1952 knerror "module-info usergroups not supported on Windows platform" 1953 } else { 1954 if {$more ne {}} { 1955 return [isInList [getState usergroups] $more] 1956 } else { 1957 return [getState usergroups] 1958 } 1959 } 1960 } 1961 username { 1962 if {[getState is_win]} { 1963 knerror "module-info username not supported on Windows platform" 1964 } else { 1965 if {$more ne {}} { 1966 return [expr {[getState username] eq $more}] 1967 } else { 1968 return [getState username] 1969 } 1970 } 1971 } 1972 default { 1973 knerror "module-info $what not supported" 1974 return {} 1975 } 1976 } 1977} 1978 1979proc module-whatis {args} { 1980 set message [join $args] 1981 reportDebug $message 1982 lappend ::g_whatis $message 1983 1984 return {} 1985} 1986 1987# convert environment variable references in string to their values 1988# every local variable is prefixed by '0' to ensure they will not be 1989# overwritten through variable reference resolution process 1990proc resolvStringWithEnv {0str} { 1991 # fetch variable references in string 1992 set 0match_list [regexp -all -inline {\$[{]?([A-Za-z_][A-Za-z0-9_]*)[}]?}\ 1993 ${0str}] 1994 if {[llength ${0match_list}] > 0} { 1995 # put in local scope every environment variable referred in string 1996 for {set 0i 1} {${0i} < [llength ${0match_list}]} {incr 0i 2} { 1997 set 0varname [lindex ${0match_list} ${0i}] 1998 if {![info exists ${0varname}]} { 1999 set ${0varname} [get-env ${0varname}] 2000 } 2001 } 2002 # resolv variable reference with values (now in local scope) 2003 set 0res [subst -nobackslashes -nocommands ${0str}] 2004 } else { 2005 set 0res ${0str} 2006 } 2007 2008 reportDebug "'${0str}' resolved to '${0res}'" 2009 2010 return ${0res} 2011} 2012 2013# deduce modulepath from modulefile and module name 2014proc getModulepathFromModuleName {modfile modname} { 2015 return [string range $modfile 0 end-[string length /$modname]] 2016} 2017 2018# deduce module name from modulefile and modulepath 2019proc getModuleNameFromModulepath {modfile modpath} { 2020 return [string range $modfile [string length $modpath/] end] 2021} 2022 2023# extract module name from modulefile and currently enabled modulepaths 2024proc findModuleNameFromModulefile {modfile} { 2025 set ret {} 2026 2027 foreach modpath [getModulePathList] { 2028 if {[string first $modpath/ $modfile/] == 0} { 2029 set ret [getModuleNameFromModulepath $modfile $modpath] 2030 break 2031 } 2032 } 2033 return $ret 2034} 2035 2036# extract modulepath from modulefile and currently enabled modulepaths 2037proc findModulepathFromModulefile {modfile} { 2038 set ret {} 2039 2040 foreach modpath [getModulePathList] { 2041 if {[string first $modpath/ $modfile/] == 0} { 2042 set ret $modpath 2043 break 2044 } 2045 } 2046 return $ret 2047} 2048 2049# Determine with a name provided as argument the corresponding module name, 2050# version and name/version. Module name is guessed from current module name 2051# when shorthand version notation is used. Both name and version are guessed 2052# from current module if name provided is empty. If 'name_relative_tocur' is 2053# enabled then name argument may be interpreted as a name relative to the 2054# current modulefile directory (useful for module-version and module-alias 2055# for instance). 2056proc getModuleNameVersion {{name {}} {name_relative_tocur 0}} { 2057 set curmod [currentModuleName] 2058 set curmodname [file dirname $curmod] 2059 set curmodversion [file tail $curmod] 2060 2061 if {$name eq {}} { 2062 set name $curmodname 2063 set version $curmodversion 2064 # check for shorthand version notation like "/version" or "./version" 2065 # only if we are currently interpreting a modulefile or modulerc 2066 } elseif {$curmod ne {} && [regexp {^\.?\/(.*)$} $name match version]} { 2067 # if we cannot distinguish a module name, raise error when shorthand 2068 # version notation is used 2069 if {$::ModulesCurrentModulefile ne $curmod && $curmod ne {.modulerc}} { 2070 # name is the name of current module directory 2071 set name $curmodname 2072 } else { 2073 reportError "Invalid modulename '$name' found" 2074 return {} 2075 } 2076 } else { 2077 set name [string trimright $name /] 2078 set version [file tail $name] 2079 if {$name eq $version} { 2080 set version {} 2081 } else { 2082 set name [file dirname $name] 2083 } 2084 # name may correspond to last part of current module 2085 # if so name is replaced by current module name 2086 if {$name_relative_tocur && [file tail $curmodname] eq $name} { 2087 set name $curmodname 2088 } 2089 } 2090 2091 if {$version eq {}} { 2092 set mod $name 2093 } else { 2094 set mod $name/$version 2095 } 2096 2097 return [list $mod $name $version] 2098} 2099 2100# Register alias or symbolic version deep resolution in a global array that 2101# can be used thereafter to get in one query the actual modulefile behind 2102# a virtual name. Also consolidate a global array that in the same manner 2103# list all the symbols held by modulefiles. 2104proc setModuleResolution {mod target {symver {}} {override_res_path 1}\ 2105 {auto_symver 0}} { 2106 global g_moduleResolved g_resolvedHash g_resolvedPath g_symbolHash 2107 2108 # find end-point module and register step-by-step path to get to it 2109 set res $target 2110 lappend res_path $res 2111 while {$mod ne $res && [info exists g_resolvedPath($res)]} { 2112 set res $g_resolvedPath($res) 2113 lappend res_path $res 2114 } 2115 2116 # error if resolution end on initial module 2117 if {$mod eq $res} { 2118 reportError "Resolution loop on '$res' detected" 2119 return 0 2120 } 2121 2122 # module name will be useful when registering symbol 2123 if {$symver ne {}} { 2124 lassign [getModuleNameVersion $mod] modfull modname 2125 } 2126 2127 # change default symbol owner if previously given; auto symbol are defined 2128 # only if no default is pre-existing 2129 if {$symver eq {default} && !$auto_symver} { 2130 # alternative name "modname" is set when mod = "modname/default" both 2131 # names will be registered to be known for queries and resolution defs 2132 set modalt $modname 2133 2134 if {[info exists g_moduleResolved($mod)]} { 2135 set prev $g_moduleResolved($mod) 2136 # there may not be a default in case of auto symbol 2137 if {[info exists g_symbolHash($prev)] && [set idx [lsearch -exact\ 2138 $g_symbolHash($prev) default]] != -1} { 2139 reportDebug "remove symbol 'default' from '$prev'" 2140 set g_symbolHash($prev) [lreplace $g_symbolHash($prev) $idx $idx] 2141 } 2142 } 2143 } 2144 2145 # register end-point resolution 2146 reportDebug "$mod resolved to $res" 2147 set g_moduleResolved($mod) $res 2148 # set first element of resolution path only if not already set or 2149 # scratching enabled, no change when propagating symbol along res path 2150 if {$override_res_path || ![info exists g_resolvedPath($mod)]} { 2151 set g_resolvedPath($mod) $target 2152 } 2153 lappend g_resolvedHash($res) $mod 2154 2155 # also register resolution on alternative name if any 2156 if {[info exists modalt]} { 2157 reportDebug "$modalt resolved to $res" 2158 set g_moduleResolved($modalt) $res 2159 if {$override_res_path || ![info exists g_resolvedPath($modalt)]} { 2160 set g_resolvedPath($modalt) $target 2161 } 2162 lappend g_resolvedHash($res) $modalt 2163 # register name alternative to know their existence 2164 set ::g_moduleAltName($modalt) $mod 2165 set ::g_moduleAltName($mod) $modalt 2166 } 2167 2168 # if other modules were pointing to this one, adapt resolution end-point 2169 set relmod_list {} 2170 if {[info exists g_resolvedHash($mod)]} { 2171 set relmod_list $g_resolvedHash($mod) 2172 unset g_resolvedHash($mod) 2173 } 2174 # also adapt resolution for modules pointing to the alternative name 2175 if {[info exists modalt] && [info exists g_resolvedHash($modalt)]} { 2176 set relmod_list [concat $relmod_list $g_resolvedHash($modalt)] 2177 unset g_resolvedHash($modalt) 2178 } 2179 foreach relmod $relmod_list { 2180 set g_moduleResolved($relmod) $res 2181 reportDebug "$relmod now resolved to $res" 2182 lappend g_resolvedHash($res) $relmod 2183 } 2184 2185 # register and propagate symbols to the resolution path, execption made for 2186 # auto symbol which are stored separately and not propagated 2187 if {[info exists g_symbolHash($mod)]} { 2188 set sym_list $g_symbolHash($mod) 2189 } else { 2190 set sym_list {} 2191 } 2192 if {$symver ne {} && $auto_symver} { 2193 reportDebug "define auto symbolic version '$mod' targeting $target" 2194 set ::g_autoSymbol($mod) $target 2195 } elseif {$symver ne {} && !$auto_symver} { 2196 # merge symbol definitions in case of alternative name 2197 if {[info exists modalt] && [info exists g_symbolHash($modalt)]} { 2198 set sym_list [lsort -dictionary -unique [concat $sym_list\ 2199 $g_symbolHash($modalt)]] 2200 reportDebug "set symbols '$sym_list' to $mod and $modalt" 2201 set g_symbolHash($mod) $sym_list 2202 set g_symbolHash($modalt) $sym_list 2203 } 2204 2205 # dictionary-sort symbols and remove eventual duplicates 2206 set sym_list [lsort -dictionary -unique [concat $sym_list\ 2207 [list $symver]]] 2208 2209 # propagate symbols in g_symbolHash and g_moduleVersion toward the 2210 # resolution path, handle that locally if we still work on same 2211 # modulename, call for a proper resolution as soon as we change of 2212 # module to get this new resolution registered 2213 foreach modres $res_path { 2214 lassign [getModuleNameVersion $modres] modfull modresname 2215 if {$modname eq $modresname} { 2216 if {[info exists g_symbolHash($modres)]} { 2217 set modres_sym_list [lsort -dictionary -unique [concat\ 2218 $g_symbolHash($modres) $sym_list]] 2219 } else { 2220 set modres_sym_list $sym_list 2221 } 2222 # sync symbols of alternative name if any 2223 if {[info exists ::g_moduleAltName($modres)]} { 2224 set altmodres $::g_moduleAltName($modres) 2225 reportDebug "set symbols '$modres_sym_list' to $modres and\ 2226 $altmodres" 2227 set g_symbolHash($altmodres) $modres_sym_list 2228 } else { 2229 reportDebug "set symbols '$modres_sym_list' to $modres" 2230 } 2231 set g_symbolHash($modres) $modres_sym_list 2232 2233 # register symbolic version for querying in g_moduleVersion 2234 foreach symelt $sym_list { 2235 set modvers $modresname/$symelt 2236 reportDebug "module-version $modvers = $modres" 2237 set ::g_moduleVersion($modvers) $modres 2238 set ::g_sourceVersion($modvers) $::ModulesCurrentModulefile 2239 # record eventual missing resolution 2240 if {![info exists g_moduleResolved($modvers)]} { 2241 set g_moduleResolved($modvers) $modres 2242 reportDebug "$modvers resolved to $modres" 2243 lappend g_resolvedHash($modres) $modvers 2244 } 2245 } 2246 # as we change of module name a proper resolution call should be 2247 # made (see below) and will handle the rest of the resolution path 2248 } else { 2249 set need_set_res 1 2250 break 2251 } 2252 } 2253 # when registering an alias, existing symbols on alias source name should 2254 # be broadcast along the resolution path with a proper resolution call 2255 # (see below) 2256 } else { 2257 lassign [getModuleNameVersion $target] modres modresname 2258 set need_set_res 1 2259 } 2260 2261 # resolution needed to broadcast symbols along resolution path without 2262 # altering initial path already set for these symbols 2263 if {[info exists need_set_res]} { 2264 foreach symelt $sym_list { 2265 set modvers $modresname/$symelt 2266 reportDebug "set resolution for $modvers" 2267 setModuleResolution $modvers $modres $symelt 0 2268 } 2269 } 2270 2271 return 1 2272} 2273 2274# retrieve all names that resolve to passed mod 2275proc getAllModuleResolvedName {mod {flag_autosym 0} {modspec {}}} { 2276 set namelist {} 2277 set resmodlist {} 2278 set icase [isIcase] 2279 defineModEqProc $icase [getConf extended_default] 2280 2281 # get parent directories of mod 2282 foreach modelt [split $mod /] { 2283 if {[info exists modroot]} { 2284 append modroot / 2285 } 2286 append modroot $modelt 2287 lappend resmodlist $modroot 2288 } 2289 2290 # add additionnaly all the altnames set on directories, parents of mod 2291 # or on distant directories whose default version resolves to mod 2292 for {set i 0} {$i < [llength $resmodlist]} {incr i 1} { 2293 set modelt [getArrayKey ::g_resolvedHash [lindex $resmodlist $i] $icase] 2294 if {[info exists ::g_resolvedHash($modelt)]} { 2295 foreach resmod $::g_resolvedHash($modelt) { 2296 # if alternative name corresponds to one root name test if default 2297 # symbol is hidden 2298 set resmoddfl [expr {[lsearch -exact $resmodlist $resmod] != -1 ?\ 2299 "$resmod/default" : {}}] 2300 # if alternative name corresponds to default symbol and is hidden 2301 # test if query matches bare module name 2302 set resmodpar [expr {[file tail $resmod] eq {default} ? [file\ 2303 dirname $resmod] : {}}] 2304 2305 # if modelt is not a parent directory of mod, check its resolution 2306 # points to mod (directly for alias/sym or indirectly for dir 2307 # whose default version bridge resolution toward mod) 2308 # if modspec arg is set, exclude hidden entries not explicitly 2309 # matching modspec. auto symbols cannot be hidden 2310 if {($modspec eq {} || ([info exists ::g_autoSymbol($resmod)] &&\ 2311 $::g_autoSymbol($resmod) eq $mod) || (![isModuleHidden $resmod\ 2312 $modspec] && ($resmoddfl eq {} || ![isModuleHidden $resmoddfl\ 2313 $modspec])) || [modEq $modspec $resmod eqspec] || ($resmodpar\ 2314 ne {} && [modEq $modspec $resmodpar eqspec])) && ([modEq\ 2315 $modelt $mod eqstart] || $::g_moduleResolved($resmod) eq $mod\ 2316 || $mod eq [lindex [getPathToModule\ 2317 $::g_moduleResolved($resmod) {} 0] 1])} { 2318 # prefix automatically generated symbols with 'as|' if asked 2319 if {$flag_autosym && [info exists ::g_autoSymbol($resmod)]} { 2320 appendNoDupToList namelist as|$resmod 2321 } else { 2322 appendNoDupToList namelist $resmod 2323 } 2324 2325 unset modroot 2326 foreach reselt [split [file dirname $resmod] /] { 2327 if {[info exists modroot]} { 2328 append modroot / 2329 } 2330 append modroot $reselt 2331 appendNoDupToList resmodlist $modroot 2332 } 2333 } 2334 } 2335 } 2336 } 2337 return $namelist 2338} 2339 2340# Specifies a default or alias version for a module that points to an 2341# existing module version Note that aliases defaults are stored by the 2342# short module name (not the full path) so aliases and defaults from one 2343# directory will apply to modules of the same name found in other 2344# directories. 2345proc module-version {args} { 2346 reportDebug $args 2347 lassign [getModuleNameVersion [lindex $args 0] 1] mod modname modversion 2348 2349 # go for registration only if valid modulename 2350 if {$mod ne {}} { 2351 foreach version [lrange $args 1 end] { 2352 set aliasversion $modname/$version 2353 # do not alter a previously defined alias version 2354 if {![info exists ::g_moduleVersion($aliasversion)]} { 2355 setModuleResolution $aliasversion $mod $version 2356 } else { 2357 reportWarning "Symbolic version '$aliasversion' already defined" 2358 } 2359 } 2360 } 2361 2362 return {} 2363} 2364 2365proc module-alias {args} { 2366 lassign [getModuleNameVersion [lindex $args 0]] alias 2367 lassign [getModuleNameVersion [lindex $args 1] 1] mod 2368 2369 reportDebug "$alias = $mod" 2370 2371 if {[setModuleResolution $alias $mod]} { 2372 set ::g_moduleAlias($alias) $mod 2373 set ::g_sourceAlias($alias) $::ModulesCurrentModulefile 2374 } 2375 2376 return {} 2377} 2378 2379proc module-virtual {args} { 2380 lassign [getModuleNameVersion [lindex $args 0]] mod 2381 set modfile [getAbsolutePath [lindex $args 1]] 2382 2383 reportDebug "$mod = $modfile" 2384 2385 set ::g_moduleVirtual($mod) $modfile 2386 set ::g_sourceVirtual($mod) $::ModulesCurrentModulefile 2387 2388 return {} 2389} 2390 2391# Parse date time argument value and translate it into epoch time 2392proc parseDateTimeArg {opt datetime} { 2393 if {[regexp {^\d{4}-\d{2}-\d{2}(T\d{2}:\d{2})?$} $datetime match\ 2394 timespec]} { 2395 # time specification is optional 2396 if {$timespec eq {}} { 2397 append datetime T00:00 2398 } 2399 # return corresponding epoch time 2400 return [clock scan $datetime -format %Y-%m-%dT%H:%M] 2401 } else { 2402 knerror "Incorrect $opt value '$datetime' (valid date time format is\ 2403 'YYYY-MM-DD\[THH:MM\]')" 2404 } 2405} 2406 2407# parse application critera arguments and determine if command applies 2408proc parseApplicationCriteriaArgs {nearsec args} { 2409 set otherargs {} 2410 2411 # parse argument list 2412 foreach arg $args { 2413 if {[info exists nextargisval]} { 2414 set $nextargisval $arg 2415 unset nextargisval 2416 } elseif {[info exists nextargisdatetime]} { 2417 set ${nextargisdatetime}raw $arg 2418 # get epoch time from date time argument value 2419 set $nextargisdatetime [parseDateTimeArg $prevarg $arg] 2420 unset nextargisdatetime 2421 } elseif {[info exists nextargisign]} { 2422 unset nextargisign 2423 } else { 2424 switch -- $arg { 2425 --after - --before { 2426 if {[getState tcl_version_lt85]} { 2427 knerror "Option '$arg' not supported on Tcl<8.5" 2428 set nextargisign 1 2429 } else { 2430 set nextargisdatetime [string trimleft $arg -] 2431 } 2432 } 2433 --not-group - --not-user { 2434 if {[getState is_win]} { 2435 knerror "Option '$arg' not supported on Windows platform" 2436 set nextargisign 1 2437 } else { 2438 set nextargisval not[string range $arg 6 end]list 2439 } 2440 } 2441 default { 2442 lappend otherargs $arg 2443 } 2444 } 2445 set prevarg $arg 2446 } 2447 } 2448 2449 if {[info exists nextargisval] || [info exists nextargisdatetime]} { 2450 knerror "Missing value for '$prevarg' option" 2451 } 2452 2453 # does it apply to current user? 2454 set notuser [expr {[info exists notuserlist] && [isInList $notuserlist\ 2455 [getState username]]}] 2456 set notgroup [expr {[info exists notgrouplist] && [isIntBetweenList\ 2457 $notgrouplist [getState usergroups]]}] 2458 2459 # does it apply currently? 2460 set isbefore [expr {[info exists before] && [getState clock_seconds] <\ 2461 $before}] 2462 set isafter [expr {[info exists after] && [getState clock_seconds] >=\ 2463 $after}] 2464 2465 # are criteria met 2466 set apply [expr {!$notuser && !$notgroup && ($isbefore || $isafter ||\ 2467 (![info exists before] && ![info exists after]))}] 2468 2469 # is end limit near ? 2470 set isnearly [expr {!$apply && !$notuser && !$notgroup && [info exists\ 2471 after] && !$isafter && [getState clock_seconds] >= ($after - $nearsec)}] 2472 if {![info exists afterraw]} { 2473 set afterraw {} 2474 } 2475 2476 return [list $apply $isnearly $afterraw $otherargs] 2477} 2478 2479proc module-forbid {args} { 2480 # parse application criteria arguments to determine if command apply 2481 lassign [eval parseApplicationCriteriaArgs [expr {[getConf\ 2482 nearly_forbidden_days] * 86400}] $args] apply isnearly after otherargs 2483 2484 # parse remaining argument list, do it even if command does not apply to 2485 # raise any command specification error 2486 foreach arg $otherargs { 2487 if {[info exists nextargisval]} { 2488 set $nextargisval $arg 2489 unset nextargisval 2490 } else { 2491 switch -glob -- $arg { 2492 --nearly-message { 2493 set nextargisval nearlymessage 2494 } 2495 --message { 2496 set nextargisval message 2497 } 2498 -* { 2499 knerror "Invalid option '$arg'" 2500 } 2501 default { 2502 lappend modarglist $arg 2503 } 2504 } 2505 set prevarg $arg 2506 } 2507 } 2508 2509 if {[info exists nextargisval]} { 2510 knerror "Missing value for '$prevarg' option" 2511 } 2512 2513 if {![info exists modarglist]} { 2514 knerror {No module specified in argument} 2515 } 2516 2517 # skip record if application criteria are not met 2518 if {$apply} { 2519 set proplist {} 2520 if {[info exists message]} { 2521 lappend proplist message $message 2522 } 2523 2524 # record each forbid spec after parsing them 2525 foreach modarg [eval parseModuleVersionSpecifier 0 $modarglist] { 2526 setModspecTag $modarg forbidden $proplist 2527 } 2528 } elseif {$isnearly} { 2529 lappend proplist after $after 2530 if {[info exists nearlymessage]} { 2531 lappend proplist message $nearlymessage 2532 } 2533 # record each nearly forbid spec after parsing them 2534 foreach modarg [eval parseModuleVersionSpecifier 0 $modarglist] { 2535 setModspecTag $modarg nearly-forbidden $proplist 2536 } 2537 } 2538} 2539 2540proc module-hide {args} { 2541 set hidinglvl 1 2542 2543 # parse application criteria arguments to determine if command apply 2544 lassign [eval parseApplicationCriteriaArgs 0 $args] apply isnearly after\ 2545 otherargs 2546 2547 # parse remaining argument list, do it even if command does not apply to 2548 # raise any command specification error 2549 foreach arg $otherargs { 2550 switch -glob -- $arg { 2551 --hard { 2552 # hardened stealth 2553 set hidinglvl 2 2554 } 2555 --soft { 2556 # soften level of camouflage 2557 set hidinglvl 0 2558 } 2559 -* { 2560 knerror "Invalid option '$arg'" 2561 } 2562 default { 2563 lappend modarglist $arg 2564 } 2565 } 2566 } 2567 2568 if {![info exists modarglist]} { 2569 knerror {No module specified in argument} 2570 } 2571 2572 # skip hide spec record if application criteria are not met 2573 if {$apply} { 2574 # record each hide spec after parsing them 2575 foreach modarg [eval parseModuleVersionSpecifier 0 $modarglist] { 2576 setModspecHidingLevel $modarg $hidinglvl 2577 } 2578 } 2579} 2580 2581proc module {command args} { 2582 set mode [currentMode] 2583 reportDebug "cmd='$command', args='$args'" 2584 2585 # guess if called from top level 2586 set topcall [expr {[getEvalModuleStackDepth] == 0}] 2587 set tryhelpmsg [expr {$topcall ? "\nTry 'module --help' for more\ 2588 information." : {}}] 2589 if {$topcall} { 2590 set msgprefix {} 2591 } else { 2592 set msgprefix {module: } 2593 } 2594 2595 # resolve and check command name 2596 lassign [parseModuleCommandName $command help] command cmdvalid cmdempty 2597 # clear other args if no command name supplied 2598 if {$cmdempty} { 2599 set args {} 2600 } 2601 # raise error if supplied command is not known 2602 if {!$cmdvalid} { 2603 knerror "${msgprefix}Invalid command '$command'$tryhelpmsg" 2604 } 2605 2606 # parse options, do that globally to ignore options not related to a given 2607 # module sub-command (exclude them from arg list) 2608 lassign [eval parseModuleCommandArgs $command $args] show_oneperline\ 2609 show_mtime show_filter search_filter search_match dump_state\ 2610 addpath_pos args 2611 2612 # parse module version specification 2613 if {[isInList [list avail paths whatis load unload switch help test\ 2614 display path is-avail] $command]} { 2615 set args [eval parseModuleVersionSpecifier 0 $args] 2616 } 2617 2618 if {!$topcall} { 2619 # some commands can only be called from top level, not within modulefile 2620 switch -- $command { 2621 path - paths - autoinit - help - prepend-path - append-path -\ 2622 remove-path - is-loaded - is-saved - is-used - is-avail -\ 2623 info-loaded - clear - sh-to-mod { 2624 knerror "${msgprefix}Command '$command' not supported$tryhelpmsg" 2625 } 2626 } 2627 # other commands can only be called from modulefile evaluated from 2628 # command acting as top-level context (source and autoinit) 2629 if {([getEvalModuleStackDepth] > 1 || [notInList [list source autoinit]\ 2630 [currentCommandName]]) && $command eq {config}} { 2631 knerror "${msgprefix}Command '$command' not supported$tryhelpmsg" 2632 } 2633 } 2634 2635 # argument number check 2636 switch -- $command { 2637 unload - source - display - initadd - initprepend - initrm - test -\ 2638 is-avail { 2639 if {[llength $args] == 0} { 2640 set argnberr 1 2641 } 2642 } 2643 reload - aliases - list - purge - savelist - initlist - initclear -\ 2644 autoinit { 2645 if {[llength $args] != 0} { 2646 set argnberr 1 2647 } 2648 } 2649 switch { 2650 if {[llength $args] == 0 || [llength $args] > 2} { 2651 set argnberr 1 2652 } 2653 } 2654 path - paths - info-loaded { 2655 if {[llength $args] != 1} { 2656 set argnberr 1 2657 } 2658 } 2659 search - save - restore - saverm - saveshow - clear { 2660 if {[llength $args] > 1} { 2661 set argnberr 1 2662 } 2663 } 2664 initswitch { 2665 if {[llength $args] != 2} { 2666 set argnberr 1 2667 } 2668 } 2669 prepend-path - append-path - remove-path - sh-to-mod { 2670 if {[llength $args] < 2} { 2671 set argnberr 1 2672 } 2673 } 2674 config { 2675 if {[llength $args] > 2} { 2676 set argnberr 1 2677 } 2678 } 2679 } 2680 if {[info exists argnberr]} { 2681 knerror "Unexpected number of args for '$command' command$tryhelpmsg" 2682 } 2683 2684 # define if modfile should always be fully read even for validity check 2685 pushAlwaysReadFullFile [expr {![isInList [list path paths list avail\ 2686 aliases] $command]}] 2687 pushCommandName $command 2688 2689 if {$topcall} { 2690 # Find and execute any global rc file found 2691 runModulerc 2692 } 2693 2694 switch -- $command { 2695 load { 2696 # ignore flag used in collection to track non-user asked state 2697 set args [replaceFromList $args --notuasked] 2698 # no error raised on empty argument list to cope with 2699 # initadd command that may expect this behavior 2700 if {[llength $args] > 0} { 2701 set ret 0 2702 # if top command is source, consider module load commands made 2703 # within sourced file evaluation as top load command 2704 if {$topcall || ([getEvalModuleStackDepth] == 1 && ( 2705 [aboveCommandName] eq {source} || [aboveCommandName] eq\ 2706 {autoinit}))} { 2707 set ret [eval cmdModuleLoad load 1 $args] 2708 } elseif {$mode eq {load}} { 2709 # load here if no auto mode, done through prereq elsewhere 2710 # inhibited if currently in DepRe context 2711 if {![getConf auto_handling] && [currentModuleEvalContext] ne\ 2712 {depre}} { 2713 # attempt load of not already loaded modules 2714 foreach arg $args { 2715 if {![is-loaded $arg] && ![is-loading $arg]} { 2716 lappend modlist $arg 2717 } 2718 } 2719 if {[info exists modlist]} { 2720 set ret [eval cmdModuleLoad reqlo 0 $modlist] 2721 # ignore obtained error if force mode enabled 2722 if {[getState force]} { 2723 set ret 0 2724 } 2725 } 2726 } 2727 # register modulefiles to load as individual prereqs 2728 foreach arg $args { 2729 prereq $arg 2730 } 2731 # mods unload is handled via UReqUn mechanism when auto enabled 2732 # also unloads are triggered by ongoing reload, purge or 2733 # restore commands 2734 } elseif {![getConf auto_handling] && [notInList [list purge\ 2735 reload restore] [aboveCommandName]]} { 2736 # on unload mode, unload mods in reverse order, if loaded 2737 # prior this mod, if not user asked and not required by 2738 # other loaded mods 2739 set modlist [getLoadedModuleList] 2740 set modidx [lsearch -exact $modlist [currentModuleName]] 2741 if {$modidx != 0} { 2742 set priormodlist [lrange $modlist 0 $modidx] 2743 foreach arg [lreverse $args] { 2744 if {[set unmod [getLoadedMatchingName $arg {} 0\ 2745 $priormodlist]] ne {}} { 2746 if {[cmdModuleUnload urequn match 1 0 1 1 $unmod]} { 2747 reportWarning "Unload of useless requirement\ 2748 $unmod failed" 1 2749 } 2750 } 2751 } 2752 } 2753 } 2754 # sub-module interpretation failed, raise error 2755 if {$ret && !$topcall} { 2756 knerror {} MODULES_ERR_SUBFAILED 2757 } 2758 } 2759 } 2760 unload { 2761 # if top command is source, consider module load commands made 2762 # within sourced file evaluation as top load command 2763 if {$topcall || ([getEvalModuleStackDepth] == 1 && ( 2764 [aboveCommandName] eq {source} || [aboveCommandName] eq\ 2765 {autoinit}))} { 2766 set ret [eval cmdModuleUnload unload match 1 0 0 0 $args] 2767 } elseif {$mode eq {load}} { 2768 # unload mods only on load mode, nothing done on unload mode as 2769 # the registered conflict guarantees the target module cannot 2770 # be loaded unless forced 2771 # do not unload module required by others even in force mode 2772 set ret [eval cmdModuleUnload conun match 0 0 0 1 $args] 2773 2774 # register modulefiles to unload as individual conflicts 2775 foreach arg $args { 2776 # do not break on error yet, go through the whole modfile 2777 # evaluation in case conflict is solved later on 2778 catch {conflict $arg} 2779 } 2780 # sub-module interpretation failed, raise error 2781 if {$ret} { 2782 knerror {} MODULES_ERR_SUBFAILED 2783 } 2784 } 2785 } 2786 reload { 2787 cmdModuleReload 2788 } 2789 use { 2790 if {$topcall || $mode eq {load}} { 2791 eval cmdModuleUse $addpath_pos $args 2792 } else { 2793 eval cmdModuleUnuse $args 2794 } 2795 } 2796 unuse { 2797 eval cmdModuleUnuse $args 2798 } 2799 source { 2800 if {$topcall || $mode eq {load}} { 2801 eval cmdModuleSource $args 2802 } else { 2803 # on unload mode, unsource script in reverse order 2804 eval cmdModuleUnsource [lreverse $args] 2805 } 2806 } 2807 switch { 2808 # pass 'user asked state' to switch procedure 2809 set uasked [expr {$topcall || ([getEvalModuleStackDepth] == 1 &&\ 2810 ([aboveCommandName] eq {source} || [aboveCommandName] eq\ 2811 {autoinit}))}] 2812 if {$uasked} { 2813 eval cmdModuleSwitch $uasked $args 2814 } else { 2815 # CAUTION: it is not recommended to use the `switch` 2816 # sub-command in modulefiles as this command is intended for 2817 # the command-line for a 2in1 operation. Could be removed from 2818 # the modulefile scope in a future release. Use `module unload` 2819 # and `module load` commands in modulefiles instead. 2820 2821 switch -- $mode { 2822 load { 2823 eval cmdModuleSwitch $uasked $args 2824 } 2825 unload { 2826 # find what has been asked for unload and load 2827 lassign $args swunmod swlomod 2828 if {$swlomod eq {} && $swunmod ne {}} { 2829 set swlomod $swunmod 2830 } 2831 2832 # apply same mechanisms than for 'module load' and 2833 # 'module unload' for an unload evaluation: nothing done 2834 # for switched-off module and unload of switched-on 2835 # module. If auto handling is enabled switched-on module 2836 # is handled via UReqUn mechanism. Also unloads are 2837 # triggered by ongoing reload, purge or restore commands 2838 if {![getConf auto_handling] && $swlomod ne {} &&\ 2839 [notInList [list purge reload restore]\ 2840 [aboveCommandName]]} { 2841 # unload mod if it was loaded prior this mod, not user 2842 # asked and not required by another loaded module 2843 set modlist [getLoadedModuleList] 2844 set modidx [lsearch -exact $modlist [currentModuleName]] 2845 if {$modidx != 0} { 2846 set priormodlist [lrange $modlist 0 $modidx] 2847 if {[set unmod [getLoadedMatchingName $swlomod {} 0\ 2848 $priormodlist]] ne {}} { 2849 if {[cmdModuleUnload urequn match 1 0 1 1 $unmod]} { 2850 reportWarning "Unload of useless requirement\ 2851 $unmod failed" 1 2852 } 2853 } 2854 } 2855 } 2856 } 2857 } 2858 } 2859 } 2860 display { 2861 eval cmdModuleDisplay $args 2862 } 2863 avail { 2864 eval cmdModuleAvail $show_oneperline $show_mtime "{$show_filter}"\ 2865 "{$search_filter}" "{$search_match}" $args 2866 } 2867 aliases { 2868 cmdModuleAliases 2869 } 2870 path { 2871 eval cmdModulePath $args 2872 } 2873 paths { 2874 eval cmdModulePaths $args 2875 } 2876 list { 2877 cmdModuleList $show_oneperline $show_mtime 2878 } 2879 whatis { 2880 if {$args ne {}} { 2881 foreach arg $args { 2882 cmdModuleWhatIs $arg 2883 } 2884 } else { 2885 cmdModuleWhatIs 2886 } 2887 } 2888 search { 2889 eval cmdModuleApropos $args 2890 } 2891 purge { 2892 eval cmdModulePurge 2893 } 2894 save { 2895 eval cmdModuleSave $args 2896 } 2897 restore { 2898 eval cmdModuleRestore $args 2899 } 2900 saverm { 2901 eval cmdModuleSaverm $args 2902 } 2903 saveshow { 2904 eval cmdModuleSaveshow $args 2905 } 2906 savelist { 2907 cmdModuleSavelist $show_oneperline $show_mtime 2908 } 2909 initadd { 2910 eval cmdModuleInit add $args 2911 } 2912 initprepend { 2913 eval cmdModuleInit prepend $args 2914 } 2915 initswitch { 2916 eval cmdModuleInit switch $args 2917 } 2918 initrm { 2919 eval cmdModuleInit rm $args 2920 } 2921 initlist { 2922 eval cmdModuleInit list $args 2923 } 2924 initclear { 2925 eval cmdModuleInit clear $args 2926 } 2927 autoinit { 2928 cmdModuleAutoinit 2929 } 2930 clear { 2931 # ensure empty string is correctly passed 2932 eval cmdModuleClear "{$args}" 2933 } 2934 config { 2935 eval cmdModuleConfig $dump_state $args 2936 } 2937 sh-to-mod { 2938 eval cmdModuleShToMod $args 2939 } 2940 help { 2941 eval cmdModuleHelp $args 2942 } 2943 test { 2944 eval cmdModuleTest $args 2945 } 2946 prepend-path - append-path - remove-path - is-loaded - is-saved -\ 2947 is-used - is-avail { 2948 eval cmdModuleResurface $command $args 2949 } 2950 info-loaded { 2951 eval cmdModuleResurface module-info loaded $args 2952 } 2953 } 2954 popCommandName 2955 popAlwaysReadFullFile 2956 2957 # if called from top level render settings if any 2958 if {$topcall} { 2959 renderSettings 2960 } 2961 2962 return {} 2963} 2964 2965proc ml {args} { 2966 # ml cannot be called within modulefile, top level only 2967 if {[getEvalModuleStackDepth] > 0} { 2968 knerror {Command 'ml' not supported} 2969 } 2970 2971 # filter out all known options from argument list to guess command name 2972 # without them in the way 2973 lassign [eval parseModuleCommandArgs ml $args] show_oneperline\ 2974 show_mtime show_filter search_filter search_match dump_state\ 2975 addpath_pos fargs 2976 2977 # determine if first argument is a known module sub-command 2978 lassign [parseModuleCommandName [lindex $fargs 0] list] command cmdvalid\ 2979 cmdempty 2980 2981 if {$cmdempty} { 2982 # consider empty string supplied as first argument as module name 2983 if {[llength $fargs] > 0} { 2984 set cmdvalid 0 2985 } 2986 set margs $args 2987 } else { 2988 # first argument was command name 2989 set margs [lrange $args 1 end] 2990 } 2991 2992 # directly call module procedure if sub-command spotted as first argument 2993 # or no argument supplied 2994 if {$cmdvalid} { 2995 eval module $command $margs 2996 } else { 2997 # no need to look for option arguments as they have already been parsed 2998 # in main procedure (error has already been raised for badly written 2999 # argument like '-' or '--') 3000 3001 # parse specified module and get list of mods to unload and mods to load 3002 lassign [eval parseModuleVersionSpecifier 1 $fargs] modunlist modlolist 3003 3004 # define if modfile should always be fully read even for validity check 3005 pushAlwaysReadFullFile 1 3006 pushCommandName ml 3007 3008 # Find and execute any global rc file found 3009 runModulerc 3010 3011 set ret 0 3012 pushSettings 3013 3014 # first unload specified modules 3015 if {[llength $modunlist] > 0} { 3016 set ret [eval cmdModuleUnload unload match 1 0 0 0 $modunlist] 3017 } 3018 # then load other modules unless unload phase failed 3019 if {!$ret && [llength $modlolist] > 0} { 3020 set ret [eval cmdModuleLoad load 1 $modlolist] 3021 } 3022 3023 # rollback changes if any load or unload failed 3024 if {$ret} { 3025 restoreSettings 3026 } 3027 popSettings 3028 3029 popCommandName 3030 popAlwaysReadFullFile 3031 3032 renderSettings 3033 } 3034 3035 return {} 3036} 3037 3038proc getModshareVarName {var} { 3039 # specific modshare variable for DYLD-related variables as a suffixed 3040 # variable will lead to warning messages with this tool 3041 if {[string range $var 0 4] eq {DYLD_}} { 3042 return MODULES_MODSHARE_${var} 3043 } else { 3044 return ${var}_modshare 3045 } 3046} 3047 3048proc setenv {var val} { 3049 reportDebug "var='$var', val='$val'" 3050 3051 # clean any previously defined reference counter array 3052 unset-env [getModshareVarName $var] 1 3053 3054 # Set the variable for later use during the modulefile evaluation 3055 set-env $var $val 3056 3057 return {} 3058} 3059 3060# undo setenv in unload mode 3061proc setenv-un {var val} { 3062 reportDebug "var='$var', val='$val'" 3063 3064 # clean any existing reference counter array 3065 unset-env [getModshareVarName $var] 1 3066 3067 # Add variable to the list of variable to unset in shell output code but 3068 # set it in interp context as done on load mode for later use during the 3069 # modulefile evaluation 3070 unset-env $var 0 $val 3071 3072 return {} 3073} 3074 3075# optimized setenv/unsetenv for whatis mode: init env variable with an empty 3076# value if undefined. do not care about value, just avoid variable to be 3077# undefined for later use during the modulefile evaluation 3078proc setenv-wh {var args} { 3079 if {![info exists ::env($var)]} { 3080 reportDebug "var='$var', val=''" 3081 set ::env($var) {} 3082 } 3083 return {} 3084} 3085 3086proc getenv {var {valifundef _UNDEFINED_}} { 3087 reportDebug "var='$var', valifundef='$valifundef'" 3088 3089 if {[currentMode] ne {display}} { 3090 return [get-env $var $valifundef] 3091 } else { 3092 return "\$$var" 3093 } 3094} 3095 3096proc unsetenv {var {val {}}} { 3097 reportDebug "var='$var', val='$val'" 3098 3099 # clean any existing reference counter array 3100 unset-env [getModshareVarName $var] 1 3101 3102 # Set the variable for later use during the modulefile evaluation 3103 unset-env $var 3104 3105 return {} 3106} 3107 3108# undo unsetenv in unload mode 3109proc unsetenv-un {var {val {}}} { 3110 if {$val ne {}} { 3111 return [setenv $var $val] 3112 } else { 3113 return [unsetenv $var] 3114 } 3115} 3116 3117proc chdir {dir} { 3118 reportDebug $dir 3119 3120 if {[file exists $dir] && [file isdirectory $dir]} { 3121 set ::g_changeDir $dir 3122 } else { 3123 # report issue but does not treat it as an error to have the 3124 # same behavior as C-version 3125 reportWarning "Cannot chdir to '$dir' for '[currentModuleName]'" 3126 } 3127 3128 return {} 3129} 3130 3131# superseed exit command to handle it if called within a modulefile 3132# rather than exiting the whole process 3133proc exitModfileCmd {{code 0}} { 3134 reportDebug ($code) 3135 3136 if {[currentMode] eq {load}} { 3137 setState inhibit_interp 1 3138 } 3139 3140 # break to gently end interpretation of current modulefile 3141 return -code break 3142} 3143 3144# enables sub interp to return ModulesVersion value to the main interp 3145proc setModulesVersion {val} { 3146 set ::ModulesVersion $val 3147} 3148 3149# supersede puts command to catch content sent to stdout/stderr within 3150# modulefile in order to correctly send stderr content (if a pager has been 3151# enabled) or postpone content channel send after rendering on stdout the 3152# relative environment changes required by the modulefile 3153proc putsModfileCmd {itrp args} { 3154 reportDebug "$args (itrp=$itrp)" 3155 3156 # determine if puts call targets the stdout or stderr channel 3157 switch -- [llength $args] { 3158 1 { 3159 set deferPuts 1 3160 } 3161 2 { 3162 switch -- [lindex $args 0] { 3163 -nonewline - stdout { 3164 set deferPuts 1 3165 } 3166 stderr { 3167 set reportArgs [list [lindex $args 1]] 3168 } 3169 } 3170 } 3171 3 { 3172 if {[lindex $args 0] eq {-nonewline}} { 3173 switch -- [lindex $args 1] { 3174 stdout { 3175 set deferPuts 1 3176 } 3177 stderr { 3178 set reportArgs [list [lindex $args 2] 1] 3179 } 3180 } 3181 } else { 3182 set wrongNumArgs 1 3183 } 3184 } 3185 default { 3186 set wrongNumArgs 1 3187 } 3188 } 3189 3190 # raise error if bad argument number detected, do this here rather in _puts 3191 # not to confuse people with an error reported by an internal name (_puts) 3192 if {[info exists wrongNumArgs]} { 3193 knerror {wrong # args: should be "puts ?-nonewline? ?channelId? string"} 3194 # defer puts if it targets stdout (see renderSettings) 3195 } elseif {[info exists deferPuts]} { 3196 lappend ::g_stdoutPuts $args 3197 # if it targets stderr call report, which knows what channel to use 3198 } elseif {[info exists reportArgs]} { 3199 # report message only if not silent 3200 if {[isVerbosityLevel concise]} { 3201 eval report $reportArgs 3202 } 3203 # pass to real puts command if not related to stdout and do that in modfile 3204 # interpreter context to get access to eventual specific channel 3205 } else { 3206 # re-throw error as a known error for accurate stack trace print 3207 if {[catch {$itrp eval _puts $args} errMsg]} { 3208 knerror $errMsg MODULES_ERR_CUSTOM 3209 } 3210 } 3211} 3212 3213######################################################################## 3214# path fiddling 3215# 3216proc getReferenceCountArray {var separator} { 3217 # get reference counter set in environment 3218 set sharevar [getModshareVarName $var] 3219 array set refcount {} 3220 if {[info exists ::env($sharevar)]} { 3221 set modsharelist [psplit $::env($sharevar) [getState path_separator]] 3222 # ignore environment ref count variable if malformed 3223 if {([llength $modsharelist] % 2) == 0} { 3224 array set refcount $modsharelist 3225 } else { 3226 reportDebug "Reference counter value in '$sharevar' is malformed\ 3227 ($modsharelist)" 3228 } 3229 } 3230 3231 array set countarr {} 3232 if {[info exists ::env($var)]} { 3233 # do not skip a bare empty path entry that can also be found in 3234 # reference counter array (sometimes var is cleared by setting it 3235 # empty not unsetting it, ignore var in this case) 3236 if {$::env($var) eq {} && [info exists refcount()]} { 3237 lappend eltlist {} 3238 } else { 3239 set eltlist [split $::env($var) $separator] 3240 } 3241 3242 # just go thought the elements of the variable, which means additional 3243 # elements part of the reference counter variable will be ignored 3244 foreach elt $eltlist { 3245 # no reference counter, means value has been set once 3246 if {![info exists refcount($elt)]} { 3247 set count 1 3248 # bad reference counter value is ignored 3249 } elseif {![string is digit -strict $refcount($elt)]} { 3250 reportDebug "Reference counter value for '$elt' in '$sharevar' is\ 3251 erroneous ($refcount($elt))" 3252 set count 1 3253 } else { 3254 set count $refcount($elt) 3255 } 3256 set countarr($elt) $count 3257 } 3258 } 3259 3260 set count_list [array get countarr] 3261 reportDebug "(var=$var, delim=$separator) got '$count_list'" 3262 3263 return $count_list 3264} 3265 3266 3267proc unload-path {args} { 3268 reportDebug ($args) 3269 3270 lassign [eval parsePathCommandArgs unload-path $args] separator\ 3271 allow_dup idx_val var path_list 3272 3273 array set countarr [getReferenceCountArray $var $separator] 3274 3275 # Don't worry about dealing with this variable if it is already scheduled 3276 # for deletion 3277 if {[info exists ::g_stateEnvVars($var)] && $::g_stateEnvVars($var) eq\ 3278 {del}} { 3279 return {} 3280 } 3281 3282 # save initial variable content to match index arguments 3283 set dir_list [split [get-env $var] $separator] 3284 # detect if empty env value means empty path entry 3285 if {[llength $dir_list] == 0 && [info exists countarr()]} { 3286 lappend dir_list {} 3287 } 3288 3289 # build list of index to remove from variable 3290 set del_idx_list [list] 3291 foreach dir $path_list { 3292 # retrieve dir value if working on an index list 3293 if {$idx_val} { 3294 set idx $dir 3295 # go to next index if this one is not part of the existing range 3296 # needed to distinguish an empty value to an out-of-bound value 3297 if {$idx < 0 || $idx >= [llength $dir_list]} { 3298 continue 3299 } else { 3300 set dir [lindex $dir_list $idx] 3301 } 3302 } 3303 3304 # update reference counter array 3305 if {[info exists countarr($dir)]} { 3306 incr countarr($dir) -1 3307 set newcount $countarr($dir) 3308 if {$countarr($dir) <= 0} { 3309 unset countarr($dir) 3310 } 3311 } else { 3312 set newcount 0 3313 } 3314 3315 # get all entry indexes corresponding to dir 3316 set found_idx_list [lsearch -all -exact $dir_list $dir] 3317 3318 # remove all found entries 3319 if {$newcount <= 0} { 3320 # only remove passed position in --index mode 3321 if {$idx_val} { 3322 lappend del_idx_list $idx 3323 } else { 3324 set del_idx_list [concat $del_idx_list $found_idx_list] 3325 } 3326 # if multiple entries found remove the extra entries compared to new 3327 # reference counter 3328 } elseif {[llength $found_idx_list] > $newcount} { 3329 # only remove passed position in --index mode 3330 if {$idx_val} { 3331 lappend del_idx_list $idx 3332 } else { 3333 # delete extra entries, starting from end of the list (on a path 3334 # variable, entries at the end have less priority than those at 3335 # the start) 3336 set del_idx_list [concat $del_idx_list [lrange $found_idx_list\ 3337 $newcount end]] 3338 } 3339 } 3340 } 3341 3342 # update variable if some element need to be removed 3343 if {[llength $del_idx_list] > 0} { 3344 set del_idx_list [lsort -integer -unique $del_idx_list] 3345 set newpath [list] 3346 set nbelem [llength $dir_list] 3347 # rebuild list of element without indexes set for deletion 3348 for {set i 0} {$i < $nbelem} {incr i} { 3349 if {[notInList $del_idx_list $i]} { 3350 lappend newpath [lindex $dir_list $i] 3351 } 3352 } 3353 } else { 3354 set newpath $dir_list 3355 } 3356 3357 # set env variable and corresponding reference counter in any case 3358 if {[llength $newpath] == 0} { 3359 unset-env $var 3360 } else { 3361 set-env $var [join $newpath $separator] 3362 } 3363 3364 set sharevar [getModshareVarName $var] 3365 if {[array size countarr] > 0} { 3366 set-env $sharevar [pjoin [array get countarr] [getState path_separator]] 3367 } else { 3368 unset-env $sharevar 1 3369 } 3370 return {} 3371} 3372 3373proc add-path {pos args} { 3374 reportDebug "($args) pos=$pos" 3375 3376 lassign [eval parsePathCommandArgs add-path $args] separator allow_dup\ 3377 idx_val var path_list 3378 3379 set sharevar [getModshareVarName $var] 3380 array set countarr [getReferenceCountArray $var $separator] 3381 3382 if {$pos eq {prepend}} { 3383 set path_list [lreverse $path_list] 3384 } 3385 3386 set val [get-env $var] 3387 3388 foreach dir $path_list { 3389 if {![info exists countarr($dir)] || $allow_dup} { 3390 # ignore env var set empty if no empty entry found in reference 3391 # counter array (sometimes var is cleared by setting it empty not 3392 # unsetting it) 3393 if {$val ne {} || [info exists countarr()]} { 3394 set val [expr {$pos eq {prepend} ? "$dir$separator$val" :\ 3395 "$val$separator$dir"}] 3396 } else { 3397 set val $dir 3398 } 3399 } 3400 if {[info exists countarr($dir)]} { 3401 incr countarr($dir) 3402 } else { 3403 set countarr($dir) 1 3404 } 3405 } 3406 3407 set-env $var $val 3408 set-env $sharevar [pjoin [array get countarr] [getState path_separator]] 3409 3410 return {} 3411} 3412 3413# analyze argument list passed to a path command to set default value or raise 3414# error in case some attributes are missing 3415proc parsePathCommandArgs {cmd args} { 3416 # parse argument list 3417 set next_is_delim 0 3418 set allow_dup 0 3419 set idx_val 0 3420 foreach arg $args { 3421 # everything passed after variable name is considered a value 3422 if {[info exists var]} { 3423 # set multiple passed values in a list 3424 lappend val_raw_list $arg 3425 } else { 3426 switch -glob -- $arg { 3427 --index { 3428 if {$cmd eq {add-path}} { 3429 reportWarning "--index option has no effect on $cmd" 3430 } else { 3431 set idx_val 1 3432 } 3433 } 3434 --duplicates { 3435 if {$cmd eq {unload-path}} { 3436 reportWarning "--duplicates option has no effect on $cmd" 3437 } else { 3438 set allow_dup 1 3439 } 3440 } 3441 -d - -delim - --delim { 3442 set next_is_delim 1 3443 } 3444 --delim=* { 3445 set delim [string range $arg 8 end] 3446 } 3447 -* { 3448 knerror "invalid option '$arg' for $cmd" 3449 } 3450 default { 3451 if {$next_is_delim} { 3452 set delim $arg 3453 set next_is_delim 0 3454 } else { 3455 set var $arg 3456 } 3457 } 3458 } 3459 } 3460 } 3461 3462 # adapt with default value or raise error if some arguments are missing 3463 if {![info exists delim]} { 3464 set delim [getState path_separator] 3465 } elseif {$delim eq {}} { 3466 knerror "$cmd should get a non-empty path delimiter" 3467 } 3468 if {![info exists var]} { 3469 knerror "$cmd should get an environment variable name" 3470 } elseif {$var eq {}} { 3471 knerror "$cmd should get a valid environment variable name" 3472 } 3473 if {![info exists val_raw_list]} { 3474 knerror "$cmd should get a value for environment variable $var" 3475 } 3476 3477 # set list of value to add 3478 set val_list [list] 3479 foreach val $val_raw_list { 3480 # check passed indexes are numbers 3481 if {$idx_val && ![string is integer -strict $val]} { 3482 knerror "$cmd should get valid number as index value" 3483 } 3484 3485 switch -- $val \ 3486 {} { 3487 # add empty entry in list 3488 lappend val_list {} 3489 } \ 3490 $delim { 3491 knerror "$cmd cannot handle path equals to separator string" 3492 } \ 3493 default { 3494 # split passed value with delimiter 3495 set val_list [concat $val_list [split $val $delim]] 3496 } 3497 } 3498 3499 reportDebug "(delim=$delim, allow_dup=$allow_dup, idx_val=$idx_val,\ 3500 var=$var, val=$val_list, nbval=[llength $val_list])" 3501 3502 return [list $delim $allow_dup $idx_val $var $val_list] 3503} 3504 3505proc prepend-path {args} { 3506 reportDebug $args 3507 3508 # Set the variable for later use during the modulefile evaluation 3509 eval add-path prepend $args 3510 3511 return {} 3512} 3513 3514proc append-path {args} { 3515 reportDebug $args 3516 3517 # Set the variable for later use during the modulefile evaluation 3518 eval add-path append $args 3519 3520 return {} 3521} 3522 3523proc remove-path {args} { 3524 reportDebug $args 3525 3526 # Set the variable for later use during the modulefile evaluation 3527 eval unload-path $args 3528 3529 return {} 3530} 3531 3532# undo remove-path in unload mode 3533proc remove-path-un {args} { 3534 # clear variable if it does not exist on unload mode for later use 3535 # during the modulefile evaluation 3536 lassign [eval parsePathCommandArgs unload-path $args] separator\ 3537 allow_dup idx_val var path_list 3538 if {![info exists ::env($var)]} { 3539 reset-to-unset-env $var 3540 } 3541} 3542 3543# optimized *-path for whatis mode: init env variable with an empty value if 3544# undefined. do not care about value, just avoid variable to be undefined for 3545# later use during the modulefile evaluation 3546proc edit-path-wh {args} { 3547 reportDebug $args 3548 3549 # get variable name 3550 lassign [eval parsePathCommandArgs edit-path-wh $args] separator\ 3551 allow_dup idx_val var path_list 3552 3553 if {![info exists ::env($var)]} { 3554 set ::env($var) {} 3555 } 3556 3557 return {} 3558} 3559 3560proc set-alias {alias what} { 3561 reportDebug "alias='$alias', val='$what'" 3562 3563 set ::g_Aliases($alias) $what 3564 set ::g_stateAliases($alias) new 3565 3566 return {} 3567} 3568 3569# undo set-alias in unload mode 3570proc set-alias-un {alias what} { 3571 return [unset-alias $alias] 3572} 3573 3574proc unset-alias {alias} { 3575 reportDebug alias='$alias' 3576 3577 set ::g_Aliases($alias) {} 3578 set ::g_stateAliases($alias) del 3579 3580 return {} 3581} 3582 3583proc set-function {function what} { 3584 reportDebug "function='$function', val='$what'" 3585 3586 set ::g_Functions($function) $what 3587 set ::g_stateFunctions($function) new 3588 3589 return {} 3590} 3591 3592# undo set-function in unload mode 3593proc set-function-un {function what} { 3594 return [unset-function $function] 3595} 3596 3597proc unset-function {function} { 3598 reportDebug function='$function' 3599 3600 set ::g_Functions($function) {} 3601 set ::g_stateFunctions($function) del 3602 3603 return {} 3604} 3605 3606 3607proc is-loaded {args} { 3608 reportDebug $args 3609 # parse module version specification 3610 set args [eval parseModuleVersionSpecifier 0 $args] 3611 3612 foreach mod $args { 3613 if {[getLoadedMatchingName $mod returnfirst] ne {}} { 3614 return 1 3615 } 3616 } 3617 # is something loaded whatever it is? 3618 return [expr {[llength $args] == 0 && [llength [getLoadedModuleList]] > 0}] 3619} 3620 3621proc is-loading {args} { 3622 reportDebug $args 3623 3624 foreach mod $args { 3625 if {[getLoadedMatchingName $mod returnfirst 1] ne {}} { 3626 return 1 3627 } 3628 } 3629 # is something else loading whatever it is? 3630 return [expr {[llength $args] == 0 && [llength [getLoadingModuleList]] >1}] 3631} 3632 3633proc conflict {args} { 3634 reportDebug $args 3635 set currentModule [currentModuleName] 3636 # get module short name if loaded by its full pathname 3637 if {[set isfullpath [isModuleFullPath $currentModule]]} { 3638 set currentSModule [findModuleNameFromModulefile $currentModule] 3639 } 3640 defineModEqProc [isIcase] [getConf extended_default] 3641 3642 # parse module version specification 3643 set args [eval parseModuleVersionSpecifier 0 $args] 3644 3645 # register conflict list 3646 eval setLoadedConflict "{$currentModule}" $args 3647 3648 foreach mod $args { 3649 # if the conflict module is loading and it does not correspond to 3650 # currently evaluated module, we cannot proceed 3651 set isloading [expr {![doesModuleMatchesName $currentModule $mod] &&\ 3652 (!$isfullpath || ![doesModuleMatchesName $currentSModule $mod]) &&\ 3653 [is-loading $mod]}] 3654 # if the conflicting module is loaded, we cannot either 3655 if {[is-loaded $mod] || $isloading} { 3656 set retisconun [isModuleEvaluated conun $currentModule $mod] 3657 # report message on currently evaluated module message block 3658 if {![set retiseval [isModuleEvaluated any $currentModule $mod]] ||\ 3659 [currentMsgRecordId] ne [topMsgRecordId] || !$retisconun} { 3660 # more appropriate msg if an eval was attempted or is by-passed 3661 set msg [expr {$retiseval || [getState force] ?\ 3662 [getConIsLoadedMsg [list $mod] $isloading] :\ 3663 [getErrConflictMsg $currentModule $mod]}] 3664 3665 # still proceed if force mode enabled 3666 if {[getState force]} { 3667 reportWarning $msg 3668 # indicate message has already been reported 3669 lappend ::report_conflict($currentModule) $mod 3670 } else { 3671 knerror $msg MODULES_ERR_GLOBAL 3672 } 3673 } 3674 } 3675 } 3676 3677 return {} 3678} 3679 3680proc prereq {args} { 3681 reportDebug $args 3682 set currentModule [currentModuleName] 3683 3684 # parse module version specification 3685 set args [eval parseModuleVersionSpecifier 0 $args] 3686 3687 # register prereq list (sets of optional prereq are registered as list) 3688 setLoadedPrereq $currentModule $args 3689 3690 # if dependency resolving is enabled try to load prereq 3691 if {[getConf auto_handling] && ![eval is-loaded $args] && ![eval\ 3692 is-loading $args]} { 3693 set imax [llength $args] 3694 set prereqloaded 0 3695 # if prereq list specified, try to load first then 3696 # try next if load of first module not successful 3697 for {set i 0} {$i<$imax && $prereqloaded==0} {incr i 1} { 3698 set arg [lindex $args $i] 3699 3700 # hold output of each evaluation until they are all done to drop 3701 # those that failed if one succeed 3702 set curholdid load-$i-$arg 3703 pushReportHoldId $curholdid 3704 if {[catch {cmdModuleLoad reqlo 0 $arg} errorMsg]} { 3705 # if an error is raised, release output and rethrow the error 3706 # (could be raised if no modulepath defined for instance) 3707 popReportHoldId 3708 lappend holdidlist $curholdid report 3709 eval releaseHeldReport $holdidlist 3710 knerror $errorMsg 3711 } 3712 popReportHoldId 3713 3714 if {[is-loaded $arg]} { 3715 set prereqloaded 1 3716 # set previous reports to be dropped as this one succeed 3717 if {[info exists holdidlist]} { 3718 foreach {holdid action} $holdidlist { 3719 lappend newholdidlist $holdid drop 3720 } 3721 set holdidlist $newholdidlist 3722 } 3723 } 3724 lappend holdidlist $curholdid report 3725 } 3726 # output held messages 3727 eval releaseHeldReport $holdidlist 3728 } 3729 3730 if {![eval is-loaded $args] && ![eval is-loading $args]} { 3731 set retisreqlo [eval isModuleEvaluated reqlo "{$currentModule}" $args] 3732 # report message on currently evaluated module message block 3733 if {![set retiseval [eval isModuleEvaluated any "{$currentModule}"\ 3734 $args]] || [currentMsgRecordId] ne [topMsgRecordId] ||\ 3735 !$retisreqlo} { 3736 3737 # more appropriate msg if an evaluation was attempted or is by-passed 3738 set msg [expr {$retiseval || [getState force] ? [getReqNotLoadedMsg\ 3739 $args] : [getErrPrereqMsg $currentModule $args]}] 3740 # still proceed if force mode enabled 3741 if {[getState force]} { 3742 reportWarning $msg 3743 # no error raise if done later 3744 } elseif {$retisreqlo} { 3745 reportError $msg 3746 } else { 3747 knerror $msg MODULES_ERR_GLOBAL 3748 } 3749 } 3750 3751 # raise reqlo-specific msg to top level if attempted 3752 if {$retisreqlo} { 3753 set msg [getErrReqLoMsg $args] 3754 if {[getState force]} { 3755 reportWarning $msg 1 3756 } else { 3757 knerror $msg MODULES_ERR_GLOBALTOP 3758 } 3759 } 3760 } 3761 3762 return {} 3763} 3764 3765proc x-resource {resource {value {}}} { 3766 reportDebug "($resource, $value)" 3767 3768 # sometimes x-resource value may be provided within resource name 3769 # as the "x-resource {Ileaf.popup.saveUnder: True}" example provided 3770 # in manpage. so here is an attempt to extract real resource name and 3771 # value from resource argument 3772 if {[string length $value] == 0 && ![file exists $resource]} { 3773 # look first for a space character as delimiter, then for a colon 3774 set sepapos [string first { } $resource] 3775 if { $sepapos == -1 } { 3776 set sepapos [string first : $resource] 3777 } 3778 3779 if { $sepapos > -1 } { 3780 set value [string range $resource [expr {$sepapos + 1}] end] 3781 set resource [string range $resource 0 [expr {$sepapos - 1}]] 3782 reportDebug "corrected ($resource, $value)" 3783 } else { 3784 # if not a file and no value provided x-resource cannot be 3785 # recorded as it will produce an error when passed to xrdb 3786 reportWarning "x-resource $resource is not a valid string or file" 3787 return {} 3788 } 3789 } 3790 3791 # check current environment can handle X11 resource edition elsewhere exit 3792 if {[catch {runCommand xrdb -query} errMsg]} { 3793 knerror "X11 resources cannot be edited, issue spotted\n[sgr er\ 3794 ERROR]: $errMsg" MODULES_ERR_GLOBAL 3795 } 3796 3797 # if a resource does hold an empty value in g_newXResources or 3798 # g_delXResources arrays, it means this is a resource file to parse 3799 if {[currentMode] eq {load}} { 3800 set ::g_newXResources($resource) $value 3801 } else { 3802 set ::g_delXResources($resource) $value 3803 } 3804 3805 return {} 3806} 3807 3808proc uname {what} { 3809 reportDebug $what 3810 3811 return [switch -- $what { 3812 sysname {getState os} 3813 machine {getState machine} 3814 nodename - node {getState nodename} 3815 release {getState osversion} 3816 domain {getState domainname} 3817 version {getState kernelversion} 3818 default {knerror "uname $what not supported"} 3819 }] 3820} 3821 3822# run shell command 3823proc system {args} { 3824 reportDebug $args 3825 3826 set mode [currentMode] 3827 set status {} 3828 3829 switch -- $mode { 3830 load - unload { 3831 # run through the appropriate shell 3832 if {[getState is_win]} { 3833 set shell cmd.exe 3834 set shellarg /c 3835 } else { 3836 set shell /bin/sh 3837 set shellarg -c 3838 } 3839 3840 if {[catch {exec >&@stderr $shell $shellarg [join $args]}]} { 3841 # non-zero exit status, get it: 3842 set status [lindex $::errorCode 2] 3843 } else { 3844 # exit status was 0 3845 set status 0 3846 } 3847 } 3848 } 3849 3850 return $status 3851} 3852 3853# test at least one of the collections passed as argument exists 3854proc is-saved {args} { 3855 reportDebug $args 3856 3857 foreach coll $args { 3858 lassign [getCollectionFilename $coll] collfile colldesc 3859 if {[file exists $collfile]} { 3860 return 1 3861 } 3862 } 3863 # is something saved whatever it is? 3864 return [expr {[llength $args] == 0 && [llength [findCollections]] > 0}] 3865} 3866 3867# test at least one of the directories passed as argument is set in MODULEPATH 3868proc is-used {args} { 3869 reportDebug $args 3870 3871 set modpathlist [getModulePathList] 3872 foreach path $args { 3873 # transform given path in an absolute path to compare with dirs 3874 # registered in the MODULEPATH env var which are returned absolute. 3875 set abspath [getAbsolutePath $path] 3876 if {[isInList $modpathlist $abspath]} { 3877 return 1 3878 } 3879 } 3880 # is something used whatever it is? 3881 return [expr {[llength $args] == 0 && [llength $modpathlist] > 0}] 3882} 3883 3884# test at least one of the modulefiles passed as argument exists 3885proc is-avail {args} { 3886 reportDebug $args 3887 # parse module version specification 3888 set args [eval parseModuleVersionSpecifier 0 $args] 3889 set ret 0 3890 3891 # disable error reporting to avoid modulefile errors 3892 # to pollute result. Only if not already inhibited 3893 set alreadyinhibit [getState inhibit_errreport] 3894 if {!$alreadyinhibit} { 3895 inhibitErrorReport 3896 } 3897 3898 foreach mod $args { 3899 lassign [getPathToModule $mod] modfile modname 3900 if {$modfile ne {}} { 3901 set ret 1 3902 break 3903 } 3904 } 3905 3906 # re-enable only is it was disabled from this procedure 3907 if {!$alreadyinhibit} { 3908 setState inhibit_errreport 0 3909 } 3910 return $ret 3911} 3912 3913proc execShAndGetEnv {shell script args} { 3914 set sep {%ModulesShToMod%} 3915 set shdesc [concat [list $script] $args] 3916 set sherr 0 3917 set shellopts [list] 3918 3919 upvar ignvarlist ignvarlist 3920 set ignvarlist [list OLDPWD PWD _ _AST_FEATURES PS1] 3921 3922 # define shell command to run to source script and analyze the environment 3923 # changes it performs 3924 switch -- [file tail $shell] { 3925 dash - sh { 3926 # declare is not supported by dash but functions cannot be retrieved 3927 # anyway, so keep using declare and throw errors out to avoid overall 3928 # execution error. dash does not pass arguments to sourced script but 3929 # it does not raise error if arguments are set 3930 set command "export -p; echo $sep; declare -f 2>/dev/null; echo\ 3931 $sep; alias; echo $sep; pwd; echo $sep; . [listTo shell $shdesc]\ 3932 2>&1; echo $sep; export -p; echo $sep; declare -f 2>/dev/null;\ 3933 echo $sep; alias; echo $sep; pwd" 3934 set varre {export (\S+?)=["']?(.*?)["']?$} 3935 set funcre {(\S+?) \(\)\s?\n?{\s?\n(.+?)\n}$} 3936 set aliasre {(\S+?)='(.*?)'$} 3937 set varvalmap [list {\"} {"} \\\\ \\] 3938 set alvalmap [list {'\''} ' {'"'"'} '] 3939 } 3940 bash { 3941 set command "export -p; echo $sep; declare -f; echo $sep; alias;\ 3942 echo $sep; pwd; echo $sep; . [listTo shell $shdesc] 2>&1; echo\ 3943 $sep; export -p; echo $sep; declare -f; echo $sep; alias; echo\ 3944 $sep; pwd" 3945 set varre {declare -x (\S+?)="(.*?)"$} 3946 set funcre {(\S+?) \(\)\s?\n{\s?\n(.+?)\n}$} 3947 set aliasre {alias (\S+?)='(.*?)'$} 3948 set varvalmap [list {\"} {"} \\\\ \\] 3949 set alvalmap [list {'\''} '] 3950 lappend shellopts --noprofile --norc 3951 } 3952 ksh - ksh93 { 3953 set command "typeset -x; echo $sep; typeset +f | while read f; do\ 3954 typeset -f \${f%\\(\\)}; echo; done; echo $sep; alias; echo $sep;\ 3955 pwd; echo $sep; . [listTo shell $shdesc] 2>&1; echo $sep; typeset\ 3956 -x; echo $sep; typeset +f | while read f; do typeset -f\ 3957 \${f%\\(\\)}; echo; done; echo $sep; alias; echo $sep; pwd" 3958 set varre {(\S+?)=\$?'?(.*?)'?$} 3959 set funcre {(\S+?)\(\) {\n?(.+?)}[;\n]?$} 3960 set aliasre {(\S+?)=\$?'?(.*?)'?$} 3961 set varvalmap [list {\'} '] 3962 set alvalmap [list {\"} {"} {\\'} ' {\'} ' {\\\\} {\\}] 3963 } 3964 zsh { 3965 set command "typeset -x; echo $sep; declare -f; echo $sep; alias;\ 3966 echo $sep; pwd; echo $sep; . [listTo shell $shdesc] 2>&1; echo\ 3967 $sep; typeset -x; echo $sep; declare -f; echo $sep; alias; echo\ 3968 $sep; pwd" 3969 set varre {(\S+?)=\$?'?(.*?)'?$} 3970 set funcre {(\S+?) \(\) {\n(.+?)\n}$} 3971 set aliasre {(\S+?)=\$?'?(.*?)'?$} 3972 set varvalmap [list {'\''} '] 3973 set alvalmap [list {'\''} '] 3974 } 3975 csh - tcsh { 3976 set command "setenv; echo $sep; echo $sep; alias; echo $sep; pwd;\ 3977 echo $sep; source [listTo shell $shdesc] >& /dev/stdout; echo\ 3978 $sep; setenv; echo $sep; echo $sep; alias; echo $sep; pwd" 3979 set varre {(\S+?)=(.*?)$} 3980 set aliasre {(\S+?)\t(.*?)$} 3981 set varvalmap [list] 3982 set alvalmap [list] 3983 lappend shellopts -f 3984 } 3985 fish { 3986 # exclude builtins and fish-specific functions from search to reduce 3987 # the number of functions to parse 3988 set getfunc {set funcout (string match -r -v $funcfilter (functions\ 3989 -n) | while read f; functions $f; end);} 3990 set command "set -xgL; echo '$sep'; set funcfilter (string join '|'\ 3991 (string replace \\\[ \\\\\\\[ (builtin -n)))\\|fish\\.\\*;\ 3992 $getfunc; string split \$funcout; echo '$sep'; string split\ 3993 \$funcout; echo '$sep'; pwd; echo '$sep'; source [listTo shell\ 3994 $shdesc] 2>&1; or exit \$status; echo '$sep'; set -xgL; echo\ 3995 '$sep'; $getfunc; string split \$funcout; echo '$sep'; string\ 3996 split \$funcout; echo '$sep'; pwd" 3997 set varre {^(\S+?\M) ?'?(.*?)'?$} 3998 # exclude alias from function list 3999 set funcre {^function (\S+?)(?: [^\n]*?--description\ 4000 (?!'?alias)[^\n]+)?\n(.+?)\nend$} 4001 # fetch aliases from available functions 4002 set aliasre {^function (\S+?) [^\n]*?--description\ 4003 '?alias[^\n]+\n\s*(.+?)\nend$} 4004 # translate back fish-specific code 4005 set varvalmap [list {' '} : {\'} ' {\"} \" \\\\ \\] 4006 set alvalmap [list { $argv;} {}] 4007 4008 # fish builtins change LS_COLORS variable 4009 lappend ignvarlist LS_COLORS 4010 } 4011 default { 4012 knerror "Shell '$shell' not supported" 4013 } 4014 } 4015 4016 if {![file exists $script]} { 4017 knerror "Script '$script' cannot be found" 4018 } 4019 4020 set shellpath [getCommandPath $shell] 4021 if {$shellpath eq {}} { 4022 knerror "Shell '$shell' cannot be found" 4023 } 4024 set shellexec [concat [list $shellpath] $shellopts [list -c $command]] 4025 4026 reportDebug "running '$shellexec'" 4027 if {[catch {set output [eval exec $shellexec]} output]} { 4028 set sherr 1 4029 } 4030 4031 # link result variables to calling context 4032 upvar cwdbefout cwdbefout cwdaftout cwdaftout 4033 4034 # extract each output sections 4035 set idx 0 4036 foreach varout {varbefout funcbefout aliasbefout cwdbefout scriptout\ 4037 varaftout funcaftout aliasaftout cwdaftout} { 4038 if {[set sepidx [string first $sep $output $idx]] == -1} { 4039 set $varout [string trimright [string range $output $idx end] \n] 4040 if {$varout ne {cwdaftout} && !$sherr} { 4041 knerror "Unexpected output when sourcing '$shdesc' in shell\ 4042 '$shell'" 4043 } 4044 } else { 4045 set $varout [string trimright [string range $output $idx [expr\ 4046 {$sepidx - 1}]] \n] 4047 set idx [expr {$sepidx + [string length $sep] + 1}] 4048 } 4049 # remove expected Tcl error message 4050 if {$sherr && $varout eq {scriptout} && [set erridx [string\ 4051 last {child process exited abnormally} [set $varout]]] != -1} { 4052 set $varout [string range [set $varout] 0 [expr {$erridx - 2}]] 4053 } 4054 } 4055 if {$sepidx != -1 && !$sherr} { 4056 knerror "Unexpected output when sourcing '$shdesc' in shell '$shell'" 4057 } 4058 4059 reportDebug "script output is '$scriptout'" 4060 if {$sherr} { 4061 # throw error if script had an issue, send script output along if any 4062 set errmsg "Script '$script' exited abnormally" 4063 if {$scriptout ne {}} { 4064 append errmsg "\n with following output\n$scriptout" 4065 } 4066 knerror $errmsg 4067 } 4068 4069 # link result variables to calling context 4070 upvar varbef varbef varaft varaft 4071 upvar funcbef funcbef funcaft funcaft 4072 upvar aliasbef aliasbef aliasaft aliasaft 4073 4074 # extract environment variable information 4075 foreach {out arr} [list varbefout varbef varaftout varaft] { 4076 foreach {match name value} [regexp -all -inline -lineanchor $varre [set\ 4077 $out]] { 4078 # convert shell-specific escaping 4079 set ${arr}($name) [string map $varvalmap $value] 4080 } 4081 } 4082 # extract function information if function supported by shell 4083 if {[info exists funcre]} { 4084 foreach {out arr} [list funcbefout funcbef funcaftout funcaft] { 4085 foreach {match name value} [regexp -all -inline -lineanchor $funcre\ 4086 [set $out]] { 4087 # no specific escaping to convert for functions 4088 set ${arr}($name) $value 4089 } 4090 } 4091 } 4092 # extract alias information 4093 foreach {out arr} [list aliasbefout aliasbef aliasaftout aliasaft] { 4094 foreach {match name value} [regexp -all -inline -lineanchor $aliasre\ 4095 [set $out]] { 4096 set ${arr}($name) [string map $alvalmap $value] 4097 } 4098 } 4099} 4100 4101# execute script with args through shell and convert environment changes into 4102# corresponding modulefile commands 4103proc sh-to-mod {args} { 4104 set modcontent [list] 4105 set pathsep [getState path_separator] 4106 4107 # evaluate script and retrieve environment before and after evaluation 4108 # procedure will set result variables in current context 4109 eval execShAndGetEnv $args 4110 4111 # check environment variable change 4112 lassign [getDiffBetweenArray varbef varaft] notaft diff notbef 4113 foreach name $notaft { 4114 if {[notInList $ignvarlist $name]} { 4115 lappend modcontent [list unsetenv $name] 4116 } 4117 } 4118 foreach name $diff { 4119 if {[notInList $ignvarlist $name]} { 4120 # new value is totally different (also consider a bare ':' as a 4121 # totally different value to avoid erroneous matches) 4122 if {$varbef($name) eq $pathsep || [set idx [string first\ 4123 $varbef($name) $varaft($name)]] == -1} { 4124 lappend modcontent [list setenv $name $varaft($name)] 4125 } else { 4126 # content should be prepended 4127 if {$idx > 0} { 4128 set modcmd [list prepend-path] 4129 # check from the end to get the largest chunk to prepend 4130 set idx [string last $varbef($name) $varaft($name)] 4131 # get delimiter from char found between new and existing value 4132 set delim [string index $varaft($name) [expr {$idx - 1}]] 4133 if {$delim ne $pathsep} { 4134 lappend modcmd -d $delim 4135 } 4136 lappend modcmd $name 4137 # split value and remove duplicate entries 4138 set vallist [list] 4139 eval appendNoDupToList vallist [split [string range\ 4140 $varaft($name) 0 [expr {$idx - 2}]] $delim] 4141 # an empty element is added 4142 if {[llength $vallist] == 0} { 4143 lappend vallist {} 4144 } 4145 lappend modcontent [concat $modcmd $vallist] 4146 } 4147 # content should be appended 4148 if {($idx + [string length $varbef($name)]) < [string length\ 4149 $varaft($name)]} { 4150 set modcmd [list append-path] 4151 set delim [string index $varaft($name) [expr {$idx + [string\ 4152 length $varbef($name)]}]] 4153 if {$delim ne $pathsep} { 4154 lappend modcmd -d $delim 4155 } 4156 lappend modcmd $name 4157 set vallist [list] 4158 eval appendNoDupToList vallist [split [string range\ 4159 $varaft($name) [expr {$idx + [string length $varbef($name)]\ 4160 + 1}] end] $delim] 4161 if {[llength $vallist] == 0} { 4162 lappend vallist {} 4163 } 4164 lappend modcontent [concat $modcmd $vallist] 4165 } 4166 } 4167 } 4168 } 4169 foreach name $notbef { 4170 if {[notInList $ignvarlist $name]} { 4171 if {[string first $pathsep $varaft($name)] == -1} { 4172 lappend modcontent [list setenv $name $varaft($name)] 4173 } else { 4174 # define a path-like variable if path separator found in it 4175 # split value and remove duplicate entries 4176 set vallist [list] 4177 eval appendNoDupToList vallist [split $varaft($name) $pathsep] 4178 lappend modcontent [concat [list prepend-path $name] $vallist] 4179 } 4180 } 4181 } 4182 # check function change 4183 lassign [getDiffBetweenArray funcbef funcaft] notaft diff notbef 4184 foreach name $notaft { 4185 lappend modcontent [list unset-function $name] 4186 } 4187 foreach name [concat $diff $notbef] { 4188 lappend modcontent [list set-function $name \n$funcaft($name)] 4189 } 4190 # check alias change 4191 lassign [getDiffBetweenArray aliasbef aliasaft] notaft diff notbef 4192 foreach name $notaft { 4193 lappend modcontent [list unset-alias $name] 4194 } 4195 foreach name [concat $diff $notbef] { 4196 lappend modcontent [list set-alias $name $aliasaft($name)] 4197 } 4198 # check current working directory change 4199 if {$cwdbefout ne $cwdaftout} { 4200 lappend modcontent [list chdir $cwdaftout] 4201 } 4202 4203 # sort result to ensure consistent output whatever the evaluation shell 4204 set modcontent [lsort -dictionary $modcontent] 4205 4206 reportDebug "resulting env changes '$modcontent'" 4207 return $modcontent 4208} 4209 4210proc source-sh {shell script args} { 4211 # evaluate script and get the environment changes it performs translated 4212 # into modulefile commands 4213 set shtomodargs [concat [list $shell $script] $args] 4214 set modcontent [eval sh-to-mod $shtomodargs] 4215 4216 # register resulting modulefile commands 4217 setLoadedSourceSh [currentModuleName] [concat [list $shtomodargs]\ 4218 $modcontent] 4219 4220 # evaluate resulting modulefile commands 4221 foreach modcmd $modcontent { 4222 eval $modcmd 4223 } 4224} 4225 4226# undo source-sh in unload mode 4227proc source-sh-un {shell script args} { 4228 set shtomodargs [concat [list $shell $script] $args] 4229 set modsrcsh [getLoadedSourceSh [currentModuleName]] 4230 4231 # find commands resulting from source-sh evaluation recorded in env 4232 if {[set idx [lsearch -exact $modsrcsh $shtomodargs]] != -1 } { 4233 set modcontent [lindex $modsrcsh [expr {$idx + 1}]] 4234 } else { 4235 set modcontent {} 4236 } 4237 4238 # get name of current module unload Tcl interp 4239 set itrp __modfile_[currentMode]_[getEvalModuleStackDepth] 4240 4241 # evaluate each recorded command in unload Tcl interp to get them reversed 4242 foreach modcmd $modcontent { 4243 interp eval $itrp $modcmd 4244 } 4245} 4246 4247# report underlying modulefile cmds in display mode 4248proc source-sh-di {shell script args} { 4249 set shtomodargs [concat [list $shell $script] $args] 4250 4251 # if module loaded, get as much content from environment as possible 4252 if {[is-loaded [currentModuleName]]} { 4253 set modsrcsh [getLoadedSourceSh [currentModuleName]] 4254 4255 # find commands resulting from source-sh evaluation recorded in env 4256 if {[set idx [lsearch -exact $modsrcsh $shtomodargs]] != -1 } { 4257 set reccontent [lindex $modsrcsh [expr {$idx + 1}]] 4258 } else { 4259 set reccontent {} 4260 } 4261 4262 # need to evaluate script to get alias and function definition 4263 eval execShAndGetEnv $shtomodargs 4264 4265 set modcontent {} 4266 foreach cmd $reccontent { 4267 # build modulefile content to show with recorded elements in env 4268 # and alias/function definition obtained by reevaluating script 4269 switch -- [lindex $cmd 0] { 4270 set-alias { 4271 set alname [lindex $cmd 1] 4272 if {[info exists aliasaft($alname)]} { 4273 set albody $aliasaft($alname) 4274 } else { 4275 set albody {} 4276 } 4277 lappend modcontent [list set-alias $alname $albody] 4278 } 4279 set-function { 4280 set fnname [lindex $cmd 1] 4281 if {[info exists funcaft($fnname)]} { 4282 set fnbody \n$funcaft($fnname) 4283 } else { 4284 set fnbody {} 4285 } 4286 lappend modcontent [list set-function $fnname $fnbody] 4287 } 4288 default { 4289 lappend modcontent $cmd 4290 } 4291 } 4292 } 4293 # not loaded, so get full content from script evaluation 4294 } else { 4295 set modcontent [eval sh-to-mod $shtomodargs] 4296 } 4297 4298 # get name of current module unload Tcl interp 4299 set itrp __modfile_[currentMode]_[getEvalModuleStackDepth] 4300 4301 # evaluate each recorded command in display Tcl interp to get them printed 4302 foreach modcmd $modcontent { 4303 interp eval $itrp $modcmd 4304 } 4305} 4306 4307######################################################################## 4308# internal module procedures 4309# 4310set g_modeStack {} 4311 4312proc currentMode {} { 4313 return [lindex $::g_modeStack end] 4314} 4315 4316proc pushMode {mode} { 4317 lappend ::g_modeStack $mode 4318} 4319 4320proc popMode {} { 4321 set ::g_modeStack [lrange $::g_modeStack 0 end-1] 4322} 4323 4324set g_moduleNameStack {} 4325 4326proc currentModuleName {} { 4327 return [lindex $::g_moduleNameStack end] 4328} 4329 4330proc pushModuleName {moduleName} { 4331 lappend ::g_moduleNameStack $moduleName 4332} 4333 4334proc popModuleName {} { 4335 set ::g_moduleNameStack [lrange $::g_moduleNameStack 0 end-1] 4336} 4337 4338# get number of either modulefile/modulerc currently being evaluated 4339proc getEvalModuleStackDepth {} { 4340 return [llength $::g_moduleNameStack] 4341} 4342 4343set g_moduleFileStack {} 4344 4345proc pushModuleFile {modfile} { 4346 lappend ::g_moduleFileStack $modfile 4347 set ::ModulesCurrentModulefile $modfile 4348} 4349 4350proc popModuleFile {} { 4351 set ::g_moduleFileStack [lrange $::g_moduleFileStack 0 end-1] 4352 set ::ModulesCurrentModulefile [lindex $::g_moduleFileStack end] 4353} 4354 4355set g_specifiedNameStack {} 4356 4357proc currentSpecifiedName {} { 4358 return [lindex $::g_specifiedNameStack end] 4359} 4360 4361proc pushSpecifiedName {specifiedName} { 4362 lappend ::g_specifiedNameStack $specifiedName 4363} 4364 4365proc popSpecifiedName {} { 4366 set ::g_specifiedNameStack [lrange $::g_specifiedNameStack 0 end-1] 4367} 4368 4369set g_commandNameStack {} 4370 4371proc currentCommandName {} { 4372 return [lindex $::g_commandNameStack end] 4373} 4374 4375proc aboveCommandName {} { 4376 return [lindex $::g_commandNameStack end-1] 4377} 4378 4379proc pushCommandName {commandName} { 4380 lappend ::g_commandNameStack $commandName 4381} 4382 4383proc popCommandName {} { 4384 set ::g_commandNameStack [lrange $::g_commandNameStack 0 end-1] 4385} 4386 4387proc ongoingCommandName {commandName} { 4388 return [expr {[lsearch -exact $::g_commandNameStack $commandName] != -1}] 4389} 4390 4391# stack of report holder unique identifiers 4392set g_reportHoldIdStack {} 4393 4394proc isReportHeld {} { 4395 return [expr {[llength $::g_reportHoldIdStack] > 0}] 4396} 4397 4398proc currentReportHoldId {} { 4399 return [lindex $::g_reportHoldIdStack end] 4400} 4401 4402proc pushReportHoldId {holdid} { 4403 lappend ::g_reportHoldIdStack $holdid 4404} 4405 4406proc popReportHoldId {} { 4407 set ::g_reportHoldIdStack [lrange $::g_reportHoldIdStack 0 end-1] 4408} 4409 4410 4411# stack of message recording/eval unique identifiers 4412set g_evalIdStack {} 4413set g_msgRecordIdStack {} 4414 4415proc currentMsgRecordId {} { 4416 return [lindex $::g_msgRecordIdStack end] 4417} 4418 4419proc currentEvalId {} { 4420 return [lindex $::g_evalIdStack end] 4421} 4422 4423proc topMsgRecordId {} { 4424 return [lindex $::g_msgRecordIdStack 0] 4425} 4426 4427proc topEvalId {} { 4428 return [lindex $::g_evalIdStack 0] 4429} 4430 4431proc pushMsgRecordId {recid {setmsgid 1}} { 4432 lappend ::g_evalIdStack $recid 4433 if {$setmsgid} { 4434 lappend ::g_msgRecordIdStack $recid 4435 } 4436} 4437 4438proc popMsgRecordId {{setmsgid 1}} { 4439 set ::g_evalIdStack [lrange $::g_evalIdStack 0 end-1] 4440 if {$setmsgid} { 4441 set ::g_msgRecordIdStack [lrange $::g_msgRecordIdStack 0 end-1] 4442 } 4443} 4444 4445proc clearAllMsgRecordId {} { 4446 set ::g_evalIdStack {} 4447 set ::g_msgRecordIdStack {} 4448} 4449 4450# stack of prefixes clarifying debug message entries 4451set g_debugMsgPrefixStack {} 4452 4453proc currentDebugMsgPrefix {} { 4454 return [lindex $::g_debugMsgPrefixStack end] 4455} 4456 4457proc pushDebugMsgPrefix {args} { 4458 lappend ::g_debugMsgPrefixStack "\[#[join $args :]\] " 4459} 4460 4461proc popDebugMsgPrefix {} { 4462 set ::g_debugMsgPrefixStack [lrange $::g_debugMsgPrefixStack 0 end-1] 4463} 4464 4465# gather for the current top evaluation the information on all evaluations 4466# happening under its umbrella 4467proc registerModuleEval {context mod {unset 0} {failedcontext {}}} { 4468 set evalid [topEvalId] 4469 set contextset 0 4470 4471 # add mod to existing evaluation context list 4472 if {[info exists ::g_moduleEval($evalid)]} { 4473 for {set i 0} {$i < [llength $::g_moduleEval($evalid)]} {incr i 1} { 4474 set contextevallist [lindex $::g_moduleEval($evalid) $i] 4475 if {[lindex $contextevallist 0] eq $context} { 4476 if {$unset} { 4477 set contextevallist [replaceFromList $contextevallist $mod] 4478 } else { 4479 lappend contextevallist $mod 4480 } 4481 set ::g_moduleEval($evalid) [expr {[llength $contextevallist] > 1\ 4482 ? [lreplace $::g_moduleEval($evalid) $i $i $contextevallist]\ 4483 : [lreplace $::g_moduleEval($evalid) $i $i]}] 4484 set contextset 1 4485 break 4486 } 4487 } 4488 } 4489 4490 # add mod to new evaluation context list 4491 if {!$unset && !$contextset} { 4492 lappend ::g_moduleEval($evalid) [list $context $mod] 4493 } 4494 4495 # add mod to failed evaluation list 4496 if {$unset} { 4497 lappend ::g_moduleFailedEval($evalid) $failedcontext $mod 4498 } 4499} 4500 4501# get context of currently evaluated module 4502proc currentModuleEvalContext {} { 4503 return [lindex $::g_moduleEvalAttempt([currentModuleName]) end] 4504} 4505 4506# record module evaluation attempt and corresponding context 4507proc registerModuleEvalAttempt {context mod} { 4508 appendNoDupToList ::g_moduleEvalAttempt($mod) $context 4509} 4510 4511proc unregisterModuleEvalAttempt {context mod} { 4512 set ::g_moduleEvalAttempt($mod) [replaceFromList\ 4513 $::g_moduleEvalAttempt($mod) $context] 4514} 4515 4516# is at least one module passed as argument evaluated in passed context 4517proc isModuleEvaluated {context exclmod args} { 4518 set ret 0 4519 set icase [isIcase] 4520 # look at all evaluated mod except excluded one (currently evaluated mod) 4521 foreach evalmod [lsearch -all -inline -not [array names\ 4522 ::g_moduleEvalAttempt] $exclmod] { 4523 set evalmatch 0 4524 # test arguments against all names of evaluated module (translate 4525 # eventual modspec in evalmod into module names, in case module 4526 # evaluation stopped prior module name setup) 4527 foreach mod [concat [getAllModulesFromVersSpec $evalmod]\ 4528 [getAllModuleResolvedName $evalmod]] { 4529 foreach name $args { 4530 if {[modEq $name $mod eqstart]} { 4531 set evalmatch 1 4532 if {$context eq {any} || [isInList\ 4533 $::g_moduleEvalAttempt($evalmod) $context]} { 4534 set ret 1 4535 } 4536 break 4537 } 4538 } 4539 if {$evalmatch} { 4540 break 4541 } 4542 } 4543 if {$ret} { 4544 break 4545 } 4546 } 4547 return $ret 4548} 4549 4550# was passed mod already evaluated for context and failed 4551proc isModuleEvalFailed {context mod} { 4552 set ret 0 4553 set evalid [topEvalId] 4554 if {[info exists ::g_moduleFailedEval($evalid)]} { 4555 foreach {curcon curmod} $::g_moduleFailedEval($evalid) { 4556 if {$context eq $curcon && $mod eq $curmod} { 4557 set ret 1 4558 break 4559 } 4560 } 4561 } 4562 return $ret 4563} 4564 4565# stack of flag defining whether a modfile should be always fully read or not 4566# even for validity check, which is useful in case a file need to be read 4567# multiple times as a full read will make file content cached thus file will 4568# be read only once 4569set g_alwaysReadFullFileStack {} 4570 4571proc currentAlwaysReadFullFile {} { 4572 return [lindex $::g_alwaysReadFullFileStack end] 4573} 4574 4575proc pushAlwaysReadFullFile {alwaysReadFullFile} { 4576 lappend ::g_alwaysReadFullFileStack $alwaysReadFullFile 4577} 4578 4579proc popAlwaysReadFullFile {} { 4580 set ::g_alwaysReadFullFileStack [lrange $::g_alwaysReadFullFileStack 0\ 4581 end-1] 4582} 4583 4584# return list of currently loading modules in stack 4585proc getLoadingModuleList {} { 4586 set modlist [list] 4587 for {set i 0} {$i < [llength $::g_moduleNameStack]} {incr i 1} { 4588 if {[lindex $::g_modeStack $i] eq {load}} { 4589 lappend modlist [lindex $::g_moduleNameStack $i] 4590 } 4591 } 4592 return $modlist 4593} 4594 4595# return list of currently loading modulefiles in stack 4596proc getLoadingModuleFileList {} { 4597 set modlist [list] 4598 for {set i 0} {$i < [llength $::g_moduleFileStack]} {incr i 1} { 4599 if {[lindex $::g_modeStack $i] eq {load}} { 4600 lappend modlist [lindex $::g_moduleFileStack $i] 4601 } 4602 } 4603 return $modlist 4604} 4605 4606# return list of currently unloading modules in stack 4607proc getUnloadingModuleList {} { 4608 set modlist [list] 4609 for {set i 0} {$i < [llength $::g_moduleNameStack]} {incr i 1} { 4610 if {[lindex $::g_modeStack $i] eq {unload}} { 4611 lappend modlist [lindex $::g_moduleNameStack $i] 4612 } 4613 } 4614 return $modlist 4615} 4616# return list of loaded modules by parsing LOADEDMODULES env variable 4617proc getLoadedModuleList {{filter_empty 1}} { 4618 set modlist [list] 4619 foreach mod [split [get-env LOADEDMODULES] [getState path_separator]] { 4620 # ignore empty element 4621 if {$mod ne {} || !$filter_empty} { 4622 lappend modlist $mod 4623 } 4624 } 4625 return $modlist 4626} 4627 4628# return list of loaded module files by parsing _LMFILES_ env variable 4629proc getLoadedModuleFileList {} { 4630 set modfilelist [list] 4631 foreach modfile [split [get-env _LMFILES_] [getState path_separator]] { 4632 # ignore empty element 4633 if {$modfile ne {}} { 4634 lappend modfilelist $modfile 4635 } 4636 } 4637 return $modfilelist 4638} 4639 4640# return list of declared source-sh by loaded module by parsing 4641# MODULES_LMSOURCESH 4642proc getLoadedModuleSourceShList {} { 4643 set modsrcshlist [list] 4644 set pathsep [getState path_separator] 4645 set sub1sep [getState sub1_separator] 4646 set sub2sep [getState sub2_separator] 4647 set unsermap [list <EnvModEscPS> $pathsep <EnvModEscS1> $sub1sep\ 4648 <EnvModEscS2> $sub2sep] 4649 4650 foreach modsrcshser [split [get-env MODULES_LMSOURCESH] $pathsep] { 4651 set srcshlist [split $modsrcshser $sub1sep] 4652 # ignore empty element (1 is meaningless as first elt is loaded mod) 4653 if {[llength $srcshlist] > 1} { 4654 set modsrcsh {} 4655 # keep first arg as string and other args as lists 4656 foreach srcsh $srcshlist { 4657 # unescape delimiter chars used in content 4658 if {[llength $modsrcsh] == 0} { 4659 lappend modsrcsh [string map $unsermap $srcsh] 4660 } else { 4661 lappend modsrcsh [string map $unsermap [split $srcsh $sub2sep]] 4662 } 4663 } 4664 lappend modsrcshlist $modsrcsh 4665 } 4666 } 4667 return $modsrcshlist 4668} 4669 4670# return list of loaded module declared conflict by parsing MODULES_LMCONFLICT 4671proc getLoadedModuleConflictList {} { 4672 set modconlist [list] 4673 # get sub level separator that serialize second level of info in env var 4674 set sub1sep [getState sub1_separator] 4675 foreach modconser [split [get-env MODULES_LMCONFLICT] [getState\ 4676 path_separator]] { 4677 # recover range specifier ':' from its serialized form '<' 4678 set conlist [split [string map {< :} $modconser] $sub1sep] 4679 # ignore empty element (1 is meaningless as first elt is loaded mod) 4680 if {[llength $conlist] > 1} { 4681 lappend modconlist $conlist 4682 } 4683 } 4684 return $modconlist 4685} 4686 4687# return list of loaded module declared prereq by parsing MODULES_LMPREREQ 4688proc getLoadedModulePrereqList {} { 4689 set modprelist [list] 4690 set sub1sep [getState sub1_separator] 4691 # get sub sub level separator that serialize third level of info in env var 4692 set sub2sep [getState sub2_separator] 4693 foreach modpreser [split [get-env MODULES_LMPREREQ] [getState\ 4694 path_separator]] { 4695 # recover range specifier ':' from its serialized form '<' 4696 set prelist [split [string map {< :} $modpreser] $sub1sep] 4697 # ignore empty element (1 is meaningless as first elt is loaded mod) 4698 if {[llength $prelist] > 1} { 4699 set modpre {} 4700 # keep first arg as string and other args as lists 4701 foreach pre $prelist { 4702 if {[llength $modpre] == 0} { 4703 lappend modpre $pre 4704 } else { 4705 lappend modpre [split $pre $sub2sep] 4706 } 4707 } 4708 4709 lappend modprelist $modpre 4710 } 4711 } 4712 return $modprelist 4713} 4714 4715# return list of loaded module asked by user by parsing MODULES_LMNOTUASKED 4716proc getLoadedModuleNotUserAskedList {} { 4717 set nuaskedlist [list] 4718 foreach mod [split [get-env MODULES_LMNOTUASKED] [getState\ 4719 path_separator]] { 4720 # ignore empty element 4721 if {$mod ne {}} { 4722 lappend nuaskedlist $mod 4723 } 4724 } 4725 return $nuaskedlist 4726} 4727 4728# return list of loaded module declared altnames by parsing MODULES_LMALTNAME 4729proc getLoadedModuleAltnameList {} { 4730 set modaltlist [list] 4731 set sub1sep [getState sub1_separator] 4732 foreach modaltser [split [get-env MODULES_LMALTNAME] [getState\ 4733 path_separator]] { 4734 set altlist [split $modaltser $sub1sep] 4735 # ignore empty element (1 is meaningless as first elt is loaded mod) 4736 if {[llength $altlist] > 1} { 4737 lappend modaltlist $altlist 4738 } 4739 } 4740 return $modaltlist 4741} 4742 4743# sort passed module list following both loaded and dependency orders 4744proc sortModulePerLoadedAndDepOrder {modlist {nporeq 0} {loading 0}} { 4745 # sort per loaded order 4746 set sortlist {} 4747 if {[llength $modlist] > 0} { 4748 foreach lmmod [getLoadedModuleList] { 4749 if {[isInList $modlist $lmmod]} { 4750 lappend sortlist $lmmod 4751 } 4752 } 4753 # also sort eventual loading modules if asked 4754 if {$loading} { 4755 foreach loadingmod [lreverse [getLoadingModuleList]] { 4756 if {[isInList $modlist $loadingmod]} { 4757 lappend sortlist $loadingmod 4758 } 4759 } 4760 } 4761 } 4762 4763 # then refine sort with dependencies between loaded modules: a dependent 4764 # module should be placed prior the loaded module requiring it 4765 set reqListVar [expr {$nporeq ? {::g_moduleNPODepend} :\ 4766 {::g_moduleDepend}}] 4767 set i 0 4768 set imax [llength $sortlist] 4769 while {$i < $imax} { 4770 set mod [lindex $sortlist $i] 4771 set jmin $imax 4772 4773 if {[info exists ${reqListVar}($mod)]} { 4774 # goes over all dependend modules to find the first one in the loaded 4775 # order list located after requiring mod 4776 foreach lmmodlist [set ${reqListVar}($mod)] { 4777 foreach lmmod $lmmodlist { 4778 set j [lsearch -exact $sortlist $lmmod] 4779 if {$j > $i && $j < $jmin} { 4780 set jmin $j 4781 set jminmod $lmmod 4782 } 4783 } 4784 } 4785 } 4786 4787 # move first dependent module found after currently inspected mod right 4788 # before it 4789 if {$jmin != $imax} { 4790 set sortlist [linsert [lreplace $sortlist $jmin $jmin] $i $jminmod] 4791 # or go to next element in list if current element has not been changed 4792 } else { 4793 incr i 4794 } 4795 } 4796 4797 return $sortlist 4798} 4799 4800# return list of module paths by parsing MODULEPATH env variable 4801# behavior param enables to exit in error when no MODULEPATH env variable 4802# is set. by default an empty list is returned if no MODULEPATH set 4803# resolv_var param tells if environement variable references in path elements 4804# should be resolved or passed as-is in result list 4805# set_abs param applies an absolute path name convertion to path elements 4806# if enabled 4807proc getModulePathList {{behavior returnempty} {resolv_var 1} {set_abs 1}} { 4808 if {[info exists ::env(MODULEPATH)]} { 4809 set modpathlist [list] 4810 foreach modpath [split $::env(MODULEPATH) [getState path_separator]] { 4811 # ignore empty element 4812 if {$modpath ne {}} { 4813 if {$resolv_var} { 4814 set modpath [resolvStringWithEnv $modpath] 4815 } 4816 if {$set_abs} { 4817 set modpath [getAbsolutePath $modpath] 4818 } 4819 appendNoDupToList modpathlist $modpath 4820 } 4821 } 4822 return $modpathlist 4823 } elseif {$behavior eq {exiterronundef}} { 4824 reportErrorAndExit {No module path defined} 4825 } else { 4826 return {} 4827 } 4828} 4829 4830proc setModspecTag {modspec tag {props {}}} { 4831 reportDebug "Set tag '$tag' with properties '$props' on module\ 4832 specification '$modspec'" 4833 lappend ::g_moduleTag($modspec) $tag $props 4834} 4835 4836proc getModuleTag {mod} { 4837 set taglist [list] 4838 # look if mod matches some module specifications if any 4839 if {[array size ::g_moduleTag] > 0} { 4840 if {[info procs modEq] eq {}} { 4841 defineModEqProc [isIcase] [getConf extended_default] 4842 } 4843 foreach hmodspec [array names ::g_moduleTag] { 4844 if {[modEq $hmodspec $mod eqstart]} { 4845 eval lappend taglist $::g_moduleTag($hmodspec) 4846 } 4847 } 4848 } 4849 return $taglist 4850} 4851 4852proc isModuleTagged {mod tag} { 4853 array set tags [getModuleTag $mod] 4854 4855 return [info exists tags($tag)] 4856} 4857 4858proc getModuleTagProp {mod tag prop} { 4859 set ret {} 4860 array set tags [getModuleTag $mod] 4861 4862 if {[info exists tags($tag)]} { 4863 array set props $tags($tag) 4864 if {[info exists props($prop)]} { 4865 set ret $props($prop) 4866 } 4867 } 4868 4869 return $ret 4870} 4871 4872proc isModuleDotHidden {mod} { 4873 foreach elt [split $mod /] { 4874 if {[string index $elt 0] eq {.}} { 4875 return 1 4876 } 4877 } 4878 return 0 4879} 4880 4881proc getModuleHidingLevel {mod} { 4882 set ret -1 4883 # look if mod matches one of the hidden module specifications if any 4884 if {[array size ::g_moduleHide] > 0} { 4885 foreach hmodspec [array names ::g_moduleHide] { 4886 if {$::g_moduleHide($hmodspec) > $ret && [modEq $hmodspec $mod\ 4887 eqstart]} { 4888 set ret $::g_moduleHide($hmodspec) 4889 } 4890 } 4891 } 4892 return $ret 4893} 4894 4895proc setModspecHidingLevel {modspec lvl} { 4896 # skip record if an higher hiding level is already set 4897 if {![info exists ::g_moduleHide($modspec)] || $lvl >\ 4898 $::g_moduleHide($modspec)} { 4899 reportDebug "Record hidden module specification '$modspec' (lvl=$lvl)" 4900 set ::g_moduleHide($modspec) $lvl 4901 } 4902} 4903 4904# test if mod is declared hidden or has one element in its name starting with 4905# dot character. mod is considered hidden depending on their hiding level, 4906# current search query and hiding threshold. when retdetails option is 4907# enabled, mod hiding level and query match hind are also returned 4908proc isModuleHidden {mod {modspec {}} {retdetails 0}} { 4909 set testid $mod:$modspec:$retdetails 4910 # returned saved result if already tested 4911 if {[info exists ::g_isModuleHiddenMemCache($testid)]} { 4912 return $::g_isModuleHiddenMemCache($testid) 4913 } else { 4914 if {[set hidlvl [getModuleHidingLevel $mod]] >= [getState\ 4915 hiding_threshold]} { 4916 # soft hidden mods are considered matched if their root name matches 4917 # search query, other kind of hidden most must fuly matches query 4918 set hidmatch [expr {$hidlvl == 0 ? [expr {[modStartNb $mod $modspec]\ 4919 > 0}] : [modEq $modspec $mod eqspec]}] 4920 } else { 4921 set hidlvl -1 4922 set hidmatch 0 4923 } 4924 if {$hidlvl < 1 && [isModuleDotHidden $mod] && [getState\ 4925 hiding_threshold] < 1} { 4926 set hidlvl 1 4927 # dot hidden are considered matched if remaining string part after 4928 # search query is not dot hidden 4929 set hidmatch [expr {[set i [modStartNb $mod $modspec]] > 0 &&\ 4930 ![isModuleDotHidden [join [lrange [file split $mod] $i end] /]]}] 4931 } 4932 # hidden if hiding level greater or equal hiding threshold and not 4933 # matched or if matched hard hiding level are kept hidden 4934 set ishid [expr {$hidlvl != -1 && (!$hidmatch || $hidlvl > 1)}] 4935 4936 set ret [expr {$retdetails ? [list $hidlvl $hidmatch $ishid] : $ishid}] 4937 4938 # cache test result 4939 set ::g_isModuleHiddenMemCache($testid) $ret 4940 4941 return $ret 4942 } 4943} 4944 4945# check if module name is specified as a full pathname (not a name relative 4946# to a modulepath) 4947proc isModuleFullPath {mod} { 4948 return [regexp {^(|\.|\.\.)/} $mod] 4949} 4950 4951# check if a module corresponds to a virtual module (module name 4952# does not corresponds to end of the modulefile name) 4953proc isModuleVirtual {mod modfile} { 4954 return [expr {[string first $mod $modfile end-[string length $mod]] == -1}] 4955} 4956 4957# Return the full pathname and modulename to the module. 4958# Resolve aliases and default versions if the module name is something like 4959# "name/version" or just "name" (find default version). 4960proc getPathToModule {mod {indir {}} {report_issue 1} {look_loaded no}\ 4961 {excdir {}}} { 4962 reportDebug "finding '$mod' in '$indir' (report_issue=$report_issue,\ 4963 look_loaded=$look_loaded, excdir='$excdir')" 4964 4965 if {$mod eq {}} { 4966 set retlist [list {} 0 none {Invalid empty module name}] 4967 # try first to look at loaded modules if enabled to find maching module 4968 # or to find a closest match (used when switching with single name arg) 4969 } elseif {$look_loaded ne {no}} { 4970 switch -- $look_loaded { 4971 match {set getLoadedNameProc getLoadedMatchingName} 4972 close {set getLoadedNameProc getLoadedWithClosestName} 4973 } 4974 set retlist [if {[set lm [$getLoadedNameProc $mod]] ne {}} {list\ 4975 [getModulefileFromLoadedModule $lm] $lm} {list {} $mod notloaded}] 4976 # Check for $mod specified as a full pathname 4977 } elseif {[isModuleFullPath $mod]} { 4978 set mod [getAbsolutePath $mod] 4979 # note that a raw filename as an argument returns the full 4980 # path as the module name 4981 lassign [checkValidModule $mod] check_valid check_msg 4982 switch -- $check_valid { 4983 true { 4984 set retlist [list $mod $mod] 4985 } 4986 invalid - accesserr { 4987 set retlist [list {} $mod $check_valid $check_msg $mod] 4988 } 4989 } 4990 } else { 4991 set dir_list [expr {$indir ne {} ? $indir : [getModulePathList\ 4992 exiterronundef]}] 4993 # remove excluded directories (already searched) 4994 foreach dir $excdir { 4995 set dir_list [replaceFromList $dir_list $dir] 4996 } 4997 4998 set icase [isIcase] 4999 defineGetEqArrayKeyProc $icase [getConf extended_default] [getConf\ 5000 implicit_default] 5001 5002 # Now search for $mod in module paths 5003 set modspec $mod 5004 foreach dir $dir_list { 5005 # get list of modules corresponding to searched query 5006 array unset mod_list 5007 array set mod_list [getModules $dir $mod 0 [list rc_defs_included\ 5008 resolve]] 5009 5010 set prevmod {} 5011 set mod_res {} 5012 # loop to resolve correct modulefile in case specified mod is a 5013 # directory that should be analyzed to get default mod in it 5014 while {$prevmod ne $mod} { 5015 set mod [getEqArrayKey mod_list $mod] 5016 set prevmod $mod 5017 if {[info exists mod_list($mod)]} { 5018 switch -- [lindex $mod_list($mod) 0] { 5019 alias - version { 5020 set newmod [resolveModuleVersionOrAlias $mod $icase] 5021 if {[info exists mod_list($newmod)]} { 5022 set mod $newmod 5023 } else { 5024 # restart search on new modulename, constrained to 5025 # specified dir if set, if not found in current res 5026 return [getPathToModule $newmod $indir $report_issue] 5027 } 5028 } 5029 directory { 5030 # is implicit default disabled and none explicitly set? 5031 if {[lindex $mod_list($mod) 1] eq {}} { 5032 set retlist [list {} $mod none "No default version\ 5033 defined for '$mod'"] 5034 } else { 5035 # Move to default element in directory 5036 set mod $mod/[lindex $mod_list($mod) 1] 5037 # restart search if default element is an hidden dir 5038 if {![info exists mod_list($mod)] && [isModuleHidden\ 5039 $mod $modspec]} { 5040 return [getPathToModule $mod $indir $report_issue] 5041 } 5042 } 5043 } 5044 modulefile { 5045 # If mod was a file in this path, return that file 5046 set retlist [list $dir/$mod $mod] 5047 } 5048 virtual { 5049 # return virtual name with file it targets 5050 set retlist [list [lindex $mod_list($mod) 2] $mod] 5051 } 5052 invalid - accesserr { 5053 # may found mod but issue, so end search with error 5054 set retlist [concat [list {} $mod] $mod_list($mod)] 5055 } 5056 } 5057 } 5058 } 5059 # break loop if found something (valid or invalid module) 5060 # elsewhere go to next path 5061 if {[info exists retlist]} { 5062 break 5063 } 5064 } 5065 } 5066 5067 # set result if nothing found 5068 if {![info exists retlist]} { 5069 set retlist [list {} $mod none "Unable to locate a modulefile for\ 5070 '$mod'"] 5071 # update result if forbidden 5072 } elseif {[isModuleTagged [lindex $retlist 1] forbidden]} { 5073 set retlist [list {} [lindex $retlist 1] accesserr [getForbiddenMsg\ 5074 [lindex $retlist 1]]] 5075 } 5076 if {[lindex $retlist 0] ne {}} { 5077 reportTrace "'[lindex $retlist 1]' ([lindex $retlist 0]) matching\ 5078 '$mod'" {Select module} 5079 # no error if we look at loaded modules and passed mod not found loaded 5080 } elseif {[lindex $retlist 2] ne {notloaded} && $report_issue} { 5081 eval reportIssue [lrange $retlist 2 4] 5082 } 5083 return $retlist 5084} 5085 5086proc isModuleLoaded {mod} { 5087 cacheCurrentModules 5088 5089 return [info exists ::g_loadedModules($mod)] 5090} 5091 5092proc getModulefileFromLoadedModule {mod} { 5093 if {[isModuleLoaded $mod]} { 5094 return $::g_loadedModules($mod) 5095 } else { 5096 return {} 5097 } 5098} 5099 5100proc isModulefileLoaded {modfile} { 5101 cacheCurrentModules 5102 5103 return [info exists ::g_loadedModuleFiles($modfile)] 5104} 5105 5106proc getModuleFromLoadedModulefile {modfile {idx all}} { 5107 if {[isModulefileLoaded $modfile]} { 5108 if {$idx eq {all}} { 5109 return $::g_loadedModuleFiles($modfile) 5110 } else { 5111 return [lindex $::g_loadedModuleFiles($modfile) $idx] 5112 } 5113 } else { 5114 return {} 5115 } 5116} 5117 5118proc isModuleLoading {mod} { 5119 return [isInList [getLoadingModuleList] $mod] 5120} 5121 5122proc isModulefileLoading {modfile} { 5123 return [isInList [getLoadingModuleFileList] $modfile] 5124} 5125 5126proc getModuleFromLoadingModulefile {modfile {idx all}} { 5127 if {[isModulefileLoading $modfile]} { 5128 set loadingmodlist [getLoadingModuleList] 5129 foreach i [lsearch -all -exact [getLoadingModuleFileList] $modfile] { 5130 lappend modlist [lindex $loadingmodlist $i] 5131 } 5132 5133 if {$idx eq {all}} { 5134 return $modlist 5135 } else { 5136 return [lindex $modlist $idx] 5137 } 5138 } else { 5139 return {} 5140 } 5141} 5142 5143proc setLoadedModule {mod modfile uasked} { 5144 set ::g_loadedModules($mod) $modfile 5145 # a loaded modfile may correspond to multiple loaded virtual modules 5146 lappend ::g_loadedModuleFiles($modfile) $mod 5147 # record if mod has been asked by user 5148 if {$uasked} { 5149 set ::g_loadedModuleUasked($mod) 1 5150 } 5151 # build dependency chain 5152 setModuleDependency $mod 5153} 5154 5155proc unsetLoadedModule {mod modfile} { 5156 unset ::g_loadedModules($mod) 5157 # a loaded modfile may correspond to multiple loaded virtual modules 5158 if {[llength $::g_loadedModuleFiles($modfile)] == 1} { 5159 unset ::g_loadedModuleFiles($modfile) 5160 } else { 5161 set ::g_loadedModuleFiles($modfile) [replaceFromList\ 5162 $::g_loadedModuleFiles($modfile) $mod] 5163 } 5164 if {[info exists ::g_loadedModuleUasked($mod)]} { 5165 unset ::g_loadedModuleUasked($mod) 5166 } 5167 # update dependencies 5168 unsetModuleDependency $mod 5169} 5170 5171# Define procedure to get how many parts between passed name and mod are equal 5172# Adapt procedure code whether icase is enabled or disabled 5173proc defineModStartNbProc {icase} { 5174 set procname modStartNbProc 5175 if {$icase} { 5176 append procname Icase 5177 } 5178 # define proc if not done yet or if it was defined for another context 5179 if {[info procs modStartNb] eq {} || $::g_modStartNb_proc ne $procname} { 5180 if {[info exists ::g_modStartNb_proc]} { 5181 rename ::modStartNb ::$::g_modStartNb_proc 5182 } 5183 rename ::$procname ::modStartNb 5184 set ::g_modStartNb_proc $procname 5185 } 5186} 5187 5188# alternative definitions of modStartNb proc 5189proc modStartNbProc {mod name} { 5190 # first compare against name's parent chunk by chunk 5191 set modname [getModuleNameFromVersSpec $name] 5192 if {$modname eq {.}} { 5193 set i 0 5194 set imax 0 5195 } else { 5196 set namesplit [split $modname /] 5197 set modsplit [split $mod /] 5198 # min expr function is not supported in Tcl8.4 and earlier 5199 set imax [if {[llength $namesplit] < [llength $modsplit]} {llength\ 5200 $namesplit} {llength $modsplit}] 5201 for {set i 0} {$i < $imax} {incr i} { 5202 if {![string equal [lindex $modsplit $i] [lindex $namesplit $i]]} { 5203 break 5204 } 5205 } 5206 } 5207 # if name's parent matches check if full name also matches 5208 if {$i == $imax && [modEq $name $mod eqstart]} { 5209 incr i 5210 } 5211 return $i 5212} 5213proc modStartNbProcIcase {mod name} { 5214 set modname [getModuleNameFromVersSpec $name] 5215 if {$modname eq {.}} { 5216 set i 0 5217 set imax 0 5218 } else { 5219 set namesplit [split $modname /] 5220 set modsplit [split $mod /] 5221 set imax [if {[llength $namesplit] < [llength $modsplit]} {llength\ 5222 $namesplit} {llength $modsplit}] 5223 for {set i 0} {$i < $imax} {incr i} { 5224 if {![string equal -nocase [lindex $modsplit $i] [lindex $namesplit\ 5225 $i]]} { 5226 break 5227 } 5228 } 5229 } 5230 if {$i == $imax && [modEq $name $mod eqstart]} { 5231 incr i 5232 } 5233 return $i 5234} 5235 5236# check if name matches passed mod name or one of its alternative name 5237proc doesModuleMatchesName {mod name} { 5238 cacheCurrentModules 5239 set ret 0 5240 5241 # check if main or alternative names of loaded mod matches passed name 5242 foreach matchmod [concat [list $mod] [getLoadedAltname $mod]] { 5243 if {[modEq $name $matchmod eqstart]} { 5244 set ret 1 5245 break 5246 } 5247 } 5248 return $ret 5249} 5250 5251# check if name matches one name of passed loading mod (main or alternative) 5252proc doesLoadingModuleMatchesName {mod name} { 5253 set ret 0 5254 5255 # check if main or alternative names of loading mod matches passed name 5256 # directly look at all resolved names structure as alternative names for 5257 # loading modules are not yet registered elsewhere 5258 foreach matchmod [concat [list $mod] [getAllModuleResolvedName $mod]] { 5259 if {[modEq $name $matchmod eqstart]} { 5260 set ret 1 5261 break 5262 } 5263 } 5264 return $ret 5265} 5266 5267# return the currently loaded module whose name is the closest to the 5268# name passed as argument. if no loaded module match at least one part 5269# of the passed name, an empty string is returned. 5270proc getLoadedWithClosestName {name} { 5271 set ret {} 5272 set retmax 1 5273 5274 if {[isModuleFullPath $name]} { 5275 set fullname [getAbsolutePath $name] 5276 # if module is passed as full modulefile path name, get corresponding 5277 # short name from used modulepaths 5278 if {[set shortname [findModuleNameFromModulefile $fullname]] ne {}} { 5279 set nametosplit $shortname 5280 # or look at lmfile names to return the eventual exact match 5281 } else { 5282 # module may be loaded with its full path name 5283 if {[isModuleLoaded $fullname]} { 5284 set ret $fullname 5285 # or name corresponds to the _lmfiles_ entry of a virtual modules in 5286 # which case lastly loaded virtual module is returned 5287 } elseif {[isModulefileLoaded $fullname]} { 5288 set ret [getModuleFromLoadedModulefile $fullname end] 5289 } 5290 } 5291 } else { 5292 set nametosplit $name 5293 } 5294 5295 if {[info exists nametosplit]} { 5296 cacheCurrentModules 5297 set icase [isIcase] 5298 defineModStartNbProc $icase 5299 defineModEqProc $icase [getConf extended_default] 5300 # compare name to each currently loaded module name 5301 foreach mod [getLoadedModuleList] { 5302 # if module loaded as fullpath but test name not, try to get loaded 5303 # mod short name (with currently used modulepaths) to compare it 5304 if {[isModuleFullPath $mod] && [set modname\ 5305 [findModuleNameFromModulefile $mod]] ne {}} { 5306 # no alt name to retrieve if module has been loaded full path 5307 set matchmodlist [list $modname] 5308 } else { 5309 # add alternative names of mod to the matching list 5310 set matchmodlist [concat [list $mod] [getLoadedAltname $mod]] 5311 } 5312 5313 # compare each element of the name to find closest answer. in case of 5314 # equality, last loaded module will be returned as it overwrites 5315 # previously found value 5316 foreach matchmod $matchmodlist { 5317 if {[set i [modStartNb $matchmod $nametosplit]] >= $retmax} { 5318 set retmax $i 5319 set ret $mod 5320 break 5321 } 5322 } 5323 } 5324 } 5325 5326 reportDebug "'$ret' closest to '$name'" 5327 return $ret 5328} 5329 5330# return the currently loaded module whose name is equal or include the name 5331# passed as argument. if no loaded module match, an empty string is returned. 5332# loading: look at currently loading modules instead of loaded if loading == 1 5333# lmlist: only take into account passed loaded module list not all loaded mods 5334proc getLoadedMatchingName {name {behavior {}} {loading 0} {lmlist {}}} { 5335 set ret {} 5336 set retmax 0 5337 # get default behavior from unload_match_order config 5338 if {$behavior eq {}} { 5339 set behavior [getConf unload_match_order] 5340 } 5341 5342 # use loading-specific procedures instead of loaded-specific ones 5343 if {$loading} { 5344 set isModulefileLoaded isModulefileLoading 5345 set getModuleFromLoadedModulefile getModuleFromLoadingModulefile 5346 set getLoadedModuleList getLoadingModuleList 5347 set doesModuleMatchesName doesLoadingModuleMatchesName 5348 } else { 5349 set isModulefileLoaded isModulefileLoaded 5350 set getModuleFromLoadedModulefile getModuleFromLoadedModulefile 5351 set getLoadedModuleList getLoadedModuleList 5352 set doesModuleMatchesName doesModuleMatchesName 5353 } 5354 5355 # fetch currently loaded/loading module name is no list provided 5356 if {[llength $lmlist] == 0} { 5357 set lmlist [$getLoadedModuleList] 5358 } 5359 5360 # if module is passed as full modulefile path name, look at lmfile names 5361 # to return the eventual exact match 5362 if {[isModuleFullPath $name]} { 5363 set mod [getAbsolutePath $name] 5364 # if module is loaded with its full path name loadedmodules entry is 5365 # equivalent to _lmfiles_ corresponding entry so only check _lmfiles_ 5366 if {[$isModulefileLoaded $mod]} { 5367 # a loaded modfile may correspond to multiple loaded virtual modules 5368 switch -- $behavior { 5369 returnlast { 5370 # the last loaded/loading module will be returned 5371 set ret [$getModuleFromLoadedModulefile $mod end] 5372 } 5373 returnfirst { 5374 # the first loaded/loading module will be returned 5375 set ret [$getModuleFromLoadedModulefile $mod 0] 5376 } 5377 returnall { 5378 # all loaded/loading modules will be returned 5379 set ret [$getModuleFromLoadedModulefile $mod] 5380 } 5381 } 5382 } 5383 } elseif {$name ne {}} { 5384 defineModEqProc [isIcase] [getConf extended_default] 5385 # compare name to each currently loaded/loading module name, if multiple 5386 # mod match name: 5387 foreach mod $lmlist { 5388 # if module loaded as fullpath but test name not, try to get loaded 5389 # mod short name (with currently used modulepaths) to compare it 5390 if {[isModuleFullPath $mod] && [set modname\ 5391 [findModuleNameFromModulefile $mod]] ne {}} { 5392 set matchmod $modname 5393 } else { 5394 set matchmod $mod 5395 } 5396 if {[$doesModuleMatchesName $matchmod $name]} { 5397 switch -- $behavior { 5398 returnlast { 5399 # the last loaded module will be returned 5400 set ret $mod 5401 } 5402 returnfirst { 5403 # the first loaded module will be returned 5404 set ret $mod 5405 break 5406 } 5407 returnall { 5408 # all loaded modules will be returned 5409 lappend ret $mod 5410 } 5411 } 5412 } 5413 } 5414 } 5415 5416 reportDebug "'$ret' matches '$name'" 5417 return $ret 5418} 5419 5420proc setLoadedSourceSh {mod args} { 5421 foreach arg $args { 5422 # each arg is a list with source-sh call string at index 0 and resulting 5423 # modulefile commands at all later index positions 5424 set shtomodargs [lindex $arg 0] 5425 set modcontent [lrange $arg 1 end] 5426 if {![info exists ::g_loadedModuleSourceSh($mod)] || [notInList\ 5427 $::g_loadedModuleSourceSh($mod) $shtomodargs]} { 5428 # filter alias or function definition not to record them 5429 set filtmodcont [list] 5430 foreach modcmdlist $modcontent { 5431 set modcmd [lindex $modcmdlist 0] 5432 if {$modcmd eq {set-alias} || $modcmd eq {set-function}} { 5433 # set an empty body to make valid unset-* call 5434 lappend filtmodcont [concat [lrange $modcmdlist 0 1] [list {}]] 5435 } else { 5436 lappend filtmodcont $modcmdlist 5437 } 5438 } 5439 lappend ::g_loadedModuleSourceSh($mod) $shtomodargs $filtmodcont 5440 } 5441 } 5442} 5443 5444proc unsetLoadedSourceSh {mod} { 5445 if {[info exists ::g_loadedModuleSourceSh($mod)]} { 5446 unset ::g_loadedModuleSourceSh($mod) 5447 } 5448} 5449 5450proc getLoadedSourceSh {mod {serialized 0}} { 5451 set ret {} 5452 5453 set pathsep [getState path_separator] 5454 set sub1sep [getState sub1_separator] 5455 set sub2sep [getState sub2_separator] 5456 set sermap [list $pathsep <EnvModEscPS> $sub1sep <EnvModEscS1>\ 5457 $sub2sep <EnvModEscS2>] 5458 5459 if {[info exists ::g_loadedModuleSourceSh($mod)]} { 5460 if {$serialized} { 5461 foreach {shtomodargs modcontent} $::g_loadedModuleSourceSh($mod) { 5462 # escape delimiter chars if used in content 5463 set shtomodargsser [string map $sermap $shtomodargs] 5464 set modcontentser [string map $sermap $modcontent] 5465 lappend modsrcsh $shtomodargsser$sub2sep[join $modcontentser\ 5466 $sub2sep] 5467 } 5468 set ret [join [concat [list $mod] $modsrcsh] $sub1sep] 5469 } else { 5470 set ret $::g_loadedModuleSourceSh($mod) 5471 } 5472 } 5473 5474 return $ret 5475} 5476 5477proc setLoadedConflict {mod args} { 5478 eval appendNoDupToList "{::g_loadedModuleConflict($mod)}" $args 5479} 5480 5481proc unsetLoadedConflict {mod} { 5482 if {[info exists ::g_loadedModuleConflict($mod)]} { 5483 unset ::g_loadedModuleConflict($mod) 5484 } 5485} 5486 5487proc getLoadedConflict {mod {serialized 0}} { 5488 set ret {} 5489 5490 if {[info exists ::g_loadedModuleConflict($mod)]} { 5491 if {$serialized} { 5492 # get conflict info as a string that can be registered in an env var 5493 # translate range specifier ':' into '<' to distinguish from path sep 5494 set ret [string map {: <} [join [concat [list $mod]\ 5495 $::g_loadedModuleConflict($mod)] [getState sub1_separator]]] 5496 } else { 5497 set ret $::g_loadedModuleConflict($mod) 5498 } 5499 } 5500 5501 return $ret 5502} 5503 5504proc doesModuleConflict {mod} { 5505 set does 0 5506 set modconlist {} 5507 set moddecconlist {} 5508 defineModEqProc [isIcase] [getConf extended_default] 5509 # get module short name if loaded by its full pathname 5510 if {[set isfullpath [isModuleFullPath $mod]]} { 5511 set smod [findModuleNameFromModulefile $mod] 5512 } 5513 5514 # check if any loaded module has declared a conflict 5515 foreach modcon [array names ::g_loadedModuleConflict] { 5516 # look if some loaded or loading modules correspond to conflict defined 5517 # by mod 5518 if {$modcon eq $mod || ($isfullpath && $modcon eq $smod)} { 5519 foreach withmod $::g_loadedModuleConflict($modcon) { 5520 # skip own reflexive conflict (look at mod main and alternative 5521 # names) and those already known 5522 if {![doesModuleMatchesName $mod $withmod] && (!$isfullpath ||\ 5523 ![doesModuleMatchesName $smod $withmod]) && ([set lmmodlist\ 5524 [getLoadedMatchingName $withmod returnall]] ne {} || [set\ 5525 lmmodlist [getLoadedMatchingName $withmod returnall 1]] ne {})} { 5526 # multiple loaded module may match conflict declared name 5527 foreach lmmod $lmmodlist { 5528 appendNoDupToList modconlist $lmmod 5529 } 5530 appendNoDupToList moddecconlist $withmod 5531 set does 1 5532 } 5533 } 5534 # other loaded module declared conflicts (skipping those already known) 5535 } elseif {[notInList $modconlist $modcon]} { 5536 foreach withmod $::g_loadedModuleConflict($modcon) { 5537 # check if mod or one of its alt name match conflict 5538 if {[doesModuleMatchesName $mod $withmod] || ($isfullpath &&\ 5539 [doesModuleMatchesName $smod $withmod])} { 5540 lappend modconlist $modcon 5541 lappend moddecconlist $modcon 5542 set does 1 5543 break 5544 } 5545 } 5546 } 5547 } 5548 5549 reportDebug "'$mod' conflicts with '$modconlist' (declared as '$moddecconlist')" 5550 return [list $does $modconlist $moddecconlist] 5551} 5552 5553proc setLoadedPrereq {mod args} { 5554 eval appendNoDupToList "{::g_loadedModulePrereq($mod)}" $args 5555} 5556 5557proc unsetLoadedPrereq {mod} { 5558 if {[info exists ::g_loadedModulePrereq($mod)]} { 5559 unset ::g_loadedModulePrereq($mod) 5560 } 5561} 5562 5563proc getLoadedPrereq {mod {serialized 0}} { 5564 set ret {} 5565 5566 set sub2sep [getState sub2_separator] 5567 if {[info exists ::g_loadedModulePrereq($mod)]} { 5568 if {$serialized} { 5569 # get prereq info as a string that can be registered in an env var 5570 foreach pre $::g_loadedModulePrereq($mod) { 5571 lappend modpre [join $pre $sub2sep] 5572 } 5573 # translate range specifier ':' into '<' to distinguish from path sep 5574 set ret [string map {: <} [join [concat [list $mod] $modpre]\ 5575 [getState sub1_separator]]] 5576 } else { 5577 set ret $::g_loadedModulePrereq($mod) 5578 } 5579 } 5580 5581 return $ret 5582} 5583 5584proc setLoadedAltname {mod args} { 5585 foreach arg $args { 5586 if {[string range $arg 0 2] eq {as|}} { 5587 appendNoDupToList ::g_loadedModuleAutoAltname($mod) [string range\ 5588 $arg 3 end] 5589 } else { 5590 appendNoDupToList ::g_loadedModuleAltname($mod) $arg 5591 } 5592 } 5593} 5594 5595proc unsetLoadedAltname {mod} { 5596 if {[info exists ::g_loadedModuleAltname($mod)]} { 5597 unset ::g_loadedModuleAltname($mod) 5598 } 5599 if {[info exists ::g_loadedModuleAutoAltname($mod)]} { 5600 unset ::g_loadedModuleAutoAltname($mod) 5601 } 5602} 5603 5604proc getLoadedAltname {mod {serialized 0}} { 5605 set ret {} 5606 5607 if {[info exists ::g_loadedModuleAltname($mod)]} { 5608 set ret $::g_loadedModuleAltname($mod) 5609 } 5610 if {[info exists ::g_loadedModuleAutoAltname($mod)]} { 5611 if {$serialized} { 5612 # add a 'as|' prefix to each auto sym to distinguish them when 5613 # serialized 5614 foreach altname $::g_loadedModuleAutoAltname($mod) { 5615 lappend ret as|$altname 5616 } 5617 } else { 5618 set ret [concat $ret $::g_loadedModuleAutoAltname($mod)] 5619 } 5620 } 5621 5622 if {$ret ne {} && $serialized} { 5623 # get altname info as a string that can be registered in an env var 5624 set ret [join [concat [list $mod] $ret] [getState sub1_separator]] 5625 } 5626 5627 return $ret 5628} 5629 5630proc isModuleUserAsked {mod} { 5631 cacheCurrentModules 5632 5633 return [info exists ::g_loadedModuleUasked($mod)] 5634} 5635 5636# register conflict violation state between loaded modules 5637proc setModuleConflictViolation {mod modconlist} { 5638 reportDebug "set conflict violation state for '$mod'" 5639 set ::g_conflictViolation($mod) $modconlist 5640 # also update violation state for loaded mod conflicting with mod 5641 foreach lmmod $modconlist { 5642 if {[appendNoDupToList ::g_conflictViolation($lmmod) $mod]} { 5643 reportDebug "set/update conflict violation state for '$lmmod'" 5644 } 5645 } 5646} 5647 5648# unregister conflict violation state between modules 5649proc unsetModuleConflictViolation {mod} { 5650 if {[info exists ::g_conflictViolation($mod)]} { 5651 # also update violation state for loaded mod conflicting with mod 5652 foreach lmmod $::g_conflictViolation($mod) { 5653 set convio [replaceFromList\ 5654 $::g_conflictViolation($lmmod) $mod] 5655 reportDebug "unset/update conflict violation state for '$lmmod'" 5656 if {[llength $convio] == 0} { 5657 unset ::g_conflictViolation($lmmod) 5658 } else { 5659 set ::g_conflictViolation($lmmod) $convio 5660 } 5661 } 5662 reportDebug "unset conflict violation state for '$mod'" 5663 unset ::g_conflictViolation($mod) 5664 } 5665} 5666 5667# build dependency chain between loaded modules based on registered prereqs 5668proc setModuleDependency {mod} { 5669 set modlist [getLoadedModuleList] 5670 defineModEqProc [isIcase] [getConf extended_default] 5671 # only look at modules loaded prior current one to find requirements, 5672 # modules loaded afterward are unmet dependencies as dependents have 5673 # not been reloaded after them 5674 set modidx [lsearch -exact $modlist $mod] 5675 set modnpolist [lrange $modlist [expr {$modidx + 1}] end] 5676 set modlist [lrange $modlist 0 $modidx] 5677 # reverse list to get closest match if returning lastly loaded module 5678 if {[getConf unload_match_order] eq {returnlast}} { 5679 set modlist [lreverse $modlist] 5680 } 5681 set deplist {} 5682 set depnpolist {} 5683 5684 foreach prereq [getLoadedPrereq $mod] { 5685 # get corresponding loaded module for each element of the prereq order 5686 set lmprelist {} 5687 set lmnpolist {} 5688 foreach modpre $prereq { 5689 set lmfound {} 5690 foreach lmmod $modlist { 5691 if {[doesModuleMatchesName $lmmod $modpre]} { 5692 set lmfound $lmmod 5693 break 5694 } 5695 } 5696 5697 # register an unmet dependency/requirement if no loaded mod matches 5698 if {$lmfound eq {}} { 5699 reportDebug "set an unmet requirement on '$modpre' for '$mod'" 5700 lappend ::g_moduleUnmetDep($mod) $modpre 5701 lappend ::g_unmetDepHash($modpre) $mod 5702 # add matching mod elsewhere 5703 } else { 5704 appendNoDupToList lmprelist $lmfound 5705 appendNoDupToList lmnpolist $lmfound 5706 } 5707 5708 # look if requirement can be found in the No Particular Order list 5709 foreach lmmod $modnpolist { 5710 if {[doesModuleMatchesName $lmmod $modpre]} { 5711 appendNoDupToList lmnpolist $lmmod 5712 break 5713 } 5714 } 5715 } 5716 5717 switch -- [llength $lmprelist] { 5718 0 { 5719 # prereq not satisfied 5720 reportDebug "set prereq violation state for '$mod'" 5721 lappend ::g_prereqViolation($mod) $prereq 5722 } 5723 1 { 5724 set lmmod [lindex $lmprelist 0] 5725 lappend deplist [list $lmmod] 5726 # set 'is depended by' relations 5727 lappend ::g_dependHash($lmmod) [list $mod] 5728 } 5729 default { 5730 lappend deplist $lmprelist 5731 # many modules in prereq list, means they all set an optional dep 5732 foreach lmmod $lmprelist { 5733 lappend ::g_dependHash($lmmod) [list $mod 1] 5734 } 5735 } 5736 } 5737 5738 # build 'is depended by' relations not taking loading order into account 5739 switch -- [llength $lmnpolist] { 5740 0 { 5741 # even on No Particular Order mode, prereq is not satisfied 5742 reportDebug "set NPO prereq violation state for '$mod'" 5743 lappend ::g_prereqNPOViolation($mod) $prereq 5744 } 5745 1 { 5746 set lmmod [lindex $lmnpolist 0] 5747 lappend depnpolist [list $lmmod] 5748 # set 'is depended by' relations 5749 lappend ::g_dependNPOHash($lmmod) [list $mod] 5750 } 5751 default { 5752 lappend depnpolist $lmnpolist 5753 # many modules in prereq list, means they all set an optional dep 5754 foreach lmmod $lmnpolist { 5755 lappend ::g_dependNPOHash($lmmod) [list $mod 1] 5756 } 5757 } 5758 } 5759 } 5760 5761 # conflict not satisfied 5762 lassign [doesModuleConflict $mod] doescon modconlist 5763 if {$doescon} { 5764 setModuleConflictViolation $mod $modconlist 5765 } 5766 5767 # update eventual registered unmet dependencies 5768 foreach modpre [array names ::g_unmetDepHash] { 5769 if {[doesModuleMatchesName $mod $modpre]} { 5770 reportDebug "refresh requirements targetting '$modpre'" 5771 foreach lmmod $::g_unmetDepHash($modpre) { 5772 if {[isInList [getDependentLoadedModuleList [list $lmmod] 0 0]\ 5773 $mod]} { 5774 reportDebug "skip deps refresh for '$lmmod' as dep cycle\ 5775 detected with '$mod'" 5776 5777 # remove dependency link in no particular order structs to 5778 # avoid cycle first in 'is depended by' struct 5779 if {[info exists ::g_dependNPOHash($mod)]} { 5780 set depmodlist $::g_dependNPOHash($mod) 5781 for {set i 0} {$i < [llength $depmodlist]} {incr i 1} { 5782 if {[lindex [lindex $depmodlist $i] 0] eq $lmmod} { 5783 set depmodlist [lreplace $depmodlist $i $i] 5784 break 5785 } 5786 } 5787 set ::g_dependNPOHash($mod) $depmodlist 5788 reportDebug "update NPO dependent of '$mod' to\ 5789 '$depmodlist'" 5790 } 5791 # then update 'depend on' struct 5792 set lmmoddepnpolist {} 5793 foreach depmodlist $::g_moduleNPODepend($lmmod) { 5794 if {[set depidx [lsearch -exact $depmodlist $mod]] != -1} { 5795 set depmodlist [lreplace $depmodlist $depidx $depidx] 5796 # implies to update consistenly alternate requirement or 5797 # violation state if no alternative loaded 5798 switch -- [llength $depmodlist] { 5799 0 { 5800 # do not know exact prereq name, so use correspond. 5801 # loaded module matching it 5802 lappend ::g_prereqNPOViolation($lmmod) $mod 5803 reportDebug "set NPO prereq violation state for\ 5804 '$lmmod'" 5805 } 5806 1 { 5807 # update alternate loaded mod which became a strong 5808 # requirement 5809 set altmod [lindex $depmodlist 0] 5810 set ::g_dependNPOHash($altmod) [replaceFromList\ 5811 $::g_dependNPOHash($altmod) [list $lmmod 1]\ 5812 $lmmod] 5813 reportDebug "update NPO dependent of '$altmod' to\ 5814 '$::g_dependNPOHash($altmod)'" 5815 } 5816 } 5817 } 5818 lappend lmmoddepnpolist $depmodlist 5819 } 5820 reportDebug "update NPO requirement of '$lmmod' to\ 5821 '$lmmoddepnpolist'" 5822 set ::g_moduleNPODepend($lmmod) $lmmoddepnpolist 5823 } else { 5824 # refresh actual dependencies of targetting mod 5825 unsetModuleDependency $lmmod 5826 setModuleDependency $lmmod 5827 } 5828 } 5829 } 5830 } 5831 5832 # set 'depends on' relation 5833 reportDebug "set requirements of '$mod' to '$deplist'" 5834 set ::g_moduleDepend($mod) $deplist 5835 reportDebug "set NPO requirements of '$mod' to '$depnpolist'" 5836 set ::g_moduleNPODepend($mod) $depnpolist 5837} 5838 5839# update dependency chain when unloading module 5840proc unsetModuleDependency {mod} { 5841 foreach lmmodlist $::g_moduleDepend($mod) { 5842 set manymod [expr {[llength $lmmodlist] > 1}] 5843 5844 # unset 'is depended by' mod relations 5845 foreach lmmod $lmmodlist { 5846 if {[info exists ::g_dependHash($lmmod)]} { 5847 if {$manymod} { 5848 set hashdep [list $mod 1] 5849 } else { 5850 set hashdep [list $mod] 5851 } 5852 set ::g_dependHash($lmmod) [replaceFromList\ 5853 $::g_dependHash($lmmod) $hashdep] 5854 if {[llength $::g_dependHash($lmmod)] == 0} { 5855 unset ::g_dependHash($lmmod) 5856 } 5857 } 5858 } 5859 } 5860 # unset mod's 'depends on' relation 5861 reportDebug "unset requirements of '$mod'" 5862 unset ::g_moduleDepend($mod) 5863 5864 foreach lmmodlist $::g_moduleNPODepend($mod) { 5865 set manymod [expr {[llength $lmmodlist] > 1}] 5866 5867 # unset 'is depended by' mod relations 5868 foreach lmmod $lmmodlist { 5869 if {[info exists ::g_dependNPOHash($lmmod)]} { 5870 if {$manymod} { 5871 set hashdep [list $mod 1] 5872 } else { 5873 set hashdep [list $mod] 5874 } 5875 set ::g_dependNPOHash($lmmod) [replaceFromList\ 5876 $::g_dependNPOHash($lmmod) $hashdep] 5877 if {[llength $::g_dependNPOHash($lmmod)] == 0} { 5878 unset ::g_dependNPOHash($lmmod) 5879 } 5880 } 5881 } 5882 } 5883 # unset mod's No Particular Order 'depends on' relation 5884 reportDebug "unset NPO requirements of '$mod'" 5885 unset ::g_moduleNPODepend($mod) 5886 5887 # unset eventual violation states 5888 if {[info exists ::g_prereqViolation($mod)]} { 5889 reportDebug "unset prereq violation state for '$mod'" 5890 unset ::g_prereqViolation($mod) 5891 } 5892 if {[info exists ::g_prereqNPOViolation($mod)]} { 5893 reportDebug "unset NPO prereq violation state for '$mod'" 5894 unset ::g_prereqNPOViolation($mod) 5895 } 5896 unsetModuleConflictViolation $mod 5897 5898 # unset eventual registered unmet dependencies 5899 if {[info exists ::g_moduleUnmetDep($mod)]} { 5900 foreach ummod $::g_moduleUnmetDep($mod) { 5901 if {[info exists ::g_unmetDepHash($ummod)]} { 5902 set ::g_unmetDepHash($ummod) [replaceFromList\ 5903 $::g_unmetDepHash($ummod) $mod] 5904 if {[llength $::g_unmetDepHash($ummod)] == 0} { 5905 unset ::g_unmetDepHash($ummod) 5906 } 5907 } 5908 } 5909 reportDebug "unset unmet requirements for '$mod'" 5910 unset ::g_moduleUnmetDep($mod) 5911 } 5912 5913 # unset mod's 'is depended by' relations 5914 set hashdeplist [getDirectDependentList $mod] 5915 if {[llength $hashdeplist] > 0} { 5916 reportDebug "refresh dependent of '$mod'" 5917 foreach lmmod $hashdeplist { 5918 # refresh actual dependencies of targetting mod 5919 unsetModuleDependency $lmmod 5920 setModuleDependency $lmmod 5921 } 5922 } 5923} 5924 5925# returns if any loaded module (if passed mod is empty) or passed mod and all 5926# its requirement chain satisfy their loading constraints (prereq & conflict) 5927proc areModuleConstraintsSatisfied {{mod {}} {nporeq 0}} { 5928 set ret 1 5929 cacheCurrentModules 5930 5931 # are requirements loaded after their dependent included or not 5932 if {$nporeq} { 5933 set reqVioVar ::g_prereqNPOViolation 5934 set reqListVar ::g_moduleNPODepend 5935 } else { 5936 set reqVioVar ::g_prereqViolation 5937 set reqListVar ::g_moduleDepend 5938 } 5939 5940 # check if any loaded module violates its prereq or conflict constraints 5941 if {$mod eq {}} { 5942 if {[array size ::g_conflictViolation] > 0 || [array size\ 5943 $reqVioVar] > 0} { 5944 set ret 0 5945 } 5946 } else { 5947 set fulllist [list $mod] 5948 for {set i 0} {$i < [llength $fulllist]} {incr i 1} { 5949 set depmod [lindex $fulllist $i] 5950 5951 # check if depmod violates its prereq or conflict constraints 5952 if {[info exists ::g_conflictViolation($depmod)] || [info exists\ 5953 ${reqVioVar}($depmod)]} { 5954 # found violation among the requirement chain of mod so the 5955 # constraint of mod are not satisfied 5956 set ret 0 5957 break 5958 } 5959 # add requirements of depmod to the module to check list 5960 foreach lmmodlist [set ${reqListVar}($depmod)] { 5961 eval appendNoDupToList fulllist $lmmodlist 5962 } 5963 } 5964 } 5965 5966 return $ret 5967} 5968 5969# return list of loaded modules having an unmet requirement on passed mod 5970# and their recursive dependent 5971proc getUnmetDependentLoadedModuleList {mod} { 5972 reportDebug "get dependent of upcoming loaded '$mod'" 5973 set unmetdeplist {} 5974 set depmodlist {} 5975 defineModEqProc [isIcase] [getConf extended_default] 5976 5977 # skip dependent analysis if mod has a conflict with a loaded module 5978 lassign [doesModuleConflict $mod] doescon modconlist 5979 if {!$doescon} { 5980 foreach ummod [array names ::g_unmetDepHash] { 5981 if {[doesModuleMatchesName $mod $ummod]} { 5982 foreach depmod $::g_unmetDepHash($ummod) { 5983 lappend depmodlist $depmod 5984 # temporarily remove prereq violation of depmod if mod 5985 # load solves it (no other prereq is missing) 5986 if {[info exists ::g_prereqViolation($depmod)]} { 5987 foreach prereq $::g_prereqViolation($depmod) { 5988 foreach modpre $prereq { 5989 # also temporarily remove prereq violation for 5990 # requirements loaded after dependent module 5991 if {[doesModuleMatchesName $mod $modpre] ||\ 5992 [is-loaded $modpre]} { 5993 # backup original violation to restore it later 5994 if {![info exists preunvioarr($depmod)]} { 5995 set preunvioarr($depmod)\ 5996 $::g_prereqViolation($depmod) 5997 } 5998 # temporarily remove matching violation 5999 set ::g_prereqViolation($depmod) [replaceFromList\ 6000 $::g_prereqViolation($depmod) $prereq] 6001 if {[llength $::g_prereqViolation($depmod)] == 0} { 6002 unset ::g_prereqViolation($depmod) 6003 } 6004 break 6005 } 6006 } 6007 } 6008 } 6009 } 6010 } 6011 } 6012 } 6013 6014 # select dependent if all its constraint are now satisfied (after removing 6015 # eventual prereq violation toward mod) 6016 foreach depmod $depmodlist { 6017 if {[areModuleConstraintsSatisfied $depmod]} { 6018 appendNoDupToList unmetdeplist $depmod 6019 } 6020 } 6021 6022 # get dependent of dependent 6023 set deplist [getDependentLoadedModuleList $unmetdeplist 0 0 0 0 1] 6024 6025 # restore temporarily lift prereq violation 6026 if {[array exists preunvioarr]} { 6027 foreach depmod [array names preunvioarr] { 6028 set ::g_prereqViolation($depmod) $preunvioarr($depmod) 6029 } 6030 } 6031 6032 set sortlist [sortModulePerLoadedAndDepOrder [concat $unmetdeplist\ 6033 $deplist]] 6034 reportDebug "got '$sortlist'" 6035 return $sortlist 6036} 6037 6038# return list of loaded modules declaring a prereq on passed mod with 6039# distinction made with strong prereqs (no alternative loaded) or weak and 6040# also with prereq loaded after their dependent module 6041proc getDirectDependentList {mod {strong 0} {nporeq 0} {loading 0}\ 6042 {othmodlist {}}} { 6043 set deplist {} 6044 6045 # include or not requirements loaded after their dependent 6046 if {$nporeq} { 6047 set depListVar ::g_dependNPOHash 6048 set reqListVar ::g_moduleNPODepend 6049 } else { 6050 set depListVar ::g_dependHash 6051 set reqListVar ::g_moduleDepend 6052 } 6053 6054 if {[info exists ${depListVar}($mod)]} { 6055 foreach depmod [set ${depListVar}($mod)] { 6056 set add 1 6057 # skip optional dependency if only looking for strong ones 6058 # look at an additionally processed mod list to determine if all 6059 # mods from a dependent list (composed of optional parts) are part 6060 # of the search, which means mod is not optional but strong dependent 6061 if {$strong && [llength $depmod] > 1} { 6062 foreach lmmodlist [set ${reqListVar}([lindex $depmod 0])] { 6063 if {[isInList $lmmodlist $mod]} { 6064 foreach lmmod $lmmodlist { 6065 # other mod part of the opt list is not there so mod 6066 # is considered optional 6067 if {[notInList $othmodlist $lmmod]} { 6068 set add 0 6069 break 6070 } 6071 } 6072 break 6073 } 6074 } 6075 } 6076 6077 if {$add} { 6078 lappend deplist [lindex $depmod 0] 6079 } 6080 } 6081 } 6082 6083 # take currently loading modules into account if asked 6084 if {$loading} { 6085 set modlist [getLoadedModuleList] 6086 defineModEqProc [isIcase] [getConf extended_default] 6087 # reverse list to get closest match if returning lastly loaded module 6088 if {[getConf unload_match_order] eq {returnlast}} { 6089 set modlist [lreverse $modlist] 6090 } 6091 foreach loadingmod [getLoadingModuleList] { 6092 foreach prereq [getLoadedPrereq $loadingmod] { 6093 set lmprelist {} 6094 set moddep 0 6095 foreach modpre $prereq { 6096 foreach lmmod $modlist { 6097 if {[doesModuleMatchesName $lmmod $modpre]} { 6098 lappend lmprelist $lmmod 6099 if {$lmmod eq $mod} { 6100 set moddep 1 6101 } 6102 break 6103 } 6104 } 6105 } 6106 if {$moddep && (!$strong || [llength $lmprelist] == 1)} { 6107 lappend deplist $loadingmod 6108 break 6109 } 6110 } 6111 } 6112 } 6113 6114 return $deplist 6115} 6116 6117# gets the list of all loaded modules which are dependent of passed modlist 6118# ordered by load position. strong argument controls whether only the active 6119# dependent modules should be returned or also those that are optional. direct 6120# argument controls if only dependent module directly requiring passed mods 6121# should be returned or its full dependent tree. nporeq argument tells if 6122# requirement loaded after their dependent should be returned. sat_constraint 6123# argument controls whether only the loaded module satisfying their constraint 6124# should be part or not of the resulting list. being_unload argument controls 6125# whether loaded modules in conflict with one or multiple modules from modlist 6126# should be added to the dependent list as these modules are currently being 6127# unloaded and these conflicting loaded modules should be refreshed. 6128proc getDependentLoadedModuleList {modlist {strong 1} {direct 1} {nporeq 0}\ 6129 {loading 1} {sat_constraint 0} {being_unload 0}} { 6130 reportDebug "get loaded mod dependent of '$modlist' (strong=$strong,\ 6131 direct=$direct, nporeq=$nporeq, loading=$loading,\ 6132 sat_constraint=$sat_constraint, being_unload=$being_unload)" 6133 6134 set deplist {} 6135 set fulllist $modlist 6136 # look at consistent requirements for unloading modules 6137 set unlonporeq [expr {$being_unload ? 0 : $nporeq}] 6138 foreach mod $modlist { 6139 # no duplicates or modules from query list 6140 eval appendNoDupToList fulllist [getDirectDependentList $mod $strong\ 6141 $unlonporeq $loading $fulllist] 6142 } 6143 6144 if {$being_unload} { 6145 # invite modules in violation with mods to be part of the dependent list 6146 # with their own dependent modules as mod is being unloaded. Achieve so 6147 # by faking that conflict violation is gone 6148 foreach mod $modlist { 6149 lassign [doesModuleConflict $mod] doescon modconlist 6150 if {$doescon} { 6151 unsetModuleConflictViolation $mod 6152 set conunvioarr($mod) $modconlist 6153 eval appendNoDupToList fulllist $modconlist 6154 } 6155 } 6156 } 6157 set unloadingmodlist [getUnloadingModuleList] 6158 for {set i [llength $modlist]} {$i < [llength $fulllist]} {incr i 1} { 6159 set depmod [lindex $fulllist $i] 6160 6161 # skip already added mod or mod violating constraints if asked 6162 if {!$sat_constraint || [areModuleConstraintsSatisfied $depmod\ 6163 $nporeq]} { 6164 # get dependent mod of dep mod when looking at full dep tree 6165 if {!$direct} { 6166 eval appendNoDupToList fulllist [getDirectDependentList $depmod\ 6167 $strong $nporeq 0 $fulllist] 6168 } 6169 # avoid module currently unloading from result list 6170 if {[notInList $unloadingmodlist $depmod]} { 6171 lappend deplist $depmod 6172 } 6173 } 6174 } 6175 6176 # restore conflict violation if any 6177 if {[array exists conunvioarr]} { 6178 foreach conunvio [array names conunvioarr] { 6179 setModuleConflictViolation $conunvio $conunvioarr($conunvio) 6180 } 6181 } 6182 6183 # sort complete result list to match both loaded and dependency orders 6184 set sortlist [sortModulePerLoadedAndDepOrder $deplist $nporeq $loading] 6185 reportDebug "got '$sortlist'" 6186 return $sortlist 6187} 6188 6189# test if passed 'mod' could be automatically unloaded or not, which means it 6190# has been loaded automatically and no loaded modules require it anymore. 6191# unmodlist: pass a list of modules that are going to be unloaded 6192proc isModuleUnloadable {mod {unmodlist {}}} { 6193 set ret 1 6194 # get currently unloading modules if no specific unmodlist set 6195 if {[llength $unmodlist] == 0} { 6196 set unmodlist [getUnloadingModuleList] 6197 } 6198 6199 if {[isModuleUserAsked $mod]} { 6200 set ret 0 6201 } else { 6202 # mod is unloadable if all its dependent are unloaded or unloading 6203 foreach depmod [getDirectDependentList $mod] { 6204 if {[notInList $unmodlist $depmod]} { 6205 set ret 0 6206 break 6207 } 6208 } 6209 } 6210 6211 return $ret 6212} 6213 6214# gets the list of all loaded modules which are required by passed modlist 6215# ordered by load position. 6216proc getRequiredLoadedModuleList {modlist} { 6217 reportDebug "get mods required by '$modlist'" 6218 6219 # search over all list of loaded modules, starting with passed module 6220 # list, then adding in turns their requirements 6221 set fulllist $modlist 6222 for {set i 0} {$i < [llength $fulllist]} {incr i 1} { 6223 # gets the list of loaded modules which are required by depmod 6224 eval appendNoDupToList fulllist $::g_moduleDepend([lindex $fulllist $i]) 6225 } 6226 6227 # sort complete result list to match both loaded and dependency orders 6228 set sortlist [sortModulePerLoadedAndDepOrder [lrange $fulllist [llength\ 6229 $modlist] end]] 6230 reportDebug "got '$sortlist'" 6231 return $sortlist 6232} 6233 6234# finds required modules that can be unloaded if passed modules are unloaded: 6235# they have been loaded automatically and are not depended (mandatory or 6236# optionally) by other module 6237proc getUnloadableLoadedModuleList {modlist} { 6238 reportDebug "get unloadable mods once '$modlist' unloaded" 6239 6240 # search over all list of unloaded modules, starting with passed module 6241 # list, then adding in turns unloadable requirements 6242 set fulllist $modlist 6243 for {set i 0} {$i < [llength $fulllist]} {incr i 1} { 6244 set depmod [lindex $fulllist $i] 6245 # gets the list of loaded modules which are required by depmod 6246 set deplist {} 6247 foreach lmmodlist $::g_moduleDepend($depmod) { 6248 foreach lmmod $lmmodlist { 6249 if {[notInList $fulllist $lmmod]} { 6250 lappend deplist $lmmod 6251 } 6252 } 6253 } 6254 6255 # get those required module that have been automatically loaded and are 6256 # only required by modules currently being unloaded 6257 foreach lmmod $deplist { 6258 if {[isModuleUnloadable $lmmod $fulllist]} { 6259 lappend fulllist $lmmod 6260 } 6261 } 6262 } 6263 6264 # sort complete result list to match both loaded and dependency orders 6265 set sortlist [sortModulePerLoadedAndDepOrder [lrange $fulllist [llength\ 6266 $modlist] end]] 6267 reportDebug "got '$sortlist'" 6268 return $sortlist 6269} 6270 6271# runs the global RC files if they exist 6272proc runModulerc {} { 6273 set rclist {} 6274 6275 reportDebug running... 6276 6277 if {[set rcfile [getConf rcfile]] ne {}} { 6278 # if MODULERCFILE is a dir, look at a modulerc file in it 6279 if {[file isdirectory $rcfile]\ 6280 && [file isfile $rcfile/modulerc]} { 6281 lappend rclist $rcfile/modulerc 6282 } elseif {[file isfile $rcfile]} { 6283 lappend rclist $rcfile 6284 } 6285 } 6286 if {[file isfile @etcdir@/rc]} { 6287 lappend rclist @etcdir@/rc 6288 } 6289 if {[info exists ::env(HOME)] && [file isfile $::env(HOME)/.modulerc]} { 6290 lappend rclist $::env(HOME)/.modulerc 6291 } 6292 6293 foreach rc $rclist { 6294 if {[file readable $rc]} { 6295 reportDebug "Executing $rc" 6296 cmdModuleSource $rc 6297 lappendState rc_loaded $rc 6298 } 6299 } 6300 6301 # identify alias or symbolic version set in these global RC files to be 6302 # able to include them or not in output or resolution processes 6303 array set ::g_rcAlias [array get ::g_moduleAlias] 6304 array set ::g_rcVersion [array get ::g_moduleVersion] 6305 array set ::g_rcVirtual [array get ::g_moduleVirtual] 6306} 6307 6308# how many settings bundle are currently saved 6309proc getSavedSettingsStackDepth {} { 6310 return [llength $::g_SAVE_g_loadedModules] 6311} 6312 6313# manage settings to save as a stack to have a separate set of settings 6314# for each module loaded or unloaded in order to be able to restore the 6315# correct set in case of failure 6316proc pushSettings {} { 6317 foreach var {env g_clearedEnvVars g_Aliases g_stateEnvVars g_stateAliases\ 6318 g_stateFunctions g_Functions g_newXResources g_delXResources\ 6319 g_loadedModules g_loadedModuleFiles g_loadedModuleUasked\ 6320 g_loadedModuleConflict g_loadedModulePrereq g_loadedModuleAltname\ 6321 g_loadedModuleAutoAltname g_moduleDepend g_dependHash g_moduleNPODepend\ 6322 g_dependNPOHash g_prereqViolation g_prereqNPOViolation\ 6323 g_conflictViolation g_moduleUnmetDep g_unmetDepHash g_moduleEval} { 6324 eval "lappend ::g_SAVE_$var \[array get ::$var\]" 6325 } 6326 # save non-array variable and indication if it was set 6327 foreach var {g_changeDir g_stdoutPuts g_return_text} { 6328 if {[info exists ::$var]} { 6329 eval "lappend ::g_SAVE_$var \[list 1 \[set ::$var\]\]" 6330 } else { 6331 eval "lappend ::g_SAVE_$var \[list 0 {}\]" 6332 } 6333 } 6334 reportDebug "settings saved (#[getSavedSettingsStackDepth])" 6335} 6336 6337proc popSettings {} { 6338 set flushedid [getSavedSettingsStackDepth] 6339 foreach var {env g_clearedEnvVars g_Aliases g_stateEnvVars g_stateAliases\ 6340 g_stateFunctions g_Functions g_newXResources g_delXResources\ 6341 g_changeDir g_stdoutPuts g_return_text\ 6342 g_loadedModules g_loadedModuleFiles g_loadedModuleUasked\ 6343 g_loadedModuleConflict g_loadedModulePrereq g_loadedModuleAltname\ 6344 g_loadedModuleAutoAltname g_moduleDepend g_dependHash g_moduleNPODepend\ 6345 g_dependNPOHash g_prereqViolation g_prereqNPOViolation\ 6346 g_conflictViolation g_moduleUnmetDep g_unmetDepHash g_moduleEval} { 6347 eval "set ::g_SAVE_$var \[lrange \$::g_SAVE_$var 0 end-1\]" 6348 } 6349 reportDebug "previously saved settings flushed (#$flushedid)" 6350} 6351 6352proc restoreSettings {} { 6353 foreach var {g_clearedEnvVars g_Aliases g_stateEnvVars g_stateAliases\ 6354 g_stateFunctions g_Functions g_newXResources g_delXResources\ 6355 g_loadedModules g_loadedModuleFiles g_loadedModuleUasked\ 6356 g_loadedModuleConflict g_loadedModulePrereq g_loadedModuleAltname\ 6357 g_loadedModuleAutoAltname g_moduleDepend g_dependHash g_moduleNPODepend\ 6358 g_dependNPOHash g_prereqViolation g_prereqNPOViolation\ 6359 g_conflictViolation g_moduleUnmetDep g_unmetDepHash g_moduleEval} { 6360 # clear current $var arrays 6361 if {[info exists ::$var]} { 6362 eval "unset ::$var; array set ::$var {}" 6363 } 6364 eval "array set ::$var \[lindex \$::g_SAVE_$var end\]" 6365 } 6366 # specific restore mechanism for ::env as unsetting this array will make 6367 # Tcl stop monitoring env accesses and not update env variables anymore 6368 set envvarlist [list] 6369 foreach {var val} [lindex $::g_SAVE_env end] { 6370 lappend envvarlist $var 6371 interp-sync-env set $var $val 6372 } 6373 foreach var [array names ::env] { 6374 if {[notInList $envvarlist $var]} { 6375 interp-sync-env unset $var 6376 } 6377 } 6378 # restore non-array variable if it was set 6379 foreach var {g_changeDir g_stdoutPuts g_return_text} { 6380 if {[info exists ::$var]} { 6381 eval "unset ::$var" 6382 } 6383 eval "lassign \[lindex \$::g_SAVE_$var end\] isdefined val" 6384 if {$isdefined} { 6385 set ::$var $val 6386 } 6387 } 6388 reportDebug "previously saved settings restored\ 6389 (#[getSavedSettingsStackDepth])" 6390} 6391 6392proc renderSettings {} { 6393 global g_stateEnvVars g_stateAliases g_stateFunctions g_newXResources\ 6394 g_delXResources 6395 6396 reportDebug called. 6397 6398 # required to work on cygwin, shouldn't hurt real linux 6399 fconfigure stdout -translation lf 6400 6401 # preliminaries if there is stuff to render 6402 if {[getState autoinit] || [array size g_stateEnvVars] > 0 ||\ 6403 [array size g_stateAliases] > 0 || [array size g_newXResources] > 0 ||\ 6404 [array size g_stateFunctions] > 0 || [array size g_delXResources] > 0\ 6405 || [info exists ::g_changeDir] || [info exists ::g_stdoutPuts] ||\ 6406 [info exists ::g_return_text]} { 6407 switch -- [getState shelltype] { 6408 python { 6409 puts stdout {import os} 6410 } 6411 } 6412 set has_rendered 1 6413 } else { 6414 set has_rendered 0 6415 } 6416 6417 if {[getState autoinit]} { 6418 renderAutoinit 6419 } 6420 6421 # new environment variables 6422 foreach var [array names g_stateEnvVars] { 6423 switch -- $g_stateEnvVars($var) { 6424 new { 6425 switch -- [getState shelltype] { 6426 csh { 6427 set val [charEscaped $::env($var)] 6428 # csh barfs on long env vars 6429 if {[getState shell] eq {csh} && [string length $val] >\ 6430 [getConf csh_limit]} { 6431 if {$var eq {PATH}} { 6432 reportWarning "PATH exceeds [getConf csh_limit]\ 6433 characters, truncating and appending\ 6434 /usr/bin:/bin ..." 6435 set val [string range $val 0 [expr {[getConf\ 6436 csh_limit] - 1}]]:/usr/bin:/bin 6437 } else { 6438 reportWarning "$var exceeds [getConf csh_limit]\ 6439 characters, truncating..." 6440 set val [string range $val 0 [expr {[getConf\ 6441 csh_limit] - 1}]] 6442 } 6443 } 6444 puts stdout "setenv $var $val;" 6445 } 6446 sh { 6447 puts stdout "$var=[charEscaped $::env($var)];\ 6448 export $var;" 6449 } 6450 fish { 6451 set val [charEscaped $::env($var)] 6452 # fish shell has special treatment for PATH variable 6453 # so its value should be provided as a list separated 6454 # by spaces not by semi-colons 6455 if {$var eq {PATH}} { 6456 regsub -all : $val { } val 6457 } 6458 puts stdout "set -xg $var $val;" 6459 } 6460 tcl { 6461 set val $::env($var) 6462 puts stdout "set ::env($var) {$val};" 6463 } 6464 cmd { 6465 set val $::env($var) 6466 puts stdout "set $var=$val" 6467 } 6468 perl { 6469 set val [charEscaped $::env($var) \'] 6470 puts stdout "\$ENV{'$var'} = '$val';" 6471 } 6472 python { 6473 set val [charEscaped $::env($var) \'] 6474 puts stdout "os.environ\['$var'\] = '$val'" 6475 } 6476 ruby { 6477 set val [charEscaped $::env($var) \'] 6478 puts stdout "ENV\['$var'\] = '$val'" 6479 } 6480 lisp { 6481 set val [charEscaped $::env($var) \"] 6482 puts stdout "(setenv \"$var\" \"$val\")" 6483 } 6484 cmake { 6485 set val [charEscaped $::env($var) \"] 6486 puts stdout "set(ENV{$var} \"$val\")" 6487 } 6488 r { 6489 set val [charEscaped $::env($var) {\\'}] 6490 puts stdout "Sys.setenv('$var'='$val')" 6491 } 6492 } 6493 } 6494 del { 6495 switch -- [getState shelltype] { 6496 csh { 6497 puts stdout "unsetenv $var;" 6498 } 6499 sh { 6500 puts stdout "unset $var;" 6501 } 6502 fish { 6503 puts stdout "set -e $var;" 6504 } 6505 tcl { 6506 puts stdout "catch {unset ::env($var)};" 6507 } 6508 cmd { 6509 puts stdout "set $var=" 6510 } 6511 perl { 6512 puts stdout "delete \$ENV{'$var'};" 6513 } 6514 python { 6515 puts stdout "os.environ\['$var'\] = ''" 6516 puts stdout "del os.environ\['$var'\]" 6517 } 6518 ruby { 6519 puts stdout "ENV\['$var'\] = nil" 6520 } 6521 lisp { 6522 puts stdout "(setenv \"$var\" nil)" 6523 } 6524 cmake { 6525 puts stdout "unset(ENV{$var})" 6526 } 6527 r { 6528 puts stdout "Sys.unsetenv('$var')" 6529 } 6530 } 6531 } 6532 } 6533 } 6534 6535 foreach var [array names g_stateAliases] { 6536 switch -- $g_stateAliases($var) { 6537 new { 6538 set val $::g_Aliases($var) 6539 # convert $n in !!:n and $* in !* on csh (like on compat version) 6540 if {[getState shelltype] eq {csh}} { 6541 regsub -all {([^\\]|^)\$([0-9]+)} $val {\1!!:\2} val 6542 regsub -all {([^\\]|^)\$\*} $val {\1!*} val 6543 } 6544 # unescape \$ after now csh-specific conversion is over 6545 regsub -all {\\\$} $val {$} val 6546 switch -- [getState shelltype] { 6547 csh { 6548 set val [charEscaped $val] 6549 puts stdout "alias $var $val;" 6550 } 6551 sh { 6552 set val [charEscaped $val] 6553 puts stdout "alias $var=$val;" 6554 } 6555 fish { 6556 set val [charEscaped $val] 6557 puts stdout "alias $var $val;" 6558 } 6559 cmd { 6560 puts stdout "doskey $var=$val" 6561 } 6562 } 6563 } 6564 del { 6565 switch -- [getState shelltype] { 6566 csh { 6567 puts stdout "unalias $var;" 6568 } 6569 sh { 6570 puts stdout "unalias $var;" 6571 } 6572 fish { 6573 puts stdout "functions -e $var;" 6574 } 6575 cmd { 6576 puts stdout "doskey $var=" 6577 } 6578 } 6579 } 6580 } 6581 } 6582 foreach funcname [array names g_stateFunctions] { 6583 switch -- $g_stateFunctions($funcname) { 6584 new { 6585 # trim function body to smoothly add a finishing ; 6586 set val [string trim $::g_Functions($funcname) "; \t\n\r"] 6587 switch -- [getState shelltype] { 6588 sh { 6589 puts stdout "$funcname () { $val; }; export $funcname;" 6590 } 6591 fish { 6592 puts stdout "function $funcname; $val; end;" 6593 } 6594 } 6595 } 6596 del { 6597 switch -- [getState shelltype] { 6598 sh { 6599 puts stdout "unset -f $funcname;" 6600 } 6601 fish { 6602 puts stdout "functions -e $funcname;" 6603 } 6604 } 6605 } 6606 } 6607 } 6608 6609 # preliminaries for x-resources stuff 6610 if {[array size g_newXResources] > 0 || [array size g_delXResources] > 0} { 6611 switch -- [getState shelltype] { 6612 python { 6613 puts stdout {import subprocess} 6614 } 6615 ruby { 6616 puts stdout {require 'open3'} 6617 } 6618 } 6619 } 6620 6621 # new x resources 6622 if {[array size g_newXResources] > 0} { 6623 # xrdb executable has already be verified in x-resource 6624 set xrdb [getCommandPath xrdb] 6625 foreach var [array names g_newXResources] { 6626 set val $g_newXResources($var) 6627 # empty val means that var is a file to parse 6628 if {$val eq {}} { 6629 switch -- [getState shelltype] { 6630 sh - csh - fish { 6631 puts stdout "$xrdb -merge $var;" 6632 } 6633 tcl { 6634 puts stdout "exec $xrdb -merge $var;" 6635 } 6636 perl { 6637 puts stdout "system(\"$xrdb -merge $var\");" 6638 } 6639 python { 6640 set var [charEscaped $var \'] 6641 puts stdout "subprocess.Popen(\['$xrdb',\ 6642 '-merge', '$var'\])" 6643 } 6644 ruby { 6645 set var [charEscaped $var \'] 6646 puts stdout "Open3.popen2('$xrdb -merge $var')" 6647 } 6648 lisp { 6649 puts stdout "(shell-command-to-string \"$xrdb\ 6650 -merge $var\")" 6651 } 6652 cmake { 6653 puts stdout "execute_process(COMMAND $xrdb -merge $var)" 6654 } 6655 r { 6656 set var [charEscaped $var {\\'}] 6657 puts stdout "system('$xrdb -merge $var')" 6658 } 6659 } 6660 } else { 6661 switch -- [getState shelltype] { 6662 sh - csh - fish { 6663 set var [charEscaped $var \"] 6664 set val [charEscaped $val \"] 6665 puts stdout "echo \"$var: $val\" | $xrdb -merge;" 6666 } 6667 tcl { 6668 puts stdout "set XRDBPIPE \[open \"|$xrdb -merge\" r+\];" 6669 set var [charEscaped $var \"] 6670 set val [charEscaped $val \"] 6671 puts stdout "puts \$XRDBPIPE \"$var: $val\";" 6672 puts stdout {close $XRDBPIPE;} 6673 puts stdout {unset XRDBPIPE;} 6674 } 6675 perl { 6676 puts stdout "open(XRDBPIPE, \"|$xrdb -merge\");" 6677 set var [charEscaped $var \"] 6678 set val [charEscaped $val \"] 6679 puts stdout "print XRDBPIPE \"$var: $val\\n\";" 6680 puts stdout {close XRDBPIPE;} 6681 } 6682 python { 6683 set var [charEscaped $var \'] 6684 set val [charEscaped $val \'] 6685 puts stdout "subprocess.Popen(\['$xrdb', '-merge'\],\ 6686 stdin=subprocess.PIPE).communicate(input='$var:\ 6687 $val\\n')" 6688 } 6689 ruby { 6690 set var [charEscaped $var \'] 6691 set val [charEscaped $val \'] 6692 puts stdout "Open3.popen2('$xrdb -merge') {|i,o,t| i.puts\ 6693 '$var: $val'}" 6694 } 6695 lisp { 6696 puts stdout "(shell-command-to-string \"echo $var:\ 6697 $val | $xrdb -merge\")" 6698 } 6699 cmake { 6700 set var [charEscaped $var \"] 6701 set val [charEscaped $val \"] 6702 puts stdout "execute_process(COMMAND echo \"$var: $val\"\ 6703 COMMAND $xrdb -merge)" 6704 } 6705 r { 6706 set var [charEscaped $var {\\'}] 6707 set val [charEscaped $val {\\'}] 6708 puts stdout "system('$xrdb -merge', input='$var: $val')" 6709 } 6710 } 6711 } 6712 } 6713 } 6714 6715 if {[array size g_delXResources] > 0} { 6716 set xrdb [getCommandPath xrdb] 6717 set xres_to_del {} 6718 foreach var [array names g_delXResources] { 6719 # empty val means that var is a file to parse 6720 if {$g_delXResources($var) eq {}} { 6721 # xresource file has to be parsed to find what resources 6722 # are declared there and need to be unset 6723 foreach fline [split [exec $xrdb -n load $var] \n] { 6724 lappend xres_to_del [lindex [split $fline :] 0] 6725 } 6726 } else { 6727 lappend xres_to_del $var 6728 } 6729 } 6730 6731 # xresource strings are unset by emptying their value since there 6732 # is no command of xrdb that can properly remove one property 6733 switch -- [getState shelltype] { 6734 sh - csh - fish { 6735 foreach var $xres_to_del { 6736 puts stdout "echo \"$var:\" | $xrdb -merge;" 6737 } 6738 } 6739 tcl { 6740 foreach var $xres_to_del { 6741 puts stdout "set XRDBPIPE \[open \"|$xrdb -merge\" r+\];" 6742 set var [charEscaped $var \"] 6743 puts stdout "puts \$XRDBPIPE \"$var:\";" 6744 puts stdout {close $XRDBPIPE;} 6745 puts stdout {unset XRDBPIPE;} 6746 } 6747 } 6748 perl { 6749 foreach var $xres_to_del { 6750 puts stdout "open(XRDBPIPE, \"|$xrdb -merge\");" 6751 set var [charEscaped $var \"] 6752 puts stdout "print XRDBPIPE \"$var:\\n\";" 6753 puts stdout {close XRDBPIPE;} 6754 } 6755 } 6756 python { 6757 foreach var $xres_to_del { 6758 set var [charEscaped $var \'] 6759 puts stdout "subprocess.Popen(\['$xrdb', '-merge'\],\ 6760 stdin=subprocess.PIPE).communicate(input='$var:\\n')" 6761 } 6762 } 6763 ruby { 6764 foreach var $xres_to_del { 6765 set var [charEscaped $var \'] 6766 puts stdout "Open3.popen2('$xrdb -merge') {|i,o,t| i.puts\ 6767 '$var:'}" 6768 } 6769 } 6770 lisp { 6771 foreach var $xres_to_del { 6772 puts stdout "(shell-command-to-string \"echo $var: |\ 6773 $xrdb -merge\")" 6774 } 6775 } 6776 cmake { 6777 foreach var $xres_to_del { 6778 set var [charEscaped $var \"] 6779 puts stdout "execute_process(COMMAND echo \"$var:\"\ 6780 COMMAND $xrdb -merge)" 6781 } 6782 } 6783 r { 6784 foreach var $xres_to_del { 6785 set var [charEscaped $var {\\'}] 6786 puts stdout "system('$xrdb -merge', input='$var:')" 6787 } 6788 } 6789 } 6790 } 6791 6792 if {[info exists ::g_changeDir]} { 6793 switch -- [getState shelltype] { 6794 sh - csh - fish { 6795 puts stdout "cd '$::g_changeDir';" 6796 } 6797 tcl { 6798 puts stdout "cd \"$::g_changeDir\";" 6799 } 6800 cmd { 6801 puts stdout "cd $::g_changeDir" 6802 } 6803 perl { 6804 puts stdout "chdir '$::g_changeDir';" 6805 } 6806 python { 6807 puts stdout "os.chdir('$::g_changeDir')" 6808 } 6809 ruby { 6810 puts stdout "Dir.chdir('$::g_changeDir')" 6811 } 6812 lisp { 6813 puts stdout "(shell-command-to-string \"cd '$::g_changeDir'\")" 6814 } 6815 r { 6816 puts stdout "setwd('$::g_changeDir')" 6817 } 6818 } 6819 # cannot change current directory of cmake "shell" 6820 } 6821 6822 # send content deferred during modulefile interpretation 6823 if {[info exists ::g_stdoutPuts]} { 6824 foreach putsArgs $::g_stdoutPuts { 6825 eval puts $putsArgs 6826 # check if a finishing newline will be needed after content sent 6827 set needPutsNl [expr {[lindex $putsArgs 0] eq {-nonewline}}] 6828 } 6829 if {$needPutsNl} { 6830 puts stdout {} 6831 } 6832 } 6833 6834 # return text value if defined even if error happened 6835 if {[info exists ::g_return_text]} { 6836 reportDebug {text value should be returned.} 6837 renderText $::g_return_text 6838 } elseif {[getState error_count] > 0} { 6839 reportDebug "[getState error_count] error(s) detected." 6840 renderFalse 6841 } elseif {[getState return_false]} { 6842 reportDebug {false value should be returned.} 6843 renderFalse 6844 } elseif {$has_rendered} { 6845 # finish with true statement if something has been put 6846 renderTrue 6847 } 6848} 6849 6850proc renderAutoinit {} { 6851 reportDebug called. 6852 6853 # automatically detect which tclsh should be used for 6854 # future module commands 6855 set tclshbin [info nameofexecutable] 6856 6857 # ensure script path is absolute 6858 set ::argv0 [getAbsolutePath $::argv0] 6859 6860 switch -- [getState shelltype] { 6861 csh { 6862 set pre_hi {set _histchars = $histchars; unset histchars;} 6863 set post_hi {set histchars = $_histchars; unset _histchars;} 6864 set pre_pr {set _prompt=$prompt:q; set prompt="";} 6865 set post_pr {set prompt=$_prompt:q; unset _prompt;} 6866 # apply workaround for Tcsh history if set 6867 set eval_cmd [expr {[getConf wa_277] ? "eval `$tclshbin $::argv0\ 6868 [getState shell] \\!*`;" : "eval \"`$tclshbin $::argv0 [getState\ 6869 shell] \\!*:q`\";"}] 6870 set pre_ex {set _exit="$status";} 6871 set post_ex {test 0 = $_exit} 6872 6873 set fdef "if ( \$?histchars && \$?prompt )\ 6874alias module '$pre_hi $pre_pr $eval_cmd $pre_ex $post_hi $post_pr $post_ex' ; 6875if ( \$?histchars && ! \$?prompt )\ 6876alias module '$pre_hi $eval_cmd $pre_ex $post_hi $post_ex' ; 6877if ( ! \$?histchars && \$?prompt )\ 6878alias module '$pre_pr $eval_cmd $pre_ex $post_pr $post_ex' ; 6879if ( ! \$?histchars && ! \$?prompt ) alias module '$eval_cmd' ;" 6880 if {[getConf ml]} { 6881 append fdef { 6882alias ml 'module ml \!*' ;} 6883 } 6884 } 6885 sh { 6886 # Considering the diversity of ways local variables are handled 6887 # through the sh-variants ('local' known everywhere except on ksh, 6888 # 'typeset' known everywhere except on pure-sh, and on some systems 6889 # the pure-sh is in fact a 'ksh'), no local variables are defined and 6890 # these variables that should have been local are unset at the end 6891 6892 # on zsh, word splitting should be enabled explicitly 6893 set wsplit [expr {[getState shell] eq {zsh} ? {=} : {}}] 6894 # only redirect module from stderr to stdout when session is 6895 # attached to a terminal to avoid breaking non-terminal session 6896 # (scp, sftp, etc) 6897 set fname [expr {[getState is_stderr_tty] ? {_module_raw} : {module}}] 6898 # build quarantine mechanism in module function 6899 # an empty runtime variable is set even if no corresponding 6900 # MODULES_RUNENV_* variable found, as var cannot be unset on 6901 # modified environment command-line 6902 set fdef "${fname}() {" 6903@silentshdbgsupport@ append fdef { 6904@silentshdbgsupport@ unset _mlshdbg; 6905@silentshdbgsupport@ if [ "${MODULES_SILENT_SHELL_DEBUG:-0}" = '1' ]; then 6906@silentshdbgsupport@ case "$-" in 6907@silentshdbgsupport@ *v*x*) set +vx; _mlshdbg='vx' ;; 6908@silentshdbgsupport@ *v*) set +v; _mlshdbg='v' ;; 6909@silentshdbgsupport@ *x*) set +x; _mlshdbg='x' ;; 6910@silentshdbgsupport@ *) _mlshdbg='' ;; 6911@silentshdbgsupport@ esac; 6912@silentshdbgsupport@ fi;} 6913@quarantinesupport@ append fdef " 6914@quarantinesupport@ unset _mlre _mlIFS; 6915@quarantinesupport@ if \[ -n \"\${IFS+x}\" \]; then 6916@quarantinesupport@ _mlIFS=\$IFS; 6917@quarantinesupport@ fi; 6918@quarantinesupport@ IFS=' '; 6919@quarantinesupport@ for _mlv in \${${wsplit}MODULES_RUN_QUARANTINE:-}; do" 6920@quarantinesupport@ append fdef { 6921@quarantinesupport@ if [ "${_mlv}" = "${_mlv##*[!A-Za-z0-9_]}" -a "${_mlv}" = "${_mlv#[0-9]}" ]; then 6922@quarantinesupport@ if [ -n "`eval 'echo ${'$_mlv'+x}'`" ]; then 6923@quarantinesupport@ _mlre="${_mlre:-}${_mlv}_modquar='`eval 'echo ${'$_mlv'}'`' "; 6924@quarantinesupport@ fi; 6925@quarantinesupport@ _mlrv="MODULES_RUNENV_${_mlv}"; 6926@quarantinesupport@ _mlre="${_mlre:-}${_mlv}='`eval 'echo ${'$_mlrv':-}'`' "; 6927@quarantinesupport@ fi; 6928@quarantinesupport@ done; 6929@quarantinesupport@ if [ -n "${_mlre:-}" ]; then} 6930@quarantinesupport@ append fdef "\n eval `eval \${${wsplit}_mlre} $tclshbin $::argv0\ 6931@quarantinesupport@[getState shell] '\"\$@\"'`; 6932@quarantinesupport@ else 6933@quarantinesupport@ eval `$tclshbin $::argv0 [getState shell] \"\$@\"`; 6934@quarantinesupport@ fi;" 6935@notquarantinesupport@ append fdef " 6936@notquarantinesupport@ eval `$tclshbin $::argv0 [getState shell] \"\$@\"`;" 6937 append fdef { 6938 _mlstatus=$?;} 6939@quarantinesupport@ append fdef { 6940@quarantinesupport@ if [ -n "${_mlIFS+x}" ]; then 6941@quarantinesupport@ IFS=$_mlIFS; 6942@quarantinesupport@ else 6943@quarantinesupport@ unset IFS; 6944@quarantinesupport@ fi; 6945@quarantinesupport@ unset _mlre _mlv _mlrv _mlIFS;} 6946@silentshdbgsupport@ append fdef { 6947@silentshdbgsupport@ if [ -n "${_mlshdbg:-}" ]; then 6948@silentshdbgsupport@ set -$_mlshdbg; 6949@silentshdbgsupport@ fi; 6950@silentshdbgsupport@ unset _mlshdbg;} 6951 append fdef { 6952 return $_mlstatus;} 6953 append fdef "\n};" 6954 if {[getState is_stderr_tty]} { 6955 append fdef "\nmodule() { _module_raw \"\$@\" 2>&1; };" 6956 } 6957 if {[getConf ml]} { 6958 append fdef { 6959ml() { module ml "$@"; };} 6960 } 6961 } 6962 fish { 6963 set fdef [expr {[getState is_stderr_tty] ? "function _module_raw\n" :\ 6964 "function module\n"}] 6965@quarantinesupport@ append fdef { set -l _mlre ''; set -l _mlv; set -l _mlrv; 6966@quarantinesupport@ for _mlv in (string split ' ' $MODULES_RUN_QUARANTINE) 6967@quarantinesupport@ if string match -r '^[A-Za-z_][A-Za-z0-9_]*$' $_mlv >/dev/null 6968@quarantinesupport@ if set -q $_mlv 6969@quarantinesupport@ set _mlre $_mlre$_mlv"_modquar='$$_mlv' " 6970@quarantinesupport@ end 6971@quarantinesupport@ set _mlrv "MODULES_RUNENV_$_mlv" 6972@quarantinesupport@ set _mlre "$_mlre$_mlv='$$_mlrv' " 6973@quarantinesupport@ end 6974@quarantinesupport@ end 6975@quarantinesupport@ if [ -n "$_mlre" ] 6976@quarantinesupport@ set _mlre "env $_mlre" 6977@quarantinesupport@ end} 6978 # use "| source -" rather than "eval" to be able 6979 # to redirect stderr after stdout being evaluated 6980@quarantinesupport@ append fdef "\n eval \$_mlre $tclshbin $::argv0 [getState shell]\ 6981 (string escape -- \$argv) | source -\n" 6982@notquarantinesupport@ append fdef " eval $tclshbin $::argv0 [getState shell]\ 6983 (string escape -- \$argv) | source -\n" 6984 if {[getState is_stderr_tty]} { 6985 append fdef {end 6986function module 6987 _module_raw $argv 2>&1 6988end} 6989 } else { 6990 append fdef end 6991 } 6992 if {[getConf ml]} { 6993 append fdef { 6994function ml 6995 module ml $argv 6996end} 6997 } 6998 } 6999 tcl { 7000 set fdef "proc module {args} {" 7001@quarantinesupport@ append fdef { 7002@quarantinesupport@ set _mlre {}; 7003@quarantinesupport@ if {[info exists ::env(MODULES_RUN_QUARANTINE)]} { 7004@quarantinesupport@ foreach _mlv [split $::env(MODULES_RUN_QUARANTINE) " "] { 7005@quarantinesupport@ if {[regexp {^[A-Za-z_][A-Za-z0-9_]*$} $_mlv]} { 7006@quarantinesupport@ if {[info exists ::env($_mlv)]} { 7007@quarantinesupport@ lappend _mlre "${_mlv}_modquar=$::env($_mlv)" 7008@quarantinesupport@ } 7009@quarantinesupport@ set _mlrv "MODULES_RUNENV_${_mlv}" 7010@quarantinesupport@ lappend _mlre [expr {[info exists ::env($_mlrv)] ?\ 7011 "${_mlv}=$::env($_mlrv)" : "${_mlv}="}] 7012@quarantinesupport@ } 7013@quarantinesupport@ } 7014@quarantinesupport@ if {[llength $_mlre] > 0} { 7015@quarantinesupport@ set _mlre [linsert $_mlre 0 "env"] 7016@quarantinesupport@ } 7017@quarantinesupport@ }} 7018 append fdef { 7019 set _mlstatus 1;} 7020@quarantinesupport@ append fdef "\n catch {eval exec \$_mlre \"$tclshbin\"\ 7021 \"$::argv0\" \"[getState shell]\" \$args 2>@stderr} script\n" 7022@notquarantinesupport@ append fdef "\n catch {eval exec \"$tclshbin\"\ 7023 \"$::argv0\" \"[getState shell]\" \$args 2>@stderr} script\n" 7024 append fdef { eval $script; 7025 return $_mlstatus} 7026 append fdef "\n}" 7027 if {[getConf ml]} { 7028 append fdef { 7029proc ml {args} { 7030 return [eval module ml $args] 7031}} 7032 } 7033 } 7034 cmd { 7035 reportErrorAndExit {No autoinit mode available for 'cmd' shell} 7036 } 7037 perl { 7038 set fdef "sub module {" 7039@quarantinesupport@ append fdef { 7040@quarantinesupport@ my $_mlre = ''; 7041@quarantinesupport@ if (defined $ENV{'MODULES_RUN_QUARANTINE'}) { 7042@quarantinesupport@ foreach my $_mlv (split(' ', $ENV{'MODULES_RUN_QUARANTINE'})) { 7043@quarantinesupport@ if ($_mlv =~ /^[A-Za-z_][A-Za-z0-9_]*$/) { 7044@quarantinesupport@ if (defined $ENV{$_mlv}) { 7045@quarantinesupport@ $_mlre .= "${_mlv}_modquar='$ENV{$_mlv}' "; 7046@quarantinesupport@ } 7047@quarantinesupport@ my $_mlrv = "MODULES_RUNENV_$_mlv"; 7048@quarantinesupport@ $_mlre .= "$_mlv='$ENV{$_mlrv}' "; 7049@quarantinesupport@ } 7050@quarantinesupport@ } 7051@quarantinesupport@ if ($_mlre ne "") { 7052@quarantinesupport@ $_mlre = "env $_mlre"; 7053@quarantinesupport@ } 7054@quarantinesupport@ }} 7055 append fdef { 7056 my $args = ''; 7057 if (@_ > 0) { 7058 $args = '"' . join('" "', @_) . '"'; 7059 } 7060 my $_mlstatus = 1;} 7061@quarantinesupport@ append fdef "\n eval `\${_mlre}$tclshbin $::argv0 perl \$args`;\n" 7062@notquarantinesupport@ append fdef "\n eval `$tclshbin $::argv0 perl \$args`;\n" 7063 append fdef { return $_mlstatus;} 7064 append fdef "\n}" 7065 if {[getConf ml]} { 7066 append fdef { 7067sub ml { 7068 return module('ml', @_); 7069}} 7070 } 7071 } 7072 python { 7073 set fdef {import re, subprocess 7074def module(*arguments):} 7075@quarantinesupport@ append fdef { 7076@quarantinesupport@ _mlre = os.environ.copy() 7077@quarantinesupport@ if 'MODULES_RUN_QUARANTINE' in os.environ: 7078@quarantinesupport@ for _mlv in os.environ['MODULES_RUN_QUARANTINE'].split(): 7079@quarantinesupport@ if re.match('^[A-Za-z_][A-Za-z0-9_]*$', _mlv): 7080@quarantinesupport@ if _mlv in os.environ: 7081@quarantinesupport@ _mlre[_mlv + '_modquar'] = os.environ[_mlv] 7082@quarantinesupport@ _mlrv = 'MODULES_RUNENV_' + _mlv 7083@quarantinesupport@ if _mlrv in os.environ: 7084@quarantinesupport@ _mlre[_mlv] = os.environ[_mlrv] 7085@quarantinesupport@ else: 7086@quarantinesupport@ _mlre[_mlv] = ''} 7087 append fdef { 7088 ns = {}} 7089@quarantinesupport@ append fdef "\n exec(subprocess.Popen(\['$tclshbin',\ 7090 '$::argv0', 'python'\] + list(arguments),\ 7091 stdout=subprocess.PIPE, env=_mlre).communicate()\[0\], ns)\n" 7092@notquarantinesupport@ append fdef "\n exec(subprocess.Popen(\['$tclshbin',\ 7093 '$::argv0', 'python'\] + list(arguments),\ 7094 stdout=subprocess.PIPE).communicate()\[0\], ns)\n" 7095 append fdef { if '_mlstatus' in ns: 7096 _mlstatus = ns['_mlstatus'] 7097 else: 7098 _mlstatus = True 7099 return _mlstatus} 7100 if {[getConf ml]} { 7101 append fdef { 7102def ml(*arguments): 7103 return module('ml', *arguments) 7104} 7105 } 7106 } 7107 ruby { 7108 set fdef {class ENVModule 7109 def ENVModule.module(*args)} 7110@quarantinesupport@ append fdef { 7111@quarantinesupport@ _mlre = '' 7112@quarantinesupport@ if ENV.has_key?('MODULES_RUN_QUARANTINE') then 7113@quarantinesupport@ ENV['MODULES_RUN_QUARANTINE'].split(' ').each do |_mlv| 7114@quarantinesupport@ if _mlv =~ /^[A-Za-z_][A-Za-z0-9_]*$/ then 7115@quarantinesupport@ if ENV.has_key?(_mlv) then 7116@quarantinesupport@ _mlre << _mlv + "_modquar='" + ENV[_mlv].to_s + "' " 7117@quarantinesupport@ end 7118@quarantinesupport@ _mlrv = 'MODULES_RUNENV_' + _mlv 7119@quarantinesupport@ _mlre << _mlv + "='" + ENV[_mlrv].to_s + "' " 7120@quarantinesupport@ end 7121@quarantinesupport@ end 7122@quarantinesupport@ unless _mlre.empty? 7123@quarantinesupport@ _mlre = 'env ' + _mlre 7124@quarantinesupport@ end 7125@quarantinesupport@ end} 7126 append fdef { 7127 if args[0].kind_of?(Array) then 7128 args = args[0] 7129 end 7130 if args.length == 0 then 7131 args = '' 7132 else 7133 args = "\"#{args.join('" "')}\"" 7134 end 7135 _mlstatus = true} 7136@quarantinesupport@ append fdef "\n eval `#{_mlre}$tclshbin $::argv0 ruby #{args}`\n" 7137@notquarantinesupport@ append fdef "\n eval `$tclshbin $::argv0 ruby #{args}`\n" 7138 append fdef { return _mlstatus 7139 end} 7140 if {[getConf ml]} { 7141 append fdef { 7142 def ENVModule.ml(*args) 7143 return ENVModule.module('ml', *args) 7144 end} 7145 } 7146 append fdef { 7147end} 7148 } 7149 lisp { 7150 reportErrorAndExit {lisp mode autoinit not yet implemented} 7151 } 7152 cmake { 7153@quarantinesupport@ set pre_exec "\n execute_process(COMMAND \${_mlre} $tclshbin\ 7154 $::argv0 cmake " 7155@notquarantinesupport@ set pre_exec "\n execute_process(COMMAND $tclshbin\ 7156 $::argv0 cmake " 7157 set post_exec "\n OUTPUT_FILE \${tempfile_name})\n" 7158 set fdef {function(module) 7159 cmake_policy(SET CMP0007 NEW)} 7160@quarantinesupport@ append fdef { 7161@quarantinesupport@ set(_mlre "") 7162@quarantinesupport@ if(DEFINED ENV{MODULES_RUN_QUARANTINE}) 7163@quarantinesupport@ string(REPLACE " " ";" _mlv_list "$ENV{MODULES_RUN_QUARANTINE}") 7164@quarantinesupport@ foreach(_mlv ${_mlv_list}) 7165@quarantinesupport@ if(${_mlv} MATCHES "^[A-Za-z_][A-Za-z0-9_]*$") 7166@quarantinesupport@ if(DEFINED ENV{${_mlv}}) 7167@quarantinesupport@ set(_mlre "${_mlre}${_mlv}_modquar=$ENV{${_mlv}};") 7168@quarantinesupport@ endif() 7169@quarantinesupport@ set(_mlrv "MODULES_RUNENV_${_mlv}") 7170@quarantinesupport@ set(_mlre "${_mlre}${_mlv}=$ENV{${_mlrv}};") 7171@quarantinesupport@ endif() 7172@quarantinesupport@ endforeach() 7173@quarantinesupport@ if (NOT "${_mlre}" STREQUAL "") 7174@quarantinesupport@ set(_mlre "env;${_mlre}") 7175@quarantinesupport@ endif() 7176@quarantinesupport@ endif()} 7177 append fdef { 7178 set(_mlstatus TRUE) 7179 execute_process(COMMAND mktemp -t moduleinit.cmake.XXXXXXXXXXXX 7180 OUTPUT_VARIABLE tempfile_name 7181 OUTPUT_STRIP_TRAILING_WHITESPACE) 7182 if(${ARGC} EQUAL 1)} 7183 # adapt command definition depending on the number of args to be 7184 # able to pass to some extend (<5 args) empty string element to 7185 # modulecmd (no other way as empty element in ${ARGV} are skipped 7186 append fdef "$pre_exec\"\${ARGV0}\"$post_exec" 7187 append fdef { elseif(${ARGC} EQUAL 2)} 7188 append fdef "$pre_exec\"\${ARGV0}\" \"\${ARGV1}\"$post_exec" 7189 append fdef { elseif(${ARGC} EQUAL 3)} 7190 append fdef "$pre_exec\"\${ARGV0}\" \"\${ARGV1}\"\ 7191 \"\${ARGV2}\"$post_exec" 7192 append fdef { elseif(${ARGC} EQUAL 4)} 7193 append fdef "$pre_exec\"\${ARGV0}\" \"\${ARGV1}\"\ 7194 \"\${ARGV2}\" \"\${ARGV3}\"$post_exec" 7195 append fdef { else()} 7196 append fdef "$pre_exec\${ARGV}$post_exec" 7197 append fdef { endif() 7198 if(EXISTS ${tempfile_name}) 7199 include(${tempfile_name}) 7200 file(REMOVE ${tempfile_name}) 7201 endif() 7202 set(module_result ${_mlstatus} PARENT_SCOPE) 7203endfunction(module)} 7204 if {[getConf ml]} { 7205 append fdef { 7206function(ml) 7207 module(ml ${ARGV}) 7208 set(module_result ${module_result} PARENT_SCOPE) 7209endfunction(ml)} 7210 } 7211 } 7212 r { 7213 set fdef "module <- function(...){" 7214@quarantinesupport@ append fdef { 7215@quarantinesupport@ mlre <- '' 7216@quarantinesupport@ if (!is.na(Sys.getenv('MODULES_RUN_QUARANTINE', unset=NA))) { 7217@quarantinesupport@ for (mlv in strsplit(Sys.getenv('MODULES_RUN_QUARANTINE'), ' ')[[1]]) { 7218@quarantinesupport@ if (grepl('^[A-Za-z_][A-Za-z0-9_]*$', mlv)) { 7219@quarantinesupport@ if (!is.na(Sys.getenv(mlv, unset=NA))) { 7220@quarantinesupport@ mlre <- paste0(mlre, mlv, "_modquar='", Sys.getenv(mlv), "' ") 7221@quarantinesupport@ } 7222@quarantinesupport@ mlrv <- paste0('MODULES_RUNENV_', mlv) 7223@quarantinesupport@ mlre <- paste0(mlre, mlv, "='", Sys.getenv(mlrv), "' ") 7224@quarantinesupport@ } 7225@quarantinesupport@ } 7226@quarantinesupport@ if (mlre != '') { 7227@quarantinesupport@ mlre <- paste0('env ', mlre) 7228@quarantinesupport@ } 7229@quarantinesupport@ }} 7230 append fdef { 7231 arglist <- as.list(match.call()) 7232 arglist[1] <- 'r' 7233 args <- paste0('"', paste0(arglist, collapse='" "'), '"')} 7234@quarantinesupport@ append fdef "\n cmd <- paste(mlre, '$tclshbin', '$::argv0', args,\ 7235 sep=' ')\n" 7236@notquarantinesupport@ append fdef "\n cmd <- paste('$tclshbin', '$::argv0', args,\ 7237 sep=' ')\n" 7238 append fdef { mlstatus <- TRUE 7239 hndl <- pipe(cmd) 7240 eval(expr = parse(file=hndl)) 7241 close(hndl) 7242 invisible(mlstatus)} 7243 append fdef "\n}" 7244 if {[getConf ml]} { 7245 append fdef { 7246ml <- function(...){ 7247 module('ml', ...) 7248}} 7249 } 7250 } 7251 } 7252 7253 # output function definition 7254 puts stdout $fdef 7255} 7256 7257proc cacheCurrentModules {} { 7258 # parse loaded modules information only once, global arrays are updated 7259 # afterwards when module commands update loaded modules state 7260 if {![isStateDefined lm_info_cached]} { 7261 setState lm_info_cached 1 7262 # mark specific as well as generic modules as loaded 7263 set i 0 7264 set modfilelist [getLoadedModuleFileList] 7265 set modlist [getLoadedModuleList] 7266 set nuaskedlist [getLoadedModuleNotUserAskedList] 7267 7268 if {[llength $modlist] == [llength $modfilelist]} { 7269 # cache declared alternative names of loaded modules 7270 foreach modalt [getLoadedModuleAltnameList] { 7271 eval setLoadedAltname $modalt 7272 } 7273 7274 # cache declared source-sh of loaded modules 7275 foreach modsrcsh [getLoadedModuleSourceShList] { 7276 eval setLoadedSourceSh $modsrcsh 7277 } 7278 7279 # cache declared conflict of loaded modules 7280 foreach modcon [getLoadedModuleConflictList] { 7281 # parse module version specification to record translation 7282 foreach modconelt [lrange $modcon 1 end] { 7283 eval parseModuleVersionSpecifier 0 $modconelt 7284 } 7285 eval setLoadedConflict $modcon 7286 } 7287 7288 # cache declared prereq of loaded modules, prior to setLoadedModule 7289 # which triggers dependency chain build 7290 foreach modpre [getLoadedModulePrereqList] { 7291 # parse module version specification to record translation 7292 foreach modpreeltlist [lrange $modpre 1 end] { 7293 foreach modpreelt $modpreeltlist { 7294 eval parseModuleVersionSpecifier 0 $modpreelt 7295 } 7296 } 7297 eval setLoadedPrereq $modpre 7298 } 7299 7300 foreach mod $modlist { 7301 setLoadedModule $mod [lindex $modfilelist $i] [notInList\ 7302 $nuaskedlist $mod] 7303 incr i 7304 } 7305 7306 reportDebug "$i loaded" 7307 } else { 7308 reportErrorAndExit "Loaded environment state is\ 7309 inconsistent\nLOADEDMODULES=$modlist\n_LMFILES_=$modfilelist" 7310 } 7311 } 7312} 7313 7314# This proc resolves module aliases or version aliases to the real module name 7315# and version. 7316proc resolveModuleVersionOrAlias {name icase} { 7317 set name [getArrayKey ::g_moduleResolved $name $icase] 7318 if {[info exists ::g_moduleResolved($name)]} { 7319 set ret $::g_moduleResolved($name) 7320 } else { 7321 set ret $name 7322 } 7323 7324 reportTrace "'$name' into '$ret'" Resolve 7325 return $ret 7326} 7327 7328proc charEscaped {str {charlist { \\\t\{\}|<>!;#^$&*?"'`()}}} { 7329 return [regsub -all "\(\[$charlist\]\)" $str {\\\1}] 7330} 7331 7332proc charUnescaped {str {charlist { \\\t\{\}|<>!;#^$&*?"'`()}}} { 7333 return [regsub -all "\\\\\(\[$charlist\]\)" $str {\1}] 7334} 7335 7336proc strTo {lang str {esc 1}} { 7337 switch -- $lang { 7338 tcl { set enco \{; set encc \}} 7339 shell { set enco '; set encc '} 7340 } 7341 # escape all special characters 7342 if {$esc} { 7343 set str [charEscaped $str] 7344 } 7345 # enclose if empty or if contain a space character unless already escaped 7346 if {$str eq {} || (!$esc && [regexp {\s} $str])} { 7347 set str "$enco$str$encc" 7348 } 7349 return $str 7350} 7351 7352proc listTo {lang lst {esc 1}} { 7353 set lout [list] 7354 # transform each list element 7355 foreach str $lst { 7356 lappend lout [strTo $lang $str $esc] 7357 } 7358 return [join $lout { }] 7359} 7360 7361# find command path and remember it 7362proc getCommandPath {cmd} { 7363 return [lindex [auto_execok $cmd] 0] 7364} 7365 7366# find then run command or raise error if command not found 7367proc runCommand {cmd args} { 7368 set cmdpath [getCommandPath $cmd] 7369 if {$cmdpath eq {}} { 7370 knerror "Command '$cmd' cannot be found" MODULES_ERR_GLOBAL 7371 } else { 7372 return [eval exec $cmdpath $args] 7373 } 7374} 7375 7376proc getAbsolutePath {path} { 7377 # currently executing a modulefile or rc, so get the directory of this file 7378 if {$::ModulesCurrentModulefile ne {}} { 7379 set curdir [file dirname $::ModulesCurrentModulefile] 7380 # elsewhere get module command current working directory 7381 } else { 7382 # register pwd at first call 7383 if {![isStateDefined cwd]} { 7384 setState cwd [pwd] 7385 } 7386 set curdir [getState cwd] 7387 } 7388 7389 # empty result if empty path 7390 if {$path eq {}} { 7391 set abspath {} 7392 } else { 7393 set abslist {} 7394 # get a first version of the absolute path by joining the current 7395 # working directory to the given path. if given path is already absolute 7396 # 'file join' will not break it as $curdir will be ignored as soon a 7397 # beginning '/' character is found on $path. this first pass also clean 7398 # extra '/' character. then each element of the path is analyzed to 7399 # clear "." and ".." components. 7400 foreach elt [file split [file join $curdir $path]] { 7401 if {$elt eq {..}} { 7402 # skip ".." element if it comes after root element, remove last 7403 # element elsewhere 7404 if {[llength $abslist] > 1} { 7405 set abslist [lreplace $abslist end end] 7406 } 7407 # skip any "." element 7408 } elseif {$elt ne {.}} { 7409 lappend abslist $elt 7410 } 7411 } 7412 set abspath [eval file join $abslist] 7413 } 7414 7415 # return cleaned absolute path 7416 return $abspath 7417} 7418 7419# if no exact match found but icase mode is enabled then search if an icase 7420# match exists among all array key elements, select dictionary highest version 7421# if multiple icase matches are returned 7422proc getArrayKey {arrname name icase} { 7423 if {$icase} { 7424 upvar $arrname arr 7425 if {![info exists arr($name)]} { 7426 foreach elt [lsort -dictionary -decreasing [array names arr]] { 7427 if {[string equal -nocase $name $elt]} { 7428 reportDebug "key '$elt' in array '$arrname' matches '$name'" 7429 set name $elt 7430 break 7431 } 7432 } 7433 } 7434 } 7435 return $name 7436} 7437 7438# Define procedure to compare module names set as array keys against pattern. 7439# Adapt procedure code whether implicit_default is enabled or disabled 7440proc defineGetEqArrayKeyProc {icase extdfl impdfl} { 7441 set procname getEqArrayKeyProc 7442 if {$impdfl} { 7443 append procname Impdfl 7444 } 7445 7446 # define proc if not done yet or if it was defined for another context 7447 if {[info procs getEqArrayKey] eq {} || $::g_getEqArrayKey_proc ne\ 7448 $procname} { 7449 if {[info exists ::g_getEqArrayKey_proc]} { 7450 rename ::getEqArrayKey ::$::g_getEqArrayKey_proc 7451 } 7452 rename ::$procname ::getEqArrayKey 7453 set ::g_getEqArrayKey_proc $procname 7454 } 7455 7456 # also define modEq which is called by getEqArrayKey 7457 defineModEqProc $icase $extdfl 7458} 7459 7460# alternative definitions of getEqArrayKey proc 7461proc getEqArrayKeyProcImpdfl {arrname name} { 7462 set icase [isIcase] 7463 upvar $arrname arr 7464 7465 # extract single module specified if any 7466 lassign [getModuleVersSpec $name] mod modname 7467 # check name eventual icase match 7468 set mod [getArrayKey arr [string trimright $mod /] $icase] 7469 7470 if {$mod ne {} && [info exists arr($mod)]} { 7471 set match $mod 7472 } else { 7473 set mlist {} 7474 foreach elt [array names arr] { 7475 if {[modEq $name $elt]} { 7476 lappend mlist $elt 7477 } 7478 } 7479 if {[llength $mlist] == 1} { 7480 set match [lindex $mlist 0] 7481 # in case multiple modules match query, check directory default and 7482 # return it if it is part of match list, elsewhere return highest result 7483 } elseif {[llength $mlist] > 1} { 7484 # get corresponding icase parent directory 7485 set pname [getArrayKey arr $modname $icase] 7486 if {[info exists arr($pname)]} { 7487 set dfl $pname/[lindex $arr($pname) 1] 7488 } 7489 # resolve symbolic version entries 7490 foreach elt $mlist { 7491 if {[lindex $arr($elt) 0] eq {version}} { 7492 lappend mrlist [lindex $arr($elt) 1] 7493 } else { 7494 lappend mrlist $elt 7495 } 7496 } 7497 if {[info exists dfl] && [isInList $mrlist $dfl]} { 7498 set match $dfl 7499 } else { 7500 set match [lindex [lsort -dictionary $mrlist] end] 7501 } 7502 } 7503 } 7504 if {[info exists match]} { 7505 reportDebug "key '$match' in array '$arrname' matches '$name'" 7506 set name $match 7507 } 7508 return $name 7509} 7510proc getEqArrayKeyProc {arrname name} { 7511 set icase [isIcase] 7512 upvar $arrname arr 7513 7514 lassign [getModuleVersSpec $name] mod modname 7515 # check name eventual icase match 7516 set mod [getArrayKey arr [string trimright $mod /] $icase] 7517 7518 if {$mod ne {} && [info exists arr($mod)]} { 7519 set match $mod 7520 } else { 7521 set mlist {} 7522 foreach elt [array names arr] { 7523 if {[modEq $name $elt]} { 7524 lappend mlist $elt 7525 } 7526 } 7527 # must have a default part of result even if only one result 7528 if {[llength $mlist] >= 1} { 7529 # get corresponding icase parent directory 7530 set pname [getArrayKey arr $modname $icase] 7531 if {[info exists arr($pname)]} { 7532 set dfl $pname/[lindex $arr($pname) 1] 7533 } 7534 # resolve symbolic version entries 7535 foreach elt $mlist { 7536 if {[lindex $arr($elt) 0] eq {version}} { 7537 lappend mrlist [lindex $arr($elt) 1] 7538 } else { 7539 lappend mrlist $elt 7540 } 7541 } 7542 if {[info exists dfl] && [isInList $mrlist $dfl]} { 7543 set match $dfl 7544 } else { 7545 # raise error as no default part of result 7546 upvar retlist retlist 7547 set retlist [list {} $name none "No default version\ 7548 defined for '$name'"] 7549 } 7550 } 7551 } 7552 if {[info exists match]} { 7553 reportDebug "key '$match' in array '$arrname' matches '$name'" 7554 set name $match 7555 } 7556 return $name 7557} 7558 7559# split string while ignore any separator character that is espaced 7560proc psplit {str sep} { 7561 # use standard split if no sep character found 7562 if {[string first \\$sep $str] == -1} { 7563 set res [split $str $sep] 7564 } else { 7565 set previdx -1 7566 set idx [string first $sep $str] 7567 while {$idx != -1} { 7568 # look ahead if found separator is escaped 7569 if {[string index $str [expr {$idx-1}]] ne "\\"} { 7570 # unescape any separator character when adding to list 7571 lappend res [charUnescaped [string range $str [expr {$previdx+1}]\ 7572 [expr {$idx-1}]] $sep] 7573 set previdx $idx 7574 } 7575 set idx [string first $sep $str [expr {$idx+1}]] 7576 } 7577 7578 lappend res [charUnescaped [string range $str [expr {$previdx+1}] end]\ 7579 $sep] 7580 } 7581 7582 return $res 7583} 7584 7585# join list while escape any character equal to separator 7586proc pjoin {lst sep} { 7587 # use standard join if no sep character found 7588 if {[string first $sep $lst] == -1} { 7589 set res [join $lst $sep] 7590 } else { 7591 set res {} 7592 foreach elt $lst { 7593 # preserve empty entries 7594 if {[info exists not_first]} { 7595 append res $sep 7596 } else { 7597 set not_first 1 7598 } 7599 # escape any separator character when adding to string 7600 append res [charEscaped $elt $sep] 7601 } 7602 } 7603 7604 return $res 7605} 7606 7607# Dictionary-style string comparison 7608# Use dictionary sort of lsort proc to compare two strings in the "string 7609# compare" fashion (returning -1, 0 or 1). Tcl dictionary-style comparison 7610# enables to compare software versions (ex: "1.10" is greater than "1.8") 7611proc compareVersion {str1 str2} { 7612 if {$str1 eq $str2} { 7613 return 0 7614 # put both strings in a list, then lsort it and get first element 7615 } elseif {[lindex [lsort -dictionary [list $str1 $str2]] 0] eq $str1} { 7616 return -1 7617 } else { 7618 return 1 7619 } 7620} 7621 7622# Is provided string a version number: consider first element of string if 7623# '.' character used in it. [0-9af] on this first part is considered valid 7624# anything else could be used in latter elements 7625proc isVersion {str} { 7626 return [string is xdigit -strict [lindex [split $str .] 0]] 7627} 7628 7629# Return number of occurences of passed character in passed string 7630proc countChar {str char} { 7631 return [expr {[string length $str] - [string length [string map [list\ 7632 $char {}] $str]]}] 7633} 7634 7635# provide a lreverse proc for Tcl8.4 and earlier 7636if {[info commands lreverse] eq {}} { 7637 proc lreverse {l} { 7638 set r [list] 7639 for {set i [expr {[llength $l] - 1}]} {$i >= 0} {incr i -1} { 7640 lappend r [lindex $l $i] 7641 } 7642 return $r 7643 } 7644} 7645 7646# provide a lassign proc for Tcl8.4 and earlier 7647if {[info commands lassign] eq {}} { 7648 proc lassign {values args} { 7649 uplevel 1 [list foreach $args [linsert $values end {}] break] 7650 lrange $values [llength $args] end 7651 } 7652} 7653 7654proc isInList {lst elt} { 7655 return [expr {[lsearch -exact $lst $elt] != -1}] 7656} 7657 7658proc notInList {lst elt} { 7659 return [expr {[lsearch -exact $lst $elt] == -1}] 7660} 7661 7662proc appendNoDupToList {lstname args} { 7663 set ret 0 7664 upvar $lstname lst 7665 foreach elt $args { 7666 if {![info exists lst] || [notInList $lst $elt]} { 7667 lappend lst $elt 7668 set ret 1 7669 } 7670 } 7671 return $ret 7672} 7673 7674proc replaceFromList {list1 item {item2 {}}} { 7675 while {[set xi [lsearch -exact $list1 $item]] >= 0} { 7676 set list1 [if {[string length $item2] == 0} {lreplace $list1 $xi $xi}\ 7677 {lreplace $list1 $xi $xi $item2}] 7678 } 7679 7680 return $list1 7681} 7682 7683# test if 2 lists have at least one element in common 7684proc isIntBetweenList {list1 list2} { 7685 foreach elt $list1 { 7686 if {[isInList $list2 $elt]} { 7687 return 1 7688 } 7689 } 7690 return 0 7691} 7692 7693# returns elements from list1 not part of list2 and elements from list2 not 7694# part of list1 7695proc getDiffBetweenList {list1 list2} { 7696 set res1 [list] 7697 set res2 [list] 7698 7699 foreach elt $list1 { 7700 if {[notInList $list2 $elt]} { 7701 lappend res1 $elt 7702 } 7703 } 7704 foreach elt $list2 { 7705 if {[notInList $list1 $elt]} { 7706 lappend res2 $elt 7707 } 7708 } 7709 7710 return [list $res1 $res2] 7711} 7712 7713# return elements from arr1 not in arr2, elements from arr1 in arr2 but with a 7714# different value and elements from arr2 not in arr1 7715proc getDiffBetweenArray {arrname1 arrname2} { 7716 upvar $arrname1 arr1 7717 upvar $arrname2 arr2 7718 set notin2 [list] 7719 set diff [list] 7720 set notin1 [list] 7721 7722 foreach name [array names arr1] { 7723 # element in arr1 not in arr2 7724 if {![info exists arr2($name)]} { 7725 lappend notin2 $name 7726 # element present in both arrays but with a different value 7727 } elseif {$arr1($name) ne $arr2($name)} { 7728 lappend diff $name 7729 } 7730 } 7731 7732 foreach name [array names arr2] { 7733 # element in arr2 not in arr1 7734 if {![info exists arr1($name)]} { 7735 lappend notin1 $name 7736 } 7737 } 7738 7739 return [list $notin2 $diff $notin1] 7740} 7741 7742proc parseAccessIssue {modfile} { 7743 # retrieve and return access issue message 7744 if {[regexp {POSIX .* \{(.*)\}$} $::errorCode match errMsg]} { 7745 return "[string totitle $errMsg] on '$modfile'" 7746 } else { 7747 return "Cannot access '$modfile'" 7748 } 7749} 7750 7751proc checkValidModule {modfile} { 7752 reportDebug $modfile 7753 7754 # test file only once, cache result obtained to minimize file query 7755 return [expr {[info exists ::g_modfileValid($modfile)]\ 7756 ? $::g_modfileValid($modfile)\ 7757 : [set ::g_modfileValid($modfile) [readModuleContent $modfile 1 1 1]]}] 7758} 7759 7760# get file modification time, cache it at first query, use cache afterward 7761proc getFileMtime {fpath} { 7762 if {[info exists ::g_fileMtime($fpath)]} { 7763 return $::g_fileMtime($fpath) 7764 } else { 7765 return [set ::g_fileMtime($fpath) [file mtime $fpath]] 7766 } 7767} 7768 7769# define proc that will be used as fallback to command provided by extension 7770# library in case this library is not loaded 7771proc __readFile {filename {firstline 0}} { 7772 set fid [open $filename r] 7773 set fdata [if {$firstline} {gets $fid} {read $fid}] 7774 close $fid 7775 return $fdata 7776} 7777 7778proc readModuleContent {modfile {report_read_issue 0} {must_have_cookie 1}\ 7779 {only_check_validity 0}} { 7780 reportDebug $modfile 7781 set res {} 7782 7783 # read file 7784 if {[catch { 7785 if {[info exists ::g_modfileContent($modfile)]} { 7786 lassign $::g_modfileContent($modfile) fh fdata 7787 } else { 7788 # only read beginning of file if just checking validity and not 7789 # asked to always fully read files 7790 set fdata [readFile $modfile [expr {$only_check_validity &&\ 7791 ![currentAlwaysReadFullFile]}]] 7792 # extract magic cookie (first word of modulefile) 7793 set fh [string trimright [lindex [split [string range $fdata 0 32]]\ 7794 0] #] 7795 # cache full file read to minimize file operations 7796 if {!$only_check_validity || [currentAlwaysReadFullFile]} { 7797 set ::g_modfileContent($modfile) [list $fh $fdata] 7798 } 7799 } 7800 } errMsg ]} { 7801 if {$report_read_issue} { 7802 set msg [parseAccessIssue $modfile] 7803 if {$only_check_validity} { 7804 set res [list accesserr $msg] 7805 } else { 7806 reportError $msg 7807 } 7808 } 7809 } else { 7810 # check module validity if magic cookie is mandatory 7811 if {$must_have_cookie && ![string equal -length 8 $fh {#%Module}]} { 7812 set msg {Magic cookie '#%Module' missing} 7813 if {$only_check_validity} { 7814 set res [list invalid $msg] 7815 } else { 7816 reportInternalBug $msg $modfile 7817 } 7818 # check if min version requirement is met if magic cookie is mandatory 7819 } elseif {$must_have_cookie && [string length $fh] > 8 &&\ 7820 [compareVersion {@MODULES_RELEASE@} [string range $fh 8 end]] <0} { 7821 set msg "Modulefile requires at least Modules version [string range\ 7822 $fh 8 end]" 7823 if {$only_check_validity} { 7824 set res [list invalid $msg] 7825 } else { 7826 reportInternalBug $msg $modfile 7827 } 7828 } else { 7829 if {$only_check_validity} { 7830 # set validity information as result 7831 set res [list true {}] 7832 } else { 7833 # set file content as result 7834 set res $fdata 7835 } 7836 } 7837 } 7838 7839 return $res 7840} 7841 7842# If given module maps to default or other symbolic versions, a list of 7843# those versions is returned. This takes module/version as an argument. 7844proc getVersAliasList {mod} { 7845 set tag_list {} 7846 if {[info exists ::g_symbolHash($mod)]} { 7847 set tag_list $::g_symbolHash($mod) 7848 # withdraw hidden symbol from list 7849 if {[info exists ::g_hiddenSymHash($mod)]} { 7850 lassign [getDiffBetweenList $tag_list $::g_hiddenSymHash($mod)]\ 7851 tag_list 7852 } 7853 } 7854 7855 reportDebug "'$mod' has tag list '$tag_list'" 7856 return $tag_list 7857} 7858 7859proc doesModuleHaveSym {mod} { 7860 # is there any non-hidden symbol for mod 7861 return [expr {[info exists ::g_symbolHash($mod)] && (![info exists\ 7862 ::g_hiddenSymHash($mod)] || [llength [lindex [getDiffBetweenList\ 7863 $::g_symbolHash($mod) $::g_hiddenSymHash($mod)] 0]] > 0)}] 7864} 7865 7866# get list of elements located in a directory passed as argument. a flag is 7867# set after each element to know if it is considered hidden or not. a 7868# fetch_dotversion argument controls whether .version file should be looked at 7869# in directory .proc will be used as a fallback to command provided by 7870# extension library 7871proc __getFilesInDirectory {dir fetch_dotversion} { 7872 set dir_list [list] 7873 7874 # try then catch any issue rather than test before trying 7875 # workaround 'glob -nocomplain' which does not return permission 7876 # error on Tcl 8.4, so we need to avoid registering issue if 7877 # raised error is about a no match 7878 if {[catch {set elt_list [glob $dir/*]} errMsg]} { 7879 if {$errMsg eq "no files matched glob pattern \"$dir/*\""} { 7880 set elt_list {} 7881 } else { 7882 # rethrow other error to catch it in caller proc 7883 error $errMsg $::errorInfo $::errorCode 7884 } 7885 } 7886 7887 # Add each element in the current directory to the list 7888 foreach elt $elt_list { 7889 lappend dir_list $elt 0 7890 } 7891 7892 # search for hidden files 7893 foreach elt [glob -nocomplain -types hidden -directory $dir -tails *] { 7894 switch -- $elt { 7895 . - .. { } 7896 .modulerc - .version { 7897 if {($fetch_dotversion || $elt ne {.version}) && [file readable\ 7898 $dir/$elt]} { 7899 lappend dir_list $dir/$elt 0 7900 } 7901 } 7902 default { 7903 lappend dir_list $dir/$elt 1 7904 } 7905 } 7906 } 7907 7908 return $dir_list 7909} 7910 7911# Check a module name does match query at expected depth level when indepth 7912# search is disabled. Define procedure on the fly to adapt its 7913# code to indepth configuration option and querydepth and test mode params. 7914proc defineDoesModMatchAtDepthProc {indepth querydepth test} { 7915 set procprops $indepth:$querydepth:$test 7916 7917 # define proc if not done yet or if it was defined for another context 7918 if {[info procs doesModMatchAtDepth] eq {} ||\ 7919 $::g_doesModMatchAtDepth_procprops ne $procprops} { 7920 if {[info exists ::g_doesModMatchAtDepth_procprops]} { 7921 rename ::doesModMatchAtDepth {} 7922 } 7923 set ::g_doesModMatchAtDepth_procprops $procprops 7924 7925 # define optimized procedure 7926 if {$indepth} { 7927 set atdepth {$mod} 7928 } else { 7929 set atdepth "\[join \[lrange \[split \$mod /\] 0 $querydepth\] /\]" 7930 } 7931 proc doesModMatchAtDepth {mod} "return \[modEqStatic $atdepth $test *\]" 7932 } 7933} 7934 7935# Define procedure to check module version equals pattern. Adapt procedure 7936# code whether icase and extended_default are enabled or disabled 7937proc defineModVersCmpProc {icase extdfl} { 7938 set procname modVersCmpProc 7939 if {$icase} { 7940 append procname Icase 7941 } 7942 if {$extdfl} { 7943 append procname Extdfl 7944 } 7945 7946 # define proc if not done yet or if it was defined for another context 7947 if {[info procs modVersCmp] eq {} || $::g_modVersCmp_proc ne $procname} { 7948 if {[info exists ::g_modVersCmp_proc]} { 7949 rename ::modVersCmp ::$::g_modVersCmp_proc 7950 } 7951 rename ::$procname ::modVersCmp 7952 set ::g_modVersCmp_proc $procname 7953 } 7954} 7955 7956# alternative definitions of modVersCmp proc 7957proc modVersCmpProc {cmpspec versspec modvers test {psuf {}}} { 7958 set ret 0 7959 switch -- $cmpspec { 7960 in { 7961 foreach vers $versspec { 7962 append vers $psuf 7963 if {$test eq {eqstart}} { 7964 set ret [string equal -length [string length $vers/] $vers/\ 7965 $modvers/] 7966 } else { 7967 set ret [string $test $vers $modvers] 7968 } 7969 if {$ret} { 7970 break 7971 } 7972 } 7973 } 7974 ge { 7975 # as we work here on a version range: psuf suffix is ignored, checks 7976 # are always extended_default-enabled (as 1.2 includes 1.2.12 for 7977 # instance) and equal, eqstart and match tests are equivalent 7978 set ret [expr {[isVersion $modvers] && ([compareVersion $modvers\ 7979 $versspec] != -1 || [string match $versspec.* $modvers])}] 7980 } 7981 le { 7982 # 'ge' comment also applies here 7983 set ret [expr {[isVersion $modvers] && ([compareVersion $versspec\ 7984 $modvers] != -1 || [string match $versspec.* $modvers])}] 7985 } 7986 be { 7987 # 'ge' comment also applies here 7988 lassign $versspec lovers hivers 7989 set ret [expr {[isVersion $modvers] && ([compareVersion $modvers\ 7990 $lovers] != -1 || [string match $lovers.* $modvers]) &&\ 7991 ([compareVersion $hivers $modvers] != -1 || [string match\ 7992 $hivers.* $modvers])}] 7993 } 7994 } 7995 return $ret 7996} 7997proc modVersCmpProcIcase {cmpspec versspec modvers test {psuf {}}} { 7998 set ret 0 7999 switch -- $cmpspec { 8000 in { 8001 foreach vers $versspec { 8002 append vers $psuf 8003 if {$test eq {eqstart}} { 8004 set ret [string equal -nocase -length [string length $vers/]\ 8005 $vers/ $modvers/] 8006 } else { 8007 set ret [string $test -nocase $vers $modvers] 8008 } 8009 if {$ret} { 8010 break 8011 } 8012 } 8013 } 8014 ge { 8015 set ret [expr {[isVersion $modvers] && ([compareVersion $modvers\ 8016 $versspec] != -1 || [string match -nocase $versspec.* $modvers])}] 8017 } 8018 le { 8019 set ret [expr {[isVersion $modvers] && ([compareVersion $versspec\ 8020 $modvers] != -1 || [string match -nocase $versspec.* $modvers])}] 8021 } 8022 be { 8023 lassign $versspec lovers hivers 8024 set ret [expr {[isVersion $modvers] && ([compareVersion $modvers\ 8025 $lovers] != -1 || [string match $lovers.* $modvers]) &&\ 8026 ([compareVersion $hivers $modvers] != -1 || [string match -nocase\ 8027 $hivers.* $modvers])}] 8028 } 8029 } 8030 return $ret 8031} 8032proc modVersCmpProcExtdfl {cmpspec versspec modvers test {psuf {}}} { 8033 set ret 0 8034 switch -- $cmpspec { 8035 in { 8036 foreach vers $versspec { 8037 append vers $psuf 8038 if {$test eq {eqstart}} { 8039 set ret [string equal -length [string length $vers/] $vers/\ 8040 $modvers/] 8041 } else { 8042 set ret [string $test $vers $modvers] 8043 } 8044 if {$ret || [string match $vers.* $modvers]} { 8045 set ret 1 8046 break 8047 } 8048 } 8049 } 8050 ge { 8051 set ret [expr {[isVersion $modvers] && ([compareVersion $modvers\ 8052 $versspec] != -1 || [string match $versspec.* $modvers])}] 8053 } 8054 le { 8055 set ret [expr {[isVersion $modvers] && ([compareVersion $versspec\ 8056 $modvers] != -1 || [string match $versspec.* $modvers])}] 8057 } 8058 be { 8059 lassign $versspec lovers hivers 8060 set ret [expr {[isVersion $modvers] && ([compareVersion $modvers\ 8061 $lovers] != -1 || [string match $lovers.* $modvers]) &&\ 8062 ([compareVersion $hivers $modvers] != -1 || [string match\ 8063 $hivers.* $modvers])}] 8064 } 8065 } 8066 return $ret 8067} 8068proc modVersCmpProcIcaseExtdfl {cmpspec versspec modvers test {psuf {}}} { 8069 set ret 0 8070 switch -- $cmpspec { 8071 in { 8072 # check if one version in list matches 8073 foreach vers $versspec { 8074 append vers $psuf 8075 if {$test eq {eqstart}} { 8076 set ret [string equal -nocase -length [string length $vers/]\ 8077 $vers/ $modvers/] 8078 } else { 8079 set ret [string $test -nocase $vers $modvers] 8080 } 8081 # try the extended default match 8082 if {$ret || [string match -nocase $vers.* $modvers]} { 8083 set ret 1 8084 break 8085 } 8086 } 8087 } 8088 ge { 8089 set ret [expr {[isVersion $modvers] && ([compareVersion $modvers\ 8090 $versspec] != -1 || [string match -nocase $versspec.* $modvers])}] 8091 } 8092 le { 8093 set ret [expr {[isVersion $modvers] && ([compareVersion $versspec\ 8094 $modvers] != -1 || [string match -nocase $versspec.* $modvers])}] 8095 } 8096 be { 8097 lassign $versspec lovers hivers 8098 set ret [expr {[isVersion $modvers] && ([compareVersion $modvers\ 8099 $lovers] != -1 || [string match $lovers.* $modvers]) &&\ 8100 ([compareVersion $hivers $modvers] != -1 || [string match -nocase\ 8101 $hivers.* $modvers])}] 8102 } 8103 } 8104 return $ret 8105} 8106 8107# Setup a hardwire version of modEq procedure called modEqStatic. This 8108# optimized procedure already knows the module pattern to compare to, whose 8109# specification has already been resolved at procedure definition time, which 8110# saves lot of processing time. 8111proc defineModEqStaticProc {icase extdfl modspec} { 8112 set procprops $icase:$extdfl:$modspec 8113 8114 # define proc if not done yet or if it was defined for another context 8115 if {[info procs modEqStatic] eq {} || $::g_modEqStatic_procprops ne\ 8116 $procprops} { 8117 if {[info exists ::g_modEqStatic_procprops]} { 8118 rename ::modEqStatic {} 8119 } else { 8120 # also define modVersCmp which is called by modEqStatic 8121 defineModVersCmpProc $icase $extdfl 8122 } 8123 set ::g_modEqStatic_procprops $procprops 8124 8125 # define optimized procedure 8126 lassign [getModuleVersSpec $modspec] pmod pmodname cmpspec versspec\ 8127 pmodnamere pmodescglob 8128 # trim dup trailing / char and adapt pmod suffix if it starts with / 8129 if {[string index $pmod end] eq {/}} { 8130 set pmod [string trimright $pmod /]/ 8131 set endwslash 1 8132 } else { 8133 set endwslash 0 8134 } 8135 set nocasearg [expr {$icase ? {-nocase } : {}}] 8136 set pmodnameslen [string length $pmodname/] 8137 if {$pmod ne {} || $modspec eq {}} { 8138 set procbody " 8139 set pmod {$pmod} 8140 if {\$psuf ne {}} { 8141 if {$endwslash && \[string index \$psuf 0\] eq {/}} { 8142 append pmod \[string range \$psuf 1 end\] 8143 } else { 8144 append pmod \$psuf 8145 } 8146 } 8147 if {\$test eq {eqstart}} { 8148 set ret \[string equal $nocasearg-length \[string length\ 8149 \$pmod/\] \$pmod/ \$mod/\] 8150 } else { 8151 if {\$test eq {matchin}} { 8152 set test match 8153 set pmod *\$pmod 8154 } 8155 set ret \[string \$test $nocasearg\$pmod \$mod\] 8156 }" 8157 if {$extdfl} { 8158 append procbody " 8159 if {!\$ret && \[string first / \$pmod\] != -1} { 8160 if {\$test eq {match}} { 8161 set pmodextdfl \$pmod.* 8162 } else { 8163 set pmodextdfl {$pmodescglob.*} 8164 } 8165 set ret \[string match $nocasearg\$pmodextdfl \$mod\] 8166 }" 8167 } 8168 } else { 8169 set procbody " 8170 set pmodname {$pmodname} 8171 set pmodnamere {$pmodnamere} 8172 if {\$test eq {matchin}} { 8173 set test match 8174 if {\$pmodnamere ne {}} { 8175 set pmodnamere .*\$pmodnamere 8176 } else { 8177 set pmodnamere {.*$pmodname} 8178 } 8179 } 8180 if {(\$pmodnamere ne {} && \$test eq {match} && \[regexp\ 8181 $nocasearg (^\$pmodnamere)/ \$mod/ rematch pmodname\]) ||\ 8182 \[string equal $nocasearg -length $pmodnameslen {$pmodname/}\ 8183 \$mod/\]} { 8184 set modvers \[string range \$mod \[string length \$pmodname/\]\ 8185 end\] 8186 set ret \[modVersCmp {$cmpspec} {$versspec} \$modvers \$test\ 8187 \$psuf\] 8188 } else { 8189 set ret 0 8190 }" 8191 } 8192 append procbody " 8193 return \$ret" 8194 proc modEqStatic {mod {test equal} {psuf {}}} $procbody 8195 } 8196} 8197 8198# Define procedure to check module name equals pattern. Adapt procedure 8199# code whether icase and extended_default are enabled or disabled 8200proc defineModEqProc {icase extdfl} { 8201 set procname modEqProc 8202 if {$icase} { 8203 append procname Icase 8204 } 8205 if {$extdfl} { 8206 append procname Extdfl 8207 } 8208 8209 # define proc if not done yet or if it was defined for another context 8210 if {[info procs modEq] eq {} || $::g_modEq_proc ne $procname} { 8211 if {[info exists ::g_modEq_proc]} { 8212 rename ::modEq ::$::g_modEq_proc 8213 } 8214 rename ::$procname ::modEq 8215 set ::g_modEq_proc $procname 8216 } 8217 8218 # also define modVersCmp which is called by modEq 8219 defineModVersCmpProc $icase $extdfl 8220} 8221 8222# alternative definitions of modEq proc 8223proc modEqProc {pattern mod {test equal} {trspec 1} {psuf {}}} { 8224 # extract specified module name from name and version spec 8225 if {$trspec} { 8226 lassign [getModuleVersSpec $pattern] pmod pmodname cmpspec versspec\ 8227 pmodnamere pmodescglob 8228 } else { 8229 set pmod $pattern 8230 } 8231 # trim dup trailing / char and adapt pmod suffix if it starts with / 8232 if {[string index $pmod end] eq {/}} { 8233 set pmod [string trimright $pmod /]/ 8234 set endwslash 1 8235 } else { 8236 set endwslash 0 8237 } 8238 # specified module can be translated in a simple mod name/vers or is empty 8239 if {$pmod ne {} || $pattern eq {}} { 8240 if {$psuf ne {}} { 8241 if {$endwslash && [string index $psuf 0] eq {/}} { 8242 append pmod [string range $psuf 1 end] 8243 } else { 8244 append pmod $psuf 8245 } 8246 } 8247 if {$test eq {eqstart}} { 8248 set ret [string equal -length [string length $pmod/] $pmod/ $mod/] 8249 } else { 8250 # contains test 8251 if {$test eq {matchin}} { 8252 set test match 8253 set pmod *$pmod 8254 } elseif {$test eq {eqspec}} { 8255 set test equal 8256 } 8257 set ret [string $test $pmod $mod] 8258 } 8259 } elseif {$test eq {eqspec}} { 8260 # test equality against all version described in spec (list or range 8261 # boundaries), trspec is considered enabled and psuf empty 8262 foreach pmod [getAllModulesFromVersSpec $pattern] { 8263 if {[set ret [string equal $pmod $mod]]} { 8264 break 8265 } 8266 } 8267 } else { 8268 # contains test 8269 if {$test eq {matchin}} { 8270 set test match 8271 if {$pmodnamere ne {}} { 8272 set pmodnamere .*$pmodnamere 8273 } else { 8274 set pmodnamere .*$pmodname 8275 } 8276 } 8277 # for more complex specification, first check if module name matches 8278 # use a regexp test if module name contains wildcard characters 8279 if {($pmodnamere ne {} && $test eq {match} && [regexp (^$pmodnamere)/\ 8280 $mod/ rematch pmodname]) || [string equal -length [string length\ 8281 $pmodname/] $pmodname/ $mod/]} { 8282 # then compare versions 8283 set modvers [string range $mod [string length $pmodname/] end] 8284 set ret [modVersCmp $cmpspec $versspec $modvers $test $psuf] 8285 } else { 8286 set ret 0 8287 } 8288 } 8289 return $ret 8290} 8291proc modEqProcIcase {pattern mod {test equal} {trspec 1} {psuf {}}} { 8292 if {$trspec} { 8293 lassign [getModuleVersSpec $pattern] pmod pmodname cmpspec versspec\ 8294 pmodnamere pmodescglob 8295 } else { 8296 set pmod $pattern 8297 } 8298 if {[string index $pmod end] eq {/}} { 8299 set pmod [string trimright $pmod /]/ 8300 set endwslash 1 8301 } else { 8302 set endwslash 0 8303 } 8304 if {$pmod ne {} || $pattern eq {}} { 8305 if {$psuf ne {}} { 8306 if {$endwslash && [string index $psuf 0] eq {/}} { 8307 append pmod [string range $psuf 1 end] 8308 } else { 8309 append pmod $psuf 8310 } 8311 } 8312 if {$test eq {eqstart}} { 8313 set ret [string equal -nocase -length [string length $pmod/] $pmod/\ 8314 $mod/] 8315 } else { 8316 # contains test 8317 if {$test eq {matchin}} { 8318 set test match 8319 set pmod *$pmod 8320 } elseif {$test eq {eqspec}} { 8321 set test equal 8322 } 8323 set ret [string $test -nocase $pmod $mod] 8324 } 8325 } elseif {$test eq {eqspec}} { 8326 # test equality against all version described in spec (list or range 8327 # boundaries), trspec is considered enabled and psuf empty 8328 foreach pmod [getAllModulesFromVersSpec $pattern] { 8329 if {[set ret [string equal -nocase $pmod $mod]]} { 8330 break 8331 } 8332 } 8333 } else { 8334 # contains test 8335 if {$test eq {matchin}} { 8336 set test match 8337 if {$pmodnamere ne {}} { 8338 set pmodnamere .*$pmodnamere 8339 } else { 8340 set pmodnamere .*$pmodname 8341 } 8342 } 8343 # for more complex specification, first check if module name matches 8344 # use a regexp test if module name contains wildcard characters 8345 if {($pmodnamere ne {} && $test eq {match} && [regexp -nocase\ 8346 (^$pmodnamere)/ $mod/ rematch pmodname]) || [string equal -nocase\ 8347 -length [string length $pmodname/] $pmodname/ $mod/]} { 8348 # then compare versions 8349 set modvers [string range $mod [string length $pmodname/] end] 8350 set ret [modVersCmp $cmpspec $versspec $modvers $test $psuf] 8351 } else { 8352 set ret 0 8353 } 8354 } 8355 return $ret 8356} 8357proc modEqProcExtdfl {pattern mod {test equal} {trspec 1} {psuf {}}} { 8358 if {$trspec} { 8359 lassign [getModuleVersSpec $pattern] pmod pmodname cmpspec versspec\ 8360 pmodnamere pmodescglob 8361 } else { 8362 set pmod $pattern 8363 } 8364 if {[string index $pmod end] eq {/}} { 8365 set pmod [string trimright $pmod /]/ 8366 set endwslash 1 8367 } else { 8368 set endwslash 0 8369 } 8370 if {$pmod ne {} || $pattern eq {}} { 8371 if {$psuf ne {}} { 8372 if {$endwslash && [string index $psuf 0] eq {/}} { 8373 append pmod [string range $psuf 1 end] 8374 } else { 8375 append pmod $psuf 8376 } 8377 } 8378 if {$test eq {eqstart}} { 8379 set ret [string equal -length [string length $pmod/] $pmod/ $mod/] 8380 } else { 8381 # contains test 8382 if {$test eq {matchin}} { 8383 set test match 8384 set pmod *$pmod 8385 } elseif {$test eq {eqspec}} { 8386 set test equal 8387 set eqspec 1 8388 } 8389 set ret [string $test $pmod $mod] 8390 } 8391 # try the extended default match if not root module and not eqspec test 8392 if {![info exists eqspec] && !$ret && [string first / $pmod] != -1} { 8393 if {$test eq {match}} { 8394 set pmodextdfl $pmod.* 8395 } else { 8396 set pmodextdfl $pmodescglob.* 8397 } 8398 set ret [string match $pmodextdfl $mod] 8399 } 8400 } elseif {$test eq {eqspec}} { 8401 # test equality against all version described in spec (list or range 8402 # boundaries), trspec is considered enabled and psuf empty 8403 foreach pmod [getAllModulesFromVersSpec $pattern] { 8404 if {[set ret [string equal $pmod $mod]]} { 8405 break 8406 } 8407 } 8408 } else { 8409 # contains test 8410 if {$test eq {matchin}} { 8411 set test match 8412 if {$pmodnamere ne {}} { 8413 set pmodnamere .*$pmodnamere 8414 } else { 8415 set pmodnamere .*$pmodname 8416 } 8417 } 8418 # for more complex specification, first check if module name matches 8419 # use a regexp test if module name contains wildcard characters 8420 if {($pmodnamere ne {} && $test eq {match} && [regexp (^$pmodnamere)/\ 8421 $mod/ rematch pmodname]) || [string equal -length [string length\ 8422 $pmodname/] $pmodname/ $mod/]} { 8423 # then compare versions 8424 set modvers [string range $mod [string length $pmodname/] end] 8425 set ret [modVersCmp $cmpspec $versspec $modvers $test $psuf] 8426 } else { 8427 set ret 0 8428 } 8429 } 8430 return $ret 8431} 8432proc modEqProcIcaseExtdfl {pattern mod {test equal} {trspec 1} {psuf {}}} { 8433 if {$trspec} { 8434 lassign [getModuleVersSpec $pattern] pmod pmodname cmpspec versspec\ 8435 pmodnamere pmodescglob 8436 } else { 8437 set pmod $pattern 8438 } 8439 if {[string index $pmod end] eq {/}} { 8440 set pmod [string trimright $pmod /]/ 8441 set endwslash 1 8442 } else { 8443 set endwslash 0 8444 } 8445 if {$pmod ne {} || $pattern eq {}} { 8446 if {$psuf ne {}} { 8447 if {$endwslash && [string index $psuf 0] eq {/}} { 8448 append pmod [string range $psuf 1 end] 8449 } else { 8450 append pmod $psuf 8451 } 8452 } 8453 if {$test eq {eqstart}} { 8454 set ret [string equal -nocase -length [string length $pmod/] $pmod/\ 8455 $mod/] 8456 } else { 8457 # contains test 8458 if {$test eq {matchin}} { 8459 set test match 8460 set pmod *$pmod 8461 } elseif {$test eq {eqspec}} { 8462 set test equal 8463 set eqspec 1 8464 } 8465 set ret [string $test -nocase $pmod $mod] 8466 } 8467 # try the extended default match if not root module and not eqspec test 8468 if {![info exists eqspec] && !$ret && [string first / $pmod] != -1} { 8469 if {$test eq {match}} { 8470 set pmodextdfl $pmod.* 8471 } else { 8472 set pmodextdfl $pmodescglob.* 8473 } 8474 set ret [string match -nocase $pmodextdfl $mod] 8475 } 8476 } elseif {$test eq {eqspec}} { 8477 # test equality against all version described in spec (list or range 8478 # boundaries), trspec is considered enabled and psuf empty 8479 foreach pmod [getAllModulesFromVersSpec $pattern] { 8480 if {[set ret [string equal -nocase $pmod $mod]]} { 8481 break 8482 } 8483 } 8484 } else { 8485 # contains test 8486 if {$test eq {matchin}} { 8487 set test match 8488 if {$pmodnamere ne {}} { 8489 set pmodnamere .*$pmodnamere 8490 } else { 8491 set pmodnamere .*$pmodname 8492 } 8493 } 8494 # for more complex specification, first check if module name matches 8495 # use a regexp test if module name contains wildcard characters 8496 if {($pmodnamere ne {} && $test eq {match} && [regexp -nocase\ 8497 (^$pmodnamere)/ $mod/ rematch pmodname]) || [string equal -nocase\ 8498 -length [string length $pmodname/] $pmodname/ $mod/]} { 8499 # then compare versions 8500 set modvers [string range $mod [string length $pmodname/] end] 8501 set ret [modVersCmp $cmpspec $versspec $modvers $test $psuf] 8502 } else { 8503 set ret 0 8504 } 8505 } 8506 return $ret 8507} 8508 8509# check if an existing findModules cache entry matches current search by 8510# evaluating search ids. if an exact match cannot be found, look at saved 8511# searches that contains current search (superset of looked elements), extra 8512# elements will be filtered-out by GetModules 8513proc findModulesInMemCache {searchid} { 8514 # exact same search is cached 8515 if {[info exists ::g_foundModulesMemCache($searchid)]} { 8516 set match_searchid $searchid 8517 set mod_list $::g_foundModulesMemCache($searchid) 8518 # look for a superset search 8519 } else { 8520 set match_searchid {} 8521 set mod_list {} 8522 foreach cacheid [array names ::g_foundModulesMemCache] { 8523 # cache id acts as pattern to check if it contains current search 8524 if {[string match $cacheid $searchid]} { 8525 set match_searchid $cacheid 8526 set mod_list $::g_foundModulesMemCache($cacheid) 8527 break 8528 } 8529 } 8530 } 8531 8532 return [list $match_searchid $mod_list] 8533} 8534 8535# finds all module-related files matching mod in the module path dir 8536proc findModules {dir mod depthlvl fetch_mtime} { 8537 reportDebug "finding '$mod' in $dir (depthlvl=$depthlvl,\ 8538 fetch_mtime=$fetch_mtime)" 8539 8540 # generated search id (for cache search/save) by compacting given args 8541 set searchid $dir:$mod:$depthlvl:$fetch_mtime 8542 8543 # look at memory cache for a compatible result 8544 lassign [findModulesInMemCache $searchid] cache_searchid cache_list 8545 if {$cache_searchid ne {}} { 8546 reportDebug "use cache entry '$cache_searchid'" 8547 return $cache_list 8548 } 8549 8550 defineModEqStaticProc [isIcase] [getConf extended_default] $mod 8551 8552 # every entries are requested 8553 set findall [expr {$mod eq {} || $mod eq {*}}] 8554 8555 # skip search in top dir if directly looking to a deep element, which means 8556 # findModules has already been called and top dir has already been analyzed 8557 if {[file dirname $mod] eq {.}} { 8558 # use catch protection to handle non-readable and non-existent dir 8559 if {[catch { 8560 set full_list {} 8561 foreach {fpelt hid} [getFilesInDirectory $dir 0] { 8562 set elt [file tail $fpelt] 8563 # include any .modulerc file found at the modulepath root 8564 if {$elt eq {.modulerc} || $findall || [modEqStatic $elt match]} { 8565 lappend full_list $fpelt 8566 } 8567 } 8568 }]} { 8569 return {} 8570 } 8571 } else { 8572 lappend full_list [file join $dir $mod] 8573 } 8574 foreach igndir [getConf ignored_dirs] { 8575 set ignored_dirs($igndir) 1 8576 } 8577 array set mod_list {} 8578 for {set i 0} {$i < [llength $full_list]} {incr i 1} { 8579 set element [lindex $full_list $i] 8580 set tag_list {} 8581 8582 set tail [file tail $element] 8583 set modulename [getModuleNameFromModulepath $element $dir] 8584 set parentname [file dirname $modulename] 8585 set moddepthlvl [llength [file split $modulename]] 8586 if {[file isdirectory $element]} { 8587 if {![info exists ignored_dirs($tail)]} { 8588 if {[catch { 8589 set elt_list [getFilesInDirectory $element 1] 8590 } errMsg]} { 8591 set mod_list($modulename) [list accesserr [parseAccessIssue\ 8592 $element] $element] 8593 } else { 8594 # Add each element in the current directory to the list 8595 foreach {fpelt hid} $elt_list { 8596 lappend full_list $fpelt 8597 # Flag hidden files 8598 if {$hid} { 8599 set hidden_list($fpelt) 1 8600 } 8601 } 8602 } 8603 } 8604 } else { 8605 switch -glob -- $tail { 8606 .modulerc { 8607 set mod_list($modulename) [list modulerc] 8608 } 8609 .version { 8610 # skip .version file from different depth level than search 8611 # targets if no in depth mode is enabled 8612 if {$depthlvl == 0 || $moddepthlvl == $depthlvl} { 8613 set mod_list($modulename) [list modulerc] 8614 } 8615 } 8616 *~ - *,v - \#*\# { } 8617 default { 8618 # skip modfile in no in depth mode search if it does not relate 8619 # to targeted depth level and one valid modfile has already be 8620 # found for the dirs lying at other depth level 8621 if {$depthlvl == 0 || $moddepthlvl == $depthlvl || ![info\ 8622 exists modfile_indir($parentname)]} { 8623 lassign [checkValidModule $element] check_valid check_msg 8624 switch -- $check_valid { 8625 true { 8626 set mtime [expr {$fetch_mtime ? [getFileMtime\ 8627 $element] : {}}] 8628 set mod_list($modulename) [list modulefile $mtime\ 8629 $element] 8630 8631 # a valid modfile has been found in directory 8632 if {![info exists hidden_list($element)]} { 8633 set modfile_indir($parentname) 1 8634 } 8635 } 8636 default { 8637 # register check error and relative message to get it 8638 # in case of direct access of this module element, but 8639 # no registering in parent directory structure as 8640 # element is not valid 8641 set mod_list($modulename) [list $check_valid\ 8642 $check_msg $element] 8643 } 8644 } 8645 } 8646 } 8647 } 8648 } 8649 } 8650 8651 reportDebug "found [array names mod_list]" 8652 8653 # cache search results 8654 reportDebug "create cache entry '$searchid'" 8655 set found_list [array get mod_list] 8656 set ::g_foundModulesMemCache($searchid) $found_list 8657 8658 return $found_list 8659} 8660 8661proc getModules {dir {mod {}} {fetch_mtime 0} {search {}} {filter {}}} { 8662 global g_sourceAlias g_sourceVersion g_sourceVirtual g_rcAlias\ 8663 g_moduleAlias g_rcVersion g_moduleVersion g_rcVirtual g_moduleVirtual\ 8664 g_rcfilesSourced 8665 8666 reportDebug "get '$mod' in $dir (fetch_mtime=$fetch_mtime, search=$search,\ 8667 filter=$filter)" 8668 8669 # generated search id (for cache search/save) by compacting given args 8670 set searchid $dir:$mod:$fetch_mtime:$search:$filter 8671 8672 # look at memory cache for a compatible result 8673 if {[info exists ::g_gotModulesMemCache($searchid)]} { 8674 reportDebug "use cache entry '$searchid'" 8675 return $::g_gotModulesMemCache($searchid) 8676 } 8677 8678 # extract one module name from query 8679 set modqe [getOneModuleFromVersSpec $mod] 8680 8681 # perform an in depth search or not 8682 set indepth [expr {![isInList $search noindepth]}] 8683 8684 # set a default if none defined on directory entries 8685 set implicitdfl [getConf implicit_default] 8686 8687 # automatically define latest and default sym for all modules 8688 set autosymbol [expr {$implicitdfl && [getConf advanced_version_spec]}] 8689 8690 # match passed name against any part of avail module names 8691 set contains [isInList $search contains] 8692 set mtest [expr {$contains ? {matchin} : {match}}] 8693 8694 set icase [isIcase] 8695 8696 set wild [isInList $search wild] 8697 8698 # will only keep default or latest elts in the end or remove plain dirs 8699 set filtering [expr {$filter eq {noplaindir}}] 8700 set keeping [expr {!$filtering && $filter ne {}}] 8701 8702 # check search query string corresponds to directory 8703 set querydir [string trimright $modqe *] 8704 set isquerydir [expr {[string index $querydir end] eq {/}}] 8705 set querydir [string trimright $querydir /] 8706 set querydepth [countChar $modqe /] 8707 8708 # get directory relative to module name 8709 set moddir [getModuleNameFromVersSpec $mod] 8710 set hasmoddir [expr {$moddir ne {.}}] 8711 set modroot [lindex [file split $modqe] 0] 8712 8713 # are result entries gathered in a resolution context ? 8714 set resctx [isInList $search resolve] 8715 8716 # if search for global or user rc alias only, no dir lookup is performed 8717 # and aliases from g_rcAlias are returned 8718 if {[isInList $search rc_alias_only]} { 8719 set add_rc_defs 1 8720 array set found_list {} 8721 } else { 8722 # find modules by searching mod root name in order to catch all module 8723 # related entries to correctly computed auto symbols afterward 8724 8725 if {$contains} { 8726 set findmod * 8727 } else { 8728 set findmod $modroot 8729 # if searched mod is an empty or flat element append wildcard 8730 # character to match anything starting with mod 8731 if {$wild && !$hasmoddir && [string index $findmod end] ne {*}} { 8732 append findmod * 8733 } 8734 } 8735 8736 # add alias/version definitions from global or user rc to result 8737 set add_rc_defs [isInList $search rc_defs_included] 8738 8739 # if no indepth mode search, pass the depth level of the search query 8740 set depthlvl [expr {$indepth ? 0 : [expr {$querydepth + 1}]}] 8741 8742 array set found_list [findModules $dir $findmod $depthlvl $fetch_mtime] 8743 } 8744 8745 # Phase #1: consolidate every kind of entries (directory, modulefile, 8746 # symbolic version, alias and virtual module) in found_list 8747 8748 array set err_list {} 8749 array set versmod_list {} 8750 8751 foreach elt [lsort [array names found_list]] { 8752 switch -- [lindex $found_list($elt) 0] { 8753 modulerc { 8754 # process rc files them remove them from found_list 8755 if {![info exists g_rcfilesSourced($dir/$elt)]} { 8756 execute-modulerc $dir/$elt $elt $elt 8757 # Keep track of already sourced rc files not to run them again 8758 set g_rcfilesSourced($dir/$elt) 1 8759 } 8760 unset found_list($elt) 8761 } 8762 modulefile { 8763 } 8764 default { 8765 # flag entries with error 8766 set err_list($elt) 1 8767 } 8768 } 8769 } 8770 8771 # add all versions found when parsing .version or .modulerc files in this 8772 # directory (skip versions not registered from this directory except if 8773 # global or user rc definitions should be included)) 8774 foreach vers [array names g_moduleVersion] { 8775 set versmod $g_moduleVersion($vers) 8776 if {($dir ne {} && [string first $dir/ $g_sourceVersion($vers)] == 0)\ 8777 || ($add_rc_defs && [info exists g_rcVersion($vers)])} { 8778 set found_list($vers) [list version $versmod] 8779 8780 # build module symbol list 8781 lappend versmod_list($versmod) $vers 8782 } 8783 } 8784 8785 # add aliases found when parsing .version or .modulerc files in this 8786 # directory (skip aliases not registered from this directory except if 8787 # global or user rc definitions should be included) 8788 foreach alias [array names g_moduleAlias] { 8789 if {($dir ne {} && [string first $dir/ $g_sourceAlias($alias)] == 0)\ 8790 || ($add_rc_defs && [info exists g_rcAlias($alias)])} { 8791 set found_list($alias) [list alias $g_moduleAlias($alias)] 8792 } 8793 } 8794 8795 # add virtual mods found when parsing .version or .modulerc files in this 8796 # directory (skip virtual mods not registered from this directory except if 8797 # global or user rc definitions should be included) 8798 foreach virt [array names g_moduleVirtual] { 8799 if {($dir ne {} && [string first $dir/ $g_sourceVirtual($virt)] == 0)\ 8800 || ($add_rc_defs && [info exists g_rcVirtual($virt)])} { 8801 lassign [checkValidModule $g_moduleVirtual($virt)] check_valid\ 8802 check_msg 8803 switch -- $check_valid { 8804 true { 8805 set mtime [expr {$fetch_mtime ? [getFileMtime\ 8806 $g_moduleVirtual($virt)] : {}}] 8807 # set mtime at index 1 like a modulefile entry 8808 set found_list($virt) [list virtual $mtime\ 8809 $g_moduleVirtual($virt)] 8810 } 8811 default { 8812 # register check error and relative message to get it in 8813 # case of direct access of this module element 8814 set found_list($virt) [list $check_valid $check_msg\ 8815 $g_moduleVirtual($virt)] 8816 set err_list($virt) 1 8817 } 8818 } 8819 } 8820 } 8821 8822 # Phase #2: filter-out dynamically hidden or expired elements 8823 8824 # define module name and version comparison procs 8825 defineModStartNbProc $icase 8826 defineModEqProc $icase [getConf extended_default] 8827 defineModEqStaticProc $icase [getConf extended_default] $mod 8828 8829 # remove hidden elements unless they are (or their symbols) targeted by 8830 # search query. 8831 foreach elt [array names found_list] { 8832 if {[lassign [isModuleHidden $elt $mod 1] hidlvl hidmatch]} { 8833 # is there a symbol that matches query (bare module name query 8834 # matches default symbol on resolve context or if onlydefaults filter 8835 # is applied) 8836 if {!$hidmatch && [info exists versmod_list($elt)]} { 8837 foreach eltsym $versmod_list($elt) { 8838 if {[modEqStatic $eltsym] || (($resctx || $filter eq\ 8839 {onlydefaults}) && "$mod/default" eq $eltsym)} { 8840 set hidmatch 1 8841 break 8842 } 8843 } 8844 } 8845 # consider 'default' symbols are explicitely specified if 8846 # onlydefaults filter applied or resolving bare module name 8847 if {!$hidmatch && [lindex $found_list($elt) 0] eq {version} && [file\ 8848 tail $elt] eq {default} && ($filter eq {onlydefaults} || ($resctx\ 8849 && "$mod/default" eq $elt))} { 8850 set hidmatch 1 8851 } 8852 8853 # not hidden if matched unless if hard hiding apply 8854 if {!$hidmatch || $hidlvl > 1} { 8855 # record hidden symbol, not to display it in listModules 8856 if {[lindex $found_list($elt) 0] eq {version}} { 8857 lappend ::g_hiddenSymHash([lindex $found_list($elt) 1]) [file\ 8858 tail $elt] 8859 } 8860 # transform forbidden module in error entry if it specifically 8861 # matches search query 8862 if {$hidlvl == 2 && $hidmatch && [isModuleTagged $elt\ 8863 forbidden]} { 8864 set found_list($elt) [list accesserr [getForbiddenMsg $elt]] 8865 set err_list($elt) 1 8866 } else { 8867 unset found_list($elt) 8868 } 8869 } 8870 } 8871 } 8872 8873 # Phase #3: elaborate directory content with default element selection 8874 8875 array set dir_list {} 8876 array set autosym_list {} 8877 8878 # build list of elements contained in each directory 8879 foreach elt [array names found_list] { 8880 # add a ref to element in its parent directory unless element has error 8881 # or is a symbolic version then recursively add parent element until 8882 # reaching top directory 8883 if {![info exists err_list($elt)] && [lindex $found_list($elt) 0] ne\ 8884 {version}} { 8885 set direlt $elt 8886 while {[set pardir [file dirname $direlt]] ne {.}} { 8887 appendNoDupToList dir_list($pardir) [file tail $direlt] 8888 set direlt $pardir 8889 } 8890 } 8891 } 8892 8893 # determine default element for each directory and record sorted elt list 8894 # unless if an alias or a virtual module has overwritten directory entry 8895 foreach elt [array names dir_list] { 8896 if {![info exists found_list($elt)]} { 8897 set dir_list($elt) [lsort -dictionary $dir_list($elt)] 8898 # get default element: explicitely defined default (whether it exists 8899 # or is in error) or implicit default if enabled 8900 if {[info exists found_list($elt/default)] && [lindex\ 8901 $found_list($elt/default) 0] eq {version}} { 8902 set dfl [file tail [lindex $found_list($elt/default) 1]] 8903 } elseif {$implicitdfl} { 8904 set dfl [lindex $dir_list($elt) end] 8905 } else { 8906 set dfl {} 8907 } 8908 # record directory properties 8909 set found_list($elt) [concat [list directory $dfl] $dir_list($elt)] 8910 8911 # automatically define symbols for all modules matching query if 8912 # these names do not exist yet or if in error, in which case only 8913 # auto symbol resolution is set 8914 if {$autosymbol && (!$hasmoddir || [modEq $modroot $elt eqstart])} { 8915 if {![info exists found_list($elt/default)] || [info exists\ 8916 err_list($elt/default)]} { 8917 if {![info exists found_list($elt/default)]} { 8918 set found_list($elt/default) [list version $elt/$dfl] 8919 set autosym_list($elt/default) 1 8920 } 8921 setModuleResolution $elt/default $elt/$dfl default 1 1 8922 } 8923 if {![info exists found_list($elt/latest)] || [info exists\ 8924 err_list($elt/latest)]} { 8925 set lat [lindex $dir_list($elt) end] 8926 if {![info exists found_list($elt/latest)]} { 8927 set found_list($elt/latest) [list version $elt/$lat] 8928 set autosym_list($elt/latest) 1 8929 } 8930 setModuleResolution $elt/latest $elt/$lat latest 1 1 8931 } 8932 } 8933 } 8934 } 8935 8936 # Phase #4: filter results to keep those matching search query 8937 8938 # define module name and version comparison procs 8939 defineDoesModMatchAtDepthProc $indepth $querydepth $mtest 8940 8941 array set mod_list {} 8942 array set fdir_list {} 8943 array set keep_list {} 8944 8945 # keep element matching query, add directory of element matching query, 8946 # also add directory to result if query name finishes with trailing slash; 8947 # only keep auto syms if fully matched or version not specified in query; 8948 # (hidden elements have been filtered on phase 2) 8949 foreach elt [array names found_list] { 8950 set elt_type [lindex $found_list($elt) 0] 8951 if {(($wild && [doesModMatchAtDepth $elt]) || (!$wild && ([modEqStatic\ 8952 $elt match /*] || [modEqStatic $elt match] || ($hasmoddir &&\ 8953 $elt_type eq {directory} && [modEq $moddir $elt]))) || ($isquerydir\ 8954 && $elt_type eq {directory} && [modEq $querydir $elt match 0])) &&\ 8955 (![info exists autosym_list($elt)] || ([countChar $elt /]\ 8956 != $querydepth && !$contains) || [modEqStatic $elt]) && ![info\ 8957 exists mod_list($elt)]} { 8958 if {$elt_type eq {directory}} { 8959 # add matching directory to the result list, its entries will be 8960 # computed in a second time and directory will be dropped if it 8961 # has no entry in the end 8962 set mod_list($elt) [list directory] 8963 # add dir to the filter dir list to enable its removal in next 8964 # step if dir is empty 8965 if {![info exists fdir_list($elt)]} { 8966 set fdir_list($elt) {} 8967 } 8968 } else { 8969 set mod_list($elt) $found_list($elt) 8970 } 8971 8972 # version may matches query but not its target, so it should be in 8973 # this case manually added to result (if it exists) 8974 if {$elt_type eq {version}} { 8975 # resolve eventual icase target 8976 set versmod [getArrayKey found_list [lindex $mod_list($elt) 1]\ 8977 $icase] 8978 # add target to dir struct (not version) if not already recorded 8979 set direlt . 8980 8981 # recursively add targets to result (process directory content if 8982 # target is a directory 8983 set tgt_list [list $versmod] 8984 for {set i 0} {$i < [llength $tgt_list]} {incr i} { 8985 set tgt [lindex $tgt_list $i] 8986 8987 if {![info exists mod_list($tgt)]} { 8988 if {[info exists found_list($tgt)]} { 8989 set mod_list($tgt) $found_list($tgt) 8990 # version target is directory: recursively add content 8991 if {[lindex $mod_list($tgt) 0] eq {directory}} { 8992 foreach tgtelt $dir_list($tgt) { 8993 lappend tgt_list $tgt/$tgtelt 8994 } 8995 # add dir to the filter dir list to enable its removal 8996 # in next step if dir is empty 8997 if {![info exists fdir_list($tgt)]} { 8998 set fdir_list($tgt) {} 8999 } 9000 } 9001 } 9002 9003 # record target in dir struct if part of found elts or if 9004 # hidden but should not be in error 9005 set pardir [file dirname $tgt] 9006 if {([info exists found_list($tgt)] || ($pardir ne {.} &&\ 9007 ![info exists found_list($pardir)] && [isModuleHidden\ 9008 $tgt $mod])) && ![info exists err_list($tgt)]} { 9009 # create parent directory if it does not exist 9010 if {$pardir ne {.} && ![info exists\ 9011 found_list($pardir)]} { 9012 set found_list($pardir) [list directory] 9013 set mod_list($pardir) [list directory] 9014 } 9015 9016 if {$i == 0} { 9017 set direlt $tgt 9018 } else { 9019 lappend fdir_list([file dirname $tgt]) [file tail\ 9020 $tgt] 9021 } 9022 } 9023 } 9024 } 9025 # skip adding element to directory content if in error 9026 } elseif {[info exists err_list($elt)]} { 9027 set direlt . 9028 } else { 9029 set direlt $elt 9030 } 9031 9032 # track directory content, as directory are also reported to their 9033 # parent directory the directory structure is also tracked 9034 if {[set pardir [file dirname $direlt]] ne {.}} { 9035 lappend fdir_list($pardir) [file tail $direlt] 9036 # track top level entries that will be kept if result is filtered 9037 } elseif {$keeping && $direlt ne {.} && $elt_type ne {directory}} { 9038 set keep_list($elt) 1 9039 } 9040 } 9041 } 9042 9043 # determine default element for each directory and record sorted element 9044 # list unless directory entry has been overwritten by a different module 9045 # kind or unless only matching directory should be part of result 9046 foreach elt [lsort -decreasing [array names fdir_list]] { 9047 if {[lindex $found_list($elt) 0] eq {directory} && ([info exists\ 9048 mod_list($elt)] || $keeping)} { 9049 set fdir_list($elt) [lsort -dictionary $fdir_list($elt)] 9050 # get default element: explicitely defined default if included in 9051 # result or not found or implicit default if enabled 9052 if {[info exists found_list($elt/default)] && [lindex\ 9053 $found_list($elt/default) 0] eq {version} && ([info exists\ 9054 mod_list([set versmod [lindex $found_list($elt/default) 1]])] ||\ 9055 ![info exists found_list($versmod)])} { 9056 set dfl [file tail $versmod] 9057 } elseif {$implicitdfl} { 9058 set dfl [lindex $fdir_list($elt) end] 9059 } else { 9060 set dfl {} 9061 } 9062 # remove empty dirs 9063 if {[llength $fdir_list($elt)] == 0} { 9064 unset mod_list($elt) 9065 unset fdir_list($elt) 9066 # remove unset dir reference in parent directory. parent dir 9067 # will be treated after unset dir (due to decreasing sort) if it 9068 # needs to get in turn unset 9069 if {[set pardir [file dirname $elt]] ne {.}} { 9070 set fdir_list($pardir) [replaceFromList $fdir_list($pardir)\ 9071 [file tail $elt]] 9072 } 9073 } else { 9074 # record directory properties 9075 set mod_list($elt) [concat [list directory $dfl] $fdir_list($elt)] 9076 9077 # list elements to keep for filtering step 9078 if {$keeping} { 9079 if {$filter eq {onlylatest}} { 9080 set keepelt $elt/[lindex $fdir_list($elt) end] 9081 } elseif {$dfl ne {}} { 9082 set keepelt $elt/$dfl 9083 } else { 9084 set keepelt {} 9085 } 9086 9087 # keep directory if its element depth is deeper than query 9088 if {!$indepth && [countChar $keepelt /] > $querydepth} { 9089 set keep_list($elt) 1 9090 # otherwise only keep existing modules (not directories) 9091 } elseif {[info exists mod_list($keepelt)] && [lindex\ 9092 $mod_list($keepelt) 0] ne {directory}} { 9093 set keep_list($keepelt) 1 9094 } 9095 # when noplaindir filtering, only keep dirs with tags when indepth 9096 # enabled or if correponds to query depth when indepth disabled 9097 } elseif {$filtering && $filter eq {noplaindir} &&\ 9098 (($indepth && ![doesModuleHaveSym $elt]) || (!$indepth &&\ 9099 [countChar $elt /] != $querydepth))} { 9100 unset mod_list($elt) 9101 } 9102 } 9103 } 9104 } 9105 9106 # now all matching modulefiles are settled, only keep those found at search 9107 # query depth level if 'noindepth' mode asked 9108 if {!$indepth} { 9109 # remove entries with more filename path separator than query pattern 9110 foreach elt [array names mod_list] { 9111 if {[countChar $elt /] > $querydepth} { 9112 unset mod_list($elt) 9113 } 9114 } 9115 } 9116 9117 # if result should be filtered, only keep marked elements 9118 if {$keeping} { 9119 foreach elt [array names mod_list] { 9120 if {![info exists keep_list($elt)]} { 9121 unset mod_list($elt) 9122 } 9123 } 9124 } 9125 9126 reportTrace "{[array names mod_list]} matching '$mod' in '$dir'" {Get\ 9127 modules} 9128 9129 # cache search results 9130 reportDebug "create cache entry '$searchid'" 9131 set got_list [array get mod_list] 9132 set ::g_gotModulesMemCache($searchid) $got_list 9133 9134 return $got_list 9135} 9136 9137# format an element with its tags for display in a list 9138proc formatListEltToDisplay {elt eltsgr eltsuffix tag_list tagsgr show_tags\ 9139 sgrdef {matchmap {}}} { 9140 set disp $elt$eltsuffix 9141 # hightlight matching substring 9142 if {$matchmap ne {}} { 9143 set dispsgr [sgr $eltsgr [string map $matchmap $elt]] 9144 } else { 9145 set dispsgr [sgr $eltsgr $elt] 9146 } 9147 if {$show_tags} { 9148 # display default tag graphically over element name 9149 if {[set defidx [lsearch -exact $tag_list default]] != -1 && $sgrdef} { 9150 set tag_list [lreplace $tag_list $defidx $defidx] 9151 set dispsgr [sgr de $dispsgr] 9152 } 9153 9154 # format remaining tag list 9155 if {[llength $tag_list] > 0} { 9156 append disp "([join $tag_list :])" 9157 set tagssgr [sgr se (] 9158 foreach tag $tag_list { 9159 if {![info exists colonsgr]} { 9160 set colonsgr [sgr se :] 9161 } else { 9162 append tagssgr $colonsgr 9163 } 9164 append tagssgr [sgr $tagsgr $tag] 9165 } 9166 append tagssgr [sgr se )] 9167 append dispsgr $eltsuffix$tagssgr 9168 } else { 9169 append dispsgr $eltsuffix 9170 } 9171 } else { 9172 append dispsgr $eltsuffix 9173 } 9174 return [list $disp $dispsgr] 9175} 9176 9177# format an element with its tags for a long/detailled display in a list 9178proc formatListEltToLongDisplay {elt eltsgr eltsuffix tag_list tagsgr mtime\ 9179 sgrdef {matchmap {}}} { 9180 set disp $elt$eltsuffix 9181 set displen [string length $disp] 9182 # hightlight matching substring 9183 if {$matchmap ne {}} { 9184 set dispsgr [sgr $eltsgr [string map $matchmap $elt]] 9185 } else { 9186 set dispsgr [sgr $eltsgr $elt] 9187 } 9188 # display default tag graphically over element name 9189 if {[set defidx [lsearch -exact $tag_list default]] != -1 && $sgrdef} { 9190 set tag_list [lreplace $tag_list $defidx $defidx] 9191 set dispsgr [sgr de $dispsgr] 9192 } 9193 # format remaining tag list 9194 if {[llength $tag_list] > 0} { 9195 set tagslen [string length [join $tag_list :]] 9196 foreach tag $tag_list { 9197 if {![info exists colonsgr]} { 9198 set colonsgr [sgr se :] 9199 } else { 9200 append tagssgr $colonsgr 9201 } 9202 append tagssgr [sgr $tagsgr $tag] 9203 } 9204 } else { 9205 set tagssgr {} 9206 set tagslen 0 9207 } 9208 set nbws1 [expr {40 - $displen}] 9209 set nbws2 [expr {20 - $tagslen + [expr {$nbws1 < 0 ? $nbws1 : 0}]}] 9210 return [list $disp $dispsgr$eltsuffix[string repeat { }\ 9211 $nbws1]$tagssgr[string repeat { } $nbws2]$mtime] 9212} 9213 9214proc formatArrayValToJson {vallist} { 9215 return [expr {[llength $vallist] > 0 ? "\[ \"[join $vallist {", "}]\" \]"\ 9216 : {[]}}] 9217} 9218 9219# format an element with its tags for a json display in a list 9220proc formatListEltToJsonDisplay {elt args} { 9221 set disp "\"$elt\": \{ \"name\": \"$elt\"" 9222 foreach {key vtype val} $args { 9223 append disp ", \"$key\": " 9224 append disp [expr {$vtype eq {a} ? [formatArrayValToJson $val] :\ 9225 "\"$val\""}] 9226 } 9227 append disp "\}" 9228 9229 return $disp 9230} 9231 9232# Prepare a map list to translate later on a substring in its highlighted 9233# counterpart. Translate substring into all module it specifies in case of an 9234# advanced version specification. Each string obtained is right trimmed from 9235# wildcard. No highlight is set for strings still containing wildcard chars 9236# after right trim operation. No highlist map is returned at all if hightlight 9237# rendering is disabled. 9238proc prepareMapToHightlightSubstr {substr} { 9239 set maplist {} 9240 if {[sgr hi {}] ne {}} { 9241 foreach m [getAllModulesFromVersSpec $substr] { 9242 set m [string trimright $m {*?}] 9243 if {$m ne {} && [string first * $m] == -1 && [string first ? $m] ==\ 9244 -1} { 9245 lappend maplist $m [sgr hi $m] 9246 } 9247 } 9248 } 9249 return $maplist 9250} 9251 9252# Finds all module versions for mod in the module path dir 9253proc listModules {dir mod show_mtime filter search} { 9254 set flag_default_dir [getConf avail_report_dir_sym] ;# Report default dirs 9255 set flag_default_mf [getConf avail_report_mfile_sym] ;# Report modfile syms 9256 9257 reportDebug "get '$mod' in $dir (show_mtime=$show_mtime, filter=$filter,\ 9258 search=$search)" 9259 9260 # get module list 9261 # process full dir content but do not exit when err raised from a modulerc. 9262 array set mod_list [getModules $dir $mod $show_mtime $search $filter] 9263 9264 # output is JSON format 9265 set json [isStateEqual report_format json] 9266 9267 # prepare results for display 9268 set alias_colored [expr {[sgr al {}] ne {}}] 9269 set default_colored [expr {[sgr de {}] ne {}}] 9270 set matchmap [prepareMapToHightlightSubstr $mod] 9271 set clean_list {} 9272 foreach elt [array names mod_list] { 9273 set tag_list [getVersAliasList $elt] 9274 set dispsgr {} 9275 # ignore "version" entries as symbolic version are treated 9276 # along to their relative modulefile not independently 9277 switch -- [lindex $mod_list($elt) 0] { 9278 directory { 9279 if {$json} { 9280 set dispsgr [formatListEltToJsonDisplay $elt type s directory\ 9281 symbols a $tag_list] 9282 } elseif {$show_mtime} { 9283 # append / char after name to clearly indicate this is a dir 9284 lassign [formatListEltToLongDisplay $elt di / $tag_list sy {}\ 9285 $default_colored $matchmap] disp dispsgr 9286 } else { 9287 lassign [formatListEltToDisplay $elt di / $tag_list sy\ 9288 $flag_default_dir $default_colored $matchmap] disp dispsgr 9289 } 9290 } 9291 modulefile - virtual { 9292 if {$json} { 9293 set dispsgr [formatListEltToJsonDisplay $elt type s modulefile\ 9294 symbols a $tag_list pathname s [lindex $mod_list($elt) 2]] 9295 } elseif {$show_mtime} { 9296 # add to display file modification time in addition 9297 # to potential tags 9298 lassign [formatListEltToLongDisplay $elt {} {} $tag_list sy\ 9299 [clock format [lindex $mod_list($elt) 1] -format {%Y/%m/%d\ 9300 %H:%M:%S}] $default_colored $matchmap] disp dispsgr 9301 } else { 9302 lassign [formatListEltToDisplay $elt {} {} $tag_list sy\ 9303 $flag_default_mf $default_colored $matchmap] disp dispsgr 9304 } 9305 } 9306 alias { 9307 if {$json} { 9308 set dispsgr [formatListEltToJsonDisplay $elt type s alias\ 9309 symbols a $tag_list target s [lindex $mod_list($elt) 1]] 9310 } elseif {$show_mtime} { 9311 lassign [formatListEltToLongDisplay $elt al " -> [lindex\ 9312 $mod_list($elt) 1]" $tag_list sy {} $default_colored\ 9313 $matchmap] disp dispsgr 9314 } else { 9315 # add a '@' tag to indicate elt is an alias if not colored 9316 if {!$alias_colored} { 9317 lappend tag_list @ 9318 } 9319 lassign [formatListEltToDisplay $elt al {} $tag_list sy\ 9320 $flag_default_mf $default_colored $matchmap] disp dispsgr 9321 } 9322 } 9323 } 9324 if {$dispsgr ne {}} { 9325 if {$json} { 9326 lappend clean_list $dispsgr 9327 } else { 9328 lappend clean_list $disp 9329 set sgrmap($disp) $dispsgr 9330 } 9331 } 9332 } 9333 9334 set len_list {} 9335 set max_len 0 9336 if {$json} { 9337 upvar 0 clean_list display_list 9338 if {![info exists display_list]} { 9339 set display_list {} 9340 } 9341 } else { 9342 set display_list {} 9343 # always dictionary-sort results 9344 foreach disp [lsort -dictionary $clean_list] { 9345 # compute display element length list on sorted result 9346 lappend display_list $sgrmap($disp) 9347 lappend len_list [set len [string length $disp]] 9348 if {$len > $max_len} { 9349 set max_len $len 9350 } 9351 } 9352 } 9353 9354 reportDebug "Returning $display_list" 9355 return [list $display_list $len_list $max_len] 9356} 9357 9358proc showModulePath {} { 9359 set modpathlist [getModulePathList] 9360 if {[llength $modpathlist] > 0} { 9361 report {Search path for module files (in search order):} 9362 foreach path $modpathlist { 9363 report " [sgr mp $path]" 9364 } 9365 } else { 9366 reportWarning {No directories on module search path} 9367 } 9368} 9369 9370proc displayTableHeader {sgrkey args} { 9371 foreach {title col_len} $args { 9372 set col "- [sgr $sgrkey $title] " 9373 append col [string repeat - [expr {$col_len - [string length $title] -\ 9374 3}]] 9375 lappend col_list $col 9376 } 9377 9378 report [join $col_list .] 9379} 9380 9381proc displaySeparatorLine {{title {}} {sgrkey {}}} { 9382 set tty_cols [getState term_columns] 9383 if {$title eq {}} { 9384 # adapt length if screen width is very small 9385 set max_rep 67 9386 set rep [expr {$tty_cols > $max_rep ? $max_rep : $tty_cols}] 9387 report [string repeat - $rep] 9388 } else { 9389 set len [string length $title] 9390 # max expr function is not supported in Tcl8.4 and earlier 9391 if {[set lrep [expr {($tty_cols - $len - 2)/2}]] < 1} { 9392 set lrep 1 9393 } 9394 if {[set rrep [expr {$tty_cols - $len - 2 - $lrep}]] < 1} { 9395 set rrep 1 9396 } 9397 report "[string repeat - $lrep] [sgr $sgrkey $title] [string repeat -\ 9398 $rrep]" 9399 } 9400} 9401 9402# get a list of elements and print them in a column or in a 9403# one-per-line fashion 9404proc displayElementList {header sgrkey hstyle one_per_line display_idx\ 9405 display_list {len_list {}} {max_len 0}} { 9406 set elt_cnt [llength $display_list] 9407 reportDebug "header=$header, sgrkey=$sgrkey, hstyle=$hstyle,\ 9408 elt_cnt=$elt_cnt, max_len=$max_len, one_per_line=$one_per_line,\ 9409 display_idx=$display_idx" 9410 9411 # end proc if no element are to print 9412 if {$elt_cnt == 0} { 9413 return 9414 } 9415 # output is JSON format 9416 set json [isStateEqual report_format json] 9417 9418 # display header if any provided 9419 if {$header ne {noheader}} { 9420 if {$json} { 9421 report "\"$header\": \{" 9422 } elseif {$hstyle eq {sepline}} { 9423 displaySeparatorLine $header $sgrkey 9424 } else { 9425 report [sgr $sgrkey $header]: 9426 } 9427 } 9428 9429 if {$json} { 9430 set displist [join $display_list ,\n] 9431 # display one element per line 9432 } elseif {$one_per_line} { 9433 if {$display_idx} { 9434 set idx 1 9435 foreach elt $display_list { 9436 append displist [format {%2d) %s } $idx $elt] \n 9437 incr idx 9438 } 9439 } else { 9440 append displist [join $display_list \n] \n 9441 } 9442 # elsewhere display elements in columns 9443 } else { 9444 if {$display_idx} { 9445 # save room for numbers and spacing: 2 digits + ) + space 9446 set elt_prefix_len 4 9447 } else { 9448 set elt_prefix_len 0 9449 } 9450 # save room for two spaces after element 9451 set elt_suffix_len 2 9452 9453 # compute rows*cols grid size with optimized column number 9454 # the size of each column is computed to display as much column 9455 # as possible on each line 9456 incr max_len $elt_suffix_len 9457 foreach len $len_list { 9458 lappend elt_len [incr len $elt_suffix_len] 9459 } 9460 9461 set tty_cols [getState term_columns] 9462 # find valid grid by starting with non-optimized solution where each 9463 # column length is equal to the length of the biggest element to display 9464 set cur_cols [expr {int(($tty_cols - $elt_prefix_len) / $max_len)}] 9465 # when display is found too short to display even one column 9466 if {$cur_cols == 0} { 9467 set cols 1 9468 set rows $elt_cnt 9469 array set col_width [list 0 $max_len] 9470 } else { 9471 set cols 0 9472 set rows 0 9473 } 9474 set last_round 0 9475 set restart_loop 0 9476 while {$cur_cols > $cols} { 9477 if {!$restart_loop} { 9478 if {$last_round} { 9479 incr cur_rows 9480 } else { 9481 set cur_rows [expr {int(ceil(double($elt_cnt) / $cur_cols))}] 9482 } 9483 for {set i 0} {$i < $cur_cols} {incr i} { 9484 set cur_col_width($i) 0 9485 } 9486 for {set i 0} {$i < $cur_rows} {incr i} { 9487 set row_width($i) 0 9488 } 9489 set istart 0 9490 } else { 9491 set istart [expr {$col * $cur_rows}] 9492 # only remove width of elements from current col 9493 for {set row 0} {$row < ($i % $cur_rows)} {incr row} { 9494 incr row_width($row) -[expr {$pre_col_width + $elt_prefix_len}] 9495 } 9496 } 9497 set restart_loop 0 9498 for {set i $istart} {$i < $elt_cnt} {incr i} { 9499 set col [expr {int($i / $cur_rows)}] 9500 set row [expr {$i % $cur_rows}] 9501 # restart loop if a column width change 9502 if {[lindex $elt_len $i] > $cur_col_width($col)} { 9503 set pre_col_width $cur_col_width($col) 9504 set cur_col_width($col) [lindex $elt_len $i] 9505 set restart_loop 1 9506 break 9507 } 9508 # end search of maximum number of columns if computed row width 9509 # is larger than terminal width 9510 if {[incr row_width($row) +[expr {$cur_col_width($col) \ 9511 + $elt_prefix_len}]] > $tty_cols} { 9512 # start last optimization pass by increasing row number until 9513 # reaching number used for previous column number, by doing so 9514 # this number of column may pass in terminal width, if not 9515 # fallback to previous number of column 9516 if {$last_round && $cur_rows == $rows} { 9517 incr cur_cols -1 9518 } else { 9519 set last_round 1 9520 } 9521 break 9522 } 9523 } 9524 # went through all elements without reaching terminal width limit so 9525 # this number of column solution is valid, try next with a greater 9526 # column number 9527 if {$i == $elt_cnt} { 9528 set cols $cur_cols 9529 set rows $cur_rows 9530 array set col_width [array get cur_col_width] 9531 # number of column is fixed if last optimization round has started 9532 # reach end also if there is only one row of results 9533 if {!$last_round && $rows > 1} { 9534 incr cur_cols 9535 } 9536 } 9537 9538 } 9539 reportDebug list=$display_list 9540 reportDebug "rows/cols=$rows/$cols,\ 9541 lastcol_item_cnt=[expr {int($elt_cnt % $rows)}]" 9542 9543 for {set row 0} {$row < $rows} {incr row} { 9544 for {set col 0} {$col < $cols} {incr col} { 9545 set index [expr {$col * $rows + $row}] 9546 if {$index < $elt_cnt} { 9547 if {$display_idx} { 9548 append displist [format "%2d) " [expr {$index +1}]] 9549 } 9550 # cannot use 'format' as strings may contain SGR codes 9551 append displist [lindex $display_list $index][string repeat\ 9552 { } [expr {$col_width($col) - [lindex $len_list $index]}]] 9553 } 9554 } 9555 append displist \n 9556 } 9557 } 9558 if {$json && $header ne {noheader}} { 9559 append displist "\n\}" 9560 } 9561 report $displist 1 9562 reportSeparateNextContent 9563} 9564 9565# Return conf value and from where an eventual def value has been overridden 9566proc displayConfig {val env_var {asked 0} {trans {}} {locked 0}} { 9567 array set transarr $trans 9568 9569 # get overridden value and know what has overridden it 9570 if {$asked} { 9571 set defby " (cmd-line)" 9572 } elseif {$env_var ne {} && !$locked && [info exists ::env($env_var)]} { 9573 set defby " (env-var)" 9574 } elseif {$locked} { 9575 set defby " (locked)" 9576 } else { 9577 set defby {} 9578 } 9579 9580 # translate fetched value if translation table exists 9581 if {[info exists transarr($val)]} { 9582 set val $transarr($val) 9583 } 9584 9585 return $val$defby 9586} 9587 9588# build list of what to undo then do to move from an initial list to a target 9589# list, eventually checking element presence in extra from/to lists 9590proc getMovementBetweenList {from to {extfrom {}} {extto {}}} { 9591 reportDebug "from($from) to($to) with extfrom($extfrom) extto($extto)" 9592 9593 set undo {} 9594 set do {} 9595 9596 # determine what element to undo then do 9597 # to restore a target list from a current list 9598 # with preservation of the element order 9599 set imax [if {[llength $to] > [llength $from]} {llength $to} {llength\ 9600 $from}] 9601 set list_equal 1 9602 for {set i 0} {$i < $imax} {incr i} { 9603 set to_obj [lindex $to $i] 9604 set from_obj [lindex $from $i] 9605 # check from/to element presence in extra from/to list 9606 set in_extfrom [isInList $extfrom $from_obj] 9607 set in_extto [isInList $extto $to_obj] 9608 # are elts the sames and are both part of or missing from extra lists 9609 if {$to_obj ne $from_obj || $in_extfrom != $in_extto} { 9610 set list_equal 0 9611 } 9612 if {$list_equal == 0} { 9613 if {$to_obj ne {}} { 9614 lappend do $to_obj 9615 } 9616 if {$from_obj ne {}} { 9617 lappend undo $from_obj 9618 } 9619 } 9620 } 9621 9622 return [list $undo $do] 9623} 9624 9625# build list of currently loaded modules where modulename is registered minus 9626# module version if loaded version is the default one. a helper list may be 9627# provided and looked at prior to module search 9628proc getSimplifiedLoadedModuleList {{helper_raw_list {}}\ 9629 {helper_list {}}} { 9630 reportDebug called. 9631 9632 set curr_mod_list {} 9633 set curr_nuasked_list {} 9634 set modpathlist [getModulePathList] 9635 foreach mod [getLoadedModuleList] { 9636 # if mod found in a previous LOADEDMODULES list use simplified 9637 # version of this module found in relative helper list (previously 9638 # computed simplified list) 9639 if {[set helper_idx [lsearch -exact $helper_raw_list $mod]] != -1} { 9640 set simplemod [lindex $helper_list $helper_idx] 9641 # look through modpaths for a simplified mod name if not full path 9642 } elseif {![isModuleFullPath $mod] && [llength $modpathlist] > 0} { 9643 set modfile [getModulefileFromLoadedModule $mod] 9644 set parentmod [file dirname $mod] 9645 set simplemod $mod 9646 # simplify to parent name as long as it resolves to current mod 9647 while {$parentmod ne {.}} { 9648 lassign [getPathToModule $parentmod $modpathlist 0] parentfile 9649 if {$parentfile eq $modfile} { 9650 set simplemod $parentmod 9651 set parentmod [file dirname $parentmod] 9652 } else { 9653 set parentmod . 9654 } 9655 } 9656 } else { 9657 set simplemod $mod 9658 } 9659 lappend curr_mod_list $simplemod 9660 # record not user asked module list in simplified version form 9661 if {![isModuleUserAsked $mod]} { 9662 lappend curr_nuasked_list $simplemod 9663 } 9664 } 9665 9666 return [list $curr_mod_list $curr_nuasked_list] 9667} 9668 9669# return saved collections found in user directory which corresponds to 9670# enabled collection target if any set. 9671proc findCollections {} { 9672 if {[info exists ::env(HOME)]} { 9673 set coll_search $::env(HOME)/.module/* 9674 } else { 9675 reportErrorAndExit {HOME not defined} 9676 } 9677 9678 # find saved collections (matching target suffix) 9679 # a target is a domain on which a collection is only valid. 9680 # when a target is set, only the collections made for that target 9681 # will be available to list and restore, and saving will register 9682 # the target footprint 9683 set colltarget [getConf collection_target] 9684 if {$colltarget ne {}} { 9685 append coll_search .$colltarget 9686 } 9687 9688 # workaround 'glob -nocomplain' which does not return permission 9689 # error on Tcl 8.4, so we need to avoid raising error if no match 9690 # glob excludes by default files starting with "." 9691 if {[catch {set coll_list [glob $coll_search]} errMsg ]} { 9692 if {$errMsg eq "no files matched glob pattern \"$coll_search\""} { 9693 set coll_list {} 9694 } else { 9695 reportErrorAndExit "Cannot access collection directory.\n$errMsg" 9696 } 9697 } 9698 9699 return $coll_list 9700} 9701 9702# get filename corresponding to collection name provided as argument. 9703# name provided may already be a file name. collection description name 9704# (with target info if any) is returned along with collection filename 9705proc getCollectionFilename {coll} { 9706 # initialize description with collection name 9707 set colldesc $coll 9708 9709 if {$coll eq {}} { 9710 reportErrorAndExit {Invalid empty collection name} 9711 # is collection a filepath 9712 } elseif {[string first / $coll] > -1} { 9713 # collection target has no influence when 9714 # collection is specified as a filepath 9715 set collfile $coll 9716 # elsewhere collection is a name 9717 } elseif {[info exists ::env(HOME)]} { 9718 set collfile $::env(HOME)/.module/$coll 9719 # if a target is set, append the suffix corresponding 9720 # to this target to the collection file name 9721 set colltarget [getConf collection_target] 9722 if {$colltarget ne {}} { 9723 append collfile .$colltarget 9724 # add knowledge of collection target on description 9725 append colldesc " (for target \"$colltarget\")" 9726 } 9727 } else { 9728 reportErrorAndExit {HOME not defined} 9729 } 9730 9731 return [list $collfile $colldesc] 9732} 9733 9734# generate collection content based on provided path and module lists 9735proc formatCollectionContent {path_list mod_list nuasked_list {sgr 0}} { 9736 set content {} 9737 9738 # graphically enhance module command if asked 9739 set modcmd [expr {$sgr ? [sgr cm module] : {module}}] 9740 9741 # start collection content with modulepaths 9742 foreach path $path_list { 9743 # enclose path if space character found in it 9744 if {[string first { } $path] != -1} { 9745 set path "{$path}" 9746 } 9747 # 'module use' prepends paths by default so we clarify 9748 # path order here with --append flag 9749 append content "$modcmd use --append $path" \n 9750 } 9751 9752 # then add modules 9753 foreach mod $mod_list { 9754 # mark modules not asked by user to restore the user asked state 9755 set opt [expr {[isInList $nuasked_list $mod] ? {--notuasked } : {}}] 9756 # enclose module if space character found in it 9757 if {[string first { } $mod] != -1} { 9758 set mod "{$mod}" 9759 } 9760 append content "$modcmd load $opt$mod" \n 9761 } 9762 9763 return $content 9764} 9765 9766# read given collection file and return the path and module lists it defines 9767proc readCollectionContent {collfile colldesc} { 9768 # init lists (maybe coll does not set mod to load) 9769 set path_list {} 9770 set mod_list {} 9771 set nuasked_list {} 9772 9773 # read file 9774 if {[catch { 9775 set fdata [split [readFile $collfile] \n] 9776 } errMsg ]} { 9777 reportErrorAndExit "Collection $colldesc cannot be read.\n$errMsg" 9778 } 9779 9780 # analyze collection content 9781 foreach fline $fdata { 9782 if {[regexp {module use (.*)$} $fline match patharg] == 1} { 9783 # paths are appended by default 9784 set stuff_path append 9785 # manage multiple paths and path options specified on single line, 9786 # for instance "module use --append path1 path2 path3", with list 9787 # representation of patharg (which handles quoted elements containing 9788 # space in their name) 9789 foreach path $patharg { 9790 # following path is asked to be appended 9791 if {($path eq {--append}) || ($path eq {-a})\ 9792 || ($path eq {-append})} { 9793 set stuff_path append 9794 # following path is asked to be prepended 9795 # collection generated with 'save' does not prepend 9796 } elseif {($path eq {--prepend}) || ($path eq {-p})\ 9797 || ($path eq {-prepend})} { 9798 set stuff_path prepend 9799 } else { 9800 # ensure given path is absolute to be able to correctly 9801 # compare with paths registered in MODULEPATH 9802 set path [getAbsolutePath $path] 9803 # add path to end of list 9804 if {$stuff_path eq {append}} { 9805 lappend path_list $path 9806 # insert path to first position 9807 } else { 9808 set path_list [linsert $path_list 0 $path] 9809 } 9810 } 9811 } 9812 } elseif {[regexp {module load (.*)$} $fline match modarg] == 1} { 9813 # manage multiple modules specified on a single line, for instance 9814 # "module load mod1 mod2 mod3", with list representation of modarg 9815 # make a list of modules that were not directly asked by user 9816 set cleanlist [lsearch -all -inline -not -exact $modarg\ 9817 --notuasked] 9818 if {[llength $modarg] != [llength $cleanlist]} { 9819 set nuasked_list [concat $nuasked_list $cleanlist] 9820 } 9821 set mod_list [concat $mod_list $cleanlist] 9822 } 9823 } 9824 9825 return [list $path_list $mod_list $nuasked_list] 9826} 9827 9828# analyze/translate command name passed to module 9829proc parseModuleCommandName {command defaultcmd} { 9830 set cmdempty 0 9831 9832 # resolve command if alias or shortcut name used 9833 switch -- $command { 9834 add {set command load} 9835 rm - remove {set command unload} 9836 show {set command display} 9837 apropos - keyword {set command search} 9838 {} { 9839 # if empty string supplied translate to default command 9840 set command $defaultcmd 9841 set cmdempty 1 9842 } 9843 default { 9844 # specific match for shortcut names 9845 set cmdlen [string length $command] 9846 foreach {match minlen sccmd} {load 2 load unload 4 unload delete 3\ 9847 unload refresh 3 reload reload 3 reload switch 2 switch swap 2\ 9848 switch display 2 display available 2 avail aliases 2 aliases list\ 9849 2 list whatis 2 whatis purge 2 purge initadd 5 initadd initload 6\ 9850 initadd initprepend 5 initprepend initswitch 6 initswitch\ 9851 initswap 6 initswitch initunload 8 initrm initlist 5 initlist} { 9852 if {$cmdlen >= $minlen && [string equal -length $cmdlen $command\ 9853 $match]} { 9854 set command $sccmd 9855 break 9856 } 9857 } 9858 } 9859 } 9860 9861 set cmdvalid [isInList [list load unload reload use unuse source switch\ 9862 display avail aliases path paths list whatis search purge save restore\ 9863 saverm saveshow savelist initadd initprepend initswitch initrm initlist\ 9864 initclear autoinit clear config help test prepend-path append-path\ 9865 remove-path is-loaded is-saved is-used is-avail info-loaded sh-to-mod]\ 9866 $command] 9867 9868 return [list $command $cmdvalid $cmdempty] 9869} 9870 9871# analyze arg list passed to a module cmd to set options 9872proc parseModuleCommandArgs {cmd args} { 9873 set show_oneperline 0 9874 set show_mtime 0 9875 set show_filter {} 9876 set search_filter [expr {[getConf avail_indepth] ? {} : {noindepth}}] 9877 set search_match [getConf search_match] 9878 set dump_state 0 9879 set addpath_pos prepend 9880 set otherargs {} 9881 9882 # parse argument list 9883 foreach arg $args { 9884 switch -glob -- $arg { 9885 -j - --json { 9886 # enable json output only on supported command 9887 if {[isInList [list avail savelist list search whatis] $cmd]} { 9888 setState report_format json 9889 set show_oneperline 0 9890 set show_mtime 0 9891 } 9892 } 9893 -t - --terse { 9894 set show_oneperline 1 9895 set show_mtime 0 9896 setState report_format plain 9897 } 9898 -l - --long { 9899 set show_mtime 1 9900 set show_oneperline 0 9901 setState report_format plain 9902 } 9903 --append - -append { 9904 if {$cmd eq {use}} { 9905 set addpath_pos append 9906 } else { 9907 lappend otherargs $arg 9908 } 9909 } 9910 -p - --prepend - -prepend { 9911 if {$cmd eq {use}} { 9912 set addpath_pos prepend 9913 } else { 9914 lappend otherargs $arg 9915 } 9916 } 9917 --all { 9918 # include hidden modules only on a limited set of command 9919 if {[isInList [list avail aliases search whatis ml] $cmd]} { 9920 setState hiding_threshold 2 9921 } else { 9922 lappend otherargs $arg 9923 } 9924 } 9925 -a { 9926 # -a option has a different meaning whether sub-command is use or 9927 # one of the search/listing sub-commands 9928 if {$cmd eq {use}} { 9929 set addpath_pos append 9930 } elseif {[isInList [list avail aliases search whatis ml] $cmd]} { 9931 setState hiding_threshold 2 9932 } else { 9933 lappend otherargs $arg 9934 } 9935 } 9936 -d - --default { 9937 # in case of *-path command, -d means --delim 9938 if {$arg eq {-d} && [string match *-path $cmd]} { 9939 lappend otherargs $arg 9940 } else { 9941 set show_filter onlydefaults 9942 } 9943 } 9944 -L - --latest { 9945 set show_filter onlylatest 9946 } 9947 -C - --contains { 9948 set search_match contains 9949 } 9950 -S - --starts-with { 9951 set search_match starts_with 9952 } 9953 --indepth { 9954 # empty value means 'in depth' as it is default behavior 9955 set search_filter {} 9956 } 9957 --no-indepth { 9958 set search_filter noindepth 9959 } 9960 --dump-state { 9961 set dump_state 1 9962 } 9963 --auto - --no-auto - -f - --force { 9964 reportWarning "Unsupported option '$arg'" 9965 } 9966 default { 9967 lappend otherargs $arg 9968 } 9969 } 9970 } 9971 9972 reportDebug "(show_oneperline=$show_oneperline, show_mtime=$show_mtime,\ 9973 show_filter=$show_filter, search_filter=$search_filter,\ 9974 search_match=$search_match, dump_state=$dump_state,\ 9975 addpath_pos=$addpath_pos, otherargs=$otherargs)" 9976 return [list $show_oneperline $show_mtime $show_filter $search_filter\ 9977 $search_match $dump_state $addpath_pos $otherargs] 9978} 9979 9980# when advanced_version_spec option is enabled, parse argument list to set in 9981# a global context version specification of modules passed as argument. 9982# specification may vary whether it comes from the ml or another command. 9983proc parseModuleVersionSpecifier {mlspec args} { 9984 # skip arg parse if proc was already call with same arg set by an upper 9985 # proc. check all args to ensure current arglist does not deviate from 9986 # what was previously parsed 9987 foreach arg $args { 9988 if {![info exists ::g_moduleVersSpec($arg)]} { 9989 set need_parse 1 9990 break 9991 } 9992 } 9993 9994 if {[info exists need_parse]} { 9995 if {[getConf advanced_version_spec]} { 9996 set invalidversspec 0 9997 set invalidversrange 0 9998 set mlunload 0 9999 set arglist [list] 10000 set unarglist [list] 10001 foreach arg $args { 10002 # extract module name and version specifier from arg 10003 set curverslist [lassign [split $arg @] curmod] 10004 # preserve empty argument 10005 if {$curmod ne {} || $arg eq {}} { 10006 # save previous module version spec and transformed arg if any 10007 if {[info exists modarglist]} { 10008 set modarg [join $modarglist] 10009 if {[info exists modname] && ($modname ne {} || $modspec eq {})} { 10010 setModuleVersSpec $modarg $modname $cmpspec $versspec 10011 # rework args to have 1 str element for whole module spec 10012 # append to unload list if ml spec and - prefix used 10013 if {$mlunload} { 10014 lappend unarglist $modarg 10015 } else { 10016 lappend arglist $modarg 10017 } 10018 } elseif {$modspec ne {}} { 10019 knerror "No module name defined in argument '$modarg'" 10020 } 10021 unset modarglist 10022 } 10023 if {$mlspec} { 10024 if {[string index $curmod 0] eq {-}} { 10025 set arg [string range $arg 1 end] 10026 set curmod [string range $curmod 1 end] 10027 set mlunload 1 10028 } else { 10029 set mlunload 0 10030 } 10031 } 10032 set modname $curmod 10033 set modspec {} 10034 } 10035 10036 set modspec [lindex $curverslist end] 10037 set versspecislist [expr {[string first , $modspec] != -1}] 10038 set versspecisrange [expr {[string first : $modspec] != -1}] 10039 # no deep version specification allowed nor list/range mix 10040 if {[string first / $modspec] != -1 || ($versspecislist &&\ 10041 $versspecisrange)} { 10042 set invalidversspec 1 10043 # ',' separates multiple versions 10044 } elseif {$versspecislist} { 10045 set cmpspec in 10046 set versspec [split $modspec ,] 10047 # empty element in list is erroneous 10048 set invalidversspec [expr {[lsearch -exact $versspec {}] != -1}] 10049 # ':' separates range elements 10050 } elseif {$versspecisrange} { 10051 set versspec [split $modspec :] 10052 set lovers [lindex $versspec 0] 10053 set hivers [lindex $versspec 1] 10054 if {[llength $versspec] != 2 || ($lovers eq {} && $hivers eq\ 10055 {})} { 10056 set invalidversspec 1 10057 } elseif {($lovers ne {} && ![isVersion $lovers]) || ($hivers\ 10058 ne {} && ![isVersion $hivers])} { 10059 set invalidversrange 1 10060 # greater or equal 10061 } elseif {$hivers eq {}} { 10062 set cmpspec ge 10063 set versspec $lovers 10064 # lower or equal 10065 } elseif {$lovers eq {}} { 10066 set cmpspec le 10067 set versspec $hivers 10068 # between or equal 10069 } elseif {[compareVersion $lovers $hivers] == 1} { 10070 set invalidversrange 1 10071 } else { 10072 set cmpspec be 10073 } 10074 } else { 10075 set cmpspec eq 10076 set versspec $modspec 10077 } 10078 if {$invalidversspec} { 10079 knerror "Invalid version specifier '$modspec'" 10080 } 10081 if {$invalidversrange} { 10082 knerror "Invalid version range '$modspec'" 10083 } 10084 # keep arg enclosed if composed of several words 10085 if {[string first { } $arg] != -1} { 10086 lappend modarglist "{$arg}" 10087 } else { 10088 lappend modarglist $arg 10089 } 10090 } 10091 # transform last args 10092 if {[info exists modarglist]} { 10093 set modarg [join $modarglist] 10094 if {[info exists modname] && ($modname ne {} || $modspec eq {})} { 10095 setModuleVersSpec $modarg $modname $cmpspec $versspec 10096 # rework args to have 1 string element for whole module spec 10097 # append to unload list if ml spec and - prefix used 10098 if {$mlunload} { 10099 lappend unarglist $modarg 10100 } else { 10101 lappend arglist $modarg 10102 } 10103 } elseif {$modspec ne {}} { 10104 knerror "No module name defined in argument '$modarg'" 10105 } 10106 } 10107 } else { 10108 set unarglist [list] 10109 set arglist [list] 10110 10111 foreach arg $args { 10112 if {$mlspec && [string index $arg 0] eq {-}} { 10113 set modname [string range $arg 1 end] 10114 set mlunload 1 10115 } else { 10116 set modname $arg 10117 set mlunload 0 10118 } 10119 # keep arg enclosed if composed of several words 10120 if {[string first { } $modname] != -1} { 10121 set modarg "{$modname}" 10122 } else { 10123 set modarg $modname 10124 } 10125 # record spec, especially needed if arg is enclosed 10126 setModuleVersSpec $modarg $modname eq {} 10127 # append to unload list if ml spec and - prefix used 10128 if {$mlunload} { 10129 lappend unarglist $modarg 10130 } else { 10131 lappend arglist $modarg 10132 } 10133 } 10134 } 10135 } else { 10136 set arglist $args 10137 } 10138 10139 if {$mlspec} { 10140 return [list $unarglist $arglist] 10141 } else { 10142 return $arglist 10143 } 10144} 10145 10146proc setModuleVersSpec {modarg modname cmpspec versspec} { 10147 if {$versspec eq {}} { 10148 set mod $modname 10149 set modname [file dirname $modname] 10150 } else { 10151 set modname [string trimright $modname /] 10152 if {$cmpspec ne {eq}} { 10153 set mod {} 10154 } else { 10155 set mod $modname/$versspec 10156 } 10157 } 10158 # save a regexp-ready version of modname (apply 10159 # non-greedy quantifier to '*', to avoid matching final 10160 # '/' in string comparison 10161 set modnamere [string map {. \\. + \\+ * .*? ? .} $modname] 10162 if {$modname eq $modnamere} { 10163 set modnamere {} 10164 } 10165 # save a glob-special-chars escaped version of mod 10166 set modescglob [string map {* \\* ? \\?} $mod] 10167 10168 reportDebug "Set module '$mod' (escglob '$modescglob'), module name\ 10169 '$modname' (re '$modnamere'), version cmp '$cmpspec' and version(s)\ 10170 '$versspec' for argument '$modarg'" 10171 set ::g_moduleVersSpec($modarg) [list $mod $modname $cmpspec $versspec\ 10172 $modnamere $modescglob] 10173} 10174 10175proc getModuleVersSpec {modarg} { 10176 if {[info exists ::g_moduleVersSpec($modarg)]} { 10177 return $::g_moduleVersSpec($modarg) 10178 } else { 10179 return [list $modarg [file dirname $modarg] {} {} {} [string map {* \\*\ 10180 ? \\?} $modarg]] 10181 } 10182} 10183 10184# get module name from module name and version spec if parsed 10185proc getModuleNameFromVersSpec {modarg} { 10186 if {[info exists ::g_moduleVersSpec($modarg)]} { 10187 lassign $::g_moduleVersSpec($modarg) mod modname 10188 } else { 10189 set modname [file dirname $modarg] 10190 } 10191 return $modname 10192} 10193 10194# translate module name version spec to return all modules mentionned 10195proc getAllModulesFromVersSpec {modarg} { 10196 if {[info exists ::g_moduleVersSpec($modarg)]} { 10197 lassign $::g_moduleVersSpec($modarg) mod modname cmpspec versspec 10198 if {$mod eq {} && $cmpspec ne {eq}} { 10199 foreach vers $versspec { 10200 lappend modlist $modname/$vers 10201 } 10202 } else { 10203 # add empty mod specification if cmpspec is 'eq' 10204 lappend modlist $mod 10205 } 10206 } else { 10207 lappend modlist $modarg 10208 } 10209 10210 return $modlist 10211} 10212 10213# translate module name version spec to return one module mentionned 10214proc getOneModuleFromVersSpec {modarg} { 10215 if {[info exists ::g_moduleVersSpec($modarg)]} { 10216 lassign $::g_moduleVersSpec($modarg) mod modname cmpspec versspec 10217 if {$mod eq {} && $cmpspec ne {eq}} { 10218 set mod $modname/[lindex $versspec 0] 10219 } 10220 } else { 10221 set mod $modarg 10222 } 10223 10224 return $mod 10225} 10226 10227# unload phase of a list of modules reload process 10228proc reloadModuleListUnloadPhase {lmname {force 0} {errmsgtpl {}} {context\ 10229 unload}} { 10230 upvar $lmname lmlist 10231 # unload one by one to ensure same behavior whatever auto_handling state 10232 foreach mod [lreverse $lmlist] { 10233 # save user asked state before it vanishes 10234 set isuasked($mod) [isModuleUserAsked $mod] 10235 # force unload even if requiring mods are not part of the unload list 10236 # (violation state) as modules are loaded again just after 10237 if {[cmdModuleUnload $context match 0 1 0 0 $mod]} { 10238 # avoid failing module on load phase 10239 set lmlist [replaceFromList $lmlist $mod] 10240 set errMsg [string map [list _MOD_ $mod] $errmsgtpl] 10241 if {$force} { 10242 # errMsg will always be set as force mode could not be enabled 10243 # for reload sub-cmd which provides an empty msg template 10244 reportWarning $errMsg 1 10245 # stop if one unload fails unless force mode enabled 10246 } else { 10247 knerror $errMsg 10248 } 10249 } 10250 } 10251 return [array get isuasked] 10252} 10253 10254# load phase of a list of modules reload process 10255proc reloadModuleListLoadPhase {lmname isuaskedlist {force 0} {errmsgtpl {}}\ 10256 {context load}} { 10257 upvar $lmname lmlist 10258 array set isuasked $isuaskedlist 10259 10260 # loads are made with auto handling mode disabled to avoid disturbances 10261 # from a missing prereq automatically reloaded, so these module loads may 10262 # fail as prereq may not be satisfied anymore 10263 setConf auto_handling 0 10264 foreach mod $lmlist { 10265 # reload module with user asked property preserved 10266 if {[cmdModuleLoad $context $isuasked($mod) $mod]} { 10267 set errMsg [string map [list _MOD_ $mod] $errmsgtpl] 10268 if {$force} { 10269 # errMsg will always be set as force mode could not be enabled 10270 # for reload sub-cmd which provides an empty msg template 10271 reportWarning $errMsg 1 10272 # stop if one load fails unless force mode enabled 10273 } else { 10274 knerror $errMsg 10275 } 10276 } 10277 } 10278 setConf auto_handling 1 10279} 10280 10281######################################################################## 10282# command line commands 10283# 10284proc cmdModuleList {show_oneperline show_mtime} { 10285 set loadedmodlist [getLoadedModuleList] 10286 set json [isStateEqual report_format json] 10287 10288 if {[llength $loadedmodlist] == 0} { 10289 if {!$json} { 10290 report {No Modulefiles Currently Loaded.} 10291 } 10292 } else { 10293 set display_list {} 10294 set default_colored [expr {[sgr de {}] ne {}}] 10295 set len_list {} 10296 set max_len 0 10297 foreach mod $loadedmodlist { 10298 if {$show_oneperline} { 10299 lappend display_list $mod 10300 } else { 10301 set modfile [getModulefileFromLoadedModule $mod] 10302 # skip rc find and execution if mod is registered as full path 10303 if {[isModuleFullPath $mod]} { 10304 set mtime [getFileMtime $mod] 10305 set tag_list {} 10306 # or if loaded module is a virtual module 10307 } elseif {[isModuleVirtual $mod $modfile]} { 10308 set mtime [getFileMtime $modfile] 10309 set tag_list {} 10310 } else { 10311 # call getModules to find and execute rc files for this mod 10312 set dir [getModulepathFromModuleName $modfile $mod] 10313 array set mod_list [getModules $dir $mod $show_mtime] 10314 # fetch info only if mod found 10315 if {[info exists mod_list($mod)]} { 10316 set mtime [lindex $mod_list($mod) 1] 10317 set tag_list [getVersAliasList $mod] 10318 } else { 10319 set tag_list {} 10320 } 10321 } 10322 10323 if {$json} { 10324 set dispsgr [formatListEltToJsonDisplay $mod type s modulefile\ 10325 symbols a $tag_list pathname s $modfile] 10326 } elseif {$show_mtime} { 10327 if {[info exists mtime]} { 10328 set clock_mtime [clock format $mtime -format\ 10329 {%Y/%m/%d %H:%M:%S}] 10330 unset mtime 10331 } else { 10332 set clock_mtime {} 10333 } 10334 10335 # add to display file modification time in addition to tags 10336 lassign [formatListEltToLongDisplay $mod {} {} $tag_list sy\ 10337 $clock_mtime $default_colored] disp dispsgr 10338 } else { 10339 lassign [formatListEltToDisplay $mod {} {} $tag_list sy 1\ 10340 $default_colored] disp dispsgr 10341 lappend len_list [set len [string length $disp]] 10342 if {$len > $max_len} { 10343 set max_len $len 10344 } 10345 } 10346 lappend display_list $dispsgr 10347 } 10348 } 10349 10350 if {!$json} { 10351 if {$show_mtime} { 10352 displayTableHeader hi Package 39 Versions 19 {Last mod.} 19 10353 } 10354 report {Currently Loaded Modulefiles:} 10355 } 10356 if {$show_mtime || $show_oneperline} { 10357 set display_idx 0 10358 set one_per_line 1 10359 } else { 10360 set display_idx 1 10361 set one_per_line 0 10362 } 10363 10364 displayElementList noheader {} {} $one_per_line $display_idx\ 10365 $display_list $len_list $max_len 10366 } 10367} 10368 10369proc cmdModuleDisplay {args} { 10370 reportDebug "displaying $args" 10371 10372 pushMode display 10373 set first_report 1 10374 foreach mod $args { 10375 lassign [getPathToModule $mod] modfile modname 10376 if {$modfile ne {}} { 10377 # only one separator lines between 2 modules 10378 if {$first_report} { 10379 displaySeparatorLine 10380 set first_report 0 10381 } 10382 report [sgr hi $modfile]:\n 10383 execute-modulefile $modfile $modname $mod 10384 displaySeparatorLine 10385 } 10386 } 10387 popMode 10388} 10389 10390proc cmdModulePaths {mod} { 10391 reportDebug ($mod) 10392 10393 set dir_list [getModulePathList exiterronundef] 10394 foreach dir $dir_list { 10395 array unset mod_list 10396 array set mod_list [getModules $dir $mod 0 [list rc_defs_included]] 10397 10398 # prepare list of dirs for alias/symbol target search, will first search 10399 # in currently looked dir, then in other dirs following precedence order 10400 set target_dir_list [concat [list $dir] [replaceFromList $dir_list\ 10401 $dir]] 10402 10403 # forcibly enable implicit_default to resolve alias target when it 10404 # points to a directory 10405 setConf implicit_default 1 10406 10407 # build list of modulefile to print 10408 foreach elt [array names mod_list] { 10409 switch -- [lindex $mod_list($elt) 0] { 10410 modulefile { 10411 lappend ::g_return_text $dir/$elt 10412 } 10413 virtual { 10414 lappend ::g_return_text [lindex $mod_list($elt) 2] 10415 } 10416 alias - version { 10417 # resolve alias target 10418 set aliastarget [lindex $mod_list($elt) 1] 10419 lassign [getPathToModule $aliastarget $target_dir_list 0]\ 10420 modfile modname 10421 # add module target as result instead of alias 10422 if {$modfile ne {} && ![info exists mod_list($modname)]} { 10423 lappend ::g_return_text $modfile 10424 } 10425 } 10426 } 10427 } 10428 10429 # reset implicit_default to restore behavior defined 10430 unsetConf implicit_default 10431 } 10432 10433 # sort results if any and remove duplicates 10434 if {[info exists ::g_return_text]} { 10435 set ::g_return_text [lsort -dictionary -unique $::g_return_text] 10436 } else { 10437 # set empty value to return empty if no result 10438 set ::g_return_text {} 10439 } 10440} 10441 10442proc cmdModulePath {mod} { 10443 reportDebug ($mod) 10444 lassign [getPathToModule $mod] modfile modname 10445 # if no result set empty value to return empty 10446 if {$modfile eq {}} { 10447 set ::g_return_text {} 10448 } else { 10449 lappend ::g_return_text $modfile 10450 } 10451} 10452 10453proc cmdModuleWhatIs {{mod {}}} { 10454 cmdModuleSearch $mod {} 10455} 10456 10457proc cmdModuleApropos {{search {}}} { 10458 cmdModuleSearch {} $search 10459} 10460 10461proc cmdModuleSearch {{mod {}} {search {}}} { 10462 reportDebug "($mod, $search)" 10463 10464 # disable error reporting to avoid modulefile errors 10465 # to mix with valid search results 10466 inhibitErrorReport 10467 10468 set json [isStateEqual report_format json] 10469 10470 set icase [isIcase] 10471 defineModEqProc $icase [getConf extended_default] 10472 10473 lappend searchmod rc_defs_included 10474 if {$mod eq {}} { 10475 lappend searchmod wild 10476 } 10477 set foundmod 0 10478 pushMode whatis 10479 set dir_list [getModulePathList exiterronundef] 10480 foreach dir $dir_list { 10481 array unset mod_list 10482 array set mod_list [getModules $dir $mod 0 $searchmod] 10483 array unset interp_list 10484 array set interp_list {} 10485 10486 # forcibly enable implicit_default to resolve alias target when it 10487 # points to a directory 10488 setConf implicit_default 1 10489 10490 # build list of modulefile to interpret 10491 foreach elt [array names mod_list] { 10492 switch -- [lindex $mod_list($elt) 0] { 10493 modulefile { 10494 if {[isModuleTagged $elt forbidden]} { 10495 # register any error occuring on element matching search 10496 if {[modEq $mod $elt]} { 10497 set err_list($elt) [list accesserr [getForbiddenMsg\ 10498 $elt]] 10499 } 10500 } else { 10501 set interp_list($elt) $dir/$elt 10502 # register module name in a global list (shared across 10503 # modulepaths) to get hints when solving aliases/version 10504 set full_list($elt) 1 10505 } 10506 } 10507 virtual { 10508 if {[isModuleTagged $elt forbidden]} { 10509 # register any error occuring on element matching search 10510 if {[modEq $mod $elt]} { 10511 set err_list($elt) [list accesserr [getForbiddenMsg\ 10512 $elt]] 10513 } 10514 } else { 10515 set interp_list($elt) [lindex $mod_list($elt) 2] 10516 set full_list($elt) 1 10517 } 10518 } 10519 alias { 10520 # resolve alias target 10521 set elt_target [lindex $mod_list($elt) 1] 10522 if {![info exists full_list($elt_target)]} { 10523 lassign [getPathToModule $elt_target $dir 0]\ 10524 modfile modname issuetype issuemsg 10525 # add module target as result instead of alias 10526 if {$modfile ne {} && ![info exists mod_list($modname)]} { 10527 set interp_list($modname) $modfile 10528 set full_list($modname) 1 10529 } elseif {$modfile eq {}} { 10530 # if module target not found in current modulepath add to 10531 # list for global search after initial modulepath lookup 10532 if {[string first {Unable to locate} $issuemsg] == 0} { 10533 set extra_search($modname) [list $dir [modEq $mod\ 10534 $elt]] 10535 # register resolution error if alias name matches search 10536 } elseif {[modEq $mod $elt]} { 10537 set err_list($modname) [list $issuetype $issuemsg] 10538 } 10539 } 10540 } 10541 } 10542 version { 10543 # report error of version target if matching query 10544 set elt_target [getArrayKey mod_list [lindex $mod_list($elt) 1]\ 10545 $icase] 10546 if {[info exists mod_list($elt_target)] && [isInList [list\ 10547 invalid accesserr] [lindex $mod_list($elt_target) 0]] &&\ 10548 [modEq $mod $elt]} { 10549 set err_list($elt_target) $mod_list($elt_target) 10550 } elseif {![info exists mod_list($elt_target)]} { 10551 set extra_search($elt_target) [list $dir [modEq $mod $elt]] 10552 } 10553 } 10554 invalid - accesserr { 10555 # register any error occuring on element matching search 10556 if {[modEq $mod $elt]} { 10557 set err_list($elt) $mod_list($elt) 10558 } 10559 } 10560 } 10561 } 10562 10563 # reset implicit_default to restore behavior defined 10564 unsetConf implicit_default 10565 10566 # in case during modulepath lookup we find an alias target we were 10567 # looking for in previous modulepath, remove this element from global 10568 # search list 10569 foreach elt [array names extra_search] { 10570 if {[info exists full_list($elt)]} { 10571 unset extra_search($elt) 10572 } 10573 } 10574 10575 # save results from this modulepath for interpretation step as there 10576 # is an extra round of search to match missing alias target, we cannot 10577 # process modulefiles found immediately 10578 if {[array size interp_list] > 0} { 10579 set interp_save($dir) [array get interp_list] 10580 } 10581 } 10582 10583 # forcibly enable implicit_default to resolve alias target when it points 10584 # to a directory 10585 setConf implicit_default 1 10586 10587 # find target of aliases in all modulepath except the one already tried 10588 foreach elt [array names extra_search] { 10589 lassign [getPathToModule $elt {} 0 no [lindex $extra_search($elt) 0]]\ 10590 modfile modname issuetype issuemsg issuefile 10591 # found target so append it to results in corresponding modulepath 10592 if {$modfile ne {}} { 10593 # get belonging modulepath dir depending of module kind 10594 if {[isModuleVirtual $modname $modfile]} { 10595 set dir [findModulepathFromModulefile\ 10596 $::g_sourceVirtual($modname)] 10597 } else { 10598 set dir [getModulepathFromModuleName $modfile $modname] 10599 } 10600 array unset interp_list 10601 if {[info exists interp_save($dir)]} { 10602 array set interp_list $interp_save($dir) 10603 } 10604 set interp_list($modname) $modfile 10605 set interp_save($dir) [array get interp_list] 10606 # register resolution error if primal alias name matches search 10607 } elseif {$modfile eq {} && [lindex $extra_search($elt) 1]} { 10608 set err_list($modname) [list $issuetype $issuemsg $issuefile] 10609 } 10610 } 10611 10612 # reset implicit_default to restore behavior defined 10613 unsetConf implicit_default 10614 10615 # prepare string translation to highlight search query string 10616 set matchmodmap [prepareMapToHightlightSubstr $mod] 10617 set matchsearchmap [prepareMapToHightlightSubstr $search] 10618 10619 # interpret all modulefile we got for each modulepath 10620 foreach dir $dir_list { 10621 if {[info exists interp_save($dir)]} { 10622 array unset interp_list 10623 array set interp_list $interp_save($dir) 10624 set foundmod 1 10625 set display_list {} 10626 # interpret every modulefiles obtained to get their whatis text 10627 foreach elt [lsort -dictionary [array names interp_list]] { 10628 set ::g_whatis {} 10629 execute-modulefile $interp_list($elt) $elt $elt 10630 10631 # treat whatis as a multi-line text 10632 if {$search eq {} || [regexp -nocase $search $::g_whatis]} { 10633 if {$json} { 10634 lappend display_list [formatListEltToJsonDisplay $elt\ 10635 whatis a $::g_whatis] 10636 } else { 10637 set eltsgr [string map $matchmodmap $elt] 10638 foreach line $::g_whatis { 10639 set linesgr [string map $matchsearchmap $line] 10640 lappend display_list "[string repeat { } [expr {20 -\ 10641 [string length $elt]}]]$eltsgr: $linesgr" 10642 } 10643 } 10644 } 10645 } 10646 10647 displayElementList $dir mp sepline 1 0 $display_list 10648 } 10649 } 10650 popMode 10651 10652 setState inhibit_errreport 0 10653 10654 # report errors if a modulefile was searched but not found 10655 if {$mod ne {} && !$foundmod} { 10656 # no error registered means nothing was found to match search 10657 if {![array exists err_list]} { 10658 set err_list($mod) [list none "Unable to locate a modulefile for\ 10659 '$mod'"] 10660 } 10661 foreach elt [array names err_list] { 10662 eval reportIssue $err_list($elt) 10663 } 10664 } 10665} 10666 10667proc cmdModuleSwitch {uasked old {new {}}} { 10668 # if a single name is provided it matches for the module to load and in 10669 # this case the module to unload is searched to find the closest match 10670 # (loaded module that shares at least the same root name) 10671 if {$new eq {}} { 10672 set new $old 10673 set unload_match close 10674 } else { 10675 set unload_match match 10676 } 10677 # save orig names to register them as deps if called from modulefile 10678 set argnew $new 10679 if {$new eq $old} { 10680 set argold {} 10681 } else { 10682 set argold $old 10683 } 10684 10685 reportDebug "old='$old' new='$new' (uasked=$uasked)" 10686 10687 # record sumup messages from underlying unload/load actions under the same 10688 # switch message record id to report (evaluation messages still go under 10689 # their respective unload/load block 10690 pushMsgRecordId switch-$old-$new-[getEvalModuleStackDepth] 10691 10692 set ret [cmdModuleUnload swunload $unload_match 1 0 0 0 $old] 10693 10694 # register modulefile to unload as conflict if an unload module is 10695 # mentionned on this module switch command set in a modulefile 10696 set orig_auto_handling [getConf auto_handling] 10697 if {!$uasked && $argold ne {}} { 10698 # skip conflict declaration if old spec matches new as in this case 10699 # switch means *replace loaded version of mod by this specific version* 10700 lassign [getPathToModule $new] newmodfile newmod 10701 if {$newmod eq {} || ![modEq $argold $newmod eqstart]} { 10702 # temporarily disable auto handling just to record deps, not to try 10703 # to load or unload them (already tried) 10704 setConf auto_handling 0 10705 catch {conflict $argold} 10706 setConf auto_handling $orig_auto_handling 10707 } 10708 } 10709 10710 # attempt load and depre reload only if unload succeed 10711 if {!$ret} { 10712 cmdModuleLoad swload $uasked $new 10713 10714 if {[getConf auto_handling] && [info exists deprelist] && [llength\ 10715 $deprelist] > 0} { 10716 # cmdModuleUnload handles the DepUn, UReqUn mechanisms and the unload 10717 # phase of the DepRe mechanism. List of DepRe mods and their user 10718 # asked state is set from cmdModuleUnload procedure to be used here 10719 # for the load phase of the DepRe mechanism. 10720 # Try DepRe load phase: load failure will not lead to switch failure 10721 reloadModuleListLoadPhase deprelist [array get isuasked]\ 10722 1 {Reload of dependent _MOD_ failed} depre 10723 } 10724 10725 # report a summary of automated evaluations if no error 10726 reportModuleEval 10727 } 10728 10729 # report all recorded sumup messages for this evaluation 10730 reportMsgRecord "Switching from [sgr hi $old] to [sgr hi $new]" 10731 popMsgRecordId 10732 10733 # register modulefile to load as prereq when called from modulefile 10734 if {!$uasked && !$ret && $argnew ne {}} { 10735 setConf auto_handling 0 10736 prereq $argnew 10737 setConf auto_handling $orig_auto_handling 10738 } 10739} 10740 10741proc cmdModuleSave {{coll default}} { 10742 reportDebug $coll 10743 10744 if {![areModuleConstraintsSatisfied]} { 10745 reportErrorAndExit {Cannot save collection, some module constraints are\ 10746 not satistied} 10747 } 10748 10749 # format collection content, version number of modulefile are saved if 10750 # version pinning is enabled 10751 if {[getConf collection_pin_version]} { 10752 set curr_mod_list [getLoadedModuleList] 10753 set curr_nuasked_list [getLoadedModuleNotUserAskedList] 10754 } else { 10755 lassign [getSimplifiedLoadedModuleList] curr_mod_list curr_nuasked_list 10756 } 10757 set save [formatCollectionContent [getModulePathList returnempty 0]\ 10758 $curr_mod_list $curr_nuasked_list] 10759 10760 if { [string length $save] == 0} { 10761 reportErrorAndExit {Nothing to save in a collection} 10762 } 10763 10764 # get coresponding filename and its directory 10765 lassign [getCollectionFilename $coll] collfile colldesc 10766 set colldir [file dirname $collfile] 10767 10768 if {![file exists $colldir]} { 10769 reportDebug "Creating $colldir" 10770 file mkdir $colldir 10771 } elseif {![file isdirectory $colldir]} { 10772 reportErrorAndExit "$colldir exists but is not a directory" 10773 } 10774 10775 reportDebug "Saving $collfile" 10776 10777 if {[catch { 10778 set fid [open $collfile w] 10779 puts $fid $save 10780 close $fid 10781 } errMsg ]} { 10782 reportErrorAndExit "Collection $colldesc cannot be saved.\n$errMsg" 10783 } 10784} 10785 10786proc cmdModuleRestore {{coll default}} { 10787 reportDebug $coll 10788 10789 # get coresponding filename 10790 lassign [getCollectionFilename $coll] collfile colldesc 10791 10792 if {![file exists $collfile]} { 10793 reportErrorAndExit "Collection $colldesc cannot be found" 10794 } 10795 10796 # read collection 10797 lassign [readCollectionContent $collfile $colldesc] coll_path_list\ 10798 coll_mod_list coll_nuasked_list 10799 10800 # collection should at least define a path or a mod 10801 if {[llength $coll_path_list] == 0 && [llength $coll_mod_list] == 0} { 10802 reportErrorAndExit "$colldesc is not a valid collection" 10803 } 10804 10805 # forcibly enable implicit_default to restore colls saved in this mode 10806 setConf implicit_default 1 10807 10808 # fetch what is currently loaded 10809 set curr_path_list [getModulePathList returnempty 0] 10810 # get current loaded module list in simplified and raw versions 10811 # these lists may be used later on, see below 10812 set curr_mod_list_raw [getLoadedModuleList] 10813 set curr_nuasked_list_raw [getLoadedModuleNotUserAskedList] 10814 lassign [getSimplifiedLoadedModuleList] curr_mod_list curr_nuasked_list 10815 10816 # determine what module to unload to restore collection 10817 # from current situation with preservation of the load order 10818 lassign [getMovementBetweenList $curr_mod_list $coll_mod_list\ 10819 $curr_nuasked_list $coll_nuasked_list] mod_to_unload mod_to_load 10820 # determine unload movement with raw loaded list in case versions are 10821 # pinning in saved collection 10822 lassign [getMovementBetweenList $curr_mod_list_raw $coll_mod_list\ 10823 $curr_nuasked_list_raw $coll_nuasked_list] mod_to_unload_raw\ 10824 mod_to_load_raw 10825 if {[llength $mod_to_unload] > [llength $mod_to_unload_raw]} { 10826 set mod_to_unload $mod_to_unload_raw 10827 } 10828 10829 # proceed as well for modulepath 10830 lassign [getMovementBetweenList $curr_path_list $coll_path_list] \ 10831 path_to_unuse path_to_use 10832 10833 # create an eval id to track successful/failed module evaluations 10834 pushMsgRecordId restore-$coll-[getEvalModuleStackDepth] 0 10835 10836 # unload modules one by one (no dependency auto unload) 10837 if {[llength $mod_to_unload] > 0} { 10838 eval cmdModuleUnload unload match 0 0 0 0 [lreverse $mod_to_unload] 10839 } 10840 # unuse paths 10841 if {[llength $path_to_unuse] > 0} { 10842 eval cmdModuleUnuse [lreverse $path_to_unuse] 10843 } 10844 10845 # since unloading a module may unload other modules or 10846 # paths, what to load/use has to be determined after 10847 # the undo phase, so current situation is fetched again 10848 set curr_path_list [getModulePathList returnempty 0] 10849 10850 # here we may be in a situation were no more path is left 10851 # in module path, so we cannot easily compute the simplified loaded 10852 # module list. so we provide two helper lists: simplified and raw 10853 # versions of the loaded module list computed before starting to 10854 # unload modules. these helper lists may help to learn the 10855 # simplified counterpart of a loaded module if it was already loaded 10856 # before starting to unload modules 10857 lassign [getSimplifiedLoadedModuleList $curr_mod_list_raw $curr_mod_list]\ 10858 curr_mod_list curr_nuasked_list 10859 set curr_mod_list_raw [getLoadedModuleList] 10860 set curr_nuasked_list_raw [getLoadedModuleNotUserAskedList] 10861 10862 # determine what module to load to restore collection 10863 # from current situation with preservation of the load order 10864 lassign [getMovementBetweenList $curr_mod_list $coll_mod_list\ 10865 $curr_nuasked_list $coll_nuasked_list] mod_to_unload mod_to_load 10866 # determine load movement with raw loaded list in case versions are 10867 # pinning in saved collection 10868 lassign [getMovementBetweenList $curr_mod_list_raw $coll_mod_list\ 10869 $curr_nuasked_list_raw $coll_nuasked_list] mod_to_unload_raw\ 10870 mod_to_load_raw 10871 if {[llength $mod_to_load] > [llength $mod_to_load_raw]} { 10872 set mod_to_load $mod_to_load_raw 10873 } 10874 10875 # proceed as well for modulepath 10876 lassign [getMovementBetweenList $curr_path_list $coll_path_list] \ 10877 path_to_unuse path_to_use 10878 10879 # reset implicit_default to restore behavior defined 10880 unsetConf implicit_default 10881 10882 # use paths 10883 if {[llength $path_to_use] > 0} { 10884 # always append path here to guaranty the order 10885 # computed above in the movement lists 10886 eval cmdModuleUse append $path_to_use 10887 } 10888 10889 # load modules one by one with user asked state preserved 10890 foreach mod $mod_to_load { 10891 cmdModuleLoad load [notInList $coll_nuasked_list $mod] $mod 10892 } 10893 10894 popMsgRecordId 0 10895} 10896 10897proc cmdModuleSaverm {{coll default}} { 10898 reportDebug $coll 10899 10900 # avoid to remove any kind of file with this command 10901 if {[string first / $coll] > -1} { 10902 reportErrorAndExit {Command does not remove collection specified as\ 10903 filepath} 10904 } 10905 10906 # get coresponding filename 10907 lassign [getCollectionFilename $coll] collfile colldesc 10908 10909 if {![file exists $collfile]} { 10910 reportErrorAndExit "Collection $colldesc cannot be found" 10911 } 10912 10913 # attempt to delete specified colletion 10914 if {[catch { 10915 file delete $collfile 10916 } errMsg ]} { 10917 reportErrorAndExit "Collection $colldesc cannot be removed.\n$errMsg" 10918 } 10919} 10920 10921proc cmdModuleSaveshow {{coll default}} { 10922 reportDebug $coll 10923 10924 # get coresponding filename 10925 lassign [getCollectionFilename $coll] collfile colldesc 10926 10927 if {![file exists $collfile]} { 10928 reportErrorAndExit "Collection $colldesc cannot be found" 10929 } 10930 10931 # read collection 10932 lassign [readCollectionContent $collfile $colldesc] coll_path_list\ 10933 coll_mod_list coll_nuasked_list 10934 10935 # collection should at least define a path or a mod 10936 if {[llength $coll_path_list] == 0 && [llength $coll_mod_list] == 0} { 10937 reportErrorAndExit "$colldesc is not a valid collection" 10938 } 10939 10940 displaySeparatorLine 10941 report [sgr hi $collfile]:\n 10942 report [formatCollectionContent $coll_path_list $coll_mod_list\ 10943 $coll_nuasked_list 1] 10944 displaySeparatorLine 10945} 10946 10947proc cmdModuleSavelist {show_oneperline show_mtime} { 10948 # if a target is set, only list collection matching this 10949 # target (means having target as suffix in their name) 10950 set colltarget [getConf collection_target] 10951 if {$colltarget ne {}} { 10952 set suffix .$colltarget 10953 set targetdesc " (for target \"$colltarget\")" 10954 } else { 10955 set suffix {} 10956 set targetdesc {} 10957 } 10958 10959 set json [isStateEqual report_format json] 10960 10961 reportDebug "list collections for target \"$colltarget\"" 10962 10963 set coll_list [findCollections] 10964 10965 if { [llength $coll_list] == 0} { 10966 if {!$json} { 10967 report "No named collection$targetdesc." 10968 } 10969 } else { 10970 set list {} 10971 if {!$json} { 10972 if {$show_mtime} { 10973 displayTableHeader hi Collection 59 {Last mod.} 19 10974 } 10975 report "Named collection list$targetdesc:" 10976 } 10977 set display_list {} 10978 set len_list {} 10979 set max_len 0 10980 if {$show_mtime || $show_oneperline} { 10981 set display_idx 0 10982 set one_per_line 1 10983 } else { 10984 set display_idx 1 10985 set one_per_line 0 10986 } 10987 10988 foreach coll [lsort -dictionary $coll_list] { 10989 # remove target suffix from names to display 10990 regsub $suffix$ [file tail $coll] {} mod 10991 if {$json} { 10992 lappend display_list [formatListEltToJsonDisplay $mod target s\ 10993 $colltarget pathname s $coll] 10994 # no need to test mod consistency as findCollections does not return 10995 # collection whose name starts with "." 10996 } elseif {$show_mtime} { 10997 set filetime [clock format [getFileMtime $coll]\ 10998 -format {%Y/%m/%d %H:%M:%S}] 10999 lappend display_list [format %-60s%19s $mod $filetime] 11000 } else { 11001 lappend display_list $mod 11002 lappend len_list [set len [string length $mod]] 11003 if {$len > $max_len} { 11004 set max_len $len 11005 } 11006 } 11007 } 11008 11009 displayElementList noheader {} {} $one_per_line $display_idx\ 11010 $display_list $len_list $max_len 11011 } 11012} 11013 11014 11015proc cmdModuleSource {args} { 11016 reportDebug $args 11017 foreach fpath $args { 11018 set absfpath [getAbsolutePath $fpath] 11019 if {$fpath eq {}} { 11020 reportErrorAndExit {File name empty} 11021 } elseif {[file exists $absfpath]} { 11022 pushMode load 11023 # relax constraint of having a magic cookie at the start of the 11024 # modulefile to execute as sourced files may need more flexibility 11025 # as they may be managed outside of the modulefile environment like 11026 # the initialization modulerc file 11027 execute-modulefile $absfpath $absfpath $absfpath 0 11028 popMode 11029 } else { 11030 reportErrorAndExit "File $fpath does not exist" 11031 } 11032 } 11033} 11034 11035proc cmdModuleUnsource {args} { 11036 reportDebug $args 11037 foreach fpath $args { 11038 set absfpath [getAbsolutePath $fpath] 11039 if {$fpath eq {}} { 11040 reportErrorAndExit {File name empty} 11041 } elseif {[file exists $absfpath]} { 11042 pushMode unload 11043 # relax constraint of having a magic cookie at the start of the 11044 # modulefile to execute as sourced files may need more flexibility 11045 # as they may be managed outside of the modulefile environment like 11046 # the initialization modulerc file 11047 execute-modulefile $absfpath $absfpath $absfpath 0 11048 popMode 11049 } else { 11050 reportErrorAndExit "File $fpath does not exist" 11051 } 11052 } 11053} 11054 11055proc cmdModuleLoad {context uasked args} { 11056 reportDebug "loading $args (context=$context, uasked=$uasked)" 11057 11058 set ret 0 11059 pushMode load 11060 foreach mod $args { 11061 # if a switch action is ongoing... 11062 if {$context eq {swload}} { 11063 set swprocessing 1 11064 # context is ReqLo if switch is called from a modulefile 11065 if {![isMsgRecordIdTop]} { 11066 set context reqlo 11067 } 11068 } 11069 11070 # record evaluation attempt on specified module name 11071 registerModuleEvalAttempt $context $mod 11072 lassign [getPathToModule $mod] modfile modname 11073 if {$modfile eq {}} { 11074 set ret 1 11075 # go to next module to unload 11076 continue 11077 } 11078 11079 if {[isModuleEvalFailed load $modname]} { 11080 reportDebug "$modname ($modfile) load was already tried and failed" 11081 # nullify this evaluation attempt to avoid duplicate issue report 11082 unregisterModuleEvalAttempt $context $mod 11083 continue 11084 } 11085 11086 # if a switch action is ongoing... 11087 if {[info exists swprocessing]} { 11088 # pass the DepRe mod list to the calling cmdModuleSwitch procedure to 11089 # let it handle the load phase of the DepRe mechanism along with the 11090 # DepRe modules set from switched off module. 11091 upvar deprelist swdeprelist 11092 upvar isuasked isuasked 11093 11094 # transmit loaded mod name for switch report summary 11095 uplevel 1 set new $modname 11096 } 11097 11098 # set a unique id to record messages related to this evaluation. 11099 set msgrecid load-$modname-[getEvalModuleStackDepth] 11100 pushMsgRecordId $msgrecid 11101 11102 # record evaluation attempt on actual module name 11103 registerModuleEvalAttempt $context $modname 11104 registerModuleEvalAttempt $context $modfile 11105 11106 # check if passed modname correspond to an already loaded modfile 11107 # and get its loaded name (in case it has been loaded as full path) 11108 set loadedmodname [getLoadedMatchingName $modname] 11109 if {$loadedmodname ne {}} { 11110 set modname $loadedmodname 11111 } 11112 11113 pushSettings 11114 if {[set errCode [catch { 11115 if {[isModuleLoaded $modname] || [isModuleLoading $modname]} { 11116 reportDebug "$modname ($modfile) already loaded/loading" 11117 # exit treatment but no need to restore settings 11118 continue 11119 } 11120 11121 # register altname of modname prior any conflict check 11122 eval setLoadedAltname "{$modname}" [getAllModuleResolvedName\ 11123 $modname 1 $mod] 11124 11125 if {[getConf auto_handling]} { 11126 # get loaded modules holding a requirement on modname and able to 11127 # be reloaded 11128 set deprelist [getUnmetDependentLoadedModuleList $modname] 11129 reportDebug "depre mod list is '$deprelist'" 11130 11131 # Reload all modules that have declared a prereq on mod as they 11132 # may take benefit from their prereq availability if it is newly 11133 # loaded. First perform unload phase of the reload, prior mod load 11134 # to ensure these dependent modules are unloaded with the same 11135 # loaded prereq as when they were loaded 11136 if {[llength $deprelist] > 0} { 11137 array set isuasked [reloadModuleListUnloadPhase deprelist\ 11138 [getState force] {Unload of dependent _MOD_ failed} depun] 11139 if {[info exists swprocessing]} { 11140 if {[info exists swdeprelist]} { 11141 set swdeprelist [concat $deprelist $swdeprelist] 11142 } else { 11143 set swdeprelist $deprelist 11144 } 11145 } 11146 } 11147 } 11148 11149 if {[execute-modulefile $modfile $modname $mod]} { 11150 break 11151 } 11152 11153 # register this evaluation on the main one that triggered it (after 11154 # load evaluation to report correct order with other evaluations) 11155 registerModuleEval $context $modname 11156 11157 # raise an error if a conflict violation is detected 11158 # do that after modfile evaluation to give it the chance to solve its 11159 # (module unload) conflicts through its evaluation 11160 lassign [doesModuleConflict $modname] doescon modconlist\ 11161 moddecconlist 11162 set retisconun [eval isModuleEvaluated conun "{$modname}"\ 11163 $modconlist] 11164 if {![set retiseval [eval isModuleEvaluated any "{$modname}"\ 11165 $modconlist]] || [currentMsgRecordId] ne [topMsgRecordId] ||\ 11166 !$retisconun} { 11167 # more appropriate msg if an evaluation was attempted or is 11168 # by-passed. error is reported using declared conflict name (as if 11169 # it was raised raised from a conflict modulefile command) 11170 set conmsg [expr {$retiseval || [getState force] ?\ 11171 [getConIsLoadedMsg $moddecconlist [is-loading $modconlist]] :\ 11172 [getErrConflictMsg $modname $moddecconlist]}] 11173 } 11174 11175 # still proceed if force mode enabled 11176 if {[getState force] && $doescon} { 11177 defineModEqProc [isIcase] [getConf extended_default] 11178 # report warning if not already done 11179 set report_con 1 11180 if {[info exists ::report_conflict($modname)]} { 11181 # check if conflict has not been already reported with an 11182 # alternative name 11183 foreach modalt [concat [getLoadedAltname $modconlist]\ 11184 $modconlist $moddecconlist] { 11185 foreach reportmod $::report_conflict($modname) { 11186 if {[doesModuleMatchesName $modalt $reportmod]} { 11187 set report_con 0 11188 break 11189 } 11190 } 11191 } 11192 } 11193 if {$report_con && [info exists conmsg]} { 11194 reportWarning $conmsg 11195 } 11196 # raise conun-specific msg to top level if attempted 11197 if {$retisconun} { 11198 reportWarning [getErrConUnMsg $moddecconlist] 1 11199 } 11200 } elseif {$doescon} { 11201 if {$retisconun} { 11202 if {[info exists conmsg]} { 11203 reportError $conmsg 11204 } 11205 # raise conun-specific msg to top level if attempted 11206 knerror [getErrConUnMsg $moddecconlist] 11207 } else { 11208 set errlocalreport 1 11209 knerror $conmsg 11210 } 11211 } 11212 11213 add-path append LOADEDMODULES $modname 11214 # allow duplicate modfile entries for virtual modules 11215 add-path append --duplicates _LMFILES_ $modfile 11216 # update cache arrays 11217 setLoadedModule $modname $modfile $uasked 11218 11219 # register declared source-sh in environment 11220 if {[set modsrcsh [getLoadedSourceSh $modname 1]] ne {}} { 11221 add-path append MODULES_LMSOURCESH $modsrcsh 11222 } 11223 11224 # register declared conflict in environment 11225 if {[set modcon [getLoadedConflict $modname 1]] ne {}} { 11226 add-path append MODULES_LMCONFLICT $modcon 11227 } 11228 11229 # declare the prereq of this module 11230 if {[set modpre [getLoadedPrereq $modname 1]] ne {}} { 11231 add-path append MODULES_LMPREREQ $modpre 11232 } 11233 11234 # declare module as not asked by user (automatically loaded as 11235 # dependency) if it is the case 11236 if {!$uasked} { 11237 add-path append MODULES_LMNOTUASKED $modname 11238 } 11239 11240 # declare the alternative names of this module 11241 if {[set modalt [getLoadedAltname $modname 1]] ne {}} { 11242 add-path append MODULES_LMALTNAME $modalt 11243 } 11244 11245 # Load phase of dependent module reloading. These modules can adapt 11246 # now that mod is seen loaded. Except if switch action ongoing (DepRe 11247 # load phase will occur from switch) 11248 if {[getConf auto_handling] && [llength $deprelist] > 0 && ![info\ 11249 exists swprocessing]} { 11250 reloadModuleListLoadPhase deprelist [array get isuasked]\ 11251 [getState force] {Reload of dependent _MOD_ failed} depre 11252 } 11253 11254 # report a summary of automated evaluations if no error 11255 reportModuleEval 11256 } errMsg]] != 0 && $errCode != 4} { 11257 if {$errMsg ne {}} { 11258 reportError $errMsg [expr {![info exists errlocalreport]}] 11259 } 11260 # report switched-on module load failure under switch info block 11261 # unless the above reportError call already put a mesg to this block 11262 if {[info exists swprocessing] && ($errMsg eq {} || [info exists\ 11263 errlocalreport])} { 11264 # warn as this issue does not lead to a rollback of switch action 11265 reportWarning "Load of switched-on $modname failed" 1 11266 } 11267 # rollback settings if some evaluation went wrong 11268 set ret 1 11269 restoreSettings 11270 # remove from successfully evaluated module list 11271 registerModuleEval $context $modname 1 load 11272 unset -nocomplain errlocalreport 11273 } 11274 popSettings 11275 11276 # report all recorded messages for this evaluation except if module were 11277 # already loaded 11278 if {$errCode != 4} { 11279 reportMsgRecord "Loading [sgr hi $modname]" 11280 } 11281 popMsgRecordId 11282 } 11283 popMode 11284 11285 return $ret 11286} 11287 11288proc cmdModuleUnload {context match auto force onlyureq onlyndep args} { 11289 reportDebug "unloading $args (context=$context, match=$match, auto=$auto,\ 11290 force=$force, onlyureq=$onlyureq, onlyndep=$onlyndep)" 11291 11292 set ret 0 11293 pushMode unload 11294 foreach mod $args { 11295 # if a switch action is ongoing... 11296 if {$context eq {swunload}} { 11297 set swprocessing 1 11298 # context is ConUn if switch is called from a modulefile 11299 if {![isMsgRecordIdTop]} { 11300 set context conun 11301 } 11302 } 11303 11304 # record evaluation attempt on specified module name 11305 registerModuleEvalAttempt $context $mod 11306 # resolve by also looking at matching loaded module 11307 lassign [getPathToModule $mod {} 1 $match] modfile modname errkind 11308 if {$modfile eq {}} { 11309 # no error return if module is not loaded 11310 if {$errkind eq {notloaded}} { 11311 reportDebug "$modname is not loaded" 11312 } else { 11313 set ret 1 11314 } 11315 # go to next module to unload 11316 continue 11317 } 11318 11319 if {$onlyureq && ![isModuleUnloadable $modname]} { 11320 reportDebug "$modname ($modfile) is required by loaded module or\ 11321 asked by user" 11322 continue 11323 } 11324 11325 if {[isModuleEvalFailed unload $modname]} { 11326 reportDebug "$modname ($modfile) unload was already tried and failed" 11327 # nullify this evaluation attempt to avoid duplicate issue report 11328 unregisterModuleEvalAttempt $context $mod 11329 continue 11330 } 11331 11332 # if a switch action is ongoing... 11333 if {[info exists swprocessing]} { 11334 # pass the DepRe mod list to the calling cmdModuleSwitch 11335 # procedure to let it handle the load phase of the DepRe 11336 # mechanism once the switched-to module will be loaded 11337 upvar deprelist deprelist 11338 upvar isuasked isuasked 11339 11340 # transmit unloaded mod name for switch report summary 11341 uplevel 1 set old $modname 11342 } 11343 # set a unique id to record messages related to this evaluation. 11344 set msgrecid unload-$modname-[getEvalModuleStackDepth] 11345 pushMsgRecordId $msgrecid 11346 11347 # record evaluation attempt on actual module name 11348 registerModuleEvalAttempt $context $modname 11349 registerModuleEvalAttempt $context $modfile 11350 11351 pushSettings 11352 if {[set errCode [catch { 11353 # error if unloading module violates a registered prereq 11354 # and auto handling mode is disabled 11355 set prereq_list [getDependentLoadedModuleList [list $modname]] 11356 if {[llength $prereq_list] > 0 && (![getConf auto_handling] ||\ 11357 !$auto)} { 11358 # force mode should not affect if we only look for mods w/o dep 11359 if {([getState force] || $force) && !$onlyndep} { 11360 # in case unload is called for a DepRe mechanism or a purge do 11361 # not warn about prereq violation enforced as it is due to the 11362 # dependent module which is already in a violation state 11363 if {$auto || !$force} { 11364 reportWarning [getDepLoadedMsg $prereq_list] 11365 } 11366 } else { 11367 set errlocalreport 1 11368 # exit treatment but no need to set return code to error if 11369 # called from a 'module unload' command in a modulefile in a 11370 # load evaluation mode, as set conflict will raise error at end 11371 # of modulefile evaluation 11372 if {$onlyndep} { 11373 set errharmless 1 11374 } 11375 knerror [expr {[eval isModuleEvaluated any "{$modname}"\ 11376 $prereq_list] ? [getDepLoadedMsg $prereq_list] :\ 11377 [getErrPrereqMsg $modname $prereq_list 0]}] 11378 } 11379 } 11380 11381 if {[getConf auto_handling] && $auto} { 11382 # compute lists of modules to update due to modname unload prior 11383 # unload to get requirement info before it vanishes 11384 11385 # DepUn: Dependent to Unload (modules actively requiring modname 11386 # or a module part of this DepUn batch) 11387 set depunnpolist [getDependentLoadedModuleList [list $modname] 1\ 11388 0 1 0] 11389 set depunlist [getDependentLoadedModuleList [list $modname] 1 0 0 0] 11390 # look at both regular dependencies or No Particular Order 11391 # dependencies: use NPO result if situation can be healed with NPO 11392 # dependencies, which will be part of DepRe list to restore the 11393 # correct loading order for them 11394 if {[llength $depunnpolist] <= [llength $depunlist]} { 11395 set depunlist $depunnpolist 11396 } 11397 reportDebug "depun mod list is '$depunlist'" 11398 11399 # do not check for UReqUn mods coming from DepUn modules as these 11400 # DepUn modules are reloaded 11401 if {[info exists swprocessing]} { 11402 set urequnqry [list $modname] 11403 } else { 11404 set urequnqry [concat $depunlist [list $modname]] 11405 } 11406 11407 # UReqUn: Useless Requirement to Unload (autoloaded requirements 11408 # of modname or DepUn modules not required by any remaining mods) 11409 set urequnlist [getUnloadableLoadedModuleList $urequnqry] 11410 reportDebug "urequn mod list is '$urequnlist'" 11411 11412 # DepRe: Dependent to Reload (modules optionnaly dependent or in 11413 # conflict with modname, DepUn or UReqUn modules + modules 11414 # dependent of a module part of this DepRe batch) 11415 set deprelist [getDependentLoadedModuleList [concat $urequnlist\ 11416 $depunlist [list $modname]] 0 0 1 0 1 1] 11417 reportDebug "depre mod list is '$deprelist'" 11418 11419 # DepUn mods are merged into the DepRe list as an attempt to 11420 # reload these DepUn mods is made once switched-to mod loaded 11421 if {[info exists swprocessing]} { 11422 set deprelist [sortModulePerLoadedAndDepOrder [concat\ 11423 $depunlist $deprelist] 1] 11424 set depunlist {} 11425 } 11426 11427 # Reload of all DepRe mods, as they may adapt from the mod unloads 11428 # happening here. First perform unload phase of the reload, prior 11429 # mod unloads to ensure these dependent mods are unloaded with the 11430 # same loaded prereq as when they were loaded. Avoid modules not 11431 # satisfying their constraint. 11432 if {[llength $deprelist] > 0} { 11433 array set isuasked [reloadModuleListUnloadPhase deprelist\ 11434 [getState force] {Unload of dependent _MOD_ failed} depun] 11435 } 11436 11437 # DepUn modules unload prior main mod unload 11438 if {[llength $depunlist] > 0} { 11439 foreach unmod [lreverse $depunlist] { 11440 if {[cmdModuleUnload depun match 0 0 0 0 $unmod]} { 11441 # stop if one unload fails unless force mode enabled 11442 set errMsg "Unload of dependent $unmod failed" 11443 if {[getState force] || $force} { 11444 reportWarning $errMsg 1 11445 } else { 11446 knerror $errMsg 11447 } 11448 } 11449 } 11450 } 11451 } 11452 11453 # register this evaluation on the main one that triggered it (prior 11454 # unload evaluation to report correct order with other evaluations) 11455 registerModuleEval $context $modname 11456 11457 if {[execute-modulefile $modfile $modname $mod]} { 11458 break 11459 } 11460 11461 # get module position in loaded list to remove corresponding loaded 11462 # modulefile (entry at same position in _LMFILES_) 11463 # need the unfiltered loaded module list to get correct index 11464 set lmidx [lsearch -exact [getLoadedModuleList 0] $modname] 11465 unload-path LOADEDMODULES $modname 11466 unload-path --index _LMFILES_ $lmidx 11467 if {![isModuleUserAsked $modname]} { 11468 unload-path MODULES_LMNOTUASKED $modname 11469 } 11470 # update cache arrays 11471 unsetLoadedModule $modname $modfile 11472 11473 # unregister declared source-sh 11474 if {[set modsrcsh [getLoadedSourceSh $modname 1]] ne {}} { 11475 unload-path MODULES_LMSOURCESH $modsrcsh 11476 } 11477 unsetLoadedSourceSh $modname 11478 11479 # unregister declared conflict 11480 if {[set modcon [getLoadedConflict $modname 1]] ne {}} { 11481 unload-path MODULES_LMCONFLICT $modcon 11482 } 11483 unsetLoadedConflict $modname 11484 11485 # unset prereq declared for this module 11486 if {[llength [set modpre [getLoadedPrereq $modname]]] > 0} { 11487 unload-path MODULES_LMPREREQ [getLoadedPrereq $modname 1] 11488 } 11489 unsetLoadedPrereq $modname 11490 11491 # unset alternative names declared for this module 11492 if {[llength [set modalt [getLoadedAltname $modname]]] >0} { 11493 unload-path MODULES_LMALTNAME [getLoadedAltname $modname 1] 11494 } 11495 unsetLoadedAltname $modname 11496 11497 if {[getConf auto_handling] && $auto} { 11498 # UReqUn modules unload now DepUn+main mods are unloaded 11499 if {[llength $urequnlist] > 0} { 11500 set urequnlist [lreverse $urequnlist] 11501 for {set i 0} {$i < [llength $urequnlist]} {incr i 1} { 11502 set unmod [lindex $urequnlist $i] 11503 if {[cmdModuleUnload urequn match 0 0 0 0 $unmod]} { 11504 # just warn if UReqUn module cannot be unloaded, main 11505 # unload process continues, just the UReqUn modules that 11506 # are required by unmod (whose unload failed) are 11507 # withdrawn from UReqUn module list 11508 reportWarning "Unload of useless requirement $unmod\ 11509 failed" 1 11510 lassign [getDiffBetweenList $urequnlist\ 11511 [getRequiredLoadedModuleList [list $unmod]]]\ 11512 urequnlist 11513 } 11514 } 11515 } 11516 11517 # DepRe modules load phase now DepUn+UReqUn+main mods are unloaded 11518 # except if a switch action is ongoing as this DepRe load phase 11519 # will occur after the new mod load 11520 if {[llength $deprelist] > 0 && ![info exists swprocessing]} { 11521 reloadModuleListLoadPhase deprelist [array get isuasked]\ 11522 [getState force] {Reload of dependent _MOD_ failed} depre 11523 } 11524 } 11525 11526 # report a summary of automated evaluations if no error 11527 reportModuleEval 11528 } errMsg]] != 0 && $errCode != 4} { 11529 if {$errMsg ne {}} { 11530 reportError $errMsg [expr {![info exists errlocalreport]}] 11531 } 11532 # report switched-off module unload failure under switch info block 11533 # unless the above reportError call already put a mesg to this block 11534 if {[info exists swprocessing] && ($errMsg eq {} || [info exists\ 11535 errlocalreport])} { 11536 reportError "Unload of switched-off $modname failed" 1 11537 } 11538 # rollback settings if some evaluation went wrong 11539 if {![info exists errharmless]} { 11540 set ret 1 11541 restoreSettings 11542 # remove from successfully evaluated module list 11543 registerModuleEval $context $modname 1 unload 11544 } 11545 unset -nocomplain errlocalreport errharmless 11546 } 11547 popSettings 11548 11549 # report all recorded messages for this evaluation 11550 reportMsgRecord "Unloading [sgr hi $modname]" 11551 popMsgRecordId 11552 } 11553 popMode 11554 11555 return $ret 11556} 11557 11558proc cmdModulePurge {} { 11559 reportDebug called. 11560 11561 # create an eval id to track successful/failed module evaluations 11562 pushMsgRecordId purge-[getEvalModuleStackDepth] 0 11563 11564 # unload one by one to ensure same behavior whatever auto_handling state 11565 # force it to handle loaded modules in violation state 11566 eval cmdModuleUnload unload match 0 1 0 0 [lreverse [getLoadedModuleList]] 11567 11568 popMsgRecordId 0 11569} 11570 11571proc cmdModuleReload {args} { 11572 # reload all loaded modules if no module list passed 11573 if {[llength $args] == 0} { 11574 set lmlist [getLoadedModuleList] 11575 } else { 11576 set lmlist $args 11577 } 11578 reportDebug "reloading $lmlist" 11579 11580 # create an eval id to track successful/failed module evaluations 11581 pushMsgRecordId reload-[getEvalModuleStackDepth] 0 11582 11583 # no reload of all loaded modules attempt if constraints are violated 11584 if {[llength $args] == 0 && ![areModuleConstraintsSatisfied]} { 11585 reportError {Cannot reload modules, some of their constraints are not\ 11586 satistied} 11587 } else { 11588 pushSettings 11589 if {[set errCode [catch { 11590 # run unload then load-again phases 11591 array set isuasked [reloadModuleListUnloadPhase lmlist] 11592 reloadModuleListLoadPhase lmlist [array get isuasked] 11593 } errMsg]] == 1} { 11594 # rollback settings if some evaluation went wrong 11595 restoreSettings 11596 } 11597 popSettings 11598 } 11599 11600 popMsgRecordId 0 11601} 11602 11603proc cmdModuleAliases {} { 11604 # disable error reporting to avoid modulefile errors 11605 # to mix with avail results 11606 inhibitErrorReport 11607 11608 # parse paths to fill g_moduleAlias and g_moduleVersion 11609 foreach dir [getModulePathList exiterronundef] { 11610 getModules $dir {} 0 {} 11611 } 11612 11613 setState inhibit_errreport 0 11614 11615 set display_list {} 11616 foreach name [lsort -dictionary [array names ::g_moduleAlias]] { 11617 # exclude hidden aliases from result 11618 if {![isModuleHidden $name]} { 11619 lappend display_list "[sgr al $name] -> $::g_moduleAlias($name)" 11620 } 11621 } 11622 displayElementList Aliases hi sepline 1 0 $display_list 11623 11624 set display_list {} 11625 foreach name [lsort -dictionary [array names ::g_moduleVersion]] { 11626 # exclude hidden versions or versions targeting an hidden module 11627 if {![isModuleHidden $name] && ![isModuleHidden\ 11628 $::g_moduleVersion($name)]} { 11629 lappend display_list "[sgr sy $name] -> $::g_moduleVersion($name)" 11630 } 11631 } 11632 displayElementList Versions hi sepline 1 0 $display_list 11633} 11634 11635proc cmdModuleAvail {show_oneperline show_mtime show_filter search_filter\ 11636 search_match args} { 11637 if {[llength $args] == 0} { 11638 lappend args * 11639 } 11640 11641 if {$show_mtime || $show_oneperline} { 11642 set one_per_line 1 11643 set hstyle terse 11644 set theader_shown 0 11645 set theader_cols [list hi Package/Alias 39 Versions 19 {Last mod.} 19] 11646 } else { 11647 set one_per_line 0 11648 set hstyle sepline 11649 } 11650 11651 # set a default filter (do not print dirs with no tag) if none set 11652 if {$show_filter eq {}} { 11653 set show_filter noplaindir 11654 } 11655 11656 # disable error reporting to avoid modulefile errors 11657 # to mix with avail results 11658 inhibitErrorReport 11659 11660 foreach mod $args { 11661 # look if aliases have been defined in the global or user-specific 11662 # modulerc and display them if any in a dedicated list 11663 lassign [listModules {} $mod $show_mtime $show_filter [concat\ 11664 $search_filter [list $search_match rc_alias_only wild]]]\ 11665 display_list len_list max_len 11666 if {[llength $display_list] > 0 && $show_mtime && !$theader_shown} { 11667 set theader_shown 1 11668 eval displayTableHeader $theader_cols 11669 } 11670 displayElementList {global/user modulerc} hi $hstyle $one_per_line 0\ 11671 $display_list $len_list $max_len 11672 11673 foreach dir [getModulePathList exiterronundef] { 11674 lassign [listModules $dir $mod $show_mtime $show_filter [concat\ 11675 $search_filter [list $search_match wild]]] display_list len_list\ 11676 max_len 11677 if {[llength $display_list] > 0 && $show_mtime && !$theader_shown} { 11678 set theader_shown 1 11679 eval displayTableHeader $theader_cols 11680 } 11681 displayElementList $dir mp $hstyle $one_per_line 0 $display_list\ 11682 $len_list $max_len 11683 } 11684 } 11685 11686 setState inhibit_errreport 0 11687} 11688 11689proc cmdModuleUse {pos args} { 11690 reportDebug $args 11691 11692 if {$args eq {}} { 11693 showModulePath 11694 } else { 11695 foreach path $args { 11696 if {$path eq {}} { 11697 reportError {Directory name empty} 11698 } else { 11699 # tranform given path in an absolute path to avoid dependency to 11700 # the current work directory. except if this path starts with a 11701 # variable reference 11702 if {[string index $path 0] ne {$}} { 11703 set path [getAbsolutePath $path] 11704 } 11705 if {[file isdirectory [resolvStringWithEnv $path]]} { 11706 pushMode load 11707 catch {add-path $pos MODULEPATH $path} 11708 popMode 11709 } else { 11710 reportError "Directory '$path' not found" 11711 } 11712 } 11713 } 11714 } 11715} 11716 11717proc cmdModuleUnuse {args} { 11718 reportDebug $args 11719 11720 if {$args eq {}} { 11721 showModulePath 11722 } else { 11723 foreach path $args { 11724 # get current module path list 11725 # no absolute path conversion for the moment 11726 if {![info exists modpathlist]} { 11727 set modpathlist [getModulePathList returnempty 0 0] 11728 } 11729 11730 # skip empty string 11731 if {$path eq {}} { 11732 reportError {Directory name empty} 11733 continue 11734 } 11735 11736 # transform given path in an absolute path which should have been 11737 # registered in the MODULEPATH env var. however for compatibility 11738 # with previous behavior where relative paths were registered in 11739 # MODULEPATH given path is first checked against current path list 11740 set abspath [getAbsolutePath $path] 11741 if {[isInList $modpathlist $path]} { 11742 set unusepath $path 11743 } elseif {[isInList $modpathlist $abspath]} { 11744 set unusepath $abspath 11745 } else { 11746 set unusepath {} 11747 } 11748 11749 if {$unusepath ne {}} { 11750 pushMode unload 11751 catch { 11752 unload-path MODULEPATH $unusepath 11753 } 11754 popMode 11755 11756 # refresh path list after unload 11757 set modpathlist [getModulePathList returnempty 0 0] 11758 if {[isInList $modpathlist $unusepath]} { 11759 reportWarning "Did not unuse $unusepath" 11760 } 11761 } 11762 } 11763 } 11764} 11765 11766proc cmdModuleAutoinit {} { 11767 reportDebug called. 11768 11769 # flag to make renderSettings define the module command 11770 setState autoinit 1 11771 11772 # initialize env variables around module command 11773 pushMode load 11774 11775 # register command location 11776 setenv MODULES_CMD [getAbsolutePath $::argv0] 11777 11778 # define current Modules version if versioning enabled 11779 @VERSIONING@if {![info exists ::env(MODULE_VERSION)]} { 11780 @VERSIONING@ setenv MODULE_VERSION @MODULES_RELEASE@@MODULES_BUILD@ 11781 @VERSIONING@ setenv MODULE_VERSION_STACK @MODULES_RELEASE@@MODULES_BUILD@ 11782 @VERSIONING@} 11783 11784 # initialize default MODULEPATH and LOADEDMODULES 11785 if {[get-env MODULEPATH] eq {}} { 11786 # set modpaths defined in modulespath config file if it exists, use file 11787 # in etcdir if it exists, dot file in initdir elsewhere 11788 set modulespath [expr {[file exists @etcdir@/modulespath] ?\ 11789 {@etcdir@/modulespath} : {@initdir@/.modulespath}}] 11790 if {[file readable $modulespath]} { 11791 set fdata [split [readFile $modulespath] \n] 11792 foreach fline $fdata { 11793 if {[regexp {^\s*(.*?)\s*(#.*|)$} $fline match patharg] == 1\ 11794 && $patharg ne {}} { 11795 eval cmdModuleUse append [split $patharg :] 11796 } 11797 } 11798 } 11799 11800 if {![info exists ::env(MODULEPATH)]} { 11801 setenv MODULEPATH {} 11802 } 11803 } 11804 if {![info exists ::env(LOADEDMODULES)]} { 11805 setenv LOADEDMODULES {} 11806 } 11807 11808 # source initialization modulerc if any and if no env already initialized 11809 # use initrc file in etcdir if any, modulerc file in initdir otherwise 11810 if {[get-env MODULEPATH] eq {} && [get-env LOADEDMODULES] eq {}} { 11811 set initrc [expr {[file exists @etcdir@/initrc] ? {@etcdir@/initrc} :\ 11812 {@initdir@/modulerc}}] 11813 if {[file exists $initrc]} { 11814 cmdModuleSource $initrc 11815 } 11816 } 11817 11818 # default MODULESHOME 11819 setenv MODULESHOME [getConf home] 11820 11821 # define Modules init script as shell startup file 11822 if {[getConf set_shell_startup] && [isInList [list sh csh fish]\ 11823 [getState shelltype]]} { 11824 # setup ENV variables to get module defined in sub-shells (works for 11825 # 'sh' and 'ksh' in interactive mode and 'sh' (zsh-compat), 'bash' and 11826 # 'ksh' (zsh-compat) in non-interactive mode. 11827 setenv ENV @initdir@/profile.sh 11828 setenv BASH_ENV @initdir@/bash 11829 } 11830 11831 popMode 11832} 11833 11834proc cmdModuleInit {args} { 11835 set init_cmd [lindex $args 0] 11836 set init_list [lrange $args 1 end] 11837 set notdone 1 11838 set nomatch 1 11839 11840 reportDebug $args 11841 11842 # Define startup files for each shell 11843 set files(csh) [list .modules .cshrc .cshrc_variables .login] 11844 set files(tcsh) [list .modules .tcshrc .cshrc .cshrc_variables .login] 11845 set files(sh) [list .modules .bash_profile .bash_login .profile .bashrc] 11846 set files(bash) $files(sh) 11847 set files(ksh) $files(sh) 11848 set files(fish) [list .modules .config/fish/config.fish] 11849 set files(zsh) [list .modules .zshrc .zshenv .zlogin] 11850 11851 # Process startup files for this shell 11852 set current_files $files([getState shell]) 11853 foreach filename $current_files { 11854 if {$notdone} { 11855 set filepath $::env(HOME) 11856 append filepath / $filename 11857 11858 reportDebug "Looking at $filepath" 11859 if {[file readable $filepath] && [file isfile $filepath]} { 11860 set newinit {} 11861 set thismatch 0 11862 11863 foreach curline [split [readFile $filepath] \n] { 11864 # Find module load/add command in startup file 11865 set comments {} 11866 if {$notdone && [regexp {^([ \t]*module[ \t]+(load|add)[\ 11867 \t]*)(.*)} $curline match cmd subcmd modules]} { 11868 set nomatch 0 11869 set thismatch 1 11870 regexp {([ \t]*\#.+)} $modules match comments 11871 regsub {\#.+} $modules {} modules 11872 11873 # remove existing references to the named module from 11874 # the list Change the module command line to reflect the 11875 # given command 11876 switch -- $init_cmd { 11877 list { 11878 if {![info exists notheader]} { 11879 report "[getState shell] initialization file\ 11880 \$HOME/$filename loads modules:" 11881 set notheader 0 11882 } 11883 report \t$modules 11884 } 11885 add { 11886 foreach newmodule $init_list { 11887 set modules [replaceFromList $modules $newmodule] 11888 } 11889 lappend newinit "$cmd$modules $init_list$comments" 11890 # delete new modules in potential next lines 11891 set init_cmd rm 11892 } 11893 prepend { 11894 foreach newmodule $init_list { 11895 set modules [replaceFromList $modules $newmodule] 11896 } 11897 lappend newinit "$cmd$init_list $modules$comments" 11898 # delete new modules in potential next lines 11899 set init_cmd rm 11900 } 11901 rm { 11902 set oldmodcount [llength $modules] 11903 foreach oldmodule $init_list { 11904 set modules [replaceFromList $modules $oldmodule] 11905 } 11906 set modcount [llength $modules] 11907 lappend newinit [expr {$modcount > 0 ?\ 11908 "$cmd$modules$comments" : [string trim $cmd]}] 11909 if {$oldmodcount > $modcount} { 11910 set notdone 0 11911 } 11912 } 11913 switch { 11914 set oldmodule [lindex $init_list 0] 11915 set newmodule [lindex $init_list 1] 11916 set newmodules [replaceFromList $modules\ 11917 $oldmodule $newmodule] 11918 lappend newinit $cmd$newmodules$comments 11919 if {$modules ne $newmodules} { 11920 set notdone 0 11921 } 11922 } 11923 clear { 11924 lappend newinit [string trim $cmd] 11925 } 11926 } 11927 } elseif {$curline ne {}} { 11928 # copy the line from the old file to the new 11929 lappend newinit $curline 11930 } 11931 } 11932 11933 if {$init_cmd ne {list} && $thismatch} { 11934 reportDebug "Writing $filepath" 11935 if {[catch { 11936 set fid [open $filepath w] 11937 puts $fid [join $newinit \n] 11938 close $fid 11939 } errMsg ]} { 11940 reportErrorAndExit "Init file $filepath cannot be\ 11941 written.\n$errMsg" 11942 } 11943 } 11944 } 11945 } 11946 } 11947 11948 # quit in error if command was not performed due to no match 11949 if {$nomatch && $init_cmd ne {list}} { 11950 reportErrorAndExit "Cannot find a 'module load' command in any of the\ 11951 '[getState shell]' startup files" 11952 } 11953} 11954 11955# provide access to modulefile specific commands from the command-line, making 11956# them standing as a module sub-command (see module procedure) 11957proc cmdModuleResurface {cmd args} { 11958 reportDebug "cmd='$cmd', args='$args'" 11959 11960 pushMode load 11961 pushCommandName $cmd 11962 11963 # run modulefile command and get its result 11964 if {[catch {eval $cmd $args} res]} { 11965 # report error if any and return false 11966 reportError $res 11967 } else { 11968 # register result depending of return kind (false or text) 11969 switch -- $cmd { 11970 module-info { 11971 set ::g_return_text $res 11972 } 11973 default { 11974 if {$res == 0} { 11975 # render false if command returned false 11976 setState return_false 1 11977 } 11978 } 11979 } 11980 } 11981 11982 popCommandName 11983 popMode 11984} 11985 11986proc cmdModuleTest {args} { 11987 reportDebug "testing $args" 11988 11989 pushMode test 11990 set first_report 1 11991 foreach mod $args { 11992 lassign [getPathToModule $mod] modfile modname 11993 if {$modfile ne {}} { 11994 # only one separator lines between 2 modules 11995 if {$first_report} { 11996 displaySeparatorLine 11997 set first_report 0 11998 } 11999 report "Module Specific Test for [sgr hi $modfile]:\n" 12000 execute-modulefile $modfile $modname $mod 12001 displaySeparatorLine 12002 } 12003 } 12004 popMode 12005} 12006 12007proc cmdModuleClear {{doit {}}} { 12008 reportDebug "($doit)" 12009 # fetch confirmation if no arg passed and force mode disabled 12010 if {$doit eq {} && ![getState force]} { 12011 # ask for it if stdin is attached to a terminal 12012 if {![catch {fconfigure stdin -mode}]} { 12013 report "Are you sure you want to clear all loaded modules!? \[n\] " 1 12014 flush [getState reportfd] 12015 } 12016 # fetch stdin content even if not attached to terminal in case some 12017 # content has been piped to this channel 12018 set doit [gets stdin] 12019 } 12020 12021 # should be confirmed or forced to proceed 12022 if {[string equal -nocase -length 1 $doit y] || [getState force]} { 12023 set vartoclear [list LOADEDMODULES MODULES_LMALTNAME MODULES_LMCONFLICT\ 12024 MODULES_LMNOTUASKED MODULES_LMPREREQ _LMFILES_] 12025 12026 # add any reference counter variable to the list to unset 12027 set vartoclear [concat $vartoclear [array names ::env -glob *_modshare]\ 12028 [array names ::env -glob MODULES_MODSHARE_*]] 12029 12030 # unset all Modules runtime variables 12031 pushMode load 12032 foreach var $vartoclear { 12033 unset-env $var 12034 } 12035 popMode 12036 } else { 12037 reportInfo "Modules runtime information were not cleared" 12038 } 12039} 12040 12041proc cmdModuleConfig {dump_state args} { 12042 # parse arguments 12043 set nameunset 0 12044 switch -- [llength $args] { 12045 1 { 12046 lassign $args name 12047 } 12048 2 { 12049 lassign $args name value 12050 # check if configuration should be set or unset 12051 if {$name eq {--reset}} { 12052 set name $value 12053 set nameunset 1 12054 unset value 12055 } 12056 } 12057 } 12058 12059 reportDebug "dump_state='$dump_state', reset=$nameunset,\ 12060 name=[expr {[info exists name] ? "'$name'" : {<undef>}}], value=[expr\ 12061 {[info exists value] ? "'$value'" : {<undef>}}]" 12062 12063 foreach option [array names ::g_config_defs] { 12064 lassign $::g_config_defs($option) confvar($option) defval\ 12065 conflockable($option) confvalid($option) vtrans 12066 set confval($option) [getConf $option <undef>] 12067 set confvtrans($option) {} 12068 for {set i 0} {$i < [llength $vtrans]} {incr i} { 12069 lappend confvtrans($option) [lindex $vtrans $i] [lindex\ 12070 $confvalid($option) $i] 12071 } 12072 } 12073 12074 # catch any environment variable set for modulecmd run-time execution 12075 foreach runenvvar [array names ::env -glob MODULES_RUNENV_*] { 12076 set runenvconf [string tolower [string range $runenvvar 8 end]] 12077 set confval($runenvconf) [get-env $runenvvar] 12078 # enable modification of runenv conf 12079 set confvar($runenvconf) $runenvvar 12080 set confvalid($runenvconf) {} 12081 set conflockable($runenvconf) {} 12082 set confvtrans($runenvconf) {} 12083 } 12084 12085 if {[info exists name] && ![info exists confval($name)]} { 12086 reportErrorAndExit "Configuration option '$name' does not exist" 12087 # set configuration 12088 } elseif {[info exists name] && ($nameunset || [info exists value])} { 12089 if {$confvar($name) eq {}} { 12090 reportErrorAndExit "Configuration option '$name' cannot be altered" 12091 } elseif {$conflockable($name) eq {1} && [isConfigLocked $name]} { 12092 reportErrorAndExit "Configuration option '$name' is locked" 12093 } elseif {$nameunset} { 12094 # unset configuration variable 12095 pushMode load 12096 unsetenv $confvar($name) 12097 popMode 12098 } elseif {[llength $confvalid($name)] > 0 && [notInList\ 12099 $confvalid($name) $value]} { 12100 reportErrorAndExit "Valid values for configuration option '$name'\ 12101 are: $confvalid($name)" 12102 } else { 12103 # effectively set configuration variable 12104 pushMode load 12105 setenv $confvar($name) $value 12106 popMode 12107 } 12108 # clear cached value for config if any 12109 unsetConf $name 12110 # report configuration 12111 } else { 12112 reportVersion 12113 reportSeparateNextContent 12114 displayTableHeader hi {Config. name} 24 {Value (set by if default\ 12115 overridden)} 54 12116 12117 # report all configs or just queried one 12118 if {[info exists name]} { 12119 set varlist [list $name] 12120 } else { 12121 set varlist [lsort [array names confval]] 12122 } 12123 12124 foreach var $varlist { 12125 set valrep [displayConfig $confval($var) $confvar($var) [info exists\ 12126 ::asked_$var] $confvtrans($var) [expr {$conflockable($var) eq {1}\ 12127 && [isConfigLocked $var]}]] 12128 append displist [format {%-25s %s} $var $valrep] \n 12129 } 12130 report $displist 1 12131 reportSeparateNextContent 12132 12133 if {$dump_state} { 12134 displayTableHeader hi {State name} 24 {Value} 54 12135 # define each attribute/fetched state value pair 12136 foreach state [array names ::g_state_defs] { 12137 set stateval($state) [getState $state <undef> 1] 12138 } 12139 12140 unset displist 12141 foreach state [lsort [array names stateval]] { 12142 append displist [format {%-25s %s} $state $stateval($state)] \n 12143 } 12144 report $displist 1 12145 reportSeparateNextContent 12146 12147 # report environment variable set related to Modules 12148 displayTableHeader hi {Env. variable} 24 {Value} 54 12149 set envvar_list {} 12150 foreach var [list LOADEDMODULES _LMFILES_ MODULE* *_modshare\ 12151 *_modquar *_module*] { 12152 set envvar_list [concat $envvar_list [array names ::env -glob\ 12153 $var]] 12154 } 12155 unset displist 12156 foreach var [lsort -unique $envvar_list] { 12157 append displist [format {%-25s %s} $var $::env($var)] \n 12158 } 12159 report $displist 1 12160 } 12161 } 12162} 12163 12164proc cmdModuleShToMod {args} { 12165 set scriptargs [lassign $args shell script] 12166 12167 # evaluate script and get the environment changes it performs translated 12168 # into modulefile commands 12169 set modcontent [eval sh-to-mod $args] 12170 12171 # output resulting modulefile 12172 if {[llength $modcontent] > 0} { 12173 report "#%Module" 12174 # format each command with tabs and colors if enabled 12175 foreach modcmd $modcontent { 12176 eval reportCmd -nativeargrep $modcmd 12177 } 12178 } 12179} 12180 12181proc cmdMlHelp {} { 12182 reportVersion 12183 report {Usage: ml [options] [command] [args ...] 12184 ml [options] [[-]modulefile ...] 12185 12186Examples: 12187 ml equivalent to: module list 12188 ml foo bar equivalent to: module load foo bar 12189 ml -foo -bar baz equivalent to: module unload foo bar; module load baz 12190 ml avail -t equivalent to: module avail -t 12191 12192See 'module --help' to get available commands and options.} 12193} 12194 12195proc cmdModuleHelp {args} { 12196 pushMode help 12197 set first_report 1 12198 foreach arg $args { 12199 lassign [getPathToModule $arg] modfile modname 12200 12201 if {$modfile ne {}} { 12202 # only one separator lines between 2 modules 12203 if {$first_report} { 12204 displaySeparatorLine 12205 set first_report 0 12206 } 12207 report "Module Specific Help for [sgr hi $modfile]:\n" 12208 execute-modulefile $modfile $modname $arg 12209 displaySeparatorLine 12210 } 12211 } 12212 popMode 12213 if {[llength $args] == 0} { 12214 reportVersion 12215 report {Usage: module [options] [command] [args ...] 12216 12217Loading / Unloading commands: 12218 add | load modulefile [...] Load modulefile(s) 12219 rm | unload modulefile [...] Remove modulefile(s) 12220 purge Unload all loaded modulefiles 12221 reload | refresh Unload then load all loaded modulefiles 12222 switch | swap [mod1] mod2 Unload mod1 and load mod2 12223 12224Listing / Searching commands: 12225 list [-t|-l|-j] List loaded modules 12226 avail [-d|-L] [-t|-l|-j] [-a] [-S|-C] [--indepth|--no-indepth] [mod ...] 12227 List all or matching available modules 12228 aliases [-a] List all module aliases 12229 whatis [-a] [-j] [modulefile ...] Print whatis information of modulefile(s) 12230 apropos | keyword | search [-a] [-j] str 12231 Search all name and whatis containing str 12232 is-loaded [modulefile ...] Test if any of the modulefile(s) are loaded 12233 is-avail modulefile [...] Is any of the modulefile(s) available 12234 info-loaded modulefile Get full name of matching loaded module(s) 12235 12236Collection of modules handling commands: 12237 save [collection|file] Save current module list to collection 12238 restore [collection|file] Restore module list from collection or file 12239 saverm [collection] Remove saved collection 12240 saveshow [collection|file] Display information about collection 12241 savelist [-t|-l|-j] List all saved collections 12242 is-saved [collection ...] Test if any of the collection(s) exists 12243 12244Shell's initialization files handling commands: 12245 initlist List all modules loaded from init file 12246 initadd modulefile [...] Add modulefile to shell init file 12247 initrm modulefile [...] Remove modulefile from shell init file 12248 initprepend modulefile [...] Add to beginning of list in init file 12249 initswitch mod1 mod2 Switch mod1 with mod2 from init file 12250 initclear Clear all modulefiles from init file 12251 12252Environment direct handling commands: 12253 prepend-path [-d c] var val [...] Prepend value to environment variable 12254 append-path [-d c] var val [...] Append value to environment variable 12255 remove-path [-d c] var val [...] Remove value from environment variable 12256 12257Other commands: 12258 help [modulefile ...] Print this or modulefile(s) help info 12259 display | show modulefile [...] Display information about modulefile(s) 12260 test [modulefile ...] Test modulefile(s) 12261 use [-a|-p] dir [...] Add dir(s) to MODULEPATH variable 12262 unuse dir [...] Remove dir(s) from MODULEPATH variable 12263 is-used [dir ...] Is any of the dir(s) enabled in MODULEPATH 12264 path modulefile Print modulefile path 12265 paths modulefile Print path of matching available modules 12266 clear [-f] Reset Modules-specific runtime information 12267 source scriptfile [...] Execute scriptfile(s) 12268 config [--dump-state|name [val]] Display or set Modules configuration 12269 sh-to-mod shell shellscript [arg ...] 12270 Make modulefile from script env changes 12271 12272Switches: 12273 -t | --terse Display output in terse format 12274 -l | --long Display output in long format 12275 -j | --json Display output in JSON format 12276 -a | --all Include hidden modules in search 12277 -d | --default Only show default versions available 12278 -L | --latest Only show latest versions available 12279 -S | --starts-with 12280 Search modules whose name begins with query string 12281 -C | --contains Search modules whose name contains query string 12282 -i | --icase Case insensitive match 12283 -a | --append Append directory to MODULEPATH (on 'use' sub-command) 12284 -p | --prepend Prepend directory to MODULEPATH 12285 --auto Enable automated module handling mode 12286 --no-auto Disable automated module handling mode 12287 -f | --force By-pass dependency consistency or confirmation dialog 12288 12289Options: 12290 -h | --help This usage info 12291 -V | --version Module version 12292 -D | --debug Enable debug messages 12293 -T | --trace Enable trace messages 12294 -v | --verbose Enable verbose messages 12295 -s | --silent Turn off error, warning and informational messages 12296 --paginate Pipe mesg output into a pager if stream attached to terminal 12297 --no-pager Do not pipe message output into a pager 12298 --color[=WHEN] Colorize the output; WHEN can be 'always' (default if 12299 omitted), 'auto' or 'never'} 12300 } 12301} 12302 12303######################################################################## 12304# main program 12305 12306# needed on a gentoo system. Shouldn't hurt since it is 12307# supposed to be the default behavior 12308fconfigure stderr -translation auto 12309 12310if {[catch { 12311 # parse all command-line arguments before doing any action, no output is 12312 # made during argument parse to wait for potential paging to be setup 12313 set show_help 0 12314 set show_version 0 12315 setState cmdline "$argv0 $argv" 12316 12317 # Load extension library if enabled 12318 @libtclenvmodules@if {[file readable [getConf tcl_ext_lib]]} { 12319 @libtclenvmodules@ reportDebug "Load Tcl extension library ([getConf tcl_ext_lib])" 12320 @libtclenvmodules@ load [file normalize [getConf tcl_ext_lib]] Envmodules 12321 @libtclenvmodules@ setState tcl_ext_lib_loaded 1 12322 @libtclenvmodules@} 12323 # use fallback procs if extension library is not loaded 12324 if {[info commands readFile] eq {}} { 12325 rename ::__readFile ::readFile 12326 rename ::__getFilesInDirectory ::getFilesInDirectory 12327 rename ::__initStateUsergroups ::initStateUsergroups 12328 rename ::__initStateUsername ::initStateUsername 12329 } 12330 12331 # source site configuration script if any 12332 sourceSiteConfig 12333 12334 # Parse shell 12335 setState shell [lindex $argv 0] 12336 switch -- [getState shell] { 12337 sh - bash - ksh - zsh { 12338 setState shelltype sh 12339 } 12340 csh - tcsh { 12341 setState shelltype csh 12342 } 12343 fish - cmd - tcl - perl - python - ruby - lisp - cmake - r { 12344 setState shelltype [getState shell] 12345 } 12346 default { 12347 reportErrorAndExit "Unknown shell type \'([getState shell])\'" 12348 } 12349 } 12350 12351 # extract options and command switches from other args 12352 set otherargv {} 12353 set extraargv {} 12354 set ddelimarg 0 12355 # split first arg if multi-word string detected for compat with previous 12356 # doc on module usage with scripting language: module('load mod1 mod2') 12357 set argtoparse [if {[llength [lindex $argv 1]] > 1} {concat [split [lindex\ 12358 $argv 1]] [lrange $argv 2 end]} {lrange $argv 1 end}] 12359 foreach arg $argtoparse { 12360 if {[info exists ignore_next_arg]} { 12361 unset ignore_next_arg 12362 } else { 12363 switch -glob -- $arg { 12364 -T - --trace { 12365 set asked_verbosity trace 12366 } 12367 -D - -DD - --debug { 12368 set asked_verbosity [expr {$arg eq {-DD} || ([info exists\ 12369 asked_verbosity] && [isInList {debug debug2}\ 12370 $asked_verbosity]) ? {debug2} : {debug}}] 12371 } 12372 -s - --silent { 12373 set asked_verbosity silent 12374 } 12375 -v - --verbose { 12376 set asked_verbosity verbose 12377 } 12378 --help - -h { 12379 set show_help 1 12380 } 12381 -V - --version { 12382 set show_version 1 12383 } 12384 --paginate { 12385 set asked_paginate 1 12386 } 12387 --no-pager { 12388 set asked_paginate 0 12389 } 12390 --auto { 12391 set asked_auto_handling 1 12392 } 12393 --no-auto { 12394 set asked_auto_handling 0 12395 } 12396 -f - --force { 12397 set asked_force 1 12398 } 12399 --color* { 12400 set asked_color [string range $arg 8 end] 12401 if {$asked_color eq {}} { 12402 set asked_color always 12403 } elseif {[notInList [lindex $::g_config_defs(color) 3] $asked_color]} { 12404 unset asked_color 12405 } 12406 } 12407 -t - --terse - -l - --long - --default - -L - --latest - -S -\ 12408 --starts-with - -C - --contains - -j - --json { 12409 # command-specific switches that can for compatibility be 12410 # passed before the command name, so add them to a specific 12411 # arg list to ensure command name as first position argument 12412 lappend extraargv $arg 12413 } 12414 -d { 12415 # in case of *-path command, -d means --delim 12416 if {$ddelimarg} { 12417 lappend otherargv $arg 12418 } else { 12419 lappend extraargv $arg 12420 } 12421 } 12422 -a - --append - -append - --all - -p - --prepend - -prepend -\ 12423 --delim - -delim - --delim=* - -delim=* - --duplicates - --index\ 12424 - --notuasked - --indepth - --no-indepth - --dump-state -\ 12425 --reset { 12426 # command-specific switches interpreted later on 12427 lappend otherargv $arg 12428 } 12429 append-path - prepend-path - remove-path { 12430 # detect *-path commands to say -d means --delim, not --default 12431 set ddelimarg 1 12432 lappend otherargv $arg 12433 } 12434 -i - --icase { 12435 set asked_icase always 12436 } 12437 --human - -c - --create - --userlvl=* { 12438 # ignore C-version specific option, no error only warning 12439 reportWarning "Unsupported option '$arg'" 12440 } 12441 -u - --userlvl { 12442 reportWarning "Unsupported option '$arg'" 12443 # also ignore argument value 12444 set ignore_next_arg 1 12445 } 12446 {-} - {--} - {--*} { 12447 reportErrorAndExit "Invalid option '$arg'\nTry 'module --help'\ 12448 for more information." 12449 } 12450 -* { 12451 # spare argument if ml command is called 12452 if {[lindex $otherargv 0] ne {ml}} { 12453 reportErrorAndExit "Invalid option '$arg'\nTry 'module\ 12454 --help' for more information." 12455 } else { 12456 lappend otherargv $arg 12457 } 12458 } 12459 default { 12460 lappend otherargv $arg 12461 } 12462 } 12463 } 12464 } 12465 12466 setState subcmd [lindex $otherargv 0] 12467 set otherargv [concat [lreplace $otherargv 0 0] $extraargv] 12468 setState subcmd_args $otherargv 12469 # call ml frontend if it is asked command 12470 if {[getState subcmd] eq {ml}} { 12471 set execcmdlist [concat [list ml] $otherargv] 12472 } else { 12473 set execcmdlist [concat [list module [getState subcmd]] $otherargv] 12474 } 12475 12476 # now options are known initialize error report (start pager if enabled) 12477 initErrorReport 12478 12479 # put back quarantine variables in env, if quarantine mechanism supported 12480 @quarantinesupport@if {[getConf run_quarantine] ne {} && [getState shelltype] ne {csh}} { 12481 @quarantinesupport@ foreach var [split [getConf run_quarantine]] { 12482 @quarantinesupport@ # check variable name is valid 12483 @quarantinesupport@ if {[regexp {^[A-Za-z_][A-Za-z0-9_]*$} $var]} { 12484 @quarantinesupport@ set quarvar ${var}_modquar 12485 @quarantinesupport@ # put back value 12486 @quarantinesupport@ if {[info exists env($quarvar)]} { 12487 @quarantinesupport@ reportDebug "Release '$var' environment variable from\ 12488 quarantine ($env($quarvar))" 12489 @quarantinesupport@ set env($var) $env($quarvar) 12490 @quarantinesupport@ unset env($quarvar) 12491 @quarantinesupport@ # or unset env var if no value found in quarantine 12492 @quarantinesupport@ } elseif {[info exists env($var)]} { 12493 @quarantinesupport@ reportDebug "Unset '$var' environment variable after\ 12494 quarantine" 12495 @quarantinesupport@ unset env($var) 12496 @quarantinesupport@ } 12497 @quarantinesupport@ } elseif {[string length $var] > 0} { 12498 @quarantinesupport@ reportWarning "Bad variable name set in MODULES_RUN_QUARANTINE\ 12499 ($var)" 12500 @quarantinesupport@ } 12501 @quarantinesupport@ } 12502 @quarantinesupport@} 12503 12504 if {$show_help} { 12505 if {[getState subcmd] eq {ml}} { 12506 cmdMlHelp 12507 } else { 12508 cmdModuleHelp 12509 } 12510 cleanupAndExit 0 12511 } 12512 if {$show_version} { 12513 reportVersion 12514 cleanupAndExit 0 12515 } 12516 12517 # no modulefile is currently being interpreted 12518 pushModuleFile {} 12519 12520 # eval needed to pass otherargv as list to module proc 12521 eval $execcmdlist 12522} errMsg ]} { 12523 # re-enable error report in case it was previously inhibited 12524 setState inhibit_errreport 0 12525 # remove any message record id to render next error 12526 clearAllMsgRecordId 12527 # render error if not done yet 12528 if {$errorCode ne {MODULES_ERR_RENDERED}} { 12529 raiseErrorCount 12530 renderFalse 12531 } 12532 # report stack trace in addition to the error message if error is unknown 12533 if {[notInList [list MODULES_ERR_RENDERED MODULES_ERR_KNOWN] $errorCode]} { 12534 set errMsg "$errorInfo\n[sgr hi {Please report this issue at\ 12535 https://github.com/cea-hpc/modules/issues}]" 12536 } 12537 reportError $errMsg 12538 # init error report here in case the error raised before the regular init 12539 initErrorReport 12540 cleanupAndExit 1 12541} 12542 12543cleanupAndExit 0 12544 12545# ;;; Local Variables: *** 12546# ;;; mode:tcl *** 12547# ;;; End: *** 12548# vim:set tabstop=3 shiftwidth=3 expandtab autoindent: 12549