Прога / tina-2.5.2 / tcl / lib / tcl8.3 / opt0.4 / optparse

# optparse.tcl --
#
# (private) Option parsing package
# Primarily used internally by the safe:: code.
#
# WARNING: This code will go away in a future release
# of Tcl. It is NOT supported and you should not rely
# on it. If your code does rely on this package you
# may directly incorporate this code into your application.
#
# RCS: @(#) $Id: optparse.tcl,v 1.2.12.3 2001/08/09 01:00:56 dgp Exp $

package require Tcl 8
package provide opt 0.4.3

namespace eval ::tcl {

# Exported APIs
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
OptProc OptProcArgGiven OptParse \
Lempty Lget \
Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \
SetMax SetMin


################# Example of use / 'user documentation' ###################

proc OptCreateTestProc {} {

# Defines ::tcl::OptParseTest as a test proc with parsed arguments
# (can't be defined before the code below is loaded (before "OptProc"))

# Every OptProc give usage information on "procname -help".
# Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and
# then other arguments.
#
# example of 'valid' call:
# ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
# -nostatics false ch1
OptProc OptParseTest {
{subcommand -choice {save print} "sub command"}
{arg1 3 "some number"}
{-aflag}
{-intflag 7}
{-weirdflag "help string"}
{-noStatics "Not ok to load static packages"}
{-nestedloading1 true "OK to load into nested slaves"}
{-nestedloading2 -boolean true "OK to load into nested slaves"}
{-libsOK -choice {Tk SybTcl}
"List of packages that can be loaded"}
{-precision -int 12 "Number of digits of precision"}
{-intval 7 "An integer"}
{-scale -float 1.0 "Scale factor"}
{-zoom 1.0 "Zoom factor"}
{-arbitrary foobar "Arbitrary string"}
{-random -string 12 "Random string"}
{-listval -list {} "List value"}
{-blahflag -blah abc "Funny type"}
{arg2 -boolean "a boolean"}
{arg3 -choice "ch1 ch2"}
{?optarg? -list {} "optional argument"}
} {
foreach v [info locals] {
puts stderr [format "%14s : %s" $v [set $v]]
}
}
}

################### No User serviceable part below ! ###############
# You should really not look any further :
# The following is private unexported undocumented unblessed... code
# time to hit "q" ;-) !

# Hmmm... ok, you really want to know ?

# You've been warned... Here it is...

# Array storing the parsed descriptions
variable OptDesc;
array set OptDesc {};
# Next potentially free key id (numeric)
variable OptDescN 0;

# Inside algorithm/mechanism description:
# (not for the faint hearted ;-)
#
# The argument description is parsed into a "program tree"
# It is called a "program" because it is the program used by
# the state machine interpreter that use that program to
# actually parse the arguments at run time.
#
# The general structure of a "program" is
# notation (pseudo bnf like)
# name :== definition defines "name" as being "definition"
# { x y z } means list of x, y, and z
# x* means x repeated 0 or more time
# x+ means "x x*"
# x? means optionally x
# x | y means x or y
# "cccc" means the literal string
#
# program :== { programCounter programStep* }
#
# programStep :== program | singleStep
#
# programCounter :== {"P" integer+ }
#
# singleStep :== { instruction parameters* }
#
# instruction :== single element list
#
# (the difference between singleStep and program is that \
# llength [lindex $program 0] >= 2
# while
# llength [lindex $singleStep 0] == 1
# )
#
# And for this application:
#
# singleStep :== { instruction varname {hasBeenSet currentValue} type
# typeArgs help }
# instruction :== "flags" | "value"
# type :== knowType | anyword
# knowType :== "string" | "int" | "boolean" | "boolflag" | "float"
# | "choice"
#
# for type "choice" typeArgs is a list of possible choices, the first one
# is the default value. for all other types the typeArgs is the default value
#
# a "boolflag" is the type for a flag whose presence or absence, without
# additional arguments means respectively true or false (default flag type).
#
# programCounter is the index in the list of the currently processed
# programStep (thus starting at 1 (0 is {"P" prgCounterValue}).
# If it is a list it points toward each currently selected programStep.
# (like for "flags", as they are optional, form a set and programStep).

# Performance/Implementation issues
# ---------------------------------
# We use tcl lists instead of arrays because with tcl8.0
# they should start to be much faster.
# But this code use a lot of helper procs (like Lvarset)
# which are quite slow and would be helpfully optimized
# for instance by being written in C. Also our struture
# is complex and there is maybe some places where the
# string rep might be calculated at great exense. to be checked.

#
# Parse a given description and saves it here under the given key
# generate a unused keyid if not given
#
proc ::tcl::OptKeyRegister {desc {key ""}} {
variable OptDesc;
variable OptDescN;
if {[string compare $key ""] == 0} {
# in case a key given to us as a parameter was a number
while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
set key $OptDescN;
incr OptDescN;
}
# program counter
set program [list [list "P" 1]];

# are we processing flags (which makes a single program step)
set inflags 0;

set state {};

# flag used to detect that we just have a single (flags set) subprogram.
set empty 1;

foreach item $desc {
if {$state == "args"} {
# more items after 'args'...
return -code error "'args' special argument must be the last one";
}
set res [OptNormalizeOne $item];
set state [lindex $res 0];
if {$inflags} {
if {$state == "flags"} {
# add to 'subprogram'
lappend flagsprg $res;
} else {
# put in the flags
# structure for flag programs items is a list of
# {subprgcounter {prg flag 1} {prg flag 2} {...}}
lappend program $flagsprg;
# put the other regular stuff
lappend program $res;
set inflags 0;
set empty 0;
}
} else {
if {$state == "flags"} {
set inflags 1;
# sub program counter + first sub program
set flagsprg [list [list "P" 1] $res];
} else {
lappend program $res;
set empty 0;
}
}
}
if {$inflags} {
if {$empty} {
# We just have the subprogram, optimize and remove
# unneeded level:
set program $flagsprg;
} else {
lappend program $flagsprg;
}
}

set OptDesc($key) $program;

return $key;
}

#
# Free the storage for that given key
#
proc ::tcl::OptKeyDelete {key} {
variable OptDesc;
unset OptDesc($key);
}

# Get the parsed description stored under the given key.
proc OptKeyGetDesc {descKey} {
variable OptDesc;
if {![info exists OptDesc($descKey)]} {
return -code error "Unknown option description key \"$descKey\"";
}
set OptDesc($descKey);
}

# Parse entry point for ppl who don't want to register with a key,
# for instance because the description changes dynamically.
# (otherwise one should really use OptKeyRegister once + OptKeyParse
# as it is way faster or simply OptProc which does it all)
# Assign a temporary key, call OptKeyParse and then free the storage
proc ::tcl::OptParse {desc arglist} {
set tempkey [OptKeyRegister $desc];
set ret [catch {uplevel 1 [list ::tcl::OptKeyParse $tempkey $arglist]} res];
OptKeyDelete $tempkey;
return -code $ret $res;
}

# Helper function, replacement for proc that both
# register the description under a key which is the name of the proc
# (and thus unique to that code)
# and add a first line to the code to call the OptKeyParse proc
# Stores the list of variables that have been actually given by the user
# (the other will be sets to their default value)
# into local variable named "Args".
proc ::tcl::OptProc {name desc body} {
set namespace [uplevel 1 [list ::namespace current]];
if { ([string match "::*" $name])
|| ([string compare $namespace "::"]==0)} {
# absolute name or global namespace, name is the key
set key $name;
} else {
# we are relative to some non top level namespace:
set key "${namespace}::${name}";
}
OptKeyRegister $desc $key;
uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"];
return $key;
}
# Check that a argument has been given
# assumes that "OptProc" has been used as it will check in "Args" list
proc ::tcl::OptProcArgGiven {argname} {
upvar Args alist;
expr {[lsearch $alist $argname] >=0}
}

#######
# Programs/Descriptions manipulation

# Return the instruction word/list of a given step/(sub)program
proc OptInstr {lst} {
lindex $lst 0;
}
# Is a (sub) program or a plain instruction ?
proc OptIsPrg {lst} {
expr {[llength [OptInstr $lst]]>=2}
}
# Is this instruction a program counter or a real instr
proc OptIsCounter {item} {
expr {[lindex $item 0]=="P"}
}
# Current program counter (2nd word of first word)
proc OptGetPrgCounter {lst} {
Lget $lst {0 1}
}
# Current program counter (2nd word of first word)
proc OptSetPrgCounter {lstName newValue} {
upvar $lstName lst;
set lst [lreplace $lst 0 0 [concat "P" $newValue]];
}
# returns a list of currently selected items.
proc OptSelection {lst} {
set res {};
foreach idx [lrange [lindex $lst 0] 1 end] {
lappend res [Lget $lst $idx];
}
return $res;
}

# Advance to next description
proc OptNextDesc {descName} {
uplevel 1 [list Lvarincr $descName {0 1}];
}

# Get the current description, eventually descend
proc OptCurDesc {descriptions} {
lindex $descriptions [OptGetPrgCounter $descriptions];
}
# get the current description, eventually descend
# through sub programs as needed.
proc OptCurDescFinal {descriptions} {
set item [OptCurDesc $descriptions];
# Descend untill we get the actual item and not a sub program
while {[OptIsPrg $item]} {
set item [OptCurDesc $item];
}
return $item;
}
# Current final instruction adress
proc OptCurAddr {descriptions {start {}}} {
set adress [OptGetPrgCounter $descriptions];
lappend start $adress;
set item [lindex $descriptions $adress];
if {[OptIsPrg $item]} {
return [OptCurAddr $item $start];
} else {
return $start;
}
}
# Set the value field of the current instruction
proc OptCurSetValue {descriptionsName value} {
upvar $descriptionsName descriptions
# get the current item full adress
set adress [OptCurAddr $descriptions];
# use the 3th field of the item (see OptValue / OptNewInst)
lappend adress 2
Lvarset descriptions $adress [list 1 $value];
# ^hasBeenSet flag
}

# empty state means done/paste the end of the program
proc OptState {item} {
lindex $item 0
}

# current state
proc OptCurState {descriptions} {
OptState [OptCurDesc $descriptions];
}

#######
# Arguments manipulation

# Returns the argument that has to be processed now
proc OptCurrentArg {lst} {
lindex $lst 0;
}
# Advance to next argument
proc OptNextArg {argsName} {
uplevel 1 [list Lvarpop1 $argsName];
}
#######





# Loop over all descriptions, calling OptDoOne which will
# eventually eat all the arguments.
proc OptDoAll {descriptionsName argumentsName} {
upvar $descriptionsName descriptions
upvar $argumentsName arguments;
# puts "entered DoAll";
# Nb: the places where "state" can be set are tricky to figure
# because DoOne sets the state to flagsValue and return -continue
# when needed...
set state [OptCurState $descriptions];
# We'll exit the loop in "OptDoOne" or when state is empty.
while 1 {
set curitem [OptCurDesc $descriptions];
# Do subprograms if needed, call ourselves on the sub branch
while {[OptIsPrg $curitem]} {
OptDoAll curitem arguments
# puts "done DoAll sub";
# Insert back the results in current tree;
Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\
$curitem;
OptNextDesc descriptions;
set curitem [OptCurDesc $descriptions];
set state [OptCurState $descriptions];
}
# puts "state = \"$state\" - arguments=($arguments)";
if {[Lempty $state]} {
# Nothing left to do, we are done in this branch:
break;
}
# The following statement can make us terminate/continue
# as it use return -code {break, continue, return and error}
# codes
OptDoOne descriptions state arguments;
# If we are here, no special return code where issued,
# we'll step to next instruction :
# puts "new state = \"$state\"";
OptNextDesc descriptions;
set state [OptCurState $descriptions];
}
}

# Process one step for the state machine,
# eventually consuming the current argument.
proc OptDoOne {descriptionsName stateName argumentsName} {
upvar $argumentsName arguments;
upvar $descriptionsName descriptions;
upvar $stateName state;

# the special state/instruction "args" eats all
# the remaining args (if any)
if {($state == "args")} {
if {![Lempty $arguments]} {
# If there is no additional arguments, leave the default value
# in.
OptCurSetValue descriptions $arguments;
set arguments {};
}
# puts "breaking out ('args' state: consuming every reminding args)"
return -code break;
}

if {[Lempty $arguments]} {
if {$state == "flags"} {
# no argument and no flags : we're done
# puts "returning to previous (sub)prg (no more args)";
return -code return;
} elseif {$state == "optValue"} {
set state next; # not used, for debug only
# go to next state
return ;
} else {
return -code error [OptMissingValue $descriptions];
}
} else {
set arg [OptCurrentArg $arguments];
}

switch $state {
flags {
# A non-dash argument terminates the options, as does --

# Still a flag ?
if {![OptIsFlag $arg]} {
# don't consume the argument, return to previous prg
return -code return;
}
# consume the flag
OptNextArg arguments;
if {[string compare "--" $arg] == 0} {
# return from 'flags' state
return -code return;
}

set hits [OptHits descriptions $arg];
if {$hits > 1} {
return -code error [OptAmbigous $descriptions $arg]
} elseif {$hits == 0} {
return -code error [OptFlagUsage $descriptions $arg]
}
set item [OptCurDesc $descriptions];
if {[OptNeedValue $item]} {
# we need a value, next state is
set state flagValue;
} else {
OptCurSetValue descriptions 1;
}
# continue
return -code continue;
}
flagValue -
value {
set item [OptCurDesc $descriptions];
# Test the values against their required type
if {[catch {OptCheckType $arg\
[OptType $item] [OptTypeArgs $item]} val]} {
return -code error [OptBadValue $item $arg $val]
}
# consume the value
OptNextArg arguments;
# set the value
OptCurSetValue descriptions $val;
# go to next state
if {$state == "flagValue"} {
set state flags
return -code continue;
} else {
set state next; # not used, for debug only
return ; # will go on next step
}
}
optValue {
set item [OptCurDesc $descriptions];
# Test the values against their required type
if {![catch {OptCheckType $arg\
[OptType $item] [OptTypeArgs $item]} val]} {
# right type, so :
# consume the value
OptNextArg arguments;
# set the value
OptCurSetValue descriptions $val;
}
# go to next state
set state next; # not used, for debug only
return ; # will go on next step
}
}
# If we reach this point: an unknown
# state as been entered !
return -code error "Bug! unknown state in DoOne \"$state\"\
(prg counter [OptGetPrgCounter $descriptions]:\
[OptCurDesc $descriptions])";
}

# Parse the options given the key to previously registered description
# and arguments list
proc ::tcl::OptKeyParse {descKey arglist} {

set desc [OptKeyGetDesc $descKey];

# make sure -help always give usage
if {[string compare "-help" [string tolower $arglist]] == 0} {
return -code error [OptError "Usage information:" $desc 1];
}

OptDoAll desc arglist;

if {![Lempty $arglist]} {
return -code error [OptTooManyArgs $desc $arglist];
}

# Analyse the result
# Walk through the tree:
OptTreeVars $desc "#[expr {[info level]-1}]" ;
}

# determine string length for nice tabulated output
proc OptTreeVars {desc level {vnamesLst {}}} {
foreach item $desc {
if {[OptIsCounter $item]} continue;
if {[OptIsPrg $item]} {
set vnamesLst [OptTreeVars $item $level $vnamesLst];
} else {
set vname [OptVarName $item];
upvar $level $vname var
if {[OptHasBeenSet $item]} {
# puts "adding $vname"
# lets use the input name for the returned list
# it is more usefull, for instance you can check that
# no flags at all was given with expr
# {![string match "*-*" $Args]}
lappend vnamesLst [OptName $item];
set var [OptValue $item];
} else {
set var [OptDefaultValue $item];
}
}
}
return $vnamesLst
}


# Check the type of a value
# and emit an error if arg is not of the correct type
# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# puts "checking '$arg' against '$type' ($typeArgs)";

# only types "any", "choice", and numbers can have leading "-"

switch -exact -- $type {
int {
if {![regexp {^(-+)?[0-9]+$} $arg]} {
error "not an integer"
}
return $arg;
}
float {
return [expr {double($arg)}]
}
script -
list {
# if llength fail : malformed list
if {[llength $arg]==0} {
if {[OptIsFlag $arg]} {
error "no values with leading -"
}
}
return $arg;
}
boolean {
if {![regexp -nocase {^(true|false|0|1)$} $arg]} {
error "non canonic boolean"
}
# convert true/false because expr/if is broken with "!,...
if {$arg} {
return 1
} else {
return 0
}
}
choice {
if {[lsearch -exact $typeArgs $arg] < 0} {
error "invalid choice"
}
return $arg;
}
any {
return $arg;
}
string -
default {
if {[OptIsFlag $arg]} {
error "no values with leading -"
}
return $arg
}
}
return neverReached;
}

