## start of expand.tcl
#
# prototype expand command
# Joe Mistachkin
# 7/31/2003
set expand_argument_error "wrong # args: should be \"expand ?-expand expand_list? arg ?arg ...?\""
set expand_list_error "malformed expansion list"
proc expand_processExpansionList { array_name error_name expand_list argument_count } {
# get variable to put error message into...
upvar "1" $error_name local_error
if {$argument_count > "0"} then {
# we are going to put the results into the caller's array.
upvar "1" $array_name local_array
# set all arguments to default state (not expanded)
set index "0"
while {$index < $argument_count} {
set local_array($index) "0"
incr index
}
# assume success until we find an actual error.
set result "0"
# are we processing a "to" range?
set range(from) "-1"
set range(to) "-1"
set last_item ""
foreach this_item $expand_list {
if {[string is integer -strict $this_item] != "0"} then {
if {$range(from) != "-1"} then {
# mark the end of the range...
set range(to) $this_item
# make sure it's a valid range...
if {$range(from) <= $range(to)} then {
# mark entire range to be expanded...
set index $range(from)
while {$index <= $range(to)} {
set local_array($index) "1"
incr index
}
# reset range positions...
set range(from) "-1"
set range(to) "-1"
} else {
# nope, not a valid range.
set local_error "not a valid range"
set result "-1"
break
}
} else {
if {(($this_item >= "0") && ($this_item < $argument_count))} then {
# mark this argument for expansion...
set local_array($this_item) "1"
} else {
# out of bounds.
set local_error "argument index out of bounds"
set result "-1"
break
}
}
} else {
switch -exact -- $this_item {
"to" {
if {$range(from) == "-1"} then {
if {[string is integer -strict $last_item] != "0"} then {
set range(from) $last_item
} else {
# invalid start of range...
set local_error "invalid index for start of range"
set result "-1"
break
}
} else {
# already started a range...
set local_error "range already started"
set result "-1"
break
}
}
"end" {
# mark last argument to be expanded...
set local_array([expr {$argument_count - "1"}]) "1"
}
default {
# unknown argument processing directive.
set local_error "unknown argument processing directive"
set result "-1"
break
}
}
}
# set last item processed to current item...
set last_item $this_item
}
} else {
# NOTE: not really an error.
set local_error "nothing to process"
set result "0"
}
return $result
}
proc expand { args } {
global expand_argument_error
global expand_list_error
#
# check for list of things to expand...
# (default is to expand nothing)
#
if {[llength $args] > "0"} then {
switch -exact -- [lindex $args "0"] {
"-expand" {
# we want to expand the specified arguments.
set expand "1"
# next, there should be a list of things to expand.
set index "1"
# the option and expansion list are NOT included in the argument count.
set argument_count [expr {[llength $args] - ($index + "1")}]
}
"-noexpand" {
# we want to NOT expand the specified arguments.
set expand "0"
# next, there should be a list of things to NOT expand.
set index "1"
# the option and expansion list are NOT included in the argument count.
set argument_count [expr {[llength $args] - ($index + "1")}]
}
default {
# don't expand by default.
set expand "0"
# there is no list of things to expand.
set index "-1"
# all arguments are passed along.
set argument_count [llength $args]
}
}
if {(($index == "-1") || ([llength $args] > ($index + "1")))} then {
if {$index != "-1"} then {
# get list of args to modify.
set expand_list [lindex $args $index]
set expand_error ""
array set expand_array {}
if {[expand_processExpansionList expand_array expand_error $expand_list $argument_count] != "0"} then {
error "$expand_list_error: $expand_error"
}
} else {
# no arguments to modify.
set expand_list [list]
}
# start with an empty list as the command string to evaluate.
set result [list]
# start just beyond the end of the expansion list (if any).
set this_index [expr {$index + "1"}]
while {$this_index < [llength $args]} {
# get the translated argument index...
if {$index != "-1"} then {
set argument_index [expr {$this_index - ($index + "1")}]
} else {
set argument_index $this_index
}
if {[info exists expand_array($argument_index)] != "0"} then {
# is the argument targeted for expansion?
if {$expand_array($argument_index) != "0"} then {
set do_expand [expr {$expand ? "1" : "0"}]
} else {
set do_expand [expr {$expand ? "0" : "1"}]
}
} else {
set do_expand [expr {$expand ? "0" : "1"}]
}
if {$do_expand != "0"} then {
# add the expanded list to the command string.
set result [concat $result [lindex $args $this_index]]
} else {
# add the unmodified argument to the command string.
lappend result [lindex $args $this_index]
}
incr this_index
}
} else {
# not enough arguments.
error $expand_argument_error
}
} else {
#
# NOTE: potential for design change here.
#
# return empty string when given no arguments...?
set result ""
}
uplevel "1" $result
}
proc expand_test_proc { args } {
puts stdout "number of args = [llength $args]"
puts stdout "args = \{ $args \}"
}
## end of expand.tclTry these examples:
expand -expand {1 to 3 end} expand_test_proc [list argument 1] [list argument 2] [list argument 3] [list argument 4] [list argument 5]
expand -expand {1} expand_test_proc [list this is a test.]
expand -noexpand {1} expand_test_proc [list this is a test.]
expand expand_test_proc [list this is a test.]