Posted to tcl by aspect at Fri Oct 10 06:24:10 GMT 2014view raw

  1. # dependency, adapted from the wiki
  2. proc pipe {args} {
  3. set anonvar ~
  4. set args [lassign $args body]
  5. foreach cmd $args {
  6. if {[string first $anonvar $cmd] >= 0} {
  7. set body [string map [list $anonvar "\[$body\]"] $cmd]
  8. } else {
  9. set body "$cmd \[$body\]"
  10. }
  11. }
  12. set body
  13. }
  14.  
  15. # example:
  16. # puts [pipe {open /etc/passwd r} \
  17. {read} \
  18. {string trim} \
  19. {split ~ \n} \
  20. {lindex ~ end} \
  21. {split ~ :} \
  22. {lindex ~ 4} \
  23. {puts}]
  24.  
  25.  
  26. # generate arg parsing code to go at the start of a proc
  27. # supports TIP#288 with some extensions, see BNF below
  28. proc ArgParser {argspec} {
  29. set name ""
  30. if {$name ne ""} {
  31. set name {[lindex [info level -1] 0]}
  32. }
  33. #foreach {name argspec} [list $argspec $name] {}
  34. # parse argspec into segments:
  35. # argspec ::= required* | optional* | "args"? | optional* | required*
  36. # required ::= name
  37. # optional ::= {name default}
  38. set req_l {}
  39. set opt_l {}
  40. set args {}
  41. set opt_r {}
  42. set req_r {}
  43. for {set i 0} {$i < [llength $argspec]} {incr i} {
  44. set a [lindex $argspec $i]
  45. if {!($a ne "args" && [llength $a] == 1)} { break }
  46. lappend req_l $a
  47. }
  48. for {} {$i < [llength $argspec]} {incr i} {
  49. set a [lindex $argspec $i]
  50. if {[llength $a] == 1} { break }
  51. lappend opt_l $a
  52. }
  53. for {} {$i < [llength $argspec]} {incr i} {
  54. set a [lindex $argspec $i]
  55. if {$a ne "args"} { break }
  56. lappend args $a
  57. }
  58. for {} {$i < [llength $argspec]} {incr i} {
  59. set a [lindex $argspec $i]
  60. if {[llength $a] == 1} { break }
  61. lappend opt_r $a
  62. }
  63. for {} {$i < [llength $argspec]} {incr i} {
  64. set a [lindex $argspec $i]
  65. if {[llength $a] != 1} { break }
  66. lappend req_r $a
  67. }
  68. set opt_r [lreverse $opt_r]
  69. set req_r [lreverse $req_r]
  70. if {[llength $args] > 1} {error "args can only occur once!"}
  71. if {$i != [llength $argspec]} {error "didn't consume whole argspec!"}
  72. set min_argc [expr {[llength [concat $req_l $req_r]]}]
  73. debug show {[list $req_l $opt_l $args $opt_r $req_r]}
  74. set parser [GenArgParser $req_l $opt_l $args $opt_r $req_r]
  75.  
  76. # emit code for parsing args:
  77. set badArgMsg [format {wrong # args: should be "%s"} [concat $name [FormatArgspec $argspec]]]
  78. return "try {$parser}\
  79. trap {TCL WRONGARGS} {} {throw {TCL WRONGARGS} [list $badArgMsg]}"
  80. # sl {
  81. # try $parser
  82. # trap {TCL WRONGARGS} {} {
  83. # throw {TCL WRONGARGS} $badArgMsg
  84. # }
  85. # }
  86. }
  87.  
  88. ;# rl - required left
  89. ;# ol - optional left
  90. ;# as - args
  91. ;# or - optional right
  92. ;# rr - required right
  93. proc GenArgParser {rl {ol ""} {as ""} {or ""} {rr ""}} {
  94.  
  95. set olnames [lmap x $ol {lindex $x 0}]
  96. set ollist [lmap x $olnames {string cat \$ [list $x]}]
  97. set ollist [join $ollist \ ]
  98.  
  99. set ornames [lmap x $or {lindex $x 0}]
  100. set orlist [lmap x $ornames {string cat \$ [list $x]}]
  101. set orlist [join $orlist \ ]
  102.  
  103. set arglen [llength [concat {*}$rl {*}$rr]]
  104. if {$ol eq "" && $or eq "" && $as eq ""} {
  105. set op !=
  106. } else {
  107. set op <
  108. }
  109. set precheck [subst -noc {if {[llength \$args] $op $arglen} {throw {TCL WRONGARGS} ""}}]
  110.  
  111. set script {}
  112. lappend script [subst {set args} ]
  113.  
  114. if {$rl ne ""} {
  115. lappend script [subst {lassign ~ $rl} ]
  116. }
  117.  
  118. if {$rr ne ""} {
  119. lappend script [subst {lreverse} ]
  120. lappend script [subst {lassign ~ $rr} ]
  121. lappend script [subst {lreverse} ]
  122. }
  123.  
  124. if {$ol ne ""} {
  125. if {$or eq "" && $as eq ""} {
  126. lappend script [subst {apply {{$ol} {list $ollist}} {*}~} ]
  127. } else {
  128. lappend script [subst {apply {{$ol args} {list $ollist {*}\$args}} {*}~} ]
  129.  
  130. }
  131. lappend script [subst {lassign ~ $olnames} ]
  132. }
  133.  
  134. if {$or ne ""} {
  135. lappend script [subst {lreverse} ]
  136. if {$as eq ""} {
  137. lappend script [subst {apply {{$or} {list $orlist}} {*}~} ]
  138. } else {
  139. lappend script [subst {apply {{$or args} {list $orlist {*}\$args}} {*}~} ]
  140. }
  141. lappend script [subst {lassign ~ $ornames} ]
  142. lappend script [subst {lreverse} ]
  143. }
  144. if {$as ne ""} {
  145. lappend script [subst {set args} ]
  146. } else {
  147. lappend script [subst {if {~ ne ""} {throw {TCL WRONGARGS} ""};unset args}]
  148. }
  149. debug log {script is: $script}
  150. return "$precheck;[pipe {*}$script]"
  151. }
  152.