# internal utilities

# returns the number of flags matching the given arg
# sets the (local) prg counter to the list of matches
proc OptHits {descName arg} {
upvar $descName desc;
set hits 0
set hitems {}
set i 1;

set larg [string tolower $arg];
set len [string length $larg];
set last [expr {$len-1}];

foreach item [lrange $desc 1 end] {
set flag [OptName $item]
# lets try to match case insensitively
# (string length ought to be cheap)
set lflag [string tolower $flag];
if {$len == [string length $lflag]} {
if {[string compare $larg $lflag]==0} {
# Exact match case
OptSetPrgCounter desc $i;
return 1;
}
} else {
if {[string compare $larg [string range $lflag 0 $last]]==0} {
lappend hitems $i;
incr hits;
}
}
incr i;
}
if {$hits} {
OptSetPrgCounter desc $hitems;
}
return $hits
}

# Extract fields from the list structure:

proc OptName {item} {
lindex $item 1;
}
#
proc OptHasBeenSet {item} {
Lget $item {2 0};
}
#
proc OptValue {item} {
Lget $item {2 1};
}

proc OptIsFlag {name} {
string match "-*" $name;
}
proc OptIsOpt {name} {
string match {\?*} $name;
}
proc OptVarName {item} {
set name [OptName $item];
if {[OptIsFlag $name]} {
return [string range $name 1 end];
} elseif {[OptIsOpt $name]} {
return [string trim $name "?"];
} else {
return $name;
}
}
proc OptType {item} {
lindex $item 3
}
proc OptTypeArgs {item} {
lindex $item 4
}
proc OptHelp {item} {
lindex $item 5
}
proc OptNeedValue {item} {
string compare [OptType $item] boolflag
}
proc OptDefaultValue {item} {
set val [OptTypeArgs $item]
switch -exact -- [OptType $item] {
choice {return [lindex $val 0]}
boolean -
boolflag {
# convert back false/true to 0/1 because expr !$bool
# is broken..
if {$val} {
return 1
} else {
return 0
}
}
}
return $val
}

