Posted to tcl by aspect at Mon Jul 06 08:03:34 GMT 2015view raw

  1. #!/usr/bin/tclsh
  2.  
  3. # neat little options/arguments parser I apparently wrote.
  4. # commented sections are questionable support for validation of arguments (not opts - conflicts with multi-value form).
  5.  
  6. namespace eval options {
  7.  
  8. proc options {args} {
  9. # parse optspec
  10. foreach optspec $args {
  11. set name [lindex $optspec 0]
  12. switch [llength $optspec] {
  13. 1 {
  14. dict set opts $name type 0 ;# flag
  15. uplevel 1 [list set [string range $name 1 end] 0]
  16. #dict set opts $name value 0
  17. }
  18. 2 {
  19. dict set opts $name type 1 ;# arbitrary value
  20. dict set opts $name default [lindex $optspec 1]
  21. uplevel 1 [list set [string range $name 1 end] [lindex $optspec 1]]
  22. #dict set opts $name value [lindex $optspec 1]
  23. }
  24. default {
  25. dict set opts $name type 2 ;# choice
  26. dict set opts $name default [lindex $optspec 1]
  27. dict set opts $name values [lrange $optspec 1 end]
  28. uplevel 1 [list set [string range $name 1 end] [lindex $optspec 1]]
  29. }
  30. }
  31. }
  32. # get caller's args
  33. upvar 1 args argv
  34. for {set i 0} {$i<[llength $argv]} {} {
  35. set arg [lindex $argv $i]
  36. if {![string match -* $arg]} {
  37. break
  38. }
  39. incr i
  40. if {$arg eq "--"} {
  41. break
  42. }
  43. set candidates [dict filter $opts key $arg*]
  44. switch [dict size $candidates] {
  45. 0 {
  46. return -code error -level 2 "Unknown option $arg: must be one of [dict keys $opts]"
  47. }
  48. 1 {
  49. dict for {name spec} $candidates {break}
  50. set name [string range $name 1 end]
  51. dict with spec {} ;# look out
  52. if {$type==0} {
  53. uplevel 1 [list set $name 1]
  54. #dict set opts $name value 1
  55. } else {
  56. if {[llength $argv]<($i+1)} {
  57. return -code error -level 2 "Option $name requires a value"
  58. }
  59. set val [lindex $argv $i]
  60. if {$type==2} {
  61. set is [lsearch -all -glob $values $val*]
  62. switch [llength $is] {
  63. 1 {
  64. set val [lindex $values $is]
  65. }
  66. 0 {
  67. return -code error -level 2 "Bad $name \"$val\": must be one of $values"
  68. }
  69. default {
  70. return -code error -level 2 "Ambiguous $name \"$val\": could be any of [lmap i $is {lindex $values $i}]"
  71. }
  72. }
  73. }
  74. uplevel 1 [list set $name $val]
  75. incr i
  76. }
  77. }
  78. default {
  79. return -code error -level 2 "Ambiguous option $arg: maybe one of [dict keys $candidates]"
  80. }
  81. }
  82. }
  83. set argv [lrange $argv $i end]
  84. }
  85.  
  86. proc formatArgspec {argspec} {
  87. join [lmap arg $argspec {
  88. if {[llength $arg]>1} {
  89. K "?[lindex $arg 0]?"
  90. } elseif {$arg eq "args"} {
  91. K "?args ...?"
  92. } else {
  93. K $arg
  94. }
  95. }] " "
  96. }
  97.  
  98. proc arguments {argspec} {
  99. upvar 1 args argv
  100. for {set i 0} {$i<[llength $argv]} {incr i} {
  101. if {$i >= [llength $argspec]} {
  102. return -code error -level 2 "wrong # args: should be \"[lindex [info level -1] 0] [formatArgspec $argspec]\""
  103. }
  104. set name [lindex $argspec $i 0]
  105. if {$name eq "args"} {
  106. uplevel 1 [list set args [lrange $argv $i end]]
  107. return
  108. }
  109. set value [lindex $argv $i]
  110. # set test [lindex $argspec $i 2]
  111. # if {$test != ""} {
  112. # set valid [uplevel 1 $test $value]
  113. # if {!$value} {
  114. # return -code error -level 2 "Invalid $name \"$value\", must be $test"
  115. # }
  116. # }
  117. uplevel 1 [list set $name $value]
  118. }
  119. # defaults:
  120. for {} {$i < [llength $argspec]} {incr i} {
  121. set as [lindex $argspec $i]
  122. if {[llength $as]==1} {
  123. if {$as ne "args"} {
  124. return -code error -level 2 "wrong # args: should be \"[lindex [info level -1] 0] [formatArgspec $argspec]\""
  125. }
  126. upvar 1 args args
  127. set args [lrange $argv $i end]
  128. return
  129. }
  130. lassign $as name value
  131. # set test [lindex $argspec $i 2]
  132. # if {$test != ""} {
  133. # set valid [uplevel 1 $test $value]
  134. # if {!$value} {
  135. # return -code error -level 2 "Invalid $name \"$value\", must be $test"
  136. # }
  137. # }
  138. uplevel 1 [list set $name $value]
  139. }
  140. }
  141.  
  142. namespace export options arguments
  143. }
  144.  
  145. namespace import options::*
  146. #
  147. #proc test {args} {
  148. # options {-flag} {-flip {}} {-value 100} {-colour red green blue black}
  149. # arguments {rabbit {poo yes} args}
  150. # foreach name [info locals] {
  151. # puts "$name = [set $name]"
  152. # }
  153. # puts {}
  154. #}
  155. #
  156. #test hehe
  157. #test -fla hehe
  158. #test -fli lalala hehe
  159. #test -val 230 hehe
  160. #test hjg hgj hj ghjgjh
  161. #test -col gr hg h
  162. #test
  163.