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