[25] | 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 |
---|
| 3 | # are organized in the standard fashion for Tcl tests. |
---|
| 4 | # |
---|
| 5 | # Copyright (c) 1997 Sun Microsystems, Inc. |
---|
| 6 | # Copyright (c) 1998-1999 by Scriptics Corporation. |
---|
| 7 | # |
---|
| 8 | # See the file "license.terms" for information on usage and redistribution |
---|
| 9 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 10 | # |
---|
| 11 | # RCS: @(#) $Id: indexObj.test,v 1.15 2006/04/06 18:57:58 dgp Exp $ |
---|
| 12 | |
---|
| 13 | if {[lsearch [namespace children] ::tcltest] == -1} { |
---|
| 14 | package require tcltest |
---|
| 15 | namespace import -force ::tcltest::* |
---|
| 16 | } |
---|
| 17 | |
---|
| 18 | testConstraint testindexobj [llength [info commands testindexobj]] |
---|
| 19 | |
---|
| 20 | test indexObj-1.1 {exact match} testindexobj { |
---|
| 21 | testindexobj 1 1 xyz abc def xyz alm |
---|
| 22 | } {2} |
---|
| 23 | test indexObj-1.2 {exact match} testindexobj { |
---|
| 24 | testindexobj 1 1 abc abc def xyz alm |
---|
| 25 | } {0} |
---|
| 26 | test indexObj-1.3 {exact match} testindexobj { |
---|
| 27 | testindexobj 1 1 alm abc def xyz alm |
---|
| 28 | } {3} |
---|
| 29 | test indexObj-1.4 {unique abbreviation} testindexobj { |
---|
| 30 | testindexobj 1 1 xy abc def xalb xyz alm |
---|
| 31 | } {3} |
---|
| 32 | test indexObj-1.5 {multiple abbreviations and exact match} testindexobj { |
---|
| 33 | testindexobj 1 1 x abc def xalb xyz alm x |
---|
| 34 | } {5} |
---|
| 35 | test indexObj-1.6 {forced exact match} testindexobj { |
---|
| 36 | testindexobj 1 0 xy abc def xalb xy alm |
---|
| 37 | } {3} |
---|
| 38 | test indexObj-1.7 {forced exact match} testindexobj { |
---|
| 39 | testindexobj 1 0 x abc def xalb xyz alm x |
---|
| 40 | } {5} |
---|
| 41 | test indexObj-1.8 {exact match of empty values} testindexobj { |
---|
| 42 | testindexobj 1 1 {} a aa aaa {} b bb bbb |
---|
| 43 | } 3 |
---|
| 44 | test indexObj-1.9 {exact match of empty values} testindexobj { |
---|
| 45 | testindexobj 1 0 {} a aa aaa {} b bb bbb |
---|
| 46 | } 3 |
---|
| 47 | |
---|
| 48 | test indexObj-2.1 {no match} testindexobj { |
---|
| 49 | list [catch {testindexobj 1 1 dddd abc def xalb xyz alm x} msg] $msg |
---|
| 50 | } {1 {bad token "dddd": must be abc, def, xalb, xyz, alm, or x}} |
---|
| 51 | test indexObj-2.2 {no match} testindexobj { |
---|
| 52 | list [catch {testindexobj 1 1 dddd abc} msg] $msg |
---|
| 53 | } {1 {bad token "dddd": must be abc}} |
---|
| 54 | test indexObj-2.3 {no match: no abbreviations} testindexobj { |
---|
| 55 | list [catch {testindexobj 1 0 xy abc def xalb xyz alm} msg] $msg |
---|
| 56 | } {1 {bad token "xy": must be abc, def, xalb, xyz, or alm}} |
---|
| 57 | test indexObj-2.4 {ambiguous value} testindexobj { |
---|
| 58 | list [catch {testindexobj 1 1 d dumb daughter a c} msg] $msg |
---|
| 59 | } {1 {ambiguous token "d": must be dumb, daughter, a, or c}} |
---|
| 60 | test indexObj-2.5 {omit error message} testindexobj { |
---|
| 61 | list [catch {testindexobj 0 1 d x} msg] $msg |
---|
| 62 | } {1 {}} |
---|
| 63 | test indexObj-2.6 {TCL_EXACT => no "ambiguous" error message} testindexobj { |
---|
| 64 | list [catch {testindexobj 1 0 d dumb daughter a c} msg] $msg |
---|
| 65 | } {1 {bad token "d": must be dumb, daughter, a, or c}} |
---|
| 66 | test indexObj-2.7 {exact match of empty values} testindexobj { |
---|
| 67 | list [catch {testindexobj 1 1 {} a b c} msg] $msg |
---|
| 68 | } {1 {ambiguous token "": must be a, b, or c}} |
---|
| 69 | test indexObj-2.8 {exact match of empty values: singleton case} testindexobj { |
---|
| 70 | list [catch {testindexobj 1 0 {} a} msg] $msg |
---|
| 71 | } {1 {bad token "": must be a}} |
---|
| 72 | test indexObj-2.9 {non-exact match of empty values: singleton case} testindexobj { |
---|
| 73 | # NOTE this is a special case. Although the empty string is a |
---|
| 74 | # unique prefix, we have an established history of rejecting |
---|
| 75 | # empty lookup keys, requiring any unique prefix match to have |
---|
| 76 | # at least one character. |
---|
| 77 | list [catch {testindexobj 1 1 {} a} msg] $msg |
---|
| 78 | } {1 {bad token "": must be a}} |
---|
| 79 | |
---|
| 80 | test indexObj-3.1 {cache result to skip next lookup} testindexobj { |
---|
| 81 | testindexobj check 42 |
---|
| 82 | } {42} |
---|
| 83 | |
---|
| 84 | test indexObj-4.1 {free old internal representation} testindexobj { |
---|
| 85 | set x {a b} |
---|
| 86 | lindex $x 1 |
---|
| 87 | testindexobj 1 1 $x abc def {a b} zzz |
---|
| 88 | } {2} |
---|
| 89 | |
---|
| 90 | test indexObj-5.1 {Tcl_WrongNumArgs} testindexobj { |
---|
| 91 | testwrongnumargs 1 "?option?" mycmd |
---|
| 92 | } "wrong # args: should be \"mycmd ?option?\"" |
---|
| 93 | test indexObj-5.2 {Tcl_WrongNumArgs} testindexobj { |
---|
| 94 | testwrongnumargs 2 "bar" mycmd foo |
---|
| 95 | } "wrong # args: should be \"mycmd foo bar\"" |
---|
| 96 | test indexObj-5.3 {Tcl_WrongNumArgs} testindexobj { |
---|
| 97 | testwrongnumargs 0 "bar" mycmd foo |
---|
| 98 | } "wrong # args: should be \"bar\"" |
---|
| 99 | test indexObj-5.4 {Tcl_WrongNumArgs} testindexobj { |
---|
| 100 | testwrongnumargs 0 "" mycmd foo |
---|
| 101 | } "wrong # args: should be \"\"" |
---|
| 102 | test indexObj-5.5 {Tcl_WrongNumArgs} testindexobj { |
---|
| 103 | testwrongnumargs 1 "" mycmd foo |
---|
| 104 | } "wrong # args: should be \"mycmd\"" |
---|
| 105 | test indexObj-5.6 {Tcl_WrongNumArgs} testindexobj { |
---|
| 106 | testwrongnumargs 2 "" mycmd foo |
---|
| 107 | } "wrong # args: should be \"mycmd foo\"" |
---|
| 108 | # Contrast this with test proc-3.6; they have to be like this because |
---|
| 109 | # of [Bug 1066837] so Itcl won't break. |
---|
| 110 | test indexObj-5.7 {Tcl_WrongNumArgs} testindexobj { |
---|
| 111 | testwrongnumargs 2 "fee fi" "fo fum" foo bar |
---|
| 112 | } "wrong # args: should be \"fo fum foo fee fi\"" |
---|
| 113 | |
---|
| 114 | test indexObj-6.1 {Tcl_GetIndexFromObjStruct} testindexobj { |
---|
| 115 | set x a |
---|
| 116 | testgetindexfromobjstruct $x 0 |
---|
| 117 | } "wrong # args: should be \"testgetindexfromobjstruct a 0\"" |
---|
| 118 | test indexObj-6.2 {Tcl_GetIndexFromObjStruct} testindexobj { |
---|
| 119 | set x a |
---|
| 120 | testgetindexfromobjstruct $x 0 |
---|
| 121 | testgetindexfromobjstruct $x 0 |
---|
| 122 | } "wrong # args: should be \"testgetindexfromobjstruct a 0\"" |
---|
| 123 | test indexObj-6.3 {Tcl_GetIndexFromObjStruct} testindexobj { |
---|
| 124 | set x c |
---|
| 125 | testgetindexfromobjstruct $x 1 |
---|
| 126 | } "wrong # args: should be \"testgetindexfromobjstruct c 1\"" |
---|
| 127 | test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj { |
---|
| 128 | set x c |
---|
| 129 | testgetindexfromobjstruct $x 1 |
---|
| 130 | testgetindexfromobjstruct $x 1 |
---|
| 131 | } "wrong # args: should be \"testgetindexfromobjstruct c 1\"" |
---|
| 132 | |
---|
| 133 | # cleanup |
---|
| 134 | ::tcltest::cleanupTests |
---|
| 135 | return |
---|
| 136 | |
---|
| 137 | # Local Variables: |
---|
| 138 | # mode: tcl |
---|
| 139 | # End: |
---|