# (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.8.2.1 2003/09/10 20:29:59 dgp Exp $
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
package provide opt
0.4.4.1
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse
\
OptProc OptProcArgGiven OptParse
\
Lassign Lvarpop Lvarpop1 Lvarset Lvarincr
\
################# 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
# example of 'valid' call:
# ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
{subcommand
-choice {save print
} "sub command"}
{-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"}
{-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"}
{?optarg?
-list {} "optional argument"}
foreach v
[info locals
] {
puts stderr
[format "%14s : %s" $v [set $v]]
################### No User serviceable part below ! ###############
# Array storing the parsed descriptions
# Next potentially free key id (numeric)
# 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
# "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
# llength [lindex $singleStep 0] == 1
# And for this application:
# singleStep :== { instruction varname {hasBeenSet currentValue} type
# instruction :== "flags" | "value"
# type :== knowType | anyword
# knowType :== "string" | "int" | "boolean" | "boolflag" | "float"
# 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
""}} {
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 program
[list [list "P" 1]];
# are we processing flags (which makes a single program step)
# flag used to detect that we just have a single (flags set) subprogram.
# more items after 'args'...
return -code error "'args' special argument must be the last one";
set res
[OptNormalizeOne
$item];
set state
[lindex $res 0];
# structure for flag programs items is a list of
# {subprgcounter {prg flag 1} {prg flag 2} {...}}
lappend program
$flagsprg;
# put the other regular stuff
# sub program counter + first sub program
set flagsprg
[list [list "P" 1] $res];
# We just have the subprogram, optimize and remove
lappend program
$flagsprg;
set OptDesc
($key) $program;
# Free the storage for that given key
proc ::tcl::OptKeyDelete {key
} {
# Get the parsed description stored under the given key.
proc OptKeyGetDesc
{descKey
} {
if {![info exists OptDesc
($descKey)]} {
return -code error "Unknown option description key \"$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
];
# 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 equal
$namespace "::"]} {
# absolute name or global namespace, name is the key
# 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"];
# Check that a argument has been given
# assumes that "OptProc" has been used as it will check in "Args" list
proc ::tcl::OptProcArgGiven {argname
} {
expr {[lsearch $alist $argname] >=0}
# Programs/Descriptions manipulation
# Return the instruction word/list of a given step/(sub)program
# Is a (sub) program or a plain instruction ?
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
} {
# Current program counter (2nd word of first word)
proc OptSetPrgCounter
{lstName newValue
} {
set lst
[lreplace $lst 0 0 [concat "P" $newValue]];
# returns a list of currently selected items.
proc OptSelection
{lst
} {
foreach idx
[lrange [lindex $lst 0] 1 end
] {
lappend res
[Lget
$lst $idx];
# 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];
# Current final instruction adress
proc OptCurAddr
{descriptions
{start
{}}} {
set adress
[OptGetPrgCounter
$descriptions];
set item
[lindex $descriptions $adress];
return [OptCurAddr
$item $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)
Lvarset descriptions
$adress [list 1 $value];
# empty state means done/paste the end of the program
proc OptCurState
{descriptions
} {
OptState
[OptCurDesc
$descriptions];
# Returns the argument that has to be processed now
proc OptCurrentArg
{lst
} {
# 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
;
# Nb: the places where "state" can be set are tricky to figure
# because DoOne sets the state to flagsValue and return -continue
set state
[OptCurState
$descriptions];
# We'll exit the loop in "OptDoOne" or when state is empty.
set curitem
[OptCurDesc
$descriptions];
# Do subprograms if needed, call ourselves on the sub branch
while {[OptIsPrg
$curitem]} {
OptDoAll curitem arguments
# Insert back the results in current tree;
Lvarset1nc descriptions
[OptGetPrgCounter
$descriptions]\
OptNextDesc descriptions
;
set curitem
[OptCurDesc
$descriptions];
set state
[OptCurState
$descriptions];
# puts "state = \"$state\" - arguments=($arguments)";
# Nothing left to do, we are done in this branch:
# The following statement can make us terminate/continue
# as it use return -code {break, continue, return and error}
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
;
# 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
OptCurSetValue descriptions
$arguments;
# puts "breaking out ('args' state: consuming every reminding args)"
if {[Lempty
$arguments]} {
# no argument and no flags : we're done
# puts "returning to previous (sub)prg (no more args)";
} elseif
{$state == "optValue"} {
set state next
; # not used, for debug only
return -code error [OptMissingValue
$descriptions];
set arg
[OptCurrentArg
$arguments];
# A non-dash argument terminates the options, as does --
# don't consume the argument, return to previous prg
if {[string equal
"--" $arg]} {
# return from 'flags' state
set hits
[OptHits descriptions
$arg];
return -code error [OptAmbigous
$descriptions $arg]
return -code error [OptFlagUsage
$descriptions $arg]
set item
[OptCurDesc
$descriptions];
if {[OptNeedValue
$item]} {
# we need a value, next state is
OptCurSetValue descriptions
1;
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]
OptCurSetValue descriptions
$val;
if {$state == "flagValue"} {
set state next
; # not used, for debug only
return ; # will go on next step
set item
[OptCurDesc
$descriptions];
# Test the values against their required type
if {![catch {OptCheckType
$arg\
[OptType
$item] [OptTypeArgs
$item]} val
]} {
OptCurSetValue descriptions
$val;
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
proc ::tcl::OptKeyParse {descKey arglist
} {
set desc
[OptKeyGetDesc
$descKey];
# make sure -help always give usage
if {[string equal
-nocase "-help" $arglist]} {
return -code error [OptError
"Usage information:" $desc 1];
if {![Lempty
$arglist]} {
return -code error [OptTooManyArgs
$desc $arglist];
OptTreeVars
$desc "#[expr {[info level]-1}]" ;
# determine string length for nice tabulated output
proc OptTreeVars
{desc level
{vnamesLst
{}}} {
if {[OptIsCounter
$item]} continue;
set vnamesLst
[OptTreeVars
$item $level $vnamesLst];
set vname
[OptVarName
$item];
if {[OptHasBeenSet
$item]} {
# 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];
set var
[OptDefaultValue
$item];
# 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 "-"
if {![string is integer
-strict $arg]} {
return [expr {double
($arg)}]
# if llength fail : malformed list
if {[llength $arg]==0 && [OptIsFlag
$arg]} {
error "no values with leading -"
if {![string is boolean
-strict $arg]} {
error "non canonic boolean"
# convert true/false because expr/if is broken with "!,...
return [expr {$arg ?
1 : 0}]
if {[lsearch -exact $typeArgs $arg] < 0} {
error "no values with leading -"
# returns the number of flags matching the given arg
# sets the (local) prg counter to the list of matches
proc OptHits
{descName arg
} {
set larg
[string tolower
$arg];
set len
[string length
$larg];
set last
[expr {$len-1}];
foreach item
[lrange $desc 1 end
] {
# lets try to match case insensitively
# (string length ought to be cheap)
set lflag
[string tolower
$flag];
if {$len == [string length
$lflag]} {
if {[string equal
$larg $lflag]} {
OptSetPrgCounter desc
$i;
} elseif
{[string equal
$larg [string range
$lflag 0 $last]]} {
OptSetPrgCounter desc
$hitems;
# Extract fields from the list structure:
proc OptHasBeenSet
{item
} {
string match
{\?*} $name;
set name
[OptName
$item];
return [string range
$name 1 end
];
} elseif
{[OptIsOpt
$name]} {
return [string trim
$name "?"];
proc OptTypeArgs
{item
} {
proc OptNeedValue
{item
} {
expr {![string equal
[OptType
$item] boolflag
]}
proc OptDefaultValue
{item
} {
set val
[OptTypeArgs
$item]
switch -exact -- [OptType
$item] {
choice
{return [lindex $val 0]}
# convert back false/true to 0/1 because expr !$bool
# 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?\
# 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];
} elseif
{![string equal
$varname "args"]} {
# apply 'smart' 'fuzzy' logic to try to make
# description writer's life easy, and our's difficult :
# let's guess the missing arguments :-)
return [OptNewInst
$state $varname boolflag false
""];
return [OptNewInst
$state $varname any
"" ""];
set type
[OptGuessType
$arg1]
if {[string equal
$type "string"]} {
return [OptNewInst
$state $varname $type $def $help];
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];
return [OptNewInst
$state $varname\
[OptGuessType
$arg1] $arg1 $arg2]
if {[regexp {^
-(.
+)$} $arg1 x type
]} {
return [OptNewInst
$state $varname $type $arg2 $arg3];
return -code error [OptOptUsage
$item];
return -code error [OptOptUsage
$item];
# Auto magic lasy type determination
proc OptGuessType
{arg
} {
if {[regexp -nocase {^
(true|false
)$} $arg]} {
if {[regexp {^
(-+)?
[0-9]+$} $arg]} {
if {![catch {expr {double
($arg)}}]} {
# 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),\
proc OptParamType
{item
} {
proc OptBadValue
{item arg
{err
{}}} {
# puts "bad val err = \"$err\"";
OptError
"bad value \"$arg\" for [OptParamType $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) :"\
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
} {
if {[OptIsCounter
$item]} continue;
OptLengths
$item nl tl dl
SetMax nl
[string length
[OptName
$item]]
SetMax tl
[string length
[OptType
$item]]
set dv
[OptTypeArgs
$item];
if {[OptState
$item] != "header"} {
set l
[string length
$dv];
# limit the space allocated to potentially big "choices"
if {([OptType
$item] != "choice") ||
($l<=12)} {
proc OptTree
{desc nl tl dl
} {
if {[OptIsCounter
$item]} continue;
append res
[OptTree
$item $nl $tl $dl];
set dv
[OptTypeArgs
$item];
if {[OptState
$item] != "header"} {
append res
[format "\n %-*s %-*s %-*s %s" \
$nl [OptName
$item] $tl [OptType
$item] \
proc ::tcl::OptError {prefix desc
{header
0}} {
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
return "$prefix[OptTree $desc $nl $tl $dl]"
################ General Utility functions #######################
# "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)
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
} {
if {[llength $indexLst] <= 1} {
Lvarset1nc
list $indexLst $newValue;
set idx
[lindex $indexLst 0];
set targetList
[lindex $list $idx];
# reduce refcount on targetList (not really usefull now,
# could be with optimizing compiler)
# 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
proc ::tcl::Lvarset1 {listName index newValue
} {
if {$index < 0} {return -code error "invalid negative index"}
for {set i
$lg} {$i<$index} {incr i
} {
set list [lreplace $list $index $index $newValue];
# same as Lvarset1 but no bound checking / creation
proc ::tcl::Lvarset1nc {listName index newValue
} {
set list [lreplace $list $index $index $newValue];
# Increments the value of one leaf of a lists tree
proc ::tcl::Lvarincr {listName indexLst
{howMuch
1}} {
if {[llength $indexLst] <= 1} {
Lvarincr1
list $indexLst $howMuch;
set idx
[lindex $indexLst 0];
set targetList
[lindex $list $idx];
# reduce refcount on targetList
# 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}} {
set newValue
[expr {[lindex $list $index]+$howMuch}];
set list [lreplace $list $index $index $newValue];
# Removes the first element of a list
# and returns the new list value
proc ::tcl::Lvarpop1 {listName
} {
set list [lrange $list 1 end
];
# Same but returns the removed element
# (Like the tclX version)
proc ::tcl::Lvarpop {listName
} {
set list [lrange $list 1 end
];
# 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)
uplevel 1 [list ::set $vname [lindex $list $i]];
# Set the varname to value if value is greater than varname's current value
# or if varname is undefined
proc ::tcl::SetMax {varname value
} {
if {![info exists var
] ||
$value > $var} {
# Set the varname to value if value is smaller than varname's current value
# or if varname is undefined
proc ::tcl::SetMin {varname value
} {
if {![info exists var
] ||
$value < $var} {
# everything loaded fine, lets create the test proc:
# Don't need the create temp proc anymore:
# rename OptCreateTestProc {}