# stringIsList {ab c d} => yes
# stringIsList {ab {*}c d} => no
proc stringIsList s { expr {[catch {llength $s}] ? no : yes} }
# findClosingBrace {[list a b] c d e} => {[list a b]}
# findClosingBrace {{a b} c d} => {{a b}}
# findClosingBrace {$abc def ghi} => {$abc}
# findClosingBrace {abc def ghi} => {abc}
proc findClosingBrace str {
array set closing [list \[ \] \{ \} \" \"]
switch -exact -- [string index $str 0] {
\[ - \{ - \" {
set i 0
set closingBrace $closing([string index $str 0])
set i [string first $closingBrace $str]
while {![info complete [string range $str 0 $i]]} {
set i [string first $closingBrace $str [incr i]]
}
if {$i < 0} then {
return -code error [list unmatched delimiter on $str]
}
string range $str 0 $i
}
default {
set l [regexp -inline {^[$]?[[:alnum:]_]*(?:[[:space:]]|$)} $str]
string trimright [lindex $l 0]
}
}
}
# expandStar {abc def} => {{abc def}}
# expandStar {c {*}d e c {*}d e} => {{c } d { e c } d { e}}
proc expandStar {line {i 0}} {
set i [string first "{*}" $line $i]
if {$i < 0 || [stringIsList $line]} then {
list $line
} else {
set result {}
set i0 [expr {$i - 1}]
set first [string range $line 0 $i0]
lappend result $first
set i3 [expr {$i + 3}]
set expr [findClosingBrace [string range $line $i3 end]]
lappend result $expr
set iRest [expr {$i3 + [string length $expr]}]
set rest [string range $line $iRest end]
eval lappend result [expandStar $rest]
}
}
# expandCommandLine {abc def} => {abc def}
# expandCommandLine {c {*}d e} => {eval [list c] d [list e]}
# expandCommandLine {ab [c {*}d e] e f} => {ab [eval [list c] d [list e]] e f}
proc expandCommandLine line {
if {[string first {{*}} $line] < 0} then {
return $line
}
regexp {^[[:space:]]*} $line result
append result eval
set i [string first \[ $line]
if {$i < 0} then {
foreach {a b} [expandStar $line] {
set a [string trim $a]
if {$a ne ""} then {
append result " \[list " $a "\]"
}
append result " " $b
}
string trimright $result
} else {
set line1 [string range $line 0 [expr {$i - 1}]]
set middle [findClosingBrace [string range $line $i end]]
set l [string length $middle]
set expr [string range $middle 1 end-1]
append line1 \[ [expandCommandLine $expr] \]
set rest [string range $line [expr {$i + $l}] end]
append line1 [expandCommandLine $rest]
set result ""
foreach {a b} [expandStar $line1] {
set a [string trim $a]
if {$a ne ""} then {
append result " \[list " $a "\]"
}
append result " " $b
}
string trimright $result
}
}
proc explodeLines lines {
set result {}
set currentLine ""
foreach line [split $lines \n] {
append currentLine \n $line
if {[info complete $currentLine]} then {
lappend result [string trimleft $currentLine \n]
set currentLine ""
}
}
set result
}
proc xproc {name arglist body} {
set expandedLines {}
foreach line [explodeLines $body] {
lappend expandedLines [expandCommandLine $line]
}
uplevel [list proc $name $arglist [join $expandedLines \n]]
}sourceCode is a simplified proc-inspector:
proc sourceCode p { list proc $p [info args $p] [info body $p] }This little test proc shows us how to do it:
xproc test1 arg1 {
list first element {*}$arg1 last element
}Now watch the result: % sourceCode test1
proc test1 arg1 {
eval [list list first element] $arg1 [list last element]
}
%The {*} construction has been replaced by an appropriate eval construction.Btw, is there any explanation for dummies how to tell my [Emacs speedbar] to handle xproc as well as proc?JRW: Hi, I stumbled upon this article after I ran into a similar issue. I came up with a work-around that seems to function just fine for the cases I've thrown at it, though I wont say its full-proof.Here is my quick Proc, Enjoy!
# <p>
# <br> Replacement for TCL 8.5's {*} operator for any TCL command
# <br> Expands any item starting with a '*': command *[list A B C] => command A B C
# <br>
# <br> Example:
# <br> set putArgs [list -nonewline stdout]
# <br> set output "putArgs is expanded but this string is not"
# <br>
# <br> expand puts *$putArgs $output
# <br>
# <br> Further Considerations:
# <br> Expand calls the procedure in the calling stack (using uplevel) so all upvar variables are retained
# </p>
# <p>
# <br> Known Bugs:
# <br> - Bug: If an argument is passed whose value starts with "*" it will attempt to expand it even if this was unintended
# <br> Workaround: Suggest putting a " " or some other character as the first value in the passed string if potentially unintended
# <br> If the input arguments should never start with "*" then there should not be a problem
# </p>
#
# @author JRW
# @since 01/19/2015
# @param command The TCL Command to execute
# @param args The arguments for command as they would normally be arranged, except any parameter starting with '*' gets expanded
# @return various The return value from the given command
proc expand {command args} {
foreach arg $args {
if {[string index $arg 0] == "*"} {
append command " [lrange [string trimleft $arg *] 0 end] "
} else {
lappend command $arg
}
}
return [uplevel $command]
}