util/src/TclTk/tcl8.6.12/tests/parseOld.test

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