tcl/getopt.tcl

   1 #
   2 # getopt.tcl
   3 #
   4 # Option parsing library for Tcl scripts
   5 # Copyright (C) SoftWeyr, 1997
   6 # Author V. Wagner <vitus@agropc.msk.su
   7 #
   8 # Distributed under GNU public license. (i.e. compiling into standalone
   9 # executables or encrypting is prohibited, unless source is provided to users)
  10 #
  11
  12 #
  13 # getopt - recieves an array of possible options with default values
  14 # and list of options with values, and modifies array according to supplied
  15 # values
  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
  21 # sepatate arguments
  22 # RETURN VALUE: none
  23 # SIDE EFFECTS: modifies passed array
  24 #
  25 proc getopt {arrname args} {
  26 upvar $arrname opt
  27 if ![array exist opt] {
  28   return -code error "Array $arrname doesn't exist"
  29 }
  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 -]*]
  36    } else { set list {}}
  37    switch -exact [llength $list] {
  38        0 { if [info exists opt(default)] {
  39               lappend opt(default) $option $value
  40            } else {
  41                set msg "unknown option $option. Should be one of:"
  42                foreach j [array names opt] {append msg " -" $j}
  43                return -code error $msg
  44            }
  45        }
  46        1 { set opt($list) $value
  47        }
  48        default {
  49          if [set j [lsearch -exact $list [string trimleft $option -]]]!=-1 {
  50              set opt([lindex $list $j]) $value
  51          } else {
  52              set msg "Ambiguous option $option:"
  53              foreach j $list {append msg " -" $j}
  54              return -code error $msg
  55          }
  56        }
  57    }
  58 }
  59    return
  60 }
  61
  62 #
  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
  68 # sepatate arguments
  69 # if element "default" appears in array, script contained there would
  70 # be executed for each unrecognized option with option itself and then
  71 # its value appended
  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
  76 #
  77 proc handleopt {arrname args} {
  78 upvar $arrname opt
  79 if ![array exist opt] {
  80   return -code error "Array $arrname doesn't exist"
  81 }
  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"}
  85 set result {}
  86 foreach {option value} $args {
  87     if [string match -* $option] {
  88        set list [array names opt [string trimleft $option -]*]
  89     } else {set list {}}
  90     switch -exact [llength $list] {
  91        0 { if [info exist opt(default)] {
  92              set cmd "$opt(default) [list $option $value]"
  93            } else {
  94               set msg "unknown option $option. Should be one of:"
  95              foreach j [array names opt] {append msg " -" $j}
  96              return -code error $msg
  97            }
  98        }
  99        1 { set cmd "$opt($list) [list $value]"}
 100        default {
 101             if [set j [lsearch -exact $list [string trimleft $option -]]]!=-1 {
 102                 set cmd [linsert $opt([lindex $list $j]) end $value]
 103             } else {
 104                set msg "Ambiguous option $option:"
 105                foreach j $list {append msg " -" $j}
 106                return -code error $msg
 107             }
 108        }
 109     }
 110     if [catch {uplevel $cmd} result ] {
 111         global errorInfo
 112         puts $errorInfo
 113         return -code error $result
 114     }
 115 }
 116 return $result
 117 }
 118 #
 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
 122 #
 123
 124 proc checkbooleanopt {var msg} {
 125 upvar $var test
 126 set t [string tolower $test]
 127 set r 0
 128 if [string length $t] {
 129     foreach truth {1 yes on true} {
 130       if [string match $t* $truth] {
 131         set r 1
 132         break
 133       }
 134     }
 135     foreach lie {0 no off false} {
 136       if [string match $t* $lie] {
 137          if $r {
 138            uplevel set $msg [list "Ambiquous boolean value \"$test\""]
 139            return 1
 140          } else {
 141            set test 0
 142            return 0
 143          }
 144       }
 145    }
 146 }
 147 if $r {
 148   set test 1
 149   return 0
 150 } else {
 151   uplevel set $msg [list "Expected boolean value, but got \"$test\""]
 152   return 1
 153 }
 154 }
 155 #
 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
 159 #
 160
 161 proc checklistopt {var list msg} {
 162 upvar $var test
 163 upvar $msg err
 164 foreach i $list {
 165    set tmp($i) 1
 166 }
 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*]]]
 171 if {$num==1} {
 172   set test [lindex $found 0]
 173   return 0
 174 } elseif {!$num} {
 175   set err "Unknown option $test. Should be one of [join $list ", "]"
 176   return 1
 177 } else {
 178   set err "Ambiquous option $test.\n [join $found ", "]"
 179   return 1
 180 }
 181 }
 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
 184 #
 185 # Returns 0 if no error, 1 if something wrong. Sets msg to verbose error message
 186 #
 187 proc checkintopt {var min max msg} {
 188 upvar $var test
 189 upvar $msg err
 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\""
 195    return 1
 196 }
 197 if {$test<$min} {
 198   set err  "Expected integer greater than $min, but got $test"
 199   return 1
 200 }
 201 if {$test>$max} {
 202   set err "Expected integer less than $max, but got $test"
 203 }
 204 return 0
 205 }
 206 package provide getopt 1.1