Posted to tcl by aspect at Wed Oct 08 04:04:37 GMT 2014view raw

  1. # thematically, this belongs on http://wiki.tcl.tk/21701 which inspired it
  2. # but I am too deeply troubled by the renaming to edit directly there.
  3.  
  4. # splits a Tcl word into its constituent parts, where each part is either:
  5. # a variable substitution beginning with $
  6. # a command substitution beginning with [ and ending with ]
  7. # a literal
  8. proc wordSplit {word} {
  9. set parts {}
  10. set idx 0
  11. while {$idx < [string length $word]} {
  12. set c [string index $word $idx]
  13. switch -exact $c {
  14. \\ {
  15. ;#debug log {\\ substitution starting at $idx}
  16. if {[regexp -expanded {
  17. ^([\\]
  18. (?:
  19. (?:[0-7]{,3})| # octal byte
  20. (?:x[0-9a-fA-F]{1,2})| # hex byte
  21. (?:u[0-9a-fA-F]{1,4})| # unicode
  22. (?:U[0-9a-fA-F]{1,8})| # wide unicode -- NOTE
  23. (?:\n\s*)| # newline plus whitespace
  24. [abfnrtv]| # control
  25. . # anything else is literal
  26. )
  27. )
  28. } [string range $word $idx end] -> match]} {
  29. lappend parts $match
  30. incr idx [string length $match]
  31. #set match [subst $match] ;# let Tcl figure it out
  32. } else {
  33. error "Don't know how to parse this backslash substitution. This is bad."
  34. }
  35. }
  36. \$ {
  37. ;#debug log {$ substitution starting at $idx}
  38. if {[regexp -expanded {
  39. ^(\$
  40. (?:
  41. \{[^\}]*\}| # braced var ref
  42. (?: # unbraced var ref
  43. (?:
  44. [a-zA-Z0-9_]+| # name part
  45. ::+ # namespace separator
  46. )*
  47. )(\(?) # array ref?
  48. )
  49. )
  50. } [string range $word $idx end] -> match array]} {
  51. if {$array ne ""} {
  52. set rest [string range $word $idx end]
  53. set match ""
  54. foreach part [split $rest ")"] {
  55. append match $part
  56. if {[info complete $match\)]} {
  57. break
  58. #regexp {(\\*)$} $match -> bs ;# count trailing backslashes
  59. #if {[string length $bs] % 2 == 0} break
  60. }
  61. append match ")"
  62. }
  63. if {[string index $word [expr {$idx+[string length $match]}]] ne ")"} {
  64. error "Expecting ) at $idx, token started with \"[string range $match 0 20]...\""
  65. }
  66. append match ")"
  67. }
  68. lappend parts $match
  69. incr idx [string length $match]
  70. } else {
  71. error "Error parsing variable substitution. This is bad."
  72. }
  73. }
  74. \[ {
  75. ;#debug log {\[ substitution starting at $idx}
  76. incr idx 1
  77. set rest [string range $word $idx end]
  78. set match {}
  79. foreach part [split $rest "]"] {
  80. append match $part
  81. if {[info complete $match]} {
  82. regexp {(\\*)$} $match -> bs ;# count trailing backslashes
  83. if {[string length $bs] % 2 == 0} break
  84. }
  85. append match "]"
  86. }
  87. incr idx [string length $match]
  88. if {[string index $word $idx] ne "]"} {
  89. error "Expecting \] at $idx, command started with \"[string range $match 0 20]...\""
  90. }
  91. incr idx
  92. lappend parts "\[$match\]"
  93. }
  94. default {
  95. ;#debug log {verbatim substitution starting at $idx}
  96. # no substitutions:
  97. if {[regexp -expanded {^([^\\\[\$]*)} [string range $word $idx end] -> match]} {
  98. lappend parts $match
  99. incr idx [string length $match]
  100. }
  101. }
  102. }
  103. }
  104. return $parts
  105. }
  106.