summaryrefslogtreecommitdiffstats
path: root/library/opt/optparse.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/opt/optparse.tcl')
-rw-r--r--library/opt/optparse.tcl474
1 files changed, 237 insertions, 237 deletions
diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl
index fc77fa1..c9438a0 100644
--- a/library/opt/optparse.tcl
+++ b/library/opt/optparse.tcl
@@ -11,7 +11,7 @@
package require Tcl 8.2
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
-package provide opt 0.4.6
+package provide opt 0.4.5
namespace eval ::tcl {
@@ -33,7 +33,7 @@ namespace eval ::tcl {
# 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
@@ -69,10 +69,10 @@ namespace eval ::tcl {
################### No User serviceable part below ! ###############
# Array storing the parsed descriptions
- variable OptDesc
- array set OptDesc {}
+ variable OptDesc;
+ array set OptDesc {};
# Next potentially free key id (numeric)
- variable OptDescN 0
+ variable OptDescN 0;
# Inside algorithm/mechanism description:
# (not for the faint hearted ;-)
@@ -84,8 +84,8 @@ namespace eval ::tcl {
#
# 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
+# 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
@@ -110,7 +110,7 @@ namespace eval ::tcl {
#
# And for this application:
#
-# singleStep :== { instruction varname {hasBeenSet currentValue} type
+# singleStep :== { instruction varname {hasBeenSet currentValue} type
# typeArgs help }
# instruction :== "flags" | "value"
# type :== knowType | anyword
@@ -143,54 +143,54 @@ namespace eval ::tcl {
# generate a unused keyid if not given
#
proc ::tcl::OptKeyRegister {desc {key ""}} {
- variable OptDesc
- variable OptDescN
+ variable OptDesc;
+ variable OptDescN;
if {[string equal $key ""]} {
# 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
+ set key $OptDescN;
+ incr OptDescN;
}
# program counter
- set program [list [list "P" 1]]
+ set program [list [list "P" 1]];
# are we processing flags (which makes a single program step)
- set inflags 0
+ set inflags 0;
- set state {}
+ set state {};
# flag used to detect that we just have a single (flags set) subprogram.
- set empty 1
+ set empty 1;
foreach item $desc {
if {$state == "args"} {
# more items after 'args'...
- return -code error "'args' special argument must be the last one"
+ return -code error "'args' special argument must be the last one";
}
- set res [OptNormalizeOne $item]
- set state [lindex $res 0]
+ set res [OptNormalizeOne $item];
+ set state [lindex $res 0];
if {$inflags} {
if {$state == "flags"} {
# add to 'subprogram'
- lappend flagsprg $res
+ 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
+ lappend program $flagsprg;
# put the other regular stuff
- lappend program $res
- set inflags 0
- set empty 0
+ lappend program $res;
+ set inflags 0;
+ set empty 0;
}
} else {
if {$state == "flags"} {
- set inflags 1
+ set inflags 1;
# sub program counter + first sub program
- set flagsprg [list [list "P" 1] $res]
+ set flagsprg [list [list "P" 1] $res];
} else {
- lappend program $res
- set empty 0
+ lappend program $res;
+ set empty 0;
}
}
}
@@ -198,32 +198,32 @@ proc ::tcl::OptKeyRegister {desc {key ""}} {
if {$empty} {
# We just have the subprogram, optimize and remove
# unneeded level:
- set program $flagsprg
+ set program $flagsprg;
} else {
- lappend program $flagsprg
+ lappend program $flagsprg;
}
}
- set OptDesc($key) $program
+ set OptDesc($key) $program;
- return $key
+ return $key;
}
#
# Free the storage for that given key
#
proc ::tcl::OptKeyDelete {key} {
- variable OptDesc
- unset OptDesc($key)
+ variable OptDesc;
+ unset OptDesc($key);
}
# Get the parsed description stored under the given key.
proc OptKeyGetDesc {descKey} {
- variable OptDesc
+ variable OptDesc;
if {![info exists OptDesc($descKey)]} {
- return -code error "Unknown option description key \"$descKey\""
+ return -code error "Unknown option description key \"$descKey\"";
}
- set OptDesc($descKey)
+ set OptDesc($descKey);
}
# Parse entry point for ppl who don't want to register with a key,
@@ -232,10 +232,10 @@ proc ::tcl::OptKeyDelete {key} {
# 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
+ 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
@@ -246,22 +246,22 @@ proc ::tcl::OptParse {desc arglist} {
# (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]]
+ set namespace [uplevel 1 [list ::namespace current]];
if {[string match "::*" $name] || [string equal $namespace "::"]} {
# absolute name or global namespace, name is the key
- set key $name
+ set key $name;
} else {
# we are relative to some non top level namespace:
- set key "${namespace}::${name}"
+ set key "${namespace}::${name}";
}
- OptKeyRegister $desc $key
- uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"]
- return $key
+ 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
+ upvar Args alist;
expr {[lsearch $alist $argname] >=0}
}
@@ -270,7 +270,7 @@ proc ::tcl::OptProcArgGiven {argname} {
# Return the instruction word/list of a given step/(sub)program
proc OptInstr {lst} {
- lindex $lst 0
+ lindex $lst 0;
}
# Is a (sub) program or a plain instruction ?
proc OptIsPrg {lst} {
@@ -286,56 +286,56 @@ proc ::tcl::OptProcArgGiven {argname} {
}
# Current program counter (2nd word of first word)
proc OptSetPrgCounter {lstName newValue} {
- upvar $lstName lst
- set lst [lreplace $lst 0 0 [concat "P" $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 {}
+ set res {};
foreach idx [lrange [lindex $lst 0] 1 end] {
- lappend res [Lget $lst $idx]
+ lappend res [Lget $lst $idx];
}
- return $res
+ return $res;
}
# Advance to next description
proc OptNextDesc {descName} {
- uplevel 1 [list Lvarincr $descName {0 1}]
+ uplevel 1 [list Lvarincr $descName {0 1}];
}
# Get the current description, eventually descend
proc OptCurDesc {descriptions} {
- lindex $descriptions [OptGetPrgCounter $descriptions]
+ lindex $descriptions [OptGetPrgCounter $descriptions];
}
# get the current description, eventually descend
# through sub programs as needed.
proc OptCurDescFinal {descriptions} {
- set item [OptCurDesc $descriptions]
+ set item [OptCurDesc $descriptions];
# Descend untill we get the actual item and not a sub program
while {[OptIsPrg $item]} {
- set item [OptCurDesc $item]
+ set item [OptCurDesc $item];
}
- return $item
+ return $item;
}
# Current final instruction adress
proc OptCurAddr {descriptions {start {}}} {
- set adress [OptGetPrgCounter $descriptions]
- lappend start $adress
- set item [lindex $descriptions $adress]
+ set adress [OptGetPrgCounter $descriptions];
+ lappend start $adress;
+ set item [lindex $descriptions $adress];
if {[OptIsPrg $item]} {
- return [OptCurAddr $item $start]
+ return [OptCurAddr $item $start];
} else {
- return $start
+ 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]
+ set adress [OptCurAddr $descriptions];
# use the 3th field of the item (see OptValue / OptNewInst)
lappend adress 2
- Lvarset descriptions $adress [list 1 $value]
+ Lvarset descriptions $adress [list 1 $value];
# ^hasBeenSet flag
}
@@ -343,10 +343,10 @@ proc ::tcl::OptProcArgGiven {argname} {
proc OptState {item} {
lindex $item 0
}
-
+
# current state
proc OptCurState {descriptions} {
- OptState [OptCurDesc $descriptions]
+ OptState [OptCurDesc $descriptions];
}
#######
@@ -354,11 +354,11 @@ proc ::tcl::OptProcArgGiven {argname} {
# Returns the argument that has to be processed now
proc OptCurrentArg {lst} {
- lindex $lst 0
+ lindex $lst 0;
}
# Advance to next argument
proc OptNextArg {argsName} {
- uplevel 1 [list Lvarpop1 $argsName]
+ uplevel 1 [list Lvarpop1 $argsName];
}
#######
@@ -370,49 +370,49 @@ proc ::tcl::OptProcArgGiven {argname} {
# eventually eat all the arguments.
proc OptDoAll {descriptionsName argumentsName} {
upvar $descriptionsName descriptions
- upvar $argumentsName arguments
-# puts "entered DoAll"
+ 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]
+ set state [OptCurState $descriptions];
# We'll exit the loop in "OptDoOne" or when state is empty.
while 1 {
- set curitem [OptCurDesc $descriptions]
+ 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
+# 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]
+ $curitem;
+ OptNextDesc descriptions;
+ set curitem [OptCurDesc $descriptions];
+ set state [OptCurState $descriptions];
}
-# puts "state = \"$state\" - arguments=($arguments)"
+# puts "state = \"$state\" - arguments=($arguments)";
if {[Lempty $state]} {
# Nothing left to do, we are done in this branch:
- break
+ break;
}
# The following statement can make us terminate/continue
# as it use return -code {break, continue, return and error}
# codes
- OptDoOne descriptions state arguments
+ 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]
+# 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
+ upvar $argumentsName arguments;
+ upvar $descriptionsName descriptions;
+ upvar $stateName state;
# the special state/instruction "args" eats all
# the remaining args (if any)
@@ -420,27 +420,27 @@ proc ::tcl::OptProcArgGiven {argname} {
if {![Lempty $arguments]} {
# If there is no additional arguments, leave the default value
# in.
- OptCurSetValue descriptions $arguments
- set arguments {}
+ OptCurSetValue descriptions $arguments;
+ set arguments {};
}
# puts "breaking out ('args' state: consuming every reminding args)"
- return -code break
+ 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
+# 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
+ return ;
} else {
- return -code error [OptMissingValue $descriptions]
+ return -code error [OptMissingValue $descriptions];
}
} else {
- set arg [OptCurrentArg $arguments]
+ set arg [OptCurrentArg $arguments];
}
switch $state {
@@ -450,62 +450,62 @@ proc ::tcl::OptProcArgGiven {argname} {
# Still a flag ?
if {![OptIsFlag $arg]} {
# don't consume the argument, return to previous prg
- return -code return
+ return -code return;
}
# consume the flag
- OptNextArg arguments
+ OptNextArg arguments;
if {[string equal "--" $arg]} {
# return from 'flags' state
- return -code return
+ return -code return;
}
- set hits [OptHits descriptions $arg]
+ 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]
+ set item [OptCurDesc $descriptions];
if {[OptNeedValue $item]} {
# we need a value, next state is
- set state flagValue
+ set state flagValue;
} else {
- OptCurSetValue descriptions 1
+ OptCurSetValue descriptions 1;
}
# continue
- return -code continue
+ return -code continue;
}
flagValue -
value {
- set item [OptCurDesc $descriptions]
+ 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
+ OptNextArg arguments;
# set the value
- OptCurSetValue descriptions $val
+ OptCurSetValue descriptions $val;
# go to next state
if {$state == "flagValue"} {
set state flags
- return -code continue
+ return -code continue;
} else {
set state next; # not used, for debug only
return ; # will go on next step
}
}
optValue {
- set item [OptCurDesc $descriptions]
+ 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
+ OptNextArg arguments;
# set the value
- OptCurSetValue descriptions $val
+ OptCurSetValue descriptions $val;
}
# go to next state
set state next; # not used, for debug only
@@ -516,39 +516,39 @@ proc ::tcl::OptProcArgGiven {argname} {
# state as been entered !
return -code error "Bug! unknown state in DoOne \"$state\"\
(prg counter [OptGetPrgCounter $descriptions]:\
- [OptCurDesc $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]
+ set desc [OptKeyGetDesc $descKey];
# make sure -help always give usage
if {[string equal -nocase "-help" $arglist]} {
- return -code error [OptError "Usage information:" $desc 1]
+ return -code error [OptError "Usage information:" $desc 1];
}
- OptDoAll desc arglist
+ OptDoAll desc arglist;
if {![Lempty $arglist]} {
- return -code error [OptTooManyArgs $desc $arglist]
+ return -code error [OptTooManyArgs $desc $arglist];
}
-
+
# Analyse the result
# Walk through the tree:
- OptTreeVars $desc "#[expr {[info level]-1}]"
+ 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 {[OptIsCounter $item]} continue;
if {[OptIsPrg $item]} {
- set vnamesLst [OptTreeVars $item $level $vnamesLst]
+ set vnamesLst [OptTreeVars $item $level $vnamesLst];
} else {
- set vname [OptVarName $item]
+ set vname [OptVarName $item];
upvar $level $vname var
if {[OptHasBeenSet $item]} {
# puts "adding $vname"
@@ -556,10 +556,10 @@ proc ::tcl::OptKeyParse {descKey arglist} {
# 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]
+ lappend vnamesLst [OptName $item];
+ set var [OptValue $item];
} else {
- set var [OptDefaultValue $item]
+ set var [OptDefaultValue $item];
}
}
}
@@ -571,7 +571,7 @@ proc ::tcl::OptKeyParse {descKey arglist} {
# 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)"
+# puts "checking '$arg' against '$type' ($typeArgs)";
# only types "any", "choice", and numbers can have leading "-"
@@ -580,7 +580,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
if {![string is integer -strict $arg]} {
error "not an integer"
}
- return $arg
+ return $arg;
}
float {
return [expr {double($arg)}]
@@ -591,7 +591,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
if {[llength $arg]==0 && [OptIsFlag $arg]} {
error "no values with leading -"
}
- return $arg
+ return $arg;
}
boolean {
if {![string is boolean -strict $arg]} {
@@ -604,10 +604,10 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
if {[lsearch -exact $typeArgs $arg] < 0} {
error "invalid choice"
}
- return $arg
+ return $arg;
}
any {
- return $arg
+ return $arg;
}
string -
default {
@@ -617,7 +617,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
return $arg
}
}
- return neverReached
+ return neverReached;
}
# internal utilities
@@ -625,34 +625,34 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# 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
+ upvar $descName desc;
set hits 0
set hitems {}
- set i 1
+ set i 1;
- set larg [string tolower $arg]
- set len [string length $larg]
- set last [expr {$len-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]
+ set lflag [string tolower $flag];
if {$len == [string length $lflag]} {
if {[string equal $larg $lflag]} {
# Exact match case
- OptSetPrgCounter desc $i
- return 1
+ OptSetPrgCounter desc $i;
+ return 1;
}
} elseif {[string equal $larg [string range $lflag 0 $last]]} {
- lappend hitems $i
- incr hits
+ lappend hitems $i;
+ incr hits;
}
- incr i
+ incr i;
}
if {$hits} {
- OptSetPrgCounter desc $hitems
+ OptSetPrgCounter desc $hitems;
}
return $hits
}
@@ -660,29 +660,29 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# Extract fields from the list structure:
proc OptName {item} {
- lindex $item 1
+ lindex $item 1;
}
proc OptHasBeenSet {item} {
- Lget $item {2 0}
+ Lget $item {2 0};
}
proc OptValue {item} {
- Lget $item {2 1}
+ Lget $item {2 1};
}
proc OptIsFlag {name} {
- string match "-*" $name
+ string match "-*" $name;
}
proc OptIsOpt {name} {
- string match {\?*} $name
+ string match {\?*} $name;
}
proc OptVarName {item} {
- set name [OptName $item]
+ set name [OptName $item];
if {[OptIsFlag $name]} {
- return [string range $name 1 end]
+ return [string range $name 1 end];
} elseif {[OptIsOpt $name]} {
- return [string trim $name "?"]
+ return [string trim $name "?"];
} else {
- return $name
+ return $name;
}
}
proc OptType {item} {
@@ -719,13 +719,13 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
proc OptOptUsage {item {what ""}} {
return -code error "invalid description format$what: $item\n\
should be a list of {varname|-flagname ?-type? ?defaultvalue?\
- ?helpstring?}"
+ ?helpstring?}";
}
# Generate a canonical form single instruction
proc OptNewInst {state varname type typeArgs help} {
- list $state $varname [list 0 {}] $type $typeArgs $help
+ list $state $varname [list 0 {}] $type $typeArgs $help;
# ^ ^
# | |
# hasBeenSet=+ +=currentValue
@@ -733,18 +733,18 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# 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]
+ 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"
+ set state "flags";
} elseif {$isopt} {
- set state "optValue"
+ set state "optValue";
} elseif {![string equal $varname "args"]} {
- set state "value"
+ set state "value";
} else {
- set state "args"
+ set state "args";
}
# apply 'smart' 'fuzzy' logic to try to make
@@ -754,9 +754,9 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
switch $lg {
1 {
if {$isflag} {
- return [OptNewInst $state $varname boolflag false ""]
+ return [OptNewInst $state $varname boolflag false ""];
} else {
- return [OptNewInst $state $varname any "" ""]
+ return [OptNewInst $state $varname any "" ""];
}
}
2 {
@@ -776,20 +776,20 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
set help ""
set def $arg1
}
- return [OptNewInst $state $varname $type $def $help]
+ 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 ""]
+ return [OptNewInst $state $varname $type $arg2 ""];
} else {
- return [OptNewInst $state $varname $type "" $arg2]
+ return [OptNewInst $state $varname $type "" $arg2];
}
} else {
return [OptNewInst $state $varname\
@@ -798,13 +798,13 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
}
4 {
if {[regexp {^-(.+)$} $arg1 x type]} {
- return [OptNewInst $state $varname $type $arg2 $arg3]
+ return [OptNewInst $state $varname $type $arg2 $arg3];
} else {
- return -code error [OptOptUsage $item]
+ return -code error [OptOptUsage $item];
}
}
default {
- return -code error [OptOptUsage $item]
+ return -code error [OptOptUsage $item];
}
}
}
@@ -829,7 +829,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
}
proc OptFlagUsage {desc arg} {
- OptError "bad flag \"$arg\", must be one of" $desc
+ OptError "bad flag \"$arg\", must be one of" $desc;
}
proc OptTooManyArgs {desc arguments} {
OptError "too many arguments (unexpected argument(s): $arguments),\
@@ -838,45 +838,45 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
}
proc OptParamType {item} {
if {[OptIsFlag $item]} {
- return "flag"
+ return "flag";
} else {
- return "parameter"
+ return "parameter";
}
}
proc OptBadValue {item arg {err {}}} {
-# puts "bad val err = \"$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]
+# 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
+ 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
+ upvar $nlName nl;
+ upvar $tlName tl;
+ upvar $dlName dl;
foreach item $desc {
- if {[OptIsCounter $item]} continue
+ 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]
+ set dv [OptTypeArgs $item];
if {[OptState $item] != "header"} {
- set dv "($dv)"
+ set dv "($dv)";
}
- set l [string length $dv]
+ set l [string length $dv];
# limit the space allocated to potentially big "choices"
if {([OptType $item] != "choice") || ($l<=12)} {
SetMax dl $l
@@ -890,22 +890,22 @@ proc ::tcl::OptKeyError {prefix descKey {header 0}} {
}
# output the tree
proc OptTree {desc nl tl dl} {
- set res ""
+ set res "";
foreach item $desc {
- if {[OptIsCounter $item]} continue
+ if {[OptIsCounter $item]} continue;
if {[OptIsPrg $item]} {
- append res [OptTree $item $nl $tl $dl]
+ append res [OptTree $item $nl $tl $dl];
} else {
- set dv [OptTypeArgs $item]
+ set dv [OptTypeArgs $item];
if {[OptState $item] != "header"} {
- set dv "($dv)"
+ set dv "($dv)";
}
- append res [string trimright [format "\n %-*s %-*s %-*s %s" \
+ append res [format "\n %-*s %-*s %-*s %s" \
$nl [OptName $item] $tl [OptType $item] \
- $dl $dv [OptHelp $item]]]
+ $dl $dv [OptHelp $item]]
}
}
- return $res
+ return $res;
}
# Give nice usage string
@@ -913,13 +913,13 @@ 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 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
+ # actually output
return "$prefix[OptTree $desc $nl $tl $dl]"
}
@@ -943,105 +943,105 @@ proc ::tcl::Lempty {list} {
# Gets the value of one leaf of a lists tree
proc ::tcl::Lget {list indexLst} {
if {[llength $indexLst] <= 1} {
- return [lindex $list $indexLst]
+ return [lindex $list $indexLst];
}
- Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end]
+ 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
+# 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
+ upvar $listName list;
if {[llength $indexLst] <= 1} {
- Lvarset1nc list $indexLst $newValue
+ Lvarset1nc list $indexLst $newValue;
} else {
- set idx [lindex $indexLst 0]
- set targetList [lindex $list $idx]
+ 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 {}
+# Lvarset1 list $idx {};
# recursively replace in targetList
- Lvarset targetList [lrange $indexLst 1 end] $newValue
+ Lvarset targetList [lrange $indexLst 1 end] $newValue;
# put updated sub list back in the tree
- Lvarset1nc list $idx $targetList
+ 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
+ upvar $listName list;
if {$index < 0} {return -code error "invalid negative index"}
- set lg [llength $list]
+ set lg [llength $list];
if {$index >= $lg} {
- variable emptyList
+ variable emptyList;
for {set i $lg} {$i<$index} {incr i} {
- lappend list $emptyList
+ lappend list $emptyList;
}
- lappend list $newValue
+ lappend list $newValue;
} else {
- set list [lreplace $list $index $index $newValue]
+ 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]
+ 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
+ upvar $listName list;
if {[llength $indexLst] <= 1} {
- Lvarincr1 list $indexLst $howMuch
+ Lvarincr1 list $indexLst $howMuch;
} else {
- set idx [lindex $indexLst 0]
- set targetList [lindex $list $idx]
+ set idx [lindex $indexLst 0];
+ set targetList [lindex $list $idx];
# reduce refcount on targetList
- Lvarset1nc list $idx {}
+ Lvarset1nc list $idx {};
# recursively replace in targetList
- Lvarincr targetList [lrange $indexLst 1 end] $howMuch
+ Lvarincr targetList [lrange $indexLst 1 end] $howMuch;
# put updated sub list back in the tree
- Lvarset1nc list $idx $targetList
+ 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
+ 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]
+ 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
+ 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]
+ set i 0;
+ set lg [llength $list];
foreach vname $args {
if {$i>=$lg} break
- uplevel 1 [list ::set $vname [lindex $list $i]]
- incr i
+ uplevel 1 [list ::set $vname [lindex $list $i]];
+ incr i;
}
- return $lg
+ return $lg;
}
# Misc utilities
generated by cgit v0.12 at 2024-11-07 09:15:21 (GMT)