1# This file is a Tcl script to test out the the procedures in file
2# tkIndexObj.c, which implement indexed table lookups.  The tests here are
3# organized in the standard fashion for Tcl tests.
4#
5# Copyright © 1997 Sun Microsystems, Inc.
6# Copyright © 1998-1999 Scriptics Corporation.
7#
8# See the file "license.terms" for information on usage and redistribution of
9# this file, and for a DISCLAIMER OF ALL WARRANTIES.
10
11if {"::tcltest" ni [namespace children]} {
12    package require tcltest 2.5
13    namespace import -force ::tcltest::*
14}
15
16::tcltest::loadTestedCommands
17catch [list package require -exact tcl::test [info patchlevel]]
18
19testConstraint testindexobj [llength [info commands testindexobj]]
20testConstraint testparseargs [llength [info commands testparseargs]]
21
22test indexObj-1.1 {exact match} testindexobj {
23    testindexobj 1 1 xyz abc def xyz alm
24} {2}
25test indexObj-1.2 {exact match} testindexobj {
26    testindexobj 1 1 abc abc def xyz alm
27} {0}
28test indexObj-1.3 {exact match} testindexobj {
29    testindexobj 1 1 alm abc def xyz alm
30} {3}
31test indexObj-1.4 {unique abbreviation} testindexobj {
32    testindexobj 1 1 xy abc def xalb xyz alm
33} {3}
34test indexObj-1.5 {multiple abbreviations and exact match} testindexobj {
35    testindexobj 1 1 x abc def xalb xyz alm x
36} {5}
37test indexObj-1.6 {forced exact match} testindexobj {
38    testindexobj 1 0 xy abc def xalb xy alm
39} {3}
40test indexObj-1.7 {forced exact match} testindexobj {
41    testindexobj 1 0 x abc def xalb xyz alm x
42} {5}
43test indexObj-1.8 {exact match of empty values} testindexobj {
44    testindexobj 1 1 {} a aa aaa {} b bb bbb
45} 3
46test indexObj-1.9 {exact match of empty values} testindexobj {
47    testindexobj 1 0 {} a aa aaa {} b bb bbb
48} 3
49
50test indexObj-2.1 {no match} testindexobj {
51    list [catch {testindexobj 1 1 dddd abc def xalb xyz alm x} msg] $msg
52} {1 {bad token "dddd": must be abc, def, xalb, xyz, alm, or x}}
53test indexObj-2.2 {no match} testindexobj {
54    list [catch {testindexobj 1 1 dddd abc} msg] $msg
55} {1 {bad token "dddd": must be abc}}
56test indexObj-2.3 {no match: no abbreviations} testindexobj {
57    list [catch {testindexobj 1 0 xy abc def xalb xyz alm} msg] $msg
58} {1 {bad token "xy": must be abc, def, xalb, xyz, or alm}}
59test indexObj-2.4 {ambiguous value} testindexobj {
60    list [catch {testindexobj 1 1 d dumb daughter a c} msg] $msg
61} {1 {ambiguous token "d": must be dumb, daughter, a, or c}}
62test indexObj-2.5 {omit error message} testindexobj {
63    list [catch {testindexobj 0 1 d x} msg] $msg
64} {1 {}}
65test indexObj-2.6 {TCL_EXACT => no "ambiguous" error message} testindexobj {
66    list [catch {testindexobj 1 0 d dumb daughter a c} msg] $msg
67} {1 {bad token "d": must be dumb, daughter, a, or c}}
68test indexObj-2.7 {exact match of empty values} testindexobj {
69    list [catch {testindexobj 1 1 {} a b c} msg] $msg
70} {1 {ambiguous token "": must be a, b, or c}}
71test indexObj-2.8 {exact match of empty values: singleton case} testindexobj {
72    list [catch {testindexobj 1 0 {} a} msg] $msg
73} {1 {bad token "": must be a}}
74test indexObj-2.9 {non-exact match of empty values: singleton case} testindexobj {
75    # NOTE this is a special case.  Although the empty string is a
76    # unique prefix, we have an established history of rejecting
77    # empty lookup keys, requiring any unique prefix match to have
78    # at least one character.
79    list [catch {testindexobj 1 1 {} a} msg] $msg
80} {1 {bad token "": must be a}}
81
82test indexObj-3.1 {cache result to skip next lookup} testindexobj {
83    testindexobj check 42
84} {42}
85
86test indexObj-4.1 {free old internal representation} testindexobj {
87    set x {a b}
88    lindex $x 1
89    testindexobj 1 1 $x abc def {a b} zzz
90} {2}
91
92test indexObj-5.1 {Tcl_WrongNumArgs} testindexobj {
93    testwrongnumargs 1 "?-switch?" mycmd
94} "wrong # args: should be \"mycmd ?-switch?\""
95test indexObj-5.2 {Tcl_WrongNumArgs} testindexobj {
96    testwrongnumargs 2 "bar" mycmd foo
97} "wrong # args: should be \"mycmd foo bar\""
98test indexObj-5.3 {Tcl_WrongNumArgs} testindexobj {
99    testwrongnumargs 0 "bar" mycmd foo
100} "wrong # args: should be \"bar\""
101test indexObj-5.4 {Tcl_WrongNumArgs} testindexobj {
102    testwrongnumargs 0 "" mycmd foo
103} "wrong # args: should be \"\""
104test indexObj-5.5 {Tcl_WrongNumArgs} testindexobj {
105    testwrongnumargs 1 "" mycmd foo
106} "wrong # args: should be \"mycmd\""
107test indexObj-5.6 {Tcl_WrongNumArgs} testindexobj {
108    testwrongnumargs 2 "" mycmd foo
109} "wrong # args: should be \"mycmd foo\""
110# Contrast this with test proc-3.6; they have to be like this because
111# of [Bug 1066837] so Itcl won't break.
112test indexObj-5.7 {Tcl_WrongNumArgs} {testindexobj obsolete} {
113    testwrongnumargs 2 "fee fi" "fo fum" foo bar
114} "wrong # args: should be \"fo fum foo fee fi\""
115
116test indexObj-6.1 {Tcl_GetIndexFromObjStruct} testindexobj {
117    set x a
118    testgetindexfromobjstruct $x 0
119} "wrong # args: should be \"testgetindexfromobjstruct a 0\""
120test indexObj-6.2 {Tcl_GetIndexFromObjStruct} testindexobj {
121    set x a
122    testgetindexfromobjstruct $x 0
123    testgetindexfromobjstruct $x 0
124} "wrong # args: should be \"testgetindexfromobjstruct a 0\""
125test indexObj-6.3 {Tcl_GetIndexFromObjStruct} testindexobj {
126    set x c
127    testgetindexfromobjstruct $x 1
128} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
129test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj {
130    set x c
131    testgetindexfromobjstruct $x 1
132    testgetindexfromobjstruct $x 1
133} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
134
135test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs {
136    testparseargs
137} {0 1 testparseargs}
138test indexObj-7.2 {Tcl_ParseArgsObjv} testparseargs {
139    testparseargs -bool
140} {1 1 testparseargs}
141test indexObj-7.3 {Tcl_ParseArgsObjv} testparseargs {
142    testparseargs -bool bar
143} {1 2 {testparseargs bar}}
144test indexObj-7.4 {Tcl_ParseArgsObjv} testparseargs {
145    testparseargs bar
146} {0 2 {testparseargs bar}}
147test indexObj-7.5 {Tcl_ParseArgsObjv} -constraints testparseargs -body {
148    testparseargs -help
149} -returnCodes error -result {Command-specific options:
150 -bool: booltest
151 --:    Marks the end of the options
152 -help: Print summary of command-line options and abort}
153test indexObj-7.6 {Tcl_ParseArgsObjv} testparseargs {
154    testparseargs -- -bool -help
155} {0 3 {testparseargs -bool -help}}
156test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs {
157    testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0
158} {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0}}
159
160# cleanup
161::tcltest::cleanupTests
162return
163
164# Local Variables:
165# mode: tcl
166# End:
167