# 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
}Category Package