# Description format error helper
proc OptOptUsage {item {what ""}} {
return -code error "invalid description format$what: $item\n\
should be a list of {varname|-flagname ?-type? ?defaultvalue?\
?helpstring?}";
}


# Generate a canonical form single instruction
proc OptNewInst {state varname type typeArgs help} {
list $state $varname [list 0 {}] $type $typeArgs $help;
# ^ ^
# | |
# hasBeenSet=+ +=currentValue
}

# Translate one item to canonical form
proc OptNormalizeOne {item} {
set lg [Lassign $item varname arg1 arg2 arg3];
# puts "called optnormalizeone '$item' v=($varname), lg=$lg";
set isflag [OptIsFlag $varname];
set isopt [OptIsOpt $varname];
if {$isflag} {
set state "flags";
} elseif {$isopt} {
set state "optValue";
} elseif {[string compare $varname "args"]} {
set state "value";
} else {
set state "args";
}

# apply 'smart' 'fuzzy' logic to try to make
# description writer's life easy, and our's difficult :
# let's guess the missing arguments :-)

switch $lg {
1 {
if {$isflag} {
return [OptNewInst $state $varname boolflag false ""];
} else {
return [OptNewInst $state $varname any "" ""];
}
}
2 {
# varname default
# varname help
set type [OptGuessType $arg1]
if {[string compare $type "string"] == 0} {
if {$isflag} {
set type boolflag
set def false
} else {
set type any
set def ""
}
set help $arg1
} else {
set help ""
set def $arg1
}
return [OptNewInst $state $varname $type $def $help];
}
3 {
# varname type value
# varname value comment

if {[regexp {^-(.+)$} $arg1 x type]} {
# flags/optValue as they are optional, need a "value",
# on the contrary, for a variable (non optional),
# default value is pointless, 'cept for choices :
if {$isflag || $isopt || ($type == "choice")} {
return [OptNewInst $state $varname $type $arg2 ""];
} else {
return [OptNewInst $state $varname $type "" $arg2];
}
} else {
return [OptNewInst $state $varname\
[OptGuessType $arg1] $arg1 $arg2]
}
}
4 {
if {[regexp {^-(.+)$} $arg1 x type]} {
return [OptNewInst $state $varname $type $arg2 $arg3];
} else {
return -code error [OptOptUsage $item];
}
}
default {
return -code error [OptOptUsage $item];
}
}
}

