430 lines
12 KiB
Plaintext
430 lines
12 KiB
Plaintext
|
# Commands covered: set (plus basic command syntax)
|
||
|
|
#
|
||
|
|
# 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 (c) 1991-1993 The Regents of the University of California.
|
||
|
|
# All rights reserved.
|
||
|
|
#
|
||
|
|
# Permission is hereby granted, without written agreement and without
|
||
|
|
# license or royalty fees, to use, copy, modify, and distribute this
|
||
|
|
# software and its documentation for any purpose, provided that the
|
||
|
|
# above copyright notice and the following two paragraphs appear in
|
||
|
|
# all copies of this software.
|
||
|
|
#
|
||
|
|
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||
|
|
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||
|
|
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||
|
|
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||
|
|
#
|
||
|
|
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||
|
|
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||
|
|
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||
|
|
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||
|
|
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||
|
|
#
|
||
|
|
# $Header: /user6/ouster/tcl/tests/RCS/parse.test,v 1.24 93/07/28 13:07:14 ouster Exp $ (Berkeley)
|
||
|
|
|
||
|
|
if {[string compare test [info procs test]] == 1} then {source defs}
|
||
|
|
|
||
|
|
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 parse-1.1 {basic argument parsing} {
|
||
|
|
set arg1 {}
|
||
|
|
fourArgs a b c d
|
||
|
|
list $arg1 $arg2 $arg3 $arg4
|
||
|
|
} {a b c d}
|
||
|
|
test parse-1.2 {basic argument parsing} {
|
||
|
|
set arg1 {}
|
||
|
|
eval "fourArgs 123\v4\f56\r7890"
|
||
|
|
list $arg1 $arg2 $arg3 $arg4
|
||
|
|
} {123 4 56 7890}
|
||
|
|
|
||
|
|
# Quotes.
|
||
|
|
|
||
|
|
test parse-2.1 {quotes and variable-substitution} {
|
||
|
|
getArgs "a b c" d
|
||
|
|
set argv
|
||
|
|
} {{a b c} d}
|
||
|
|
test parse-2.2 {quotes and variable-substitution} {
|
||
|
|
set a 101
|
||
|
|
getArgs "a$a b c"
|
||
|
|
set argv
|
||
|
|
} {{a101 b c}}
|
||
|
|
test parse-2.3 {quotes and variable-substitution} {
|
||
|
|
set argv "xy[format xabc]"
|
||
|
|
set argv
|
||
|
|
} {xyxabc}
|
||
|
|
test parse-2.4 {quotes and variable-substitution} {
|
||
|
|
set argv "xy\t"
|
||
|
|
set argv
|
||
|
|
} xy\t
|
||
|
|
test parse-2.5 {quotes and variable-substitution} {
|
||
|
|
set argv "a b c
|
||
|
|
d e f"
|
||
|
|
set argv
|
||
|
|
} a\ b\tc\nd\ e\ f
|
||
|
|
test parse-2.6 {quotes and variable-substitution} {
|
||
|
|
set argv a"bcd"e
|
||
|
|
set argv
|
||
|
|
} {a"bcd"e}
|
||
|
|
|
||
|
|
# Braces.
|
||
|
|
|
||
|
|
test parse-3.1 {braces} {
|
||
|
|
getArgs {a b c} d
|
||
|
|
set argv
|
||
|
|
} "{a b c} d"
|
||
|
|
test parse-3.2 {braces} {
|
||
|
|
set a 101
|
||
|
|
set argv {a$a b c}
|
||
|
|
set b [string index $argv 1]
|
||
|
|
set b
|
||
|
|
} {$}
|
||
|
|
test parse-3.3 {braces} {
|
||
|
|
set argv {a[format xyz] b}
|
||
|
|
string length $argv
|
||
|
|
} 15
|
||
|
|
test parse-3.4 {braces} {
|
||
|
|
set argv {a\nb\}}
|
||
|
|
string length $argv
|
||
|
|
} 6
|
||
|
|
test parse-3.5 {braces} {
|
||
|
|
set argv {{{{}}}}
|
||
|
|
set argv
|
||
|
|
} "{{{}}}"
|
||
|
|
test parse-3.6 {braces} {
|
||
|
|
set argv a{{}}b
|
||
|
|
set argv
|
||
|
|
} "a{{}}b"
|
||
|
|
test parse-3.7 {braces} {
|
||
|
|
set a [format "last]"]
|
||
|
|
set a
|
||
|
|
} {last]}
|
||
|
|
|
||
|
|
# Command substitution.
|
||
|
|
|
||
|
|
test parse-4.1 {command substitution} {
|
||
|
|
set a [format xyz]
|
||
|
|
set a
|
||
|
|
} xyz
|
||
|
|
test parse-4.2 {command substitution} {
|
||
|
|
set a a[format xyz]b[format q]
|
||
|
|
set a
|
||
|
|
} axyzbq
|
||
|
|
test parse-4.3 {command substitution} {
|
||
|
|
set a a[
|
||
|
|
set b 22;
|
||
|
|
format %s $b
|
||
|
|
|
||
|
|
]b
|
||
|
|
set a
|
||
|
|
} a22b
|
||
|
|
|
||
|
|
# Variable substitution.
|
||
|
|
|
||
|
|
test parse-5.1 {variable substitution} {
|
||
|
|
set a 123
|
||
|
|
set b $a
|
||
|
|
set b
|
||
|
|
} 123
|
||
|
|
test parse-5.2 {variable substitution} {
|
||
|
|
set a 345
|
||
|
|
set b x$a.b
|
||
|
|
set b
|
||
|
|
} x345.b
|
||
|
|
test parse-5.3 {variable substitution} {
|
||
|
|
set _123z xx
|
||
|
|
set b $_123z^
|
||
|
|
set b
|
||
|
|
} xx^
|
||
|
|
test parse-5.4 {variable substitution} {
|
||
|
|
set a 78
|
||
|
|
set b a${a}b
|
||
|
|
set b
|
||
|
|
} a78b
|
||
|
|
test parse-5.5 {variable substitution} {catch {$_non_existent_} msg} 1
|
||
|
|
test parse-5.6 {variable substitution} {
|
||
|
|
catch {$_non_existent_} msg
|
||
|
|
set msg
|
||
|
|
} {can't read "_non_existent_": no such variable}
|
||
|
|
test parse-5.7 {array variable substitution} {
|
||
|
|
catch {unset a}
|
||
|
|
set a(xyz) 123
|
||
|
|
set b $a(xyz)foo
|
||
|
|
set b
|
||
|
|
} 123foo
|
||
|
|
test parse-5.8 {array variable substitution} {
|
||
|
|
catch {unset a}
|
||
|
|
set "a(x y z)" 123
|
||
|
|
set b $a(x y z)foo
|
||
|
|
set b
|
||
|
|
} 123foo
|
||
|
|
test parse-5.9 {array variable substitution} {
|
||
|
|
catch {unset a}; catch {unset qqq}
|
||
|
|
set "a(x y z)" qqq
|
||
|
|
set $a([format x]\ y [format z]) foo
|
||
|
|
set qqq
|
||
|
|
} foo
|
||
|
|
test parse-5.10 {array variable substitution} {
|
||
|
|
catch {unset a}
|
||
|
|
list [catch {set b $a(22)} msg] $msg
|
||
|
|
} {1 {can't read "a(22)": no such variable}}
|
||
|
|
test parse-5.11 {array variable substitution} {
|
||
|
|
set b a$!
|
||
|
|
set b
|
||
|
|
} {a$!}
|
||
|
|
test parse-5.12 {array variable substitution} {
|
||
|
|
set b a$()
|
||
|
|
set b
|
||
|
|
} {a$()}
|
||
|
|
catch {unset a}
|
||
|
|
test parse-5.13 {array variable substitution} {
|
||
|
|
catch {unset 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 parse-5.14 {array variable substitution} {
|
||
|
|
catch {unset a}; catch {unset b}; catch {unset a1}
|
||
|
|
set a1(22) foo
|
||
|
|
set a(foo) bar
|
||
|
|
set b $a($a1(22))
|
||
|
|
set b
|
||
|
|
} bar
|
||
|
|
catch {unset a}; catch {unset a1}
|
||
|
|
|
||
|
|
# Backslash substitution.
|
||
|
|
|
||
|
|
set errNum 1
|
||
|
|
proc bsCheck {char num} {
|
||
|
|
global errNum
|
||
|
|
test parse-6.$errNum {backslash substitution} {
|
||
|
|
scan $char %c value
|
||
|
|
set value
|
||
|
|
} $num
|
||
|
|
set errNum [expr $errNum+1]
|
||
|
|
}
|
||
|
|
|
||
|
|
bsCheck \b 8
|
||
|
|
bsCheck \e 101
|
||
|
|
bsCheck \f 12
|
||
|
|
bsCheck \n 10
|
||
|
|
bsCheck \r 13
|
||
|
|
bsCheck \t 9
|
||
|
|
bsCheck \v 11
|
||
|
|
bsCheck \{ 123
|
||
|
|
bsCheck \} 125
|
||
|
|
bsCheck \[ 91
|
||
|
|
bsCheck \] 93
|
||
|
|
bsCheck \$ 36
|
||
|
|
bsCheck \ 32
|
||
|
|
bsCheck \; 59
|
||
|
|
bsCheck \\ 92
|
||
|
|
bsCheck \Ca 67
|
||
|
|
bsCheck \Ma 77
|
||
|
|
bsCheck \CMa 67
|
||
|
|
bsCheck \8a 8
|
||
|
|
bsCheck \14 12
|
||
|
|
bsCheck \141 97
|
||
|
|
bsCheck \340 224
|
||
|
|
bsCheck b\0 98
|
||
|
|
bsCheck \x 120
|
||
|
|
bsCheck \xa 10
|
||
|
|
bsCheck \x41 65
|
||
|
|
bsCheck \x541 65
|
||
|
|
|
||
|
|
test parse-7.1 {backslash substitution} {
|
||
|
|
set a "\a\c\n\]\}"
|
||
|
|
string length $a
|
||
|
|
} 5
|
||
|
|
test parse-7.2 {backslash substitution} {
|
||
|
|
set a {\a\c\n\]\}}
|
||
|
|
string length $a
|
||
|
|
} 10
|
||
|
|
test parse-7.3 {backslash substitution} {
|
||
|
|
set a "abc\
|
||
|
|
def"
|
||
|
|
set a
|
||
|
|
} {abc def}
|
||
|
|
test parse-7.4 {backslash substitution} {
|
||
|
|
set a {abc\
|
||
|
|
def}
|
||
|
|
set a
|
||
|
|
} {abc def}
|
||
|
|
test parse-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 parse-7.6 {backslash substitution} {
|
||
|
|
eval "concat abc\\"
|
||
|
|
} "abc\\"
|
||
|
|
test parse-7.7 {backslash substitution} {
|
||
|
|
eval "concat \\\na"
|
||
|
|
} "a"
|
||
|
|
test parse-7.8 {backslash substitution} {
|
||
|
|
eval "concat x\\\n \na"
|
||
|
|
} "x a"
|
||
|
|
test parse-7.9 {backslash substitution} {
|
||
|
|
eval "concat \\x"
|
||
|
|
} "x"
|
||
|
|
test parse-7.10 {backslash substitution} {
|
||
|
|
eval "list a b\\\nc d"
|
||
|
|
} {a b c d}
|
||
|
|
|
||
|
|
# Semi-colon.
|
||
|
|
|
||
|
|
test parse-8.1 {semi-colons} {
|
||
|
|
set b 0
|
||
|
|
getArgs a;set b 2
|
||
|
|
set argv
|
||
|
|
} a
|
||
|
|
test parse-8.2 {semi-colons} {
|
||
|
|
set b 0
|
||
|
|
getArgs a;set b 2
|
||
|
|
set b
|
||
|
|
} 2
|
||
|
|
test parse-8.3 {semi-colons} {
|
||
|
|
getArgs a b ; set b 1
|
||
|
|
set argv
|
||
|
|
} {a b}
|
||
|
|
test parse-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.
|
||
|
|
|
||
|
|
test parse-9.1 {result initialization} {concat abc} abc
|
||
|
|
test parse-9.2 {result initialization} {concat abc; proc foo {} {}} {}
|
||
|
|
test parse-9.3 {result initialization} {concat abc; proc foo {} $a} {}
|
||
|
|
test parse-9.4 {result initialization} {proc foo {} [concat abc]} {}
|
||
|
|
test parse-9.5 {result initialization} {concat abc; } abc
|
||
|
|
test parse-9.6 {result initialization} {
|
||
|
|
eval {
|
||
|
|
concat abc
|
||
|
|
}} abc
|
||
|
|
test parse-9.7 {result initialization} {} {}
|
||
|
|
test parse-9.8 {result initialization} {concat abc; ; ;} abc
|
||
|
|
|
||
|
|
# Syntax errors.
|
||
|
|
|
||
|
|
test parse-10.1 {syntax errors} {catch "set a \{bcd" msg} 1
|
||
|
|
test parse-10.2 {syntax errors} {
|
||
|
|
catch "set a \{bcd" msg
|
||
|
|
set msg
|
||
|
|
} {missing close-brace}
|
||
|
|
test parse-10.3 {syntax errors} {catch {set a "bcd} msg} 1
|
||
|
|
test parse-10.4 {syntax errors} {
|
||
|
|
catch {set a "bcd} msg
|
||
|
|
set msg
|
||
|
|
} {missing "}
|
||
|
|
test parse-10.5 {syntax errors} {catch {set a "bcd"xy} msg} 1
|
||
|
|
test parse-10.6 {syntax errors} {
|
||
|
|
catch {set a "bcd"xy} msg
|
||
|
|
set msg
|
||
|
|
} {extra characters after close-quote}
|
||
|
|
test parse-10.7 {syntax errors} {catch "set a {bcd}xy" msg} 1
|
||
|
|
test parse-10.8 {syntax errors} {
|
||
|
|
catch "set a {bcd}xy" msg
|
||
|
|
set msg
|
||
|
|
} {extra characters after close-brace}
|
||
|
|
test parse-10.9 {syntax errors} {catch {set a [format abc} msg} 1
|
||
|
|
test parse-10.10 {syntax errors} {
|
||
|
|
catch {set a [format abc} msg
|
||
|
|
set msg
|
||
|
|
} {missing close-bracket}
|
||
|
|
test parse-10.11 {syntax errors} {catch gorp-a-lot msg} 1
|
||
|
|
test parse-10.12 {syntax errors} {
|
||
|
|
catch gorp-a-lot msg
|
||
|
|
set msg
|
||
|
|
} {invalid command name: "gorp-a-lot"}
|
||
|
|
test parse-10.13 {syntax errors} {
|
||
|
|
set a [concat {a}\
|
||
|
|
{b}]
|
||
|
|
set a
|
||
|
|
} {a b}
|
||
|
|
test parse-10.14 {syntax errors} {catch "concat \{a\}\\\n{b}" msg} 1
|
||
|
|
test parse-10.15 {syntax errors} {
|
||
|
|
catch "concat \{a\}\\\n{b}" msg
|
||
|
|
set msg
|
||
|
|
} {extra characters after close-brace}
|
||
|
|
|
||
|
|
# 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 parse-11.1 {long values} {
|
||
|
|
string length $a
|
||
|
|
} 214
|
||
|
|
test parse-11.2 {long values} {
|
||
|
|
llength $a
|
||
|
|
} 43
|
||
|
|
test parse-1a1.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 parse-11.4 {long values} {
|
||
|
|
set b "$a"
|
||
|
|
set b
|
||
|
|
} $a
|
||
|
|
test parse-11.5 {long values} {
|
||
|
|
set b [set a]
|
||
|
|
set b
|
||
|
|
} $a
|
||
|
|
test parse-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 parse-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
|
||
|
|
test parse-11.8 {long values} {
|
||
|
|
set b
|
||
|
|
} $a
|
||
|
|
test parse-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
|
||
|
|
set i [expr $i+1]
|
||
|
|
test parse-11.10 {long values} {
|
||
|
|
set j
|
||
|
|
} $test
|
||
|
|
}
|
||
|
|
test parse-11.10 {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
|