1# Commands covered: set (plus basic command syntax). Also tests the 2# procedures in the file tclOldParse.c. This set of tests is an old 3# one that predates the new parser in Tcl 8.1. 4# 5# This file contains a collection of tests for one or more of the Tcl 6# built-in commands. Sourcing this file into Tcl runs the tests and 7# generates output for errors. No output means no errors were found. 8# 9# Copyright © 1991-1993 The Regents of the University of California. 10# Copyright © 1994-1996 Sun Microsystems, Inc. 11# Copyright © 1998-1999 Scriptics Corporation. 12# 13# See the file "license.terms" for information on usage and redistribution 14# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 16if {"::tcltest" ni [namespace children]} { 17 package require tcltest 2.5 18 namespace import -force ::tcltest::* 19} 20 21::tcltest::loadTestedCommands 22catch [list package require -exact tcl::test [info patchlevel]] 23 24testConstraint testwordend [llength [info commands testwordend]] 25 26# Save the argv value for restoration later 27set savedArgv $argv 28 29proc fourArgs {a b c d} { 30 global arg1 arg2 arg3 arg4 31 set arg1 $a 32 set arg2 $b 33 set arg3 $c 34 set arg4 $d 35} 36 37proc getArgs args { 38 global argv 39 set argv $args 40} 41 42# Basic argument parsing. 43 44test parseOld-1.1 {basic argument parsing} { 45 set arg1 {} 46 fourArgs a b c d 47 list $arg1 $arg2 $arg3 $arg4 48} {a b c d} 49test parseOld-1.2 {basic argument parsing} { 50 set arg1 {} 51 eval "fourArgs 123\v4\f56\r7890" 52 list $arg1 $arg2 $arg3 $arg4 53} {123 4 56 7890} 54 55# Quotes. 56 57test parseOld-2.1 {quotes and variable-substitution} { 58 getArgs "a b c" d 59 set argv 60} {{a b c} d} 61test parseOld-2.2 {quotes and variable-substitution} { 62 set a 101 63 getArgs "a$a b c" 64 set argv 65} {{a101 b c}} 66test parseOld-2.3 {quotes and variable-substitution} { 67 set argv "xy[format xabc]" 68 set argv 69} {xyxabc} 70test parseOld-2.4 {quotes and variable-substitution} { 71 set argv "xy\t" 72 set argv 73} xy\t 74test parseOld-2.5 {quotes and variable-substitution} { 75 set argv "a b c 76d e f" 77 set argv 78} a\ b\tc\nd\ e\ f 79test parseOld-2.6 {quotes and variable-substitution} { 80 set argv a"bcd"e 81 set argv 82} {a"bcd"e} 83 84# Braces. 85 86test parseOld-3.1 {braces} { 87 getArgs {a b c} d 88 set argv 89} "{a b c} d" 90test parseOld-3.2 {braces} { 91 set a 101 92 set argv {a$a b c} 93 set b [string index $argv 1] 94 set b 95} {$} 96test parseOld-3.3 {braces} { 97 set argv {a[format xyz] b} 98 string length $argv 99} 15 100test parseOld-3.4 {braces} { 101 set argv {a\nb\}} 102 string length $argv 103} 6 104test parseOld-3.5 {braces} { 105 set argv {{{{}}}} 106 set argv 107} "{{{}}}" 108test parseOld-3.6 {braces} { 109 set argv a{{}}b 110 set argv 111} "a{{}}b" 112test parseOld-3.7 {braces} { 113 set a [format "last]"] 114 set a 115} {last]} 116 117# Command substitution. 118 119test parseOld-4.1 {command substitution} { 120 set a [format xyz] 121 set a 122} xyz 123test parseOld-4.2 {command substitution} { 124 set a a[format xyz]b[format q] 125 set a 126} axyzbq 127test parseOld-4.3 {command substitution} { 128 set a a[ 129set b 22; 130format %s $b 131 132]b 133 set a 134} a22b 135test parseOld-4.4 {command substitution} { 136 set a 7.7 137 if {[catch {expr {int($a)}}]} {set a foo} 138 set a 139} 7.7 140 141# Variable substitution. 142 143test parseOld-5.1 {variable substitution} { 144 set a 123 145 set b $a 146 set b 147} 123 148test parseOld-5.2 {variable substitution} { 149 set a 345 150 set b x$a.b 151 set b 152} x345.b 153test parseOld-5.3 {variable substitution} { 154 set _123z xx 155 set b $_123z^ 156 set b 157} xx^ 158test parseOld-5.4 {variable substitution} { 159 set a 78 160 set b a${a}b 161 set b 162} a78b 163test parseOld-5.5 {variable substitution} {catch {$_non_existent_} msg} 1 164test parseOld-5.6 {variable substitution} { 165 catch {$_non_existent_} msg 166 set msg 167} {can't read "_non_existent_": no such variable} 168test parseOld-5.7 {array variable substitution} { 169 unset -nocomplain a 170 set a(xyz) 123 171 set b $a(xyz)foo 172 set b 173} 123foo 174test parseOld-5.8 {array variable substitution} { 175 unset -nocomplain a 176 set "a(x y z)" 123 177 set b $a(x y z)foo 178 set b 179} 123foo 180test parseOld-5.9 {array variable substitution} { 181 unset -nocomplain a qqq 182 set "a(x y z)" qqq 183 set $a([format x]\ y [format z]) foo 184 set qqq 185} foo 186test parseOld-5.10 {array variable substitution} { 187 unset -nocomplain a 188 list [catch {set b $a(22)} msg] $msg 189} {1 {can't read "a(22)": no such variable}} 190test parseOld-5.11 {array variable substitution} { 191 set b a$! 192 set b 193} {a$!} 194test parseOld-5.12 {empty array name support} { 195 list [catch {set b a$()} msg] $msg 196} {1 {can't read "()": no such variable}} 197unset -nocomplain a 198test parseOld-5.13 {array variable substitution} { 199 unset -nocomplain a 200 set long {This is a very long variable, long enough to cause storage \ 201 allocation to occur in Tcl_ParseVar. If that storage isn't getting \ 202 freed up correctly, then a core leak will occur when this test is \ 203 run. This text is probably beginning to sound like drivel, but I've \ 204 run out of things to say and I need more characters still.} 205 set a($long) 777 206 set b $a($long) 207 list $b [array names a] 208} {777 {{This is a very long variable, long enough to cause storage \ 209 allocation to occur in Tcl_ParseVar. If that storage isn't getting \ 210 freed up correctly, then a core leak will occur when this test is \ 211 run. This text is probably beginning to sound like drivel, but I've \ 212 run out of things to say and I need more characters still.}}} 213test parseOld-5.14 {array variable substitution} { 214 unset -nocomplain a b a1 215 set a1(22) foo 216 set a(foo) bar 217 set b $a($a1(22)) 218 set b 219} bar 220unset -nocomplain a a1 221 222test parseOld-7.1 {backslash substitution} { 223 set a "\a\c\n\]\}" 224 string length $a 225} 5 226test parseOld-7.2 {backslash substitution} { 227 set a {\a\c\n\]\}} 228 string length $a 229} 10 230test parseOld-7.3 {backslash substitution} { 231 set a "abc\ 232def" 233 set a 234} {abc def} 235test parseOld-7.4 {backslash substitution} { 236 set a {abc\ 237def} 238 set a 239} {abc def} 240test parseOld-7.5 {backslash substitution} { 241 set msg {} 242 set a xxx 243 set error [catch {if {24 < \ 244 35} {set a 22} {set \ 245 a 33}} msg] 246 list $error $msg $a 247} {0 22 22} 248test parseOld-7.6 {backslash substitution} { 249 eval "concat abc\\" 250} "abc\\" 251test parseOld-7.7 {backslash substitution} { 252 eval "concat \\\na" 253} "a" 254test parseOld-7.8 {backslash substitution} { 255 eval "concat x\\\n a" 256} "x a" 257test parseOld-7.9 {backslash substitution} { 258 eval "concat \\x" 259} "x" 260test parseOld-7.10 {backslash substitution} { 261 eval "list a b\\\nc d" 262} {a b c d} 263test parseOld-7.11 {backslash substitution} { 264 eval "list a \"b c\"\\\nd e" 265} {a {b c} d e} 266test parseOld-7.12 {backslash substitution} { 267 expr {[list \uA2] eq "¢"} 268} 1 269test parseOld-7.13 {backslash substitution} { 270 expr {[list \u4E21] eq "両"} 271} 1 272test parseOld-7.14 {backslash substitution} { 273 expr {[list \u4E2k] eq "Ӣk"} 274} 1 275 276# Semi-colon. 277 278test parseOld-8.1 {semi-colons} { 279 set b 0 280 getArgs a;set b 2 281 set argv 282} a 283test parseOld-8.2 {semi-colons} { 284 set b 0 285 getArgs a;set b 2 286 set b 287} 2 288test parseOld-8.3 {semi-colons} { 289 getArgs a b ; set b 1 290 set argv 291} {a b} 292test parseOld-8.4 {semi-colons} { 293 getArgs a b ; set b 1 294 set b 295} 1 296 297# The following checks are to ensure that the interpreter's result 298# gets re-initialized by Tcl_Eval in all the right places. 299 300set a 22 301test parseOld-9.1 {result initialization} {concat abc} abc 302test parseOld-9.2 {result initialization} {concat abc; proc foo {} {}} {} 303test parseOld-9.3 {result initialization} {concat abc; proc foo {} $a} {} 304test parseOld-9.4 {result initialization} {proc foo {} [concat abc]} {} 305test parseOld-9.5 {result initialization} {concat abc; } abc 306test parseOld-9.6 {result initialization} { 307 eval { 308 concat abc 309}} abc 310test parseOld-9.7 {result initialization} {} {} 311test parseOld-9.8 {result initialization} {concat abc; ; ;} abc 312 313# Syntax errors. 314 315test parseOld-10.1 {syntax errors} {catch "set a \{bcd" msg} 1 316test parseOld-10.2 {syntax errors} { 317 catch "set a \{bcd" msg 318 set msg 319} {missing close-brace} 320test parseOld-10.3 {syntax errors} {catch {set a "bcd} msg} 1 321test parseOld-10.4 {syntax errors} { 322 catch {set a "bcd} msg 323 set msg 324} {missing "} 325#" Emacs formatting >:^( 326test parseOld-10.5 {syntax errors} {catch {set a "bcd"xy} msg} 1 327test parseOld-10.6 {syntax errors} { 328 catch {set a "bcd"xy} msg 329 set msg 330} {extra characters after close-quote} 331test parseOld-10.7 {syntax errors} {catch "set a {bcd}xy" msg} 1 332test parseOld-10.8 {syntax errors} { 333 catch "set a {bcd}xy" msg 334 set msg 335} {extra characters after close-brace} 336test parseOld-10.9 {syntax errors} {catch {set a [format abc} msg} 1 337test parseOld-10.10 {syntax errors} { 338 catch {set a [format abc} msg 339 set msg 340} {missing close-bracket} 341test parseOld-10.11 {syntax errors} {catch gorp-a-lot msg} 1 342test parseOld-10.12 {syntax errors} { 343 catch gorp-a-lot msg 344 set msg 345} {invalid command name "gorp-a-lot"} 346test parseOld-10.13 {syntax errors} { 347 set a [concat {a}\ 348 {b}] 349 set a 350} {a b} 351 352# The next test will fail on the Mac, 'cause the MSL uses a fixed sized 353# buffer for %d conversions (LAME!). I won't leave the test out, however, 354# since MetroWerks may some day fix this. 355 356test parseOld-10.14 {syntax errors} { 357 list [catch {eval \$x[format "%01000d" 0](} msg] $msg $::errorInfo 358} {1 {missing )} {missing ) 359 while executing 360"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000..." 361 ("eval" body line 1) 362 invoked from within 363"eval \$x[format "%01000d" 0]("}} 364test parseOld-10.15 {syntax errors, missplaced braces} { 365 catch { 366 proc misplaced_end_brace {} { 367 set what foo 368 set when [expr ${what}size - [set off$what]}] 369 } msg 370 set msg 371} {extra characters after close-brace} 372test parseOld-10.16 {syntax errors, missplaced braces} { 373 catch { 374 set a { 375 set what foo 376 set when [expr ${what}size - [set off$what]}] 377 } msg 378 set msg 379} {extra characters after close-brace} 380test parseOld-10.17 {syntax errors, unusual spacing} { 381 list [catch {return [ [1]]} msg] $msg 382} {1 {invalid command name "1"}} 383# Long values (stressing storage management) 384 385set a {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH} 386 387test parseOld-11.1 {long values} { 388 string length $a 389} 214 390test parseOld-11.2 {long values} { 391 llength $a 392} 43 393test parseOld-11.3 {long values} { 394 set b "1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH" 395 set b 396} $a 397test parseOld-11.4 {long values} { 398 set b "$a" 399 set b 400} $a 401test parseOld-11.5 {long values} { 402 set b [set a] 403 set b 404} $a 405test parseOld-11.6 {long values} { 406 set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] 407 string length $b 408} 214 409test parseOld-11.7 {long values} { 410 set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] 411 llength $b 412} 43 413# Duplicate action of previous test 414llength [set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH]] 415test parseOld-11.8 {long values} { 416 set b 417} $a 418test parseOld-11.9 {long values} { 419 set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] 420 llength $a 421} 62 422set i 0 423foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] { 424 set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i] 425 set test $test$test$test$test 426 test parseOld-11.10-[incr i] {long values} { 427 set j 428 } $test 429} 430test parseOld-11.11 {test buffer overflow in backslashes in braces} { 431 expr {"a" == {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101}} 432} 0 433 434test parseOld-12.1 {comments} { 435 set a old 436 eval { # set a new} 437 set a 438} {old} 439test parseOld-12.2 {comments} { 440 set a old 441 eval " # set a new\nset a new" 442 set a 443} {new} 444test parseOld-12.3 {comments} { 445 set a old 446 eval " # set a new\\\nset a new" 447 set a 448} {old} 449test parseOld-12.4 {comments} { 450 set a old 451 eval " # set a new\\\\\nset a new" 452 set a 453} {new} 454 455test parseOld-13.1 {comments at the end of a bracketed script} { 456 set x "[ 457expr {1+1} 458# skip this! 459]" 460} {2} 461 462test parseOld-15.1 {TclScriptEnd procedure} { 463 info complete {puts [ 464 expr {1+1} 465 #this is a comment ]} 466} {0} 467test parseOld-15.2 {TclScriptEnd procedure} { 468 info complete "abc\\\n" 469} {0} 470test parseOld-15.3 {TclScriptEnd procedure} { 471 info complete "abc\\\\\n" 472} {1} 473test parseOld-15.4 {TclScriptEnd procedure} { 474 info complete "xyz \[abc \{abc\]" 475} {0} 476test parseOld-15.5 {TclScriptEnd procedure} { 477 info complete "xyz \[abc" 478} {0} 479 480# cleanup 481set argv $savedArgv 482::tcltest::cleanupTests 483return 484 485# Local Variables: 486# mode: tcl 487# End: 488