# Auto magic lasy type determination
proc OptGuessType {arg} {
if {[regexp -nocase {^(true|false)$} $arg]} {
return boolean
}
if {[regexp {^(-+)?[0-9]+$} $arg]} {
return int
}
if {![catch {expr {double($arg)}}]} {
return float
}
return string
}

# Error messages front ends

proc OptAmbigous {desc arg} {
OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
}
proc OptFlagUsage {desc arg} {
OptError "bad flag \"$arg\", must be one of" $desc;
}
proc OptTooManyArgs {desc arguments} {
OptError "too many arguments (unexpected argument(s): $arguments),\
usage:"\
$desc 1
}
proc OptParamType {item} {
if {[OptIsFlag $item]} {
return "flag";
} else {
return "parameter";
}
}
proc OptBadValue {item arg {err {}}} {
# puts "bad val err = \"$err\"";
OptError "bad value \"$arg\" for [OptParamType $item]"\
[list $item]
}
proc OptMissingValue {descriptions} {
# set item [OptCurDescFinal $descriptions];
set item [OptCurDesc $descriptions];
OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
(use -help for full usage) :"\
[list $item]
}

proc ::tcl::OptKeyError {prefix descKey {header 0}} {
OptError $prefix [OptKeyGetDesc $descKey] $header;
}

