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