tests/parseOld.test - main - niceSOFT/tcl

tests/parseOld.test
486 строк14 KB
jan.nijtmans
Use TCL9_0_TM_PATH in examples in stead of 8_x. tclOldParse.c doesn't exist any more.
24 окт 2024, 11:26
24 окт 2024, 11:267d90d23
# Commands covered:  set (plus basic command syntax).  This set
# of tests is an old one that predates the parser in Tcl 8.1.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.5
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]

testConstraint testwordend [llength [info commands testwordend]]

# Save the argv value for restoration later
set savedArgv $argv

proc fourArgs {a b c d} {
    global arg1 arg2 arg3 arg4
    set arg1 $a
    set arg2 $b
    set arg3 $c
    set arg4 $d
}

proc getArgs args {
    global argv
    set argv $args
}

# Basic argument parsing.

test parseOld-1.1 {basic argument parsing} {
    set arg1 {}
    fourArgs a b	c 		 d
    list $arg1 $arg2 $arg3 $arg4
} {a b c d}
test parseOld-1.2 {basic argument parsing} {
    set arg1 {}
    eval "fourArgs 123\v4\f56\r7890"
    list $arg1 $arg2 $arg3 $arg4
} {123 4 56 7890}

# Quotes.

test parseOld-2.1 {quotes and variable-substitution} {
    getArgs "a b c" d
    set argv
} {{a b c} d}
test parseOld-2.2 {quotes and variable-substitution} {
    set a 101
    getArgs "a$a b c"
    set argv
} {{a101 b c}}
test parseOld-2.3 {quotes and variable-substitution} {
    set argv "xy[format xabc]"
    set argv
} {xyxabc}
test parseOld-2.4 {quotes and variable-substitution} {
    set argv "xy\t"
    set argv
} xy\t
test parseOld-2.5 {quotes and variable-substitution} {
    set argv "a b	c
d e f"
    set argv
} a\ b\tc\nd\ e\ f
test parseOld-2.6 {quotes and variable-substitution} {
    set argv a"bcd"e
    set argv
} {a"bcd"e}

# Braces.

test parseOld-3.1 {braces} {
    getArgs {a b c} d
    set argv
} "{a b c} d"
test parseOld-3.2 {braces} {
    set a 101
    set argv {a$a b c}
    set b [string index $argv 1]
    set b
} {$}
test parseOld-3.3 {braces} {
    set argv {a[format xyz] b}
    string length $argv
} 15
test parseOld-3.4 {braces} {
    set argv {a\nb\}}
    string length $argv
} 6
test parseOld-3.5 {braces} {
    set argv {{{{}}}}
    set argv
} "{{{}}}"
test parseOld-3.6 {braces} {
    set argv a{{}}b
    set argv
} "a{{}}b"
test parseOld-3.7 {braces} {
    set a [format "last]"]
    set a
} {last]}

# Command substitution.

test parseOld-4.1 {command substitution} {
    set a [format xyz]
    set a
} xyz
test parseOld-4.2 {command substitution} {
    set a a[format xyz]b[format q]
    set a
} axyzbq
test parseOld-4.3 {command substitution} {
    set a a[
set b 22;
format %s $b

]b
    set a
} a22b
test parseOld-4.4 {command substitution} {
    set a 7.7
    if {[catch {expr {int($a)}}]} {set a foo}
    set a
} 7.7

# Variable substitution.

