1# Commands covered: subst 2# 3# This file contains a collection of tests for one or more of the Tcl 4# built-in commands. Sourcing this file into Tcl runs the tests and 5# generates output for errors. No output means no errors were found. 6# 7# Copyright © 1994 The Regents of the University of California. 8# Copyright © 1994 Sun Microsystems, Inc. 9# Copyright © 1998-2000 Ajuba Solutions. 10# 11# See the file "license.terms" for information on usage and redistribution 12# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 14if {"::tcltest" ni [namespace children]} { 15 package require tcltest 2.5 16 namespace import -force ::tcltest::* 17} 18::tcltest::loadTestedCommands 19catch [list package require -exact tcl::test [info patchlevel]] 20 21testConstraint testbytestring [llength [info commands testbytestring]] 22 23test subst-1.1 {basics} -returnCodes error -body { 24 subst 25} -result {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"} 26test subst-1.2 {basics} -returnCodes error -body { 27 subst a b c 28} -result {bad option "a": must be -nobackslashes, -nocommands, or -novariables} 29 30test subst-2.1 {simple strings} { 31 subst {} 32} {} 33test subst-2.2 {simple strings} { 34 subst a 35} a 36test subst-2.3 {simple strings} { 37 subst abcdefg 38} abcdefg 39test subst-2.4 {simple strings} testbytestring { 40 # Tcl Bug 685106 41 expr {[subst [testbytestring bar\x00soom]] eq [testbytestring bar\x00soom]} 42} 1 43 44test subst-3.1 {backslash substitutions} { 45 subst {\x\$x\[foo bar]\\} 46} "x\$x\[foo bar]\\" 47test subst-3.2 {backslash substitutions with utf chars} { 48 # 'j' is just a char that doesn't mean anything, and \344 is 'ä' 49 # that also doesn't mean anything, but is multi-byte in UTF-8. 50 list [subst \j] [subst \\j] [subst \\344] [subst \\\344] 51} "j j ä ä" 52 53test subst-4.1 {variable substitutions} { 54 set a 44 55 subst {$a} 56} {44} 57test subst-4.2 {variable substitutions} { 58 set a 44 59 subst {x$a.y{$a}.z} 60} {x44.y{44}.z} 61test subst-4.3 {variable substitutions} -setup { 62 catch {unset a} 63} -body { 64 set a(13) 82 65 set i 13 66 subst {x.$a($i)} 67} -result {x.82} 68catch {unset a} 69set long {This is a very long string, intentionally made so long that it 70 will overflow the static character size for dstrings, so that 71 additional memory will have to be allocated by subst. That way, 72 if the subst procedure forgets to free up memory while returning 73 an error, there will be memory that isn't freed (this will be 74 detected when the tests are run under a checking memory allocator 75 such as Purify).} 76test subst-4.4 {variable substitutions} -returnCodes error -body { 77 subst {$long $a} 78} -result {can't read "a": no such variable} 79 80test subst-5.1 {command substitutions} { 81 subst {[concat {}]} 82} {} 83test subst-5.2 {command substitutions} { 84 subst {[concat A test string]} 85} {A test string} 86test subst-5.3 {command substitutions} { 87 subst {x.[concat foo].y.[concat bar].z} 88} {x.foo.y.bar.z} 89test subst-5.4 {command substitutions} { 90 list [catch {subst {$long [set long] [bogus_command]}} msg] $msg 91} {1 {invalid command name "bogus_command"}} 92test subst-5.5 {command substitutions} { 93 set a 0 94 list [catch {subst {[set a 1}} msg] $a $msg 95} {1 0 {missing close-bracket}} 96test subst-5.6 {command substitutions} { 97 set a 0 98 list [catch {subst {0[set a 1}} msg] $a $msg 99} {1 0 {missing close-bracket}} 100test subst-5.7 {command substitutions} { 101 set a 0 102 list [catch {subst {0[set a 1; set a 2}} msg] $a $msg 103} {1 1 {missing close-bracket}} 104 105# repeat the tests above simulating cmd line input 106test subst-5.8 {command substitutions} { 107 set script {[subst {[set a 1}]} 108 list [catch {exec [info nameofexecutable] << $script} msg] $msg 109} {1 {missing close-bracket}} 110test subst-5.9 {command substitutions} { 111 set script {[subst {0[set a 1}]} 112 list [catch {exec [info nameofexecutable] << $script} msg] $msg 113} {1 {missing close-bracket}} 114test subst-5.10 {command substitutions} { 115 set script {[subst {0[set a 1; set a 2}]} 116 list [catch {exec [info nameofexecutable] << $script} msg] $msg 117} {1 {missing close-bracket}} 118 119test subst-6.1 {clear the result after command substitution} -body { 120 catch {unset a} 121 subst {[concat foo] $a} 122} -returnCodes error -result {can't read "a": no such variable} 123 124test subst-7.1 {switches} -returnCodes error -body { 125 subst foo bar 126} -result {bad option "foo": must be -nobackslashes, -nocommands, or -novariables} 127test subst-7.2 {switches} -returnCodes error -body { 128 subst -no bar 129} -result {ambiguous option "-no": must be -nobackslashes, -nocommands, or -novariables} 130test subst-7.3 {switches} -returnCodes error -body { 131 subst -bogus bar 132} -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables} 133test subst-7.4 {switches} { 134 set x 123 135 subst -nobackslashes {abc $x [expr {1 + 2}] \\\x41} 136} {abc 123 3 \\\x41} 137test subst-7.5 {switches} { 138 set x 123 139 subst -nocommands {abc $x [expr {1 + 2}] \\\x41} 140} {abc 123 [expr {1 + 2}] \A} 141test subst-7.6 {switches} { 142 set x 123 143 subst -novariables {abc $x [expr {1 + 2}] \\\x41} 144} {abc $x 3 \A} 145test subst-7.7 {switches} { 146 set x 123 147 subst -nov -nob -noc {abc $x [expr {1 + 2}] \\\x41} 148} {abc $x [expr {1 + 2}] \\\x41} 149 150test subst-8.1 {return in a subst} { 151 subst {foo [return {x}; bogus code] bar} 152} {foo x bar} 153test subst-8.2 {return in a subst} { 154 subst {foo [return x ; bogus code] bar} 155} {foo x bar} 156test subst-8.3 {return in a subst} { 157 subst {foo [if 1 { return {x}; bogus code }] bar} 158} {foo x bar} 159test subst-8.4 {return in a subst} { 160 subst {[eval {return hi}] there} 161} {hi there} 162test subst-8.5 {return in a subst} { 163 subst {foo [return {]}; bogus code] bar} 164} {foo ] bar} 165test subst-8.6 {return in a subst} -returnCodes error -body { 166 subst "foo \[return {x}; bogus code bar" 167} -result {missing close-bracket} 168test subst-8.7 {return in a subst, parse error} -body { 169 subst {foo [return {x} ; set a {}"" ; stuff] bar} 170} -returnCodes error -result {extra characters after close-brace} 171test subst-8.8 {return in a subst, parse error} -body { 172 subst {foo [return {x} ; set bar baz ; set a {}"" ; stuff] bar} 173} -returnCodes error -result {extra characters after close-brace} 174test subst-8.9 {return in a variable subst} { 175 subst {foo $var([return {x}]) bar} 176} {foo x bar} 177 178test subst-9.1 {error in a subst} -body { 179 subst {[error foo; bogus code]bar} 180} -returnCodes error -result foo 181test subst-9.2 {error in a subst} -body { 182 subst {[if 1 { error foo; bogus code}]bar} 183} -returnCodes error -result foo 184test subst-9.3 {error in a variable subst} -setup { 185 catch {unset var} 186} -body { 187 subst {foo $var([error foo]) bar} 188} -returnCodes error -result foo 189 190test subst-10.1 {break in a subst} { 191 subst {foo [break; bogus code] bar} 192} {foo } 193test subst-10.2 {break in a subst} { 194 subst {foo [break; return x; bogus code] bar} 195} {foo } 196test subst-10.3 {break in a subst} { 197 subst {foo [if 1 { break; bogus code}] bar} 198} {foo } 199test subst-10.4 {break in a subst, parse error} { 200 subst {foo [break ; set a {}{} ; stuff] bar} 201} {foo } 202test subst-10.5 {break in a subst, parse error} { 203 subst {foo [break ;set bar baz ;set a {}{} ; stuff] bar} 204} {foo } 205test subst-10.6 {break in a variable subst} { 206 subst {foo $var([break]) bar} 207} {foo } 208 209test subst-11.1 {continue in a subst} { 210 subst {foo [continue; bogus code] bar} 211} {foo bar} 212test subst-11.2 {continue in a subst} { 213 subst {foo [continue; return x; bogus code] bar} 214} {foo bar} 215test subst-11.3 {continue in a subst} { 216 subst {foo [if 1 { continue; bogus code}] bar} 217} {foo bar} 218test subst-11.4 {continue in a subst, parse error} -body { 219 subst {foo [continue ; set a {}{} ; stuff] bar} 220} -returnCodes error -result {extra characters after close-brace} 221test subst-11.5 {continue in a subst, parse error} -body { 222 subst {foo [continue ;set bar baz ;set a {}{} ; stuff] bar} 223} -returnCodes error -result {extra characters after close-brace} 224test subst-11.6 {continue in a variable subst} { 225 subst {foo $var([continue]) bar} 226} {foo bar} 227 228test subst-12.1 {nasty case, Bug 1036649} { 229 for {set i 0} {$i < 10} {incr i} { 230 set res [list [catch {subst "\[subst {};"} msg] $msg] 231 if {$msg ne "missing close-bracket"} break 232 } 233 return $res 234} {1 {missing close-bracket}} 235test subst-12.2 {nasty case, Bug 1036649} { 236 for {set i 0} {$i < 10} {incr i} { 237 set res [list [catch {subst "\[subst {}; "} msg] $msg] 238 if {$msg ne "missing close-bracket"} break 239 } 240 return $res 241} {1 {missing close-bracket}} 242test subst-12.3 {nasty case, Bug 1036649} { 243 set x 0 244 for {set i 0} {$i < 10} {incr i} { 245 set res [list [catch {subst "\[incr x;"} msg] $msg] 246 if {$msg ne "missing close-bracket"} break 247 } 248 lappend res $x 249} {1 {missing close-bracket} 10} 250test subst-12.4 {nasty case, Bug 1036649} { 251 set x 0 252 for {set i 0} {$i < 10} {incr i} { 253 set res [list [catch {subst "\[incr x; "} msg] $msg] 254 if {$msg ne "missing close-bracket"} break 255 } 256 lappend res $x 257} {1 {missing close-bracket} 10} 258test subst-12.5 {nasty case, Bug 1036649} { 259 set x 0 260 for {set i 0} {$i < 10} {incr i} { 261 set res [list [catch {subst "\[incr x"} msg] $msg] 262 if {$msg ne "missing close-bracket"} break 263 } 264 lappend res $x 265} {1 {missing close-bracket} 0} 266test subst-12.6 {nasty case with compilation} { 267 set x unset 268 set y unset 269 list [eval [list subst {[set x 1;break;incr x][set y $x]}]] $x $y 270} {{} 1 unset} 271test subst-12.7 {nasty case with compilation} { 272 set x unset 273 set y unset 274 list [eval [list subst {[set x 1;continue;incr x][set y $x]}]] $x $y 275} {1 1 1} 276 277test subst-13.1 {Bug 3081065} -setup { 278 set script [makeFile { 279 proc demo {string} { 280 subst $string 281 } 282 demo name2 283 } subst13.tcl] 284} -body { 285 interp create child 286 child eval [list source $script] 287 interp delete child 288 interp create child 289 child eval { 290 set count 400 291 while {[incr count -1]} { 292 lappend bloat [expr {rand()}] 293 } 294 } 295 child eval [list source $script] 296 interp delete child 297} -cleanup { 298 removeFile subst13.tcl 299} 300test subst-13.2 {Test for segfault} -body { 301 subst {[} 302} -returnCodes error -result * -match glob 303 304 305# cleanup 306::tcltest::cleanupTests 307return 308 309# Local Variables: 310# mode: tcl 311# End: 312