#####################################################################
#
# This code implements the following Tcl 8.1.1 commands, allowing you
# to use them in earlier versions of Tcl:
# String:
# equal - the '-nocase' and '-length' options are not implemented
# is boolean - the '-failindex' option is not implemented
# is false - " " " " "
# is integer - " " " " "
# is true - " " " " "
# map - the '-nocase' option is not implemented.
# See the notes in the source for other limitations.
# repeat
#
#####################################################################
package require Tcl
if {[package vcompare [package provide Tcl] 8.1] < 0} {
rename string Tcl8.1_string
proc string {cmd args} {
switch -exact -- $cmd {
#
# "string equal"
#
eq -
equ -
equa -
equal {
if {[llength $args] != 2} {
return -code error \
"wrong # args, should be string equal string1 string2"
}
foreach {str1 str2} $args break
return [StringEqual $str1 $str2]
}
#
# "string is (boolean or false or int or true)"
#
is {
if {([llength $args] < 2) || ([llength $args] > 3)} {
return -code error \
"wrong # args, should be string is class ?-strict? string"
}
set class [lindex $args 0]
set args [lrange $args 1 end]
switch -exact -- $class {
b -
bo -
boo -
bool -
boole -
boolea -
boolean {
return [eval StringIsBoolean $args]
}
f -
fa -
fal -
fals -
false {
return [eval StringIsFalse $args]
}
i -
in -
int -
inte -
integ -
intege -
integer {
return [eval StringIsInt $args]
}
t -
tr -
tru -
true {
return [eval StringIsTrue $args]
}
default {
return -code error \
"bad class \"$class\": must be boolean, false, integer or true"
}
}
}
#
# "string map"
#
map {
if {[llength $args] != 2} {
return -code error \
"wrong # args, should be string map charMap string"
}
foreach {charMap str} $args break
return [StringMap $charMap $str]
}
#
# "string repeat"
#
repe -
repea -
repeat {
if {[llength $args] != 2} {
return -code error \
"wrong # args, should be string repeat string count"
}
foreach {str n} $args break
return [StringRepeat $str $n]
}
}
uplevel [list Tcl8.1_string $cmd] $args
}
#
# This procedure implements the "string equal" command
#
proc StringEqual {str1 str2} {
if {[string compare $str1 $str2] == 0} {
return 1
} else {
return 0
}
}
#
# This procedure implements the "string is boolean" command
#
proc StringIsBoolean {args} {
if {[eval StringIsFalse $args] || [eval StringIsTrue $args]} {
return 1
} else {
return 0
}
}
#
# This procedure implements the "string is false" command
#
proc StringIsFalse {args} {
if {[llength $args] == 2} {
#
# There are two arguments; the first one must be "-strict"
#
if {![eval ValidStrict $args]} {
return 0
} else {
#
# Reduce the arguments to a single string
#
set args [lindex $args 1]
}
}
set str [string toupper [lindex $args 0]]
switch -exact -- $str {
"" -
F -
FA -
FAL -
FALS -
FALSE -
OF -
OFF -
N -
NO -
0 {
return 1
}
default {
return 0
}
}
}
#
# This procedure implements the "string is true" command
#
proc StringIsTrue {args} {
if {[llength $args] == 2} {
#
# There are two arguments; the first one must be "-strict"
#
if {![eval ValidStrict $args]} {
return 0
} else {
#
# Reduce the arguments to a single string
#
set args [lindex $args 1]
}
}
set str [string toupper [lindex $args 0]]
switch -exact -- $str {
"" -
T -
TR -
TRU -
TRUE -
Y -
YE -
YES -
ON -
1 {
return 1
}
default {
return 0
}
}
}
#
# This procedure implements the "string is int" command
#
proc StringIsInt {args} {
if {[llength $args] == 1} {
#
# There is only one argument, so a null string is a valid
# integer.
#
if {[lindex $args 0] == ""} {
return 1
}
} else {
#
# There are two arguments; the first one must be "-strict"
#
if {![eval ValidStrict $args]} {
return 0
} else {
#
# Reduce the arguments to a single string
#
set args [lindex $args 1]
}
}
#
# Args now consists of a single string which is the presumptive
# integer. We will try to convert it to one.
#
if {[catch {format %d [lindex $args 0]} temp] == 0} {
return 1
} else {
return 0
}
}
#
# This procedure processes the '-strict' option for
# 'string is (boolean, false, int, or true)'. It returns:
# 0 - '-strict' is specified and the argument is an empty string;
# therefore it is not a valid (boolean, false, int, or true).
# 1 - '-strict' is specified but the argument is not an empty string;
# therefore the calling routine must evaluate it.
# If the first argument is not '-strict' this procedure raises an error.
#
proc ValidStrict {args} {
if {[lindex $args 0] != "-strict"} {
return -code error \
"bad option \"[lindex $args 0]\": must be -strict"
} else {
if {[lindex $args 1] == ""} {
return 0
} else {
return 1
}
}
}
#
# This procedure implements a close approximation of the
# "string map" command.
#
# This implementation of "String Map" is not identical to the
# Tcl standard. It does not support the -nocase option, and
# it iterates over the string once for each Key-Value pair
# (rather than just once as Tcl does).
#
# This produces different results if a Value is followed by a
# matching Key. For example:
# "string map {ab 12 cd 34}" - produces the same results as Tcl
# "string map {ab cd cd 34}" - will produce different results if
# the Key "ab" occurs in the target string. Tcl will take a
# target string of "abcd" and produce "cd34"; this proc will
# produce "3434".
#
proc StringMap {charMap str} {
foreach {old_char new_char} $charMap {
set index [string first $old_char $str]
if {$index >= 0} {
set str1 [string range $str 0 [expr $index-1]]
set str2 [string range $str [expr $index+[string length $old_char]] end]
set str3 [StringMap [list $old_char $new_char] $str2]
set str $str1$new_char$str3
}
}
return $str
}
#
# This procedure implements the "string repeat" command
#
proc StringRepeat {text n} {
if {$n <= 0} {
return ""
} elseif {$n == 1} {
return $text
} elseif {$n == 2} {
return $text$text
} elseif {0 == ($n % 2)} {
set result [StringRepeat $text [expr {$n / 2}]]
return "$result$result"
}
return "$text[StringRepeat $text [incr n -1]]"
}
}See also string.