os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/indexObj.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/indexObj.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,135 @@
1.4 +# This file is a Tcl script to test out the the procedures in file
1.5 +# tkIndexObj.c, which implement indexed table lookups. The tests here
1.6 +# are organized in the standard fashion for Tcl tests.
1.7 +#
1.8 +# Copyright (c) 1997 Sun Microsystems, Inc.
1.9 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.10 +#
1.11 +# See the file "license.terms" for information on usage and redistribution
1.12 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.13 +#
1.14 +# RCS: @(#) $Id: indexObj.test,v 1.7.18.4 2006/04/06 18:57:30 dgp Exp $
1.15 +
1.16 +if {[lsearch [namespace children] ::tcltest] == -1} {
1.17 + package require tcltest
1.18 + namespace import -force ::tcltest::*
1.19 +}
1.20 +
1.21 +if {[info commands testindexobj] == {}} {
1.22 + puts "This application hasn't been compiled with the \"testindexobj\""
1.23 + puts "command, so I can't test Tcl_GetIndexFromObj etc."
1.24 + ::tcltest::cleanupTests
1.25 + return
1.26 +}
1.27 +
1.28 +test indexObj-1.1 {exact match} {
1.29 + testindexobj 1 1 xyz abc def xyz alm
1.30 +} {2}
1.31 +test indexObj-1.2 {exact match} {
1.32 + testindexobj 1 1 abc abc def xyz alm
1.33 +} {0}
1.34 +test indexObj-1.3 {exact match} {
1.35 + testindexobj 1 1 alm abc def xyz alm
1.36 +} {3}
1.37 +test indexObj-1.4 {unique abbreviation} {
1.38 + testindexobj 1 1 xy abc def xalb xyz alm
1.39 +} {3}
1.40 +test indexObj-1.5 {multiple abbreviations and exact match} {
1.41 + testindexobj 1 1 x abc def xalb xyz alm x
1.42 +} {5}
1.43 +test indexObj-1.6 {forced exact match} {
1.44 + testindexobj 1 0 xy abc def xalb xy alm
1.45 +} {3}
1.46 +test indexObj-1.7 {forced exact match} {
1.47 + testindexobj 1 0 x abc def xalb xyz alm x
1.48 +} {5}
1.49 +test indexObj-1.8 {exact match of empty values} {
1.50 + testindexobj 1 1 {} a aa aaa {} b bb bbb
1.51 +} 3
1.52 +test indexObj-1.9 {exact match of empty values} {
1.53 + testindexobj 1 0 {} a aa aaa {} b bb bbb
1.54 +} 3
1.55 +
1.56 +test indexObj-2.1 {no match} {
1.57 + list [catch {testindexobj 1 1 dddd abc def xalb xyz alm x} msg] $msg
1.58 +} {1 {bad token "dddd": must be abc, def, xalb, xyz, alm, or x}}
1.59 +test indexObj-2.2 {no match} {
1.60 + list [catch {testindexobj 1 1 dddd abc} msg] $msg
1.61 +} {1 {bad token "dddd": must be abc}}
1.62 +test indexObj-2.3 {no match: no abbreviations} {
1.63 + list [catch {testindexobj 1 0 xy abc def xalb xyz alm} msg] $msg
1.64 +} {1 {bad token "xy": must be abc, def, xalb, xyz, or alm}}
1.65 +test indexObj-2.4 {ambiguous value} {
1.66 + list [catch {testindexobj 1 1 d dumb daughter a c} msg] $msg
1.67 +} {1 {ambiguous token "d": must be dumb, daughter, a, or c}}
1.68 +test indexObj-2.5 {omit error message} {
1.69 + list [catch {testindexobj 0 1 d x} msg] $msg
1.70 +} {1 {}}
1.71 +test indexObj-2.6 {TCL_EXACT => no "ambiguous" error message} {
1.72 + list [catch {testindexobj 1 0 d dumb daughter a c} msg] $msg
1.73 +} {1 {bad token "d": must be dumb, daughter, a, or c}}
1.74 +test indexObj-2.7 {exact match of empty values} {
1.75 + list [catch {testindexobj 1 1 {} a b c} msg] $msg
1.76 +} {1 {ambiguous token "": must be a, b, or c}}
1.77 +test indexObj-2.8 {exact match of empty values: singleton case} {
1.78 + list [catch {testindexobj 1 0 {} a} msg] $msg
1.79 +} {1 {bad token "": must be a}}
1.80 +test indexObj-2.9 {non-exact match of empty values: singleton case} {
1.81 + # NOTE this is a special case. Although the empty string is a
1.82 + # unique prefix, we have an established history of rejecting
1.83 + # empty lookup keys, requiring any unique prefix match to have
1.84 + # at least one character.
1.85 + list [catch {testindexobj 1 1 {} a} msg] $msg
1.86 +} {1 {bad token "": must be a}}
1.87 +
1.88 +test indexObj-3.1 {cache result to skip next lookup} {
1.89 + testindexobj check 42
1.90 +} {42}
1.91 +
1.92 +test indexObj-4.1 {free old internal representation} {
1.93 + set x {a b}
1.94 + lindex $x 1
1.95 + testindexobj 1 1 $x abc def {a b} zzz
1.96 +} {2}
1.97 +
1.98 +test indexObj-5.1 {Tcl_WrongNumArgs} {
1.99 + testwrongnumargs 1 "?option?" mycmd
1.100 +} "wrong # args: should be \"mycmd ?option?\""
1.101 +test indexObj-5.2 {Tcl_WrongNumArgs} {
1.102 + testwrongnumargs 2 "bar" mycmd foo
1.103 +} "wrong # args: should be \"mycmd foo bar\""
1.104 +test indexObj-5.3 {Tcl_WrongNumArgs} {
1.105 + testwrongnumargs 0 "bar" mycmd foo
1.106 +} "wrong # args: should be \"bar\""
1.107 +test indexObj-5.4 {Tcl_WrongNumArgs} {
1.108 + testwrongnumargs 0 "" mycmd foo
1.109 +} "wrong # args: should be \"\""
1.110 +test indexObj-5.5 {Tcl_WrongNumArgs} {
1.111 + testwrongnumargs 1 "" mycmd foo
1.112 +} "wrong # args: should be \"mycmd\""
1.113 +test indexObj-5.6 {Tcl_WrongNumArgs} {
1.114 + testwrongnumargs 2 "" mycmd foo
1.115 +} "wrong # args: should be \"mycmd foo\""
1.116 +
1.117 +test indexObj-6.1 {Tcl_GetIndexFromObjStruct} {
1.118 + set x a
1.119 + testgetindexfromobjstruct $x 0
1.120 +} "wrong # args: should be \"testgetindexfromobjstruct a 0\""
1.121 +test indexObj-6.2 {Tcl_GetIndexFromObjStruct} {
1.122 + set x a
1.123 + testgetindexfromobjstruct $x 0
1.124 + testgetindexfromobjstruct $x 0
1.125 +} "wrong # args: should be \"testgetindexfromobjstruct a 0\""
1.126 +test indexObj-6.3 {Tcl_GetIndexFromObjStruct} {
1.127 + set x c
1.128 + testgetindexfromobjstruct $x 1
1.129 +} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
1.130 +test indexObj-6.4 {Tcl_GetIndexFromObjStruct} {
1.131 + set x c
1.132 + testgetindexfromobjstruct $x 1
1.133 + testgetindexfromobjstruct $x 1
1.134 +} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
1.135 +
1.136 +# cleanup
1.137 +::tcltest::cleanupTests
1.138 +return