home *** CD-ROM | disk | FTP | other *** search
/ BUG 11 / BUGCD1998_02.ISO / email / sime / simdemo.z / optargs.tcl < prev    next >
Text File  |  1997-12-09  |  3KB  |  104 lines
  1.  
  2. # optargs third cut
  3. # -----------------
  4. #
  5. # changed name to optargs since it isn't related to parseargs
  6. #
  7. # made it work without extended Tcl for wider usability
  8. #
  9. # optargs second cut
  10. # ------------------
  11. #
  12. # 'defargs' now available for defining optargs arrays instead of just 'set'
  13. #
  14. # defargs now does some sanity checking
  15. #
  16. # integer fields are checked for integerness
  17. #
  18. #
  19. # optargs first cut
  20. # -----------------
  21. #
  22. # parses an argument list of "-option" fields.
  23. #
  24. # Field types are text, integer and boolean.  Only boolean does anything
  25. # special -- booleans don't have to have an argument and set the variable
  26. # to the opposite of the default value if the matching -option is found.
  27. #
  28. # For text and integer, if a default value is there it is set if the option
  29. # isn't explicitly defined, else nothing.
  30. #
  31. # demo appears below the optargs proc
  32. #
  33. #
  34.  
  35. proc optargs {arguments descriptorArrayName} {
  36.     upvar #0 $descriptorArrayName argInfo
  37.  
  38.     # while there are any arguments, make sure they're in the array,
  39.     # process according to rules there
  40.  
  41.     while {$arguments != ""} {
  42.     set fieldId [lindex $arguments 0]
  43.     if {[string index $fieldId 0] != "-"} {
  44.         error "option '$fieldId' didn't start with dash"
  45.     }
  46.     set fieldId [string range $fieldId 1 end]
  47.     if ![info exists argInfo($fieldId)] {
  48.         error "tried to set argument '$fieldId' which did not exist."
  49.     }
  50.     set fieldDef $argInfo($fieldId)
  51.     set type [lindex $fieldDef 0]
  52.     set default [lindex $fieldDef 1]
  53.     if {$type == "boolean"} {
  54.         uplevel "set $fieldId [expr !$default]"
  55.         set arguments [lrange $arguments 1 end]
  56.     } else {
  57.         if {[llength $arguments] == 1} {
  58.         error "missing argument to option '$fieldId'"
  59.         }
  60.         set value [lindex $arguments 1]
  61.         if {$type == "integer"} {
  62.         if {![regexp {[0-9]*} $value]} {
  63.             error "'$fieldId' integer field isn't integer - '$value'"
  64.         }
  65.         }
  66.         uplevel "set $fieldId [list $value]"
  67.         set arguments [lrange $arguments 2 end]
  68.     }
  69.     }
  70.  
  71.     # if any elements in the descriptor array have defaults and they
  72.     # don't already exist with a user-set value, set them up
  73.  
  74.     foreach element [array names argInfo] {
  75.     set fieldDef $argInfo($element)
  76.     if {[llength $fieldDef] == 1} continue
  77.  
  78.     if ![uplevel "info exists $element"] {
  79.         uplevel "set $element [list [lindex $fieldDef 1]]"
  80.     }
  81.     }
  82. }
  83.  
  84. proc defargs {optArgsArrayName definitionList} {
  85.     upvar #0 $optArgsArrayName parseArray
  86.  
  87.     foreach optionInfo $definitionList {
  88.     # -option type [option]
  89.     set len [llength $optionInfo]
  90.     if {($len < 2) || ($len > 3)} {error "bad # elements in '$optionInfo'"}
  91.     set option [lindex $optionInfo 0]
  92.     set type [lindex $optionInfo 1]
  93.     if {($type == "boolean") && ($len < 3)} {
  94.         error "boolean option defs must have a default value ('$optionInfo')"
  95.     }
  96.     if {[string index $option 0] != "-"} {
  97.         error "option text in option def '$optionInfo' doesn't start with -"
  98.     }
  99.     set parseArray([string range $option 1 end]) [lrange $optionInfo 1 end]
  100.     }
  101. }
  102.  
  103.  
  104.