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.
# Init.tcl - (c) Martin S. Weber, 2003-2004
# License: BSD / Tcl. Have fun.
# 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.
#
# I.e. the following code's in my pkgindex..:
# package ifneeded Init 0.2 \
# " set ::dofastinit 1; source \[file join $dir Init Init.tcl\]"
# package ifneeded Init 0.1 \
# " set ::dofastinit 0; source \[file join $dir Init Init.tcl\]"
#
## -- SOC -- Start of Code (searchmark:)
## -- namespace mumbodjumbo
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 )
##
# onInit -type file -filePrefix prefix -fileSuffix suffix \
# -fileDirs dirlist -fileList filestosearch
# -> search for filestosearch under the directories dirlist
# with prefix prepended if [string index $fname 0] == _ and
# with suffix appended if [string index $fname end] == _.
#
# onInit -type proc -proc block
# -> execute the block when starting
#
# onInit -type cleanup -cleanup block
# -> execute the block when restarting
#
# (-type really should be implicit :)
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 mumbodjumbo
}
## --->>
## Do the actual init.
if {$::dofastinit} {
Init::doInit
package provide Init 0.2
} else {
package provide Init 0.1
}