# determine string length for nice tabulated output
proc OptLengths {desc nlName tlName dlName} {
upvar $nlName nl;
upvar $tlName tl;
upvar $dlName dl;
foreach item $desc {
if {[OptIsCounter $item]} continue;
if {[OptIsPrg $item]} {
OptLengths $item nl tl dl
} else {
SetMax nl [string length [OptName $item]]
SetMax tl [string length [OptType $item]]
set dv [OptTypeArgs $item];
if {[OptState $item] != "header"} {
set dv "($dv)";
}
set l [string length $dv];
# limit the space allocated to potentially big "choices"
if {([OptType $item] != "choice") || ($l<=12)} {
SetMax dl $l
} else {
if {![info exists dl]} {
set dl 0
}
}
}
}
}
# output the tree
proc OptTree {desc nl tl dl} {
set res "";
foreach item $desc {
if {[OptIsCounter $item]} continue;
if {[OptIsPrg $item]} {
append res [OptTree $item $nl $tl $dl];
} else {
set dv [OptTypeArgs $item];
if {[OptState $item] != "header"} {
set dv "($dv)";
}
append res [format "\n %-*s %-*s %-*s %s" \
$nl [OptName $item] $tl [OptType $item] \
$dl $dv [OptHelp $item]]
}
}
return $res;
}

