4 # Option parsing library for Tcl scripts
5 # Copyright (C) SoftWeyr, 1997
6 # Author V. Wagner <vitus@agropc.msk.su
8 # Distributed under GNU public license. (i.e. compiling into standalone
9 # executables or encrypting is prohibited, unless source is provided to users)
13 # getopt - recieves an array of possible options with default values
14 # and list of options with values, and modifies array according to supplied
16 # ARGUMENTS: arrname - array in calling procedure, whose indices is names of
17 # options WITHOUT leading dash and values are default values.
18 # if element named "default" exists in array, all unrecognized options
19 # would concatenated there in same form, as they was in args
20 # args - argument list - can be passed either as one list argument or
23 # SIDE EFFECTS: modifies passed array
25 proc getopt {arrname args} {
27 if ![array exist opt] {
28 return -code error "Array $arrname doesn't exist"
30 if {[llength $args]==1} {eval set args $args}
31 if {![llength $args]} return
32 if {[llength $args]%2!=0} {error "Odd count of opt. arguments"}
33 foreach {option value} $args {
34 if [string match -* $option] {
35 set list [array names opt [string trimleft $option -]*]
37 switch -exact [llength $list] {
38 0 { if [info exists opt(default)] {
39 lappend opt(default) $option $value
41 set msg "unknown option $option. Should be one of:"
42 foreach j [array names opt] {append msg " -" $j}
43 return -code error $msg
46 1 { set opt($list) $value
49 if [set j [lsearch -exact $list [string trimleft $option -]]]!=-1 {
50 set opt([lindex $list $j]) $value
52 set msg "Ambiguous option $option:"
53 foreach j $list {append msg " -" $j}
54 return -code error $msg
63 # handleopt - recieves an array of possible options and executes given scritp
64 # for each of valid option passed , appending opion value to it
65 # ARGUMENTS: arrname - array in calling procedure, whose indices is names of
66 # options WITHOUT leading dash and values are corresponding scripts
67 # args - argument list - can be passed either as one list argument or
69 # if element "default" appears in array, script contained there would
70 # be executed for each unrecognized option with option itself and then
72 # RETURN VALUE: return value of last script executed
73 # SIDE EFFECTS: execiting of one or more passed scripts
74 # NOTES: if you want simply return value of option, return is good candidate for
75 # script. {return -return} would terminate caller
77 proc handleopt {arrname args} {
79 if ![array exist opt] {
80 return -code error "Array $arrname doesn't exist"
82 if {[llength $args]==1} {eval set args $args}
83 if {![llength $args]} return
84 if {[llength $args]%2!=0} {error "Odd count of opt. arguments"}
86 foreach {option value} $args {
87 if [string match -* $option] {
88 set list [array names opt [string trimleft $option -]*]
90 switch -exact [llength $list] {
91 0 { if [info exist opt(default)] {
92 set cmd "$opt(default) [list $option $value]"
94 set msg "unknown option $option. Should be one of:"
95 foreach j [array names opt] {append msg " -" $j}
96 return -code error $msg
99 1 { set cmd "$opt($list) [list $value]"}
101 if [set j [lsearch -exact $list [string trimleft $option -]]]!=-1 {
102 set cmd [linsert $opt([lindex $list $j]) end $value]
104 set msg "Ambiguous option $option:"
105 foreach j $list {append msg " -" $j}
106 return -code error $msg
110 if [catch {uplevel $cmd} result ] {
113 return -code error $result
119 # checks variable for valid boolean value
120 # and replaces it with 1, if true or 0 it false. If value is not
121 # correct, message is stored in msg and 1 returned. Otherwise 0 is returned
124 proc checkbooleanopt {var msg} {
126 set t [string tolower $test]
128 if [string length $t] {
129 foreach truth {1 yes on true} {
130 if [string match $t* $truth] {
135 foreach lie {0 no off false} {
136 if [string match $t* $lie] {
138 uplevel set $msg [list "Ambiquous boolean value \"$test\""]
151 uplevel set $msg [list "Expected boolean value, but got \"$test\""]
156 # checks variable value for matching one (and only one) of given list element
157 # and replaces its value with literal value of this element
158 # Returns 0 if value is correct, 1 if it is bad. Sets msg to verbose error message
161 proc checklistopt {var list msg} {
167 # Ok, there is literal match
168 if [info exists tmp($test)] {return 0}
169 # Trying to do glob match
170 set num [llength [set found [array names tmp $test*]]]
172 set test [lindex $found 0]
175 set err "Unknown option $test. Should be one of [join $list ", "]"
178 set err "Ambiquous option $test.\n [join $found ", "]"
182 # Checks variable value for being integer and (optionally) fall into given range
183 # You can use empty string, if you don't want to check for min or max
185 # Returns 0 if no error, 1 if something wrong. Sets msg to verbose error message
187 proc checkintopt {var min max msg} {
190 if ![string length $min] {set min -0x7fffffff}
191 if ![string length $max] {set max 0x7fffffff}
192 set test [string trim $test]
193 if ![regexp {^[+-]?(0[xX][0-9A-Fa-f]+|[1-9][0-9]*|0[0-7]*)$} $test] {
194 set err "Expected integer, but got \"$test\""
198 set err "Expected integer greater than $min, but got $test"
202 set err "Expected integer less than $max, but got $test"
206 package provide getopt 1.1