interfaces/xmaxima/Tkmaxima/Getopt.tcl

   1 # -*-mode: tcl; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
   2 #
   3 #       $Id: Getopt.tcl,v 1.4 2004-10-13 12:08:57 vvzhy Exp $
   4 #
   5 ###### Getopt.tcl ######
   6 ############################################################
   7 # Netmath       Copyright (C) 1998 William F. Schelter     #
   8 # For distribution under GNU public License.  See COPYING. #
   9 ############################################################
  10
  11 #####sample option list.   Error will be signalled if "Required" option
  12 ##### not given.
  13 #set dfplotOptions {
  14 #    {xdot Required {specifies dx/dt = xdot.  eg -xdot "x+y+sin(x)^2"} }
  15 #    {ydot Required {specifies dy/dt = ydot.  eg -ydot "x-y^2+exp(x)"} }
  16 #    {xradius 10 "Width in x direction of the x values" }
  17 #    {yradius 10 "Height in y direction of the y values"}
  18 #}
  19
  20
  21 #
  22 #-----------------------------------------------------------------
  23 #
  24 # optLoc --  if $usearray is not 0, then the OPTION is stored
  25 # in a hashtable, otherwise in the variable whose name is the
  26 # same as OPTION.
  27 #  Results: a form which when 'set' will allow storing value.
  28 #
  29 #  Side Effects: none
  30 #
  31 #----------------------------------------------------------------
  32 #
  33 proc optLoc { op ar }  {
  34     #  puts "$ar,[lindex $op 0]"
  35     # puts "return=$ar\([lindex $op 0]\)"
  36     if { "$ar" == 0 } {
  37         return [lindex $op 0]
  38     } else {
  39         #puts "$ar\([lindex $op 0]\)"
  40         return "$ar\([lindex $op 0]\)"
  41     }
  42
  43 }
  44
  45
  46 #
  47 #-----------------------------------------------------------------
  48 #
  49 # getOptions --  given OPTLIST a specification for the options taken,
  50 # parse the alternating keyword1 value1 keyword2 value2 options_supplied
  51 # to make sure they are allowed, and not just typos, and to supply defaults
  52 # for ones not given.   Give an error message listing options.
  53 # a specification is  { varname default_value "doc string" }
  54 # and optlist, is a list of these.   the key should be -varname
  55 #
  56 #  -debug 1 "means print the values on standard out"
  57 #  -allowOtherKeys 1 "dont signal an error if -option is supplied but not in
  58 #                     the list"
  59 #  -usearray "should give a NAME, so that options are stored in NAME(OPTION)
  60 #  -setdefaults "if not 0 (default is 1) do `set OPTION dflt' for all options"
  61 # If a key is specified twice eg.  -key1 val1 -key1 val2, then the first
  62 # value val1 will be used
  63 #  Results:
  64 #
  65 #  Side Effects: set the values in the callers environment
  66 #
  67 #----------------------------------------------------------------
  68 #
  69
  70 proc getOptions { optlist options_supplied args } {
  71     # global  getOptionSpecs
  72
  73     set ar [assoc -usearray $args 0]
  74     set help [assoc -help $args ""]
  75     if { "$ar" != "0" } { global $ar }
  76     set debug [assoc -debug $args 0]
  77     set allowOtherKeys [assoc -allowOtherKeys $args 0]
  78     set setdefaults [assoc -setdefaults $args 1]
  79     set supplied ""
  80
  81     foreach {key val } $options_supplied {
  82         if { [info exists already($key)] } { continue }
  83         set already($key) 1
  84         set found 0
  85         foreach op $optlist {
  86             if { "$key" == "-[lindex $op 0]" } {
  87                 uplevel 1 set [optLoc $op $ar] [list $val]
  88
  89                 append supplied " [lindex $op 0]"
  90                 set found 1
  91                 break
  92             }
  93         }
  94         set caller global
  95
  96         if { $found == 0  && !$allowOtherKeys } {
  97             catch {set caller [lindex [info level -1] 0]}
  98             error [concat "`$caller'" [mc "does not take the key"] "`$key':\n[optionHelpMessage $optlist]\n$help"]
  99
 100         }
 101     }
 102     foreach op $optlist {
 103         if { [lsearch $supplied [lindex $op 0]] < 0 } {
 104             if { "[lindex $op 1]" == "Required" } {
 105                 catch {set caller [lindex [info level -1] 0]}
 106                 error [concat "`-[lindex $op 0]'" [mc "is required option for"] "`$caller':\n[optionHelpMessage $optlist]"]
 107             }
 108             if { $setdefaults }  {
 109
 110                 uplevel 1 set [optLoc $op $ar] [list [lindex $op 1]]
 111             }
 112         }
 113         # for debugging see them.
 114         # if { $debug } {   uplevel 1 puts "[optLoc $op $ar]=\$[optLoc $op $ar]"}
 115         if { $debug } {   puts "[optLoc $op $ar]=[safeValue [optLoc $op $ar] 2]"}
 116
 117     }
 118 }
 119
 120 proc getOptionDefault { key optionList } {
 121     foreach v $optionList {
 122         if { "[lindex $v 0]" == "$key" } { return [lindex $v 1]}
 123     }
 124     return ""
 125 }
 126
 127 proc assq {key list {dflt ""}} {
 128     foreach v $list { if { "[lindex $v 0]" == "$key" } { return $v }}
 129     return $dflt
 130 }
 131
 132 proc safeValue { loc level} {
 133     if { ![catch { set me [uplevel $level set $loc] } ] } {
 134         return $me
 135     }  else {
 136         return "`unset'"
 137     }
 138 }
 139
 140
 141
 142 proc optionFirstItems { lis } {
 143     set ans ""
 144     foreach v $lis { append ans " [list [lindex $v 0]]" }
 145     return $ans
 146 }
 147
 148 proc optionHelpMessage { optlist } {
 149     set msg ""
 150     foreach op $optlist  {
 151         append msg \
 152                 " -[lindex $op 0] \[ [lindex $op 1] \] --[lindex $op 2]\n"
 153     }
 154     return $msg
 155 }
 156
 157
 158 #
 159 #-----------------------------------------------------------------
 160 #
 161 # setSplittingOptionsRest --  takes ARGLIST and splits it into
 162 # two lists, the first part it stores in KEYPAIRS and the second in REST
 163 #
 164 #
 165 #  Results: none
 166 #
 167 #
 168 #  Side Effects: sets the variables in the local frame passed to KEYPAIRS
 169 #
 170 #----------------------------------------------------------------
 171 #
 172 proc setSplittingOptionsRest {  keypairs rest arglist } {
 173     upvar 1 $keypairs keys
 174     upvar 1 $rest res
 175     set i 0
 176     while { 1 } {
 177         if { $i >= [llength $arglist] } { break }
 178         if { "[string range [lindex $arglist $i] 0 0]" == "-" } {
 179             incr i 2
 180         } else {
 181             break
 182         }
 183     }
 184     set keys [lrange $arglist 0 [expr $i -1]]
 185     set res [lrange $arglist  $i end]
 186 }
 187
 188
 189
 190 ## endsource getopt.tcl