# Give nice usage string
proc ::tcl::OptError {prefix desc {header 0}} {
# determine length
if {$header} {
# add faked instruction
set h [list [OptNewInst header Var/FlagName Type Value Help]];
lappend h [OptNewInst header ------------ ---- ----- ----];
lappend h [OptNewInst header {( -help} "" "" {gives this help )}]
set desc [concat $h $desc]
}
OptLengths $desc nl tl dl
# actually output
return "$prefix[OptTree $desc $nl $tl $dl]"
}


################ General Utility functions #######################

#
# List utility functions
# Naming convention:
# "Lvarxxx" take the list VARiable name as argument
# "Lxxxx" take the list value as argument
# (which is not costly with Tcl8 objects system
# as it's still a reference and not a copy of the values)
#

# Is that list empty ?
proc ::tcl::Lempty {list} {
expr {[llength $list]==0}
}

# Gets the value of one leaf of a lists tree
proc ::tcl::Lget {list indexLst} {
if {[llength $indexLst] <= 1} {
return [lindex $list $indexLst];
}
Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end];
}
# Sets the value of one leaf of a lists tree
# (we use the version that does not create the elements because
# it would be even slower... needs to be written in C !)
# (nb: there is a non trivial recursive problem with indexes 0,
# which appear because there is no difference between a list
# of 1 element and 1 element alone : [list "a"] == "a" while
# it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1
# and [listp "a b"] maybe 0. listp does not exist either...)
proc ::tcl::Lvarset {listName indexLst newValue} {
upvar $listName list;
if {[llength $indexLst] <= 1} {
Lvarset1nc list $indexLst $newValue;
} else {
set idx [lindex $indexLst 0];
set targetList [lindex $list $idx];
# reduce refcount on targetList (not really usefull now,
# could be with optimizing compiler)
# Lvarset1 list $idx {};
# recursively replace in targetList
Lvarset targetList [lrange $indexLst 1 end] $newValue;
# put updated sub list back in the tree
Lvarset1nc list $idx $targetList;
}
}
# Set one cell to a value, eventually create all the needed elements
# (on level-1 of lists)
variable emptyList {}
proc ::tcl::Lvarset1 {listName index newValue} {
upvar $listName list;
if {$index < 0} {return -code error "invalid negative index"}
set lg [llength $list];
if {$index >= $lg} {
variable emptyList;
for {set i $lg} {$i<$index} {incr i} {
lappend list $emptyList;
}
lappend list $newValue;
} else {
set list [lreplace $list $index $index $newValue];
}
}
# same as Lvarset1 but no bound checking / creation
proc ::tcl::Lvarset1nc {listName index newValue} {
upvar $listName list;
set list [lreplace $list $index $index $newValue];
}
# Increments the value of one leaf of a lists tree
# (which must exists)
proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
upvar $listName list;
if {[llength $indexLst] <= 1} {
Lvarincr1 list $indexLst $howMuch;
} else {
set idx [lindex $indexLst 0];
set targetList [lindex $list $idx];
# reduce refcount on targetList
Lvarset1nc list $idx {};
# recursively replace in targetList
Lvarincr targetList [lrange $indexLst 1 end] $howMuch;
# put updated sub list back in the tree
Lvarset1nc list $idx $targetList;
}
}
# Increments the value of one cell of a list
proc ::tcl::Lvarincr1 {listName index {howMuch 1}} {
upvar $listName list;
set newValue [expr {[lindex $list $index]+$howMuch}];
set list [lreplace $list $index $index $newValue];
return $newValue;
}
# Removes the first element of a list
# and returns the new list value
proc ::tcl::Lvarpop1 {listName} {
upvar $listName list;
set list [lrange $list 1 end];
}
# Same but returns the removed element
# (Like the tclX version)
proc ::tcl::Lvarpop {listName} {
upvar $listName list;
set el [lindex $list 0];
set list [lrange $list 1 end];
return $el;
}
# Assign list elements to variables and return the length of the list
proc ::tcl::Lassign {list args} {
# faster than direct blown foreach (which does not byte compile)
set i 0;
set lg [llength $list];
foreach vname $args {
if {$i>=$lg} break
uplevel 1 [list ::set $vname [lindex $list $i]];
incr i;
}
return $lg;
}

# Misc utilities

# Set the varname to value if value is greater than varname's current value
# or if varname is undefined
proc ::tcl::SetMax {varname value} {
upvar 1 $varname var
if {![info exists var] || $value > $var} {
set var $value
}
}

# Set the varname to value if value is smaller than varname's current value
# or if varname is undefined
proc ::tcl::SetMin {varname value} {
upvar 1 $varname var
if {![info exists var] || $value < $var} {
set var $value
}
}


# everything loaded fine, lets create the test proc:
# OptCreateTestProc
# Don't need the create temp proc anymore:
# rename OptCreateTestProc {}
}