Everything is not yet translated to english, which leads to ugly characters after a page-rebuild, which happened obviously. So I just copied the routine back into here from my sources.... But this should be fixed (metakit dump/load does not handle special characters as äöü correct!).
# Modul : readprof1.2.tcl # # Stand : 12.11.2005 # # Zweck : Einlesen einer Konfigurationsdatei über einen sicheren Slave-Inter- # # preter (SandBox); Rückgabe der Schlüssel/Werte als Liste # # Autor : M.Hoffmann # # Weiteres : Für diverse Pakete erforderlich (FehlerDB, SW-Lib, ToDo, MsgPop32). # # Historie : # # 18.10.03 v1.0: erste Version # # 12.10.04 v1.1: wahlweise Variablenersetzung (Vorsicht: standardmässig AN); # # 13.10.04 neue Prozeduren ::repenv und ::envvar; Bugfixes. # # 12.11.05 v1.2: Bugfix: _errorMsg war ungleich "", obwohl alles ok #
package provide readprof 1.2 namespace eval readprof {}
#---------------------------------------------------------------------------------- # prof - Dateiname für 'auszuführende' Konfigdatei # cmds - In der Konfigdatei erlaubte 'Kommandos' als Liste aus je {cmdName defVal} # Rück - cmdName Value cmdName Value ... _errorMsg <rc> (wenn <rc> leer, ok) # proc readprof::readprof1 {prof cmds {substEnv 1}} {
catch {
set id [interp create -safe]; # Safe-Interpreter anlegen und absichern!
interp eval $id {
foreach cmd [info commands] {
if {$cmd != {rename} && $cmd != {if}} {
rename $cmd {}
}
}
rename if {}; rename rename {}
}
# Defaults im Array ablegen (Fehler bei 'falschen' cmds=ArrayKeys denkbar!)
array set temp $cmds
# indirektes Setzen über Proc, da SET nicht mehrere args verträgt
proc set$id {key args} {
upvar 1 temp myArr
upvar 1 substEnv sEnv
set myArr($key) [join $args]
if {$sEnv} {
# v1.1: auf Wunsch %EnvVar%s auflösen
set myArr($key) [readprof::repenv $myArr($key)]
}
}
# Aliasnamen im Slave einrichten und auf setproc mappen
foreach {cmd default} $cmds {
interp alias $id $cmd {} readprof::set$id $cmd; # arg [...]
}
# `Ausführen` der Konfigdatei
$id invokehidden source $prof
set rc ""; # v1.2
} rc
catch {
# Bugfix v1.1: IMMER aufräumen, auch nach Abbruch! D.h. extra CATCHen:
interp delete $id
rename set$id {}
}
# durch folgende Anweisung ist `temp` in jedem Falle definiert!
set temp(_errorMsg) $rc; # Profname,-Datum,-Grösse;_errorRc usw. denkbar!
return [array get temp]}
#---------------------------------------------------------------------------------- # Holt eine EINZELNE VARIABLE aus der Umgebung (wird INTERN benutzt). Gibt es die # Variable nicht, wird gemaess DOS/Windows-Verhalten ein LEERSTRING zurückgegeben. # envvar - Umgebungsvariablen-Name. # Rück - Wert. # proc readprof::envvar {var} {
set var [string trim $var %]; # eigentlich nur ein % vorn und hinten!
if {[info exists ::env($var)]} {
return $::env($var)
} else {
return ""
}}
#---------------------------------------------------------------------------------- # Ersetzt in einer Zeichenkette %Vars% durch Werte (wird ggf. von readprof benutzt, # kann aber auch unabhängig von jedem externen Programm genutzt werden) # args - Zeichenkette, die %Variablen%-Referenzen enthalten kann # Rück - Zeichenkette mit aufgelösten Variablen-Referenzen; existiert eine %Var% # nicht, wird sie durch Leerstring ersetzt (entspricht OS-.BATch-Logik) # ACHTUNG: Wegen subst-Erfordernis (regsub ersetzt nur eine Ebene) prinzipiell # unsicher, daher über safe-Slave! # proc readprof::repenv {args} {
set id [interp create -safe]; # Safe-Interpreter anlegen und absichern!
interp eval $id {
foreach cmd [info commands] {
if {$cmd != {rename} && $cmd != {if} && $cmd != {subst}} {
rename $cmd {}
}
}
rename if {}; rename rename {}
}
interp hide $id subst; # auch subst selbst von aussen verstecken!
interp alias $id __env {} readprof::envvar; # Umweg zum Lesen von env, denn
# subSpec {$::env([string trim "&" %])} geht nicht, da im Slave kein env()!
# Achtung: exp berücksichtigt nicht den denkbaren Sonderfall env(%name%)!
regsub -nocase -all {%[^ %]{1}[^%]*%} $args {[__env &]} tmp
# catch {$id invokehidden [list subst $tmp]} tmp; # neu: CATCH!
catch {$id invokehidden subst -nobackslashes -novariables $tmp} tmp; # neu: CATCH!
interp delete $id
return $tmp
}
#==================================================================================Testroutine
lappend auto_path .
package require readprof
array set settings [readprof::readprof1 $argv {
test1 default1
test2 default2
test3 default3
}]
# [Kommandos] werden schon VOR dem Aufruf ausgewertet!
set env(%fies%) "varname mit Prozenten"
puts [readprof::repenv Dies ist Appdata: '%appdata%']
puts [readprof::repenv Dies ist Appdata: '%appdata%' und das fiese: '%%fies%%']
# Test: Einschmuggeln eines Kommandos (das einzig erlaubte):
puts [readprof::repenv {Dies ist Appdata: '%appdata%' oder so: '[__env appdata]'}]
# Test: Einschmuggeln eines Kommandos (ein andres):
puts [readprof::repenv {Dies ist Appdata: '%appdata%' oder so: '[subst abcde]'}]
# puts [readprof::repenv {Dies ist Appdata: '%appdata%' oder so: '[info commands]'}]
puts ***********
parray settingsTest .RC-File
test1 Dies ist der Pfad: '%path%' test3 Dies '%appdata%' ist falsch: '%falsch%' test2 Ist dies möglich?: '*[info globals]*' Nein!