test parseOld-5.1 {variable substitution} {
    set a 123
    set b $a
    set b
} 123
test parseOld-5.2 {variable substitution} {
    set a 345
    set b x$a.b
    set b
} x345.b
test parseOld-5.3 {variable substitution} {
    set _123z xx
    set b $_123z^
    set b
} xx^
test parseOld-5.4 {variable substitution} {
    set a 78
    set b a${a}b
    set b
} a78b
test parseOld-5.5 {variable substitution} {catch {$_non_existent_} msg} 1
test parseOld-5.6 {variable substitution} {
    catch {$_non_existent_} msg
    set msg
} {can't read "_non_existent_": no such variable}
test parseOld-5.7 {array variable substitution} {
    unset -nocomplain a
    set a(xyz) 123
    set b $a(xyz)foo
    set b
} 123foo
test parseOld-5.8 {array variable substitution} {
    unset -nocomplain a
    set "a(x y z)" 123
    set b $a(x y z)foo
    set b
} 123foo
test parseOld-5.9 {array variable substitution} {
    unset -nocomplain a qqq
    set "a(x y z)" qqq
    set $a([format x]\ y [format z]) foo
    set qqq
} foo
test parseOld-5.10 {array variable substitution} {
    unset -nocomplain a
    list [catch {set b $a(22)} msg] $msg
} {1 {can't read "a(22)": no such variable}}
test parseOld-5.11 {array variable substitution} {
    set b a$!
    set b
} {a$!}
test parseOld-5.12 {empty array name support} {
    list [catch {set b a$()} msg] $msg
} {1 {can't read "()": no such variable}}
unset -nocomplain a
test parseOld-5.13 {array variable substitution} {
    unset -nocomplain a
    set long {This is a very long variable, long enough to cause storage \
	allocation to occur in Tcl_ParseVar.  If that storage isn't getting \
	freed up correctly, then a core leak will occur when this test is \
	run.  This text is probably beginning to sound like drivel, but I've \
	run out of things to say and I need more characters still.}
    set a($long) 777
    set b $a($long)
    list $b [array names a]
} {777 {{This is a very long variable, long enough to cause storage \
	allocation to occur in Tcl_ParseVar.  If that storage isn't getting \
	freed up correctly, then a core leak will occur when this test is \
	run.  This text is probably beginning to sound like drivel, but I've \
	run out of things to say and I need more characters still.}}}
test parseOld-5.14 {array variable substitution} {
    unset -nocomplain a b a1
    set a1(22) foo
    set a(foo) bar
    set b $a($a1(22))
    set b
} bar
unset -nocomplain a a1

test parseOld-7.1 {backslash substitution} {
    set a "\a\c\n\]\}"
    string length $a
} 5
test parseOld-7.2 {backslash substitution} {
    set a {\a\c\n\]\}}
    string length $a
} 10
test parseOld-7.3 {backslash substitution} {
    set a "abc\
def"
    set a
} {abc def}
test parseOld-7.4 {backslash substitution} {
    set a {abc\
def}
    set a
} {abc def}
test parseOld-7.5 {backslash substitution} {
    set msg {}
    set a xxx
    set error [catch {if {24 < \
	35} {set a 22} {set \
	    a 33}} msg]
    list $error $msg $a
} {0 22 22}
test parseOld-7.6 {backslash substitution} {
    eval "concat abc\\"
} "abc\\"
test parseOld-7.7 {backslash substitution} {
    eval "concat \\\na"
} "a"
test parseOld-7.8 {backslash substitution} {
    eval "concat x\\\n   	a"
} "x a"
test parseOld-7.9 {backslash substitution} {
    eval "concat \\x"
} "x"
test parseOld-7.10 {backslash substitution} {
    eval "list a b\\\nc d"
} {a b c d}
test parseOld-7.11 {backslash substitution} {
    eval "list a \"b c\"\\\nd e"
} {a {b c} d e}
test parseOld-7.12 {backslash substitution} {
    expr {[list \uA2] eq "¢"}
} 1
test parseOld-7.13 {backslash substitution} {
    expr {[list \u4E21] eq "両"}
} 1
test parseOld-7.14 {backslash substitution} {
    expr {[list \u4E2k] eq "Ӣk"}
} 1

# Semi-colon.

test parseOld-8.1 {semi-colons} {
    set b 0
    getArgs a;set b 2
    set argv
} a
test parseOld-8.2 {semi-colons} {
    set b 0
    getArgs a;set b 2
    set b
} 2
test parseOld-8.3 {semi-colons} {
    getArgs a b ; set b 1
    set argv
} {a b}
test parseOld-8.4 {semi-colons} {
    getArgs a b ; set b 1
    set b
} 1

# The following checks are to ensure that the interpreter's result
# gets re-initialized by Tcl_Eval in all the right places.

set a 22
test parseOld-9.1 {result initialization} {concat abc} abc
test parseOld-9.2 {result initialization} {concat abc; proc foo {} {}} {}
test parseOld-9.3 {result initialization} {concat abc; proc foo {} $a} {}
test parseOld-9.4 {result initialization} {proc foo {} [concat abc]} {}
test parseOld-9.5 {result initialization} {concat abc; } abc
test parseOld-9.6 {result initialization} {
    eval {
    concat abc
}} abc
test parseOld-9.7 {result initialization} {} {}
test parseOld-9.8 {result initialization} {concat abc; ; ;} abc

# Syntax errors.

test parseOld-10.1 {syntax errors} {catch "set a \{bcd" msg} 1
test parseOld-10.2 {syntax errors} {
	catch "set a \{bcd" msg
	set msg
} {missing close-brace}
test parseOld-10.3 {syntax errors} {catch {set a "bcd} msg} 1
test parseOld-10.4 {syntax errors} {
	catch {set a "bcd} msg
	set msg
} {missing "}
#" Emacs formatting >:^(
test parseOld-10.5 {syntax errors} {catch {set a "bcd"xy} msg} 1
test parseOld-10.6 {syntax errors} {
	catch {set a "bcd"xy} msg
	set msg
} {extra characters after close-quote}
test parseOld-10.7 {syntax errors} {catch "set a {bcd}xy" msg} 1
test parseOld-10.8 {syntax errors} {
	catch "set a {bcd}xy" msg
	set msg
} {extra characters after close-brace}
test parseOld-10.9 {syntax errors} {catch {set a [format abc} msg} 1
test parseOld-10.10 {syntax errors} {
	catch {set a [format abc} msg
	set msg
} {missing close-bracket}
test parseOld-10.11 {syntax errors} {catch gorp-a-lot msg} 1
test parseOld-10.12 {syntax errors} {
	catch gorp-a-lot msg
	set msg
} {invalid command name "gorp-a-lot"}
test parseOld-10.13 {syntax errors} {
    set a [concat {a}\
 {b}]
    set a
} {a b}

# The next test will fail on the Mac, 'cause the MSL uses a fixed sized
# buffer for %d conversions (LAME!).  I won't leave the test out, however,
# since MetroWerks may some day fix this.

test parseOld-10.14 {syntax errors} {
    list [catch {eval \$x[format "%01000d" 0](} msg] $msg $::errorInfo
} {1 {missing )} {missing )
    while executing
"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000..."
    ("eval" body line 1)
    invoked from within
"eval \$x[format "%01000d" 0]("}}
test parseOld-10.15 {syntax errors, missplaced braces} {
    catch {
	proc misplaced_end_brace {} {
	    set what foo
	    set when [expr ${what}size - [set off$what]}]
    } msg
    set msg
} {extra characters after close-brace}
test parseOld-10.16 {syntax errors, missplaced braces} {
    catch {
	set a {
	    set what foo
	    set when [expr ${what}size - [set off$what]}]
    } msg
    set msg
} {extra characters after close-brace}
test parseOld-10.17 {syntax errors, unusual spacing} {
    list [catch {return [ [1]]} msg] $msg
} {1 {invalid command name "1"}}
# Long values (stressing storage management)

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}

test parseOld-11.1 {long values} {
    string length $a
} 214
test parseOld-11.2 {long values} {
    llength $a
} 43
test parseOld-11.3 {long values} {
    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"
    set b
} $a
test parseOld-11.4 {long values} {
    set b "$a"
    set b
} $a
test parseOld-11.5 {long values} {
    set b [set a]
    set b
} $a
test parseOld-11.6 {long values} {
    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]
    string length $b
} 214
test parseOld-11.7 {long values} {
    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]
    llength $b
} 43
# Duplicate action of previous test
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]]
test parseOld-11.8 {long values} {
    set b
} $a
test parseOld-11.9 {long values} {
    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]
    llength $a
} 62
set i 0
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] {
    set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i]
    set test $test$test$test$test
    test parseOld-11.10-[incr i] {long values} {
	set j
    } $test
}
test parseOld-11.11 {test buffer overflow in backslashes in braces} {
    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}}
} 0

test parseOld-12.1 {comments} {
    set a old
    eval {  # set a new}
    set a
} {old}
test parseOld-12.2 {comments} {
    set a old
    eval "  # set a new\nset a new"
    set a
} {new}
test parseOld-12.3 {comments} {
    set a old
    eval "  # set a new\\\nset a new"
    set a
} {old}
test parseOld-12.4 {comments} {
    set a old
    eval "  # set a new\\\\\nset a new"
    set a
} {new}

test parseOld-13.1 {comments at the end of a bracketed script} {
    set x "[
expr {1+1}
# skip this!
]"
} {2}

test parseOld-15.1 {TclScriptEnd procedure} {
    info complete {puts [
	expr {1+1}
	#this is a comment ]}
} {0}
test parseOld-15.2 {TclScriptEnd procedure} {
    info complete "abc\\\n"
} {0}
test parseOld-15.3 {TclScriptEnd procedure} {
    info complete "abc\\\\\n"
} {1}
test parseOld-15.4 {TclScriptEnd procedure} {
    info complete "xyz \[abc \{abc\]"
} {0}
test parseOld-15.5 {TclScriptEnd procedure} {
    info complete "xyz \[abc"
} {0}

# cleanup
set argv $savedArgv
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End: