Posted to tcl by aspect at Mon Mar 23 08:55:06 GMT 2015view raw

  1. # this really wants to use [cmdsplit] so $arr(spacey key) and [string is digit] can work as patterns without quoting
  2.  
  3. # switch -glob matching literal []{}*: a special king of quoting hell
  4.  
  5. source debug.tcl
  6. namespace eval lmatch {
  7.  
  8. proc lmatch args {
  9. options {-compare ::tcl::mathop::eq ::tcl::mathop::== glob lmatch}
  10. arguments {pattern list}
  11. if {$compare eq "glob"} {
  12. set compare {string match}
  13. } elseif {$compare eq "nocase"} {
  14. set compare {string compare -nocase}
  15. }
  16. set pi 0
  17. set li 0
  18. try {
  19. while {$pi < [llength $pattern]} {
  20. set pat [lindex $pattern $pi]
  21. set val [lindex $list $li]
  22. switch -glob $pat {
  23. \\* { # match any single element
  24. incr li ; incr pi
  25. }
  26. \\*\\* - \{\\*\}\\* { # match any N elements
  27. set pi2 [expr {$pi + 1}]
  28. if {$pi2 >= [llength $pattern]} {
  29. return 1
  30. }
  31. for {set li2 $li} {$li2 < [llength $list]} {incr li2} {
  32. if {[uplevel 1 [list lmatch [lrange $pattern $pi2 end] [lrange $list $li2 end]]]} {
  33. return 1
  34. }
  35. }
  36. throw {LMATCH FAIL} "Failed to unify after **: [list [lrange $pattern $pi end] [lrange $list $pi end]]"
  37. }
  38. $* { # match a variable's value in the enclosing scope
  39. set lit [uplevel 1 [list subst $pat]]
  40. if {$lit ne $val} { # NOTE: this case disregards -compare!
  41. throw {LMATCH FAIL} "{$val} does not match {$lit} (value of $pat)"
  42. }
  43. incr li ; incr pi
  44. }
  45. \\[*\\] { # match with a command - FIXME: commands break list parsing, duh
  46. set cmd [string range $pat 1 end-1]
  47. if {![uplevel 1 $cmd [list $val]]} {
  48. throw {LMATCH FAIL} "{$val} is not \[$cmd\]"
  49. }
  50. incr li ; incr pi
  51. }
  52. default { # match a literal value
  53. puts "Comparing $pat with $val"
  54. if {![$compare $pat $val]} {
  55. throw {LMATCH FAIL} "{$val} ne {$pat}"
  56. }
  57. incr li ; incr pi
  58. }
  59. }
  60. }
  61. if {$pi == [llength $pattern] && $li == [llength $list]} {
  62. return 1
  63. }
  64. return 0
  65. } trap {LMATCH FAIL} {e o} {
  66. debug log {Match failed: $e at pattern index $li ($pat), value index $li ($val)}
  67. return 0
  68. }
  69.  
  70. }
  71.  
  72. proc lbind args {
  73. options
  74. arguments {pattern list}
  75. }
  76.  
  77. namespace export {[a-z]*}
  78.  
  79. proc test {} {
  80. set c foop
  81. debug assert { [lmatch {a B} {a B}] }
  82. debug assert {![lmatch {a B} {a b}] }
  83. debug assert { [lmatch {a *} {a b}] }
  84. debug assert {![lmatch {a *} {a b c}] }
  85. debug assert { [lmatch {**} {}] }
  86. debug assert { [lmatch {**} {a b c}] }
  87. debug assert { [lmatch {a **} {a b c}] }
  88. debug assert { [lmatch {a ** c} {a b c}] }
  89. debug assert {![lmatch {a * $c} {a B}] }
  90. debug assert {![lmatch {a * $c} {a B food}] }
  91. debug assert { [lmatch {a * $c} {a B foop}] }
  92. debug assert { [catch {lmatch {a * $nonesuch} {a B foop}}] }
  93. debug assert { [lmatch {"[string is digit]" a *} {123 a B}] }
  94. return 1
  95. }
  96. }
  97.  
  98. catch {rename ::lmatch {}} ;# turns out Tclx uses this name with arguments reversed :(
  99. namespace import ::lmatch::*
  100. try {
  101. ::lmatch::test
  102. } on error {e o} {
  103. puts "ERROR: $e"
  104. pdict $o
  105. }
  106.