[MSW](2005-02-24)

The following is the result of an ever-returning problem of mine: Some programs need datafiles,
and some of these datafiles are in some weird locations. I've written the following package to
set up some paths, find some files, have other code running while startup... the usual "init" stuff.

The following package has the bonus of displaying a (crude) menu to the user (must have a console) showing which files were not found, asking if she wants to continue (on own risk). Well. Hope it's
helpful for you.

----
 # test:
 # --<<snip>>--
 # package require -exact Init 0.1
 # namespace import Init::*
 #
 # onInit -type procedure -proc { puts stderr "Init 1" }
 # onInit -type procedure -proc { puts stderr "Init 2" }
 # onInit -type cleanup -cleanup { puts stderr "Cleanup 1" }
 # onInit -type cleanup -cleanup { puts stderr "cleanup 2" }
 # onInit -type procedure -proc { puts stderr "Init 3" }
 #
 # onInit -type file -filePrefix "bla_" -fileSuffix ".tcl" \
 #         -fileDirs {/home/phaeton/programming/test-src} \
 #         -fileList {_cvs_ _help_ _init_ _proc_decl_}
 #
 # doInit
 #
 # array set pref {}
 #
 # traverse pref
 #
 # parray pref
 #
 # puts "Hit key to continue"
 # gets stdin
 #
 # onInit -type file -filePrefix "bla_" -fileSuffix ".tcl" \
 #         -fileDirs {/home/phaeton/programming/test-src} \
 #         -fileList {_cvs_ _hep_ _ini_ _pro_decl_}
 #
 # reInit
 # array set pref2 {}
 # traverse pref2
 # puts "hit key to view pref"
 # gets stdin
 # parray pref
 # puts "hit key to view pref2"
 # gets stdin
 # parray pref2
 # --<<snap>>--
 #
 # Whether init automatically initializes or not, should
 # be version number dependant. You require 0.1, no auto
 # init, you require 0.2 (which will be default since it
 # has a higher version number) and autoinit takes place.
 #
 #
 ## -- SOC -- Start of Code (searchmark:)
 ## -- namespace mungodjungo
 namespace eval Init {
 	namespace export traverse reInit doInit doFinalize onInit reset
 ## let's start it
 
 variable iState
 variable doneInit 0
 variable iFFound
 
 array set iFFound {}
 
 array set iState {}
 
 ## traverse (array)
 ## traverses init state to array named in array
 proc traverse { arrN } {
     variable iState
     upvar $arrN target
     foreach name [array names iState] {
         set target($name) $iState($name)
     }
 }
 
 ## --- Interface to set Init actions --
 ## onInit ( args )
 proc onInit { args } {
     variable doneInit
     variable ::initInfo
     set fileSuffix [list]
     set filePrefix [list]
     set fileList   [list]
     set dirList    [list]
     set block      [list]
     set type        ""
 
     if {$doneInit} {
         puts stderr "Warning: onInit: initialized already, do reInit to see the effect!"
     }
     set numargs [llength $args]
     if {!$numargs} {
         puts stderr "onInit called without arguments!"
         return
     }
     ## if called with -copy, just return the current initInfo
     ## if called with -pop, pop off the last element of the list.
     if {($numargs == 1) } {
         if {[lindex $args 0] == "-copy"} {
             puts stderr "traversing initInfo."
             return $initInfo
         } elseif { [lindex $args 0] == "-pop"} {
             set tmp [lindex $initInfo end]
             set initInfo [lreplace $initInfo end end]
             puts stderr "Popping of initInfo: <$tmp>"
             return $tmp
         }
     }
     for {set i 0} {$i < $numargs} {incr i} {
         set j [expr $i +1]
         set step 0
         switch -glob -- [set cur_arg [lindex $args $i]] {
             "-*"    {
                     switch -glob -- [set cur_arg [string range $cur_arg 1 end]] {
                         "type"  {
                             set data [string tolower [lindex $args $j]]
                             if {!(($data == "cleanup")||($data=="procedure")||($data=="file"))} {
                                 puts stderr "onInit: -$cur_arg <$data>: Cannot recognize \"$data\"!"
                             }
                             set type $data
                             incr step
                             }
                         "file*" {
                             switch -- $cur_arg {
                                 "fileSuffix"    { set fileSuffix [lindex $args $j]; incr step }
                                 "filePrefix"    { set filePrefix [lindex $args $j]; incr step }
                                 "fileList"      { set fileList  [lindex $args $j]; incr step }
                                 "fileDirs"      { set dirList   [lindex $args $j]; incr step }
                                 default { puts stderr "onInit: Do not recognize file sub opt \"-$cur_arg\"" }
                             }
                             }
                         "proc" {
                             set block [lindex $args $j] ; incr step
                             }
                         "cleanup" {
                             set block [lindex $args $j] ; incr step
                             }
                         default     {
                             puts stderr "Unknown option -$cur_arg!"
                             }
                     }
                 }
             default {
                     puts stderr "Unknown argument $cur_arg"
                 }
         }
         incr i $step
     }
     if {$type == ""} {
         puts stderr "onInit: lacking type specification!"
         return
     }
     if {$type == "file"} {
         lappend initInfo [list $type [list $filePrefix $fileList $fileSuffix $dirList]]
     } else {
         lappend initInfo [list $type $block]
     }
 }
 
 ## reInit just does reinitialization
 proc reInit { } {
     variable doneInit
     variable iState
     variable iFFound
     doFinalize
     set doneInit 0
     array set iState {}
     array set iFFound {}
     doInit
 }
 
 ## reset clears the current state.
 proc reset { } {
     variable ::initInfo
     variable doneInit
     variable iState
     variable iFFound
     set doneInit 0
     array set iState {}
     array set iFFound {}
     unset initInfo
 }
 
 ## doFinalize reads the global variable initInfo
 ## which can be set by the caller, and searches
 ## for entries named Cleanup, and evaluates them.
 ## This is a special form of the Procedure spec,
 ## which causes the correlated calls to be performed
 ## at reinitialization time, where you may want to
 ## perform cleanups and such.
 
 proc doFinalize { } {
     variable ::initInfo
     if {![info exists initInfo]} {
         puts stderr "doFinalize([info level [info level]]): No initInfo found!"
         return
     }
     foreach entry $initInfo {
         if {[lindex $entry 0] == "cleanup"} {
             if [catch {uplevel #0 [lindex $entry 1]} errInf] {
                 puts stderr "doFinalize([info level [info level]]): Error in code block!"
                 puts stderr "codeblock was: <<[lindex $entry 1]>>"
                 puts stderr "thrown error: $errInf"
             }
         }
     }
     return
 }
 
 ## doInit reads the global variable initInfo
 ## which can be set by the caller. Currently
 ## initInfo consists of a simple list:
 ## < <Init-type> <Init-type-info> >,
 ## there can be multiple init-type, init-type-info
 ## tuples, all will be attempted to handled.
 ## current handling works for:
 ## Init-type		Init-type-info
 ## ----------------------------------------------------------
 ## file				< <prefix> <name(s)> <suffix> <dir(s)> >
 ## 	>> Sets in the local state array entries with the filenames
 ##	>> of the files, like banzai/bla.x comes as bla.x into the
 ##	>> array. files following [_]pattern[_] ([] meaning optional)
 ##	>> will be renamed, where the leading underscore gets replaced
 ##	>> with prefix, and the trailing one with suffix.
 ## procedure		< <procedure <arg> [<arg> ..]> >
 ##	>> Calls the listed procedure
 ## cleanup          < valid tcl cmd >
 ##  >> Evaluates each block on global level to perform cleanups
 ##  >> in the underlying program.
 ## 
 
 proc doInit { } {
 	variable ::initInfo
     variable ::env
 	variable doneInit
     variable iState
     variable iFFound
 	if {$doneInit} {
 		puts stderr "Warning, reInit ?!"
 	}
 	if {![info exists initInfo]} {
 		puts stderr " Cannot find initInfo !!! "
 	} else {
 		foreach entry $initInfo {
 			switch -- [lindex $entry 0] {
                 "cleanup"   { continue }
 				"procedure"	{ if [catch {uplevel #0 [lindex $entry 1]} errInf] {
                         puts stderr "doInit([info level [info level]]): Error in code block!"
                         puts stderr "codeblock was: <<[lindex $entry 1]>>"
                         puts stderr "thrown error: $errInf"
                     }
                     }
 				"file"		{
 					#puts stderr " -- search for files -- "
 					set l [lindex $entry 1]
 					set prefix [lindex $l 0]
 					set suffix [lindex $l 2]
 					set names [lindex $l 1]
 					set dirs [lindex $l 3]
 					#puts stderr " Prefix: $prefix, Suffix: $suffix."
 					#puts stderr " Files: $names "
 					#puts stderr " Dirs: $dirs"
                     foreach fil $names {
                         if {[string index $fil 0] == "_"} { set fil [string replace $fil 0 0 $prefix] }
                         if {[string index $fil end] == "_"} { set fil [string replace $fil end end $suffix] }
                         set iFFound([lindex [file split $fil] end]) 0
                         foreach dir $dirs {
                             set fpath [file join $dir $fil]
                             if {[file exists $fpath] && [file readable $fpath]} {
                                 set fil [lindex [file split $fil] end]
                                 set iState($fil) $fpath
                                 set iFFound($fil) 1
                                 break
                             }
                         }
                     }
                     if {[lsearch [array get iFFound] 0] != -1} {
                         if {[info exists env(INIT_DEBUG)] && $env(INIT_DEBUG) == 1} {
                             puts stderr " WARNING! Could not find all files. Continue ? \[yn\] "
                             puts stderr " --------------- File status -----------------------"
                             foreach name [array names iFFound] {
                             puts stderr [format "%-40s:........%d" $name $iFFound($name)]
                             }
                             puts -nonewline stderr " Choice ? \[yn\] :"
                             set ans [gets stdin]
                             if {$ans == "y"} {
                             puts stderr " You're driving at own risk, continuing... "
                             } else {
                             puts stderr " Exitting (user choice) "
                             exit 1
                             }
                         } else {
                             puts stderr " Bang ! Some files not found (set INIT_DEBUG to 1 in your environment "
                             puts stderr " for more information on what files were not found.) Exitting now. "
                             exit 1
                         }
                     }
 
 				}
 				default	{ puts stderr "Unknown entry $entry!!" }
 			}
 		}
         set doneInit 1
 	}
 }
 
 ## <<--- closing the namespace mungodjungo
 }
 ## --->>
 
 ## Do the actual init.
 if {$::dofastinit} {
     Init::doInit
     package provide Init 0.2
 } else {
     package provide Init 0.1
 }

----