|
|
|
|
|
# Tcl parser for optional arguments in function calls and |
|
|
# commandline arguments |
|
|
# |
|
|
# (c) 2001 Bastien Chevreux |
|
|
|
|
|
# Index of exported commands |
|
|
# - argp::registerArgs |
|
|
# - argp::setArgDefaults |
|
|
# - argp::setArgsNeeded |
|
|
# - argp::parseArgs |
|
|
|
|
|
# Internal commands |
|
|
# - argp::CheckValues |
|
|
|
|
|
# See end of file for an example on how to use |
|
|
|
|
|
package provide argp 0.2 |
|
|
|
|
|
namespace eval argp { |
|
|
variable Optstore |
|
|
variable Opttypes { |
|
|
boolean integer double string |
|
|
} |
|
|
|
|
|
namespace export {[a-z]*} |
|
|
} |
|
|
|
|
|
|
|
|
proc argp::registerArgs { func arglist } { |
|
|
variable Opttypes |
|
|
variable Optstore |
|
|
|
|
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
|
|
if { $parentns != "" } { |
|
|
append caller $parentns :: $func |
|
|
} else { |
|
|
set caller $func |
|
|
} |
|
|
set cmangled [string map {:: _} $caller] |
|
|
|
|
|
#puts $parentns |
|
|
#puts $caller |
|
|
#puts $cmangled |
|
|
|
|
|
set Optstore(keys,$cmangled) {} |
|
|
set Optstore(deflist,$cmangled) {} |
|
|
set Optstore(argneeded,$cmangled) {} |
|
|
|
|
|
foreach arg $arglist { |
|
|
foreach {opt type default allowed} $arg { |
|
|
set optindex [lsearch -glob $Opttypes $type*] |
|
|
if { $optindex < 0} { |
|
|
return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]" |
|
|
} |
|
|
set type [lindex $Opttypes $optindex] |
|
|
|
|
|
lappend Optstore(keys,$cmangled) $opt |
|
|
set Optstore(type,$opt,$cmangled) $type |
|
|
set Optstore(default,$opt,$cmangled) $default |
|
|
set Optstore(allowed,$opt,$cmangled) $allowed |
|
|
lappend Optstore(deflist,$cmangled) $opt $default |
|
|
} |
|
|
} |
|
|
|
|
|
if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} { |
|
|
return -code error "Error in declaration of optional arguments.\n$res" |
|
|
} |
|
|
} |
|
|
|
|
|
proc argp::setArgDefaults { func arglist } { |
|
|
variable Optstore |
|
|
|
|
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
|
|
if { $parentns != "" } { |
|
|
append caller $parentns :: $func |
|
|
} else { |
|
|
set caller $func |
|
|
} |
|
|
set cmangled [string map {:: _} $caller] |
|
|
|
|
|
if {![info exists Optstore(deflist,$cmangled)]} { |
|
|
return -code error "Arguments for $caller not registered yet." |
|
|
} |
|
|
set Optstore(deflist,$cmangled) {} |
|
|
foreach {opt default} $arglist { |
|
|
if {![info exists Optstore(default,$opt,$cmangled)]} { |
|
|
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
|
|
} |
|
|
set Optstore(default,$opt,$cmangled) $default |
|
|
} |
|
|
|
|
|
# set the new defaultlist |
|
|
foreach opt $Optstore(keys,$cmangled) { |
|
|
lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled) |
|
|
} |
|
|
} |
|
|
|
|
|
proc argp::setArgsNeeded { func arglist } { |
|
|
variable Optstore |
|
|
|
|
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
|
|
if { $parentns != "" } { |
|
|
append caller $parentns :: $func |
|
|
} else { |
|
|
set caller $func |
|
|
} |
|
|
set cmangled [string map {:: _} $caller] |
|
|
|
|
|
#append caller $parentns :: $func |
|
|
#set cmangled ${parentns}_$func |
|
|
|
|
|
if {![info exists Optstore(deflist,$cmangled)]} { |
|
|
return -code error "Arguments for $caller not registered yet." |
|
|
} |
|
|
|
|
|
set Optstore(argneeded,$cmangled) {} |
|
|
foreach opt $arglist { |
|
|
if {![info exists Optstore(default,$opt,$cmangled)]} { |
|
|
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
|
|
} |
|
|
lappend Optstore(argneeded,$cmangled) $opt |
|
|
} |
|
|
} |
|
|
|
|
|
|
|
|
proc argp::parseArgs { args } { |
|
|
variable Optstore |
|
|
|
|
|
if {[llength $args] == 0} { |
|
|
upvar args a opts o |
|
|
} else { |
|
|
upvar args a [lindex $args 0] o |
|
|
} |
|
|
|
|
|
if { [ catch { set caller [lindex [info level -1] 0]}]} { |
|
|
set caller "main program" |
|
|
set cmangled "" |
|
|
} else { |
|
|
set cmangled [string map {:: _} $caller] |
|
|
} |
|
|
|
|
|
if {![info exists Optstore(deflist,$cmangled)]} { |
|
|
return -code error "Arguments for $caller not registered yet." |
|
|
} |
|
|
|
|
|
# set the defaults |
|
|
array set o $Optstore(deflist,$cmangled) |
|
|
|
|
|
# but unset the needed arguments |
|
|
foreach key $Optstore(argneeded,$cmangled) { |
|
|
catch { unset o($key) } |
|
|
} |
|
|
|
|
|
foreach {key val} $a { |
|
|
if {![info exists Optstore(type,$key,$cmangled)]} { |
|
|
return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)" |
|
|
} |
|
|
switch -exact -- $Optstore(type,$key,$cmangled) { |
|
|
boolean - |
|
|
integer { |
|
|
if { $val == "" } { |
|
|
return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value." |
|
|
} |
|
|
if { ![string is $Optstore(type,$key,$cmangled) $val]} { |
|
|
return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value." |
|
|
} |
|
|
} |
|
|
double { |
|
|
if { $val == "" } { |
|
|
return -code error "$caller, $key empty string is not double value." |
|
|
} |
|
|
if { ![string is double $val]} { |
|
|
return -code error "$caller, $key $val is not double value." |
|
|
} |
|
|
if { [string is integer $val]} { |
|
|
set val [expr {$val + .0}] |
|
|
} |
|
|
} |
|
|
default { |
|
|
} |
|
|
} |
|
|
set o($key) $val |
|
|
} |
|
|
|
|
|
foreach key $Optstore(argneeded,$cmangled) { |
|
|
if {![info exists o($key)]} { |
|
|
return -code error "$caller, needed argument $key was not given." |
|
|
} |
|
|
} |
|
|
|
|
|
if { [catch { CheckValues $caller $cmangled [array get o]} err]} { |
|
|
return -code error $err |
|
|
} |
|
|
|
|
|
return |
|
|
} |
|
|
|
|
|
|
|
|
proc argp::CheckValues { caller cmangled checklist } { |
|
|
variable Optstore |
|
|
|
|
|
#puts "Checking $checklist" |
|
|
|
|
|
foreach {key val} $checklist { |
|
|
if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } { |
|
|
switch -exact -- $Optstore(type,$key,$cmangled) { |
|
|
string { |
|
|
if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} { |
|
|
return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)" |
|
|
} |
|
|
} |
|
|
double - |
|
|
integer { |
|
|
set found 0 |
|
|
foreach range $Optstore(allowed,$key,$cmangled) { |
|
|
if {[llength $range] == 1} { |
|
|
if { $val == [lindex $range 0] } { |
|
|
set found 1 |
|
|
break |
|
|
} |
|
|
} elseif {[llength $range] == 2} { |
|
|
set low [lindex $range 0] |
|
|
set high [lindex $range 1] |
|
|
|
|
|
if { ![string is integer $low] \ |
|
|
&& [string compare "-" $low] != 0} { |
|
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not <EFBFBD>-<EFBFBD>: $range" |
|
|
} |
|
|
if { ![string is integer $high] \ |
|
|
&& [string compare "+" $high] != 0} { |
|
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not <EFBFBD>+<EFBFBD>: $range" |
|
|
} |
|
|
if {[string compare "-" $low] == 0} { |
|
|
if { [string compare "+" $high] == 0 \ |
|
|
|| $val <= $high } { |
|
|
set found 1 |
|
|
break |
|
|
} |
|
|
} |
|
|
if { $val >= $low } { |
|
|
if {[string compare "+" $high] == 0 \ |
|
|
|| $val <= $high } { |
|
|
set found 1 |
|
|
break |
|
|
} |
|
|
} |
|
|
} else { |
|
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range" |
|
|
} |
|
|
} |
|
|
if { $found == 0 } { |
|
|
return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)" |
|
|
} |
|
|
} |
|
|
} |
|
|
} |
|
|
} |
|
|
}
|
|
|
|
