home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / options.tcl < prev    next >
Text File  |  1997-11-14  |  6KB  |  219 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. #      (c)     Cadre Technologies Inc.    1996
  4. #
  5. #      File:        %W%
  6. #      Author:        edri
  7. #      Description:    Simple command line option parser.
  8. #---------------------------------------------------------------------------
  9. # SccsId = %W% %G% Copyright 1996 Cadre Technologies Inc.
  10.  
  11. #
  12. # Usage:
  13. #
  14. # Fill an array like this:
  15. #
  16. #    set opts(<option>) { <varName> <optionType> <defaultValue> <description> }
  17. #    ...
  18. #
  19. # Where:
  20. #    <option> is the option string (like "-doc"),
  21. #    <varName> is the name of a variable that will be set to the value
  22. #        of the option,
  23. #    <optionType> is the type of option; allowed values are "arg" or
  24. #        "noarg"; if "arg", the named variable is set to the argument
  25. #        following the option; if "noarg", the named variable is set to 1
  26. #        if the option was specified, else it is set to 0.
  27. #    <defaultValue> is the default value the variable will get if the option
  28. #        is not specified,
  29. #    <description> is a short string describing the option.
  30. #
  31. # <optionType>, <defaultValue> and <description> are all optional.
  32. #
  33. # Then call Options::parse with the name of the program, the name of the
  34. # array, and the name of the command line arguments variable (argv).
  35. #
  36. # Optionally, names of required arguments can be specified.  If one or more
  37. # names is specified, the args array with all options removed should have
  38. # the same size as the number of names specified, and variables with those
  39. # names will be set to the corresponding argument.  If no required arguments
  40. # are specified, the caller will have to check the remainder of the args
  41. # array.
  42. #
  43. # Options::parse will return an error code if an error occurred, so use
  44. # catch when calling Options::parse to handle this error.
  45. #
  46. # Example:
  47. #
  48. #    set opts(-doc)    {generate_doc noarg 0 "generate class documents"}
  49. #    set opts(-dir)    {storage_dir  arg   . "storage directory"}
  50. #    set opts(-v)    {verbose}
  51. #
  52. #    if [catch {Options::parse climp opts argv} msg] {
  53. #       puts stderr $msg
  54. #    exit 1
  55. #    }
  56. #
  57. proc Options::isOption {char} {
  58.     if {$char == "-" || $char == "+"} {
  59.         return 1
  60.     }
  61.     return 0
  62. }
  63.  
  64. proc Options::parse {toolName optsRef argvRef args} {
  65.     upvar $optsRef options
  66.     upvar $argvRef argv
  67.  
  68.     # escape all backslashes
  69.     regsub -all {\\} $argv {\\\\} argv
  70.  
  71.     # set defaults
  72.     foreach opt [array names options] {
  73.     set optDef $options($opt)
  74.     set defSize [llength $optDef]
  75.     upvar [lindex $optDef 0] var
  76.  
  77.     if {$defSize >= 3} {
  78.         set var [lindex $optDef 2]
  79.     } else {
  80.         # default to switch option, with value "off"
  81.         set var 0
  82.     }
  83.     }
  84.  
  85.     # parse and remove options
  86.     while {[Options::isOption [string index [lindex $argv 0] 0]]} {
  87.         set opt [lvarpop argv]
  88.     if {$opt == "-help" || $opt == "-?"} {
  89.         return -code error [Options::usage $toolName options $args]
  90.     } elseif {$opt == "--"} {
  91.         # end of options
  92.         break
  93.     }
  94.  
  95.     if [info exists options($opt)] {
  96.         set optDef $options($opt)
  97.         set defSize [llength $optDef]
  98.         upvar [lindex $optDef 0] var
  99.  
  100.         if {$defSize >= 2} {
  101.             set type [lindex $optDef 1]
  102.         } else {
  103.         # default to switch option, with value "off"
  104.             set type noarg
  105.         }
  106.  
  107.         if {$defSize >= 3} {
  108.         set default [lindex $optDef 2]
  109.         } else {
  110.         # default to switch option, with value "off"
  111.             set default 0
  112.         }
  113.  
  114.         switch $type {
  115.             arg    { set var [lvarpop argv] }
  116.         noarg    { set var 1 }
  117.         default { return -code error "wrong option type: $type" }
  118.         }
  119.     } else {
  120.             # Check if option is an M4 option (-M4_<name>[=<value>] or
  121.             # +M4_<name>) and parse it if caller requested it by specifing
  122.             # "-M4" option in options.
  123.             #
  124.             if [info exists options(-M4)] {
  125.         set prefix [string range $opt 1 3]
  126.                 if {$prefix == "M4_"} {
  127.                     set asn [string first "=" $opt]
  128.                     if {$asn == -1} {
  129.             set first [string index $opt 0]
  130.             set name [string range $opt 1 end]
  131.                         if {$first == "+"} {
  132.                 set value 1
  133.                         } else {
  134.                 set value 0
  135.                         }
  136.                     } else {
  137.                         incr asn -1
  138.                         set name [string range $opt 1 $asn]
  139.                         incr asn 2
  140.                         set value [string range $opt $asn end]
  141.                     }
  142.  
  143.             set optDef $options(-M4)
  144.             upvar [lindex $optDef 0] var
  145.                     lappend var "${name}=${value}"
  146.                     
  147.                     continue
  148.                 }
  149.             }
  150.         set inv "ERROR: invalid option $opt\n\n"
  151.         return -code error "$inv[Options::usage $toolName options $args]"
  152.     }
  153.     }
  154.  
  155.     set reqLen [llength $args]
  156.     if {$reqLen > 0} {
  157.         set argLen [llength $argv]
  158.         if {$reqLen > $argLen} {
  159.             set miss "ERROR: required argument missing\n\n"
  160.             return -code error "$miss[Options::usage $toolName options $args]"
  161.         }
  162.  
  163.         set i 0
  164.         foreach arg $args {
  165.             set s [lindex $argv $i]
  166.             uplevel "set $arg \{$s\}"
  167.             incr i
  168.         }
  169.     }
  170.  
  171.     return 1
  172. }
  173.  
  174. proc Options::usage {toolName optsRef {requiredArgs ""}} {
  175.     upvar $optsRef options
  176.  
  177.     set argNames "args ..."
  178.     if {[llength $requiredArgs] > 0} {
  179.         set argNames $requiredArgs
  180.     }
  181.  
  182.     set usage "Usage: $toolName \[options] $argNames\n"
  183.     foreach opt [lsort [array names options]] {
  184.     set optDef $options($opt)
  185.     set defSize [llength $optDef]
  186.  
  187.         if {$opt == "-M4"} {
  188.             continue
  189.         }
  190.  
  191.     if {$defSize >= 2} {
  192.         set type [lindex $optDef 1]
  193.     } else {
  194.         set type noarg
  195.     }
  196.  
  197.     if {$defSize >= 3 && $type != "noarg"} {
  198.         set default " \[[lindex $optDef 2]]"
  199.     } else {
  200.         set default ""
  201.     }
  202.  
  203.     if {$defSize >= 4} {
  204.         set description [lindex $optDef 3]
  205.     } else {
  206.         set description "switch"
  207.     }
  208.  
  209.     if {$type == "arg"} {
  210.         set arg " arg"
  211.     } else {
  212.         set arg ""
  213.     }
  214.     append usage [format "  %-16s : %s\n" \
  215.         $opt$arg $description$default]
  216.     }
  217.     return $usage
  218. }
  219.