util/src/TclTk/tcl8.6.12/tests/indexObj.test

   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 (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 of
   9 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10
  11 if {"::tcltest" ni [namespace children]} {
  12     package require tcltest 2.5
  13     namespace import -force ::tcltest::*
  14 }
  15
  16 ::tcltest::loadTestedCommands
  17 catch [list package require -exact Tcltest [info patchlevel]]
  18
  19 testConstraint testindexobj [llength [info commands testindexobj]]
  20 testConstraint testparseargs [llength [info commands testparseargs]]
  21 \f
  22 test indexObj-1.1 {exact match} testindexobj {
  23     testindexobj 1 1 xyz abc def xyz alm
  24 } {2}
  25 test indexObj-1.2 {exact match} testindexobj {
  26     testindexobj 1 1 abc abc def xyz alm
  27 } {0}
  28 test indexObj-1.3 {exact match} testindexobj {
  29     testindexobj 1 1 alm abc def xyz alm
  30 } {3}
  31 test indexObj-1.4 {unique abbreviation} testindexobj {
  32     testindexobj 1 1 xy abc def xalb xyz alm
  33 } {3}
  34 test indexObj-1.5 {multiple abbreviations and exact match} testindexobj {
  35     testindexobj 1 1 x abc def xalb xyz alm x
  36 } {5}
  37 test indexObj-1.6 {forced exact match} testindexobj {
  38     testindexobj 1 0 xy abc def xalb xy alm
  39 } {3}
  40 test indexObj-1.7 {forced exact match} testindexobj {
  41     testindexobj 1 0 x abc def xalb xyz alm x
  42 } {5}
  43 test indexObj-1.8 {exact match of empty values} testindexobj {
  44     testindexobj 1 1 {} a aa aaa {} b bb bbb
  45 } 3
  46 test indexObj-1.9 {exact match of empty values} testindexobj {
  47     testindexobj 1 0 {} a aa aaa {} b bb bbb
  48 } 3
  49
  50 test 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}}
  53 test indexObj-2.2 {no match} testindexobj {
  54     list [catch {testindexobj 1 1 dddd abc} msg] $msg
  55 } {1 {bad token "dddd": must be abc}}
  56 test 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}}
  59 test 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}}
  62 test indexObj-2.5 {omit error message} testindexobj {
  63     list [catch {testindexobj 0 1 d x} msg] $msg
  64 } {1 {}}
  65 test 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}}
  68 test 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}}
  71 test 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}}
  74 test 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
  82 test indexObj-3.1 {cache result to skip next lookup} testindexobj {
  83     testindexobj check 42
  84 } {42}
  85
  86 test 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
  92 test indexObj-5.1 {Tcl_WrongNumArgs} testindexobj {
  93     testwrongnumargs 1 "?-switch?" mycmd
  94 } "wrong # args: should be \"mycmd ?-switch?\""
  95 test indexObj-5.2 {Tcl_WrongNumArgs} testindexobj {
  96     testwrongnumargs 2 "bar" mycmd foo
  97 } "wrong # args: should be \"mycmd foo bar\""
  98 test indexObj-5.3 {Tcl_WrongNumArgs} testindexobj {
  99     testwrongnumargs 0 "bar" mycmd foo
 100 } "wrong # args: should be \"bar\""
 101 test indexObj-5.4 {Tcl_WrongNumArgs} testindexobj {
 102     testwrongnumargs 0 "" mycmd foo
 103 } "wrong # args: should be \"\""
 104 test indexObj-5.5 {Tcl_WrongNumArgs} testindexobj {
 105     testwrongnumargs 1 "" mycmd foo
 106 } "wrong # args: should be \"mycmd\""
 107 test 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.
 112 test indexObj-5.7 {Tcl_WrongNumArgs} testindexobj {
 113     testwrongnumargs 2 "fee fi" "fo fum" foo bar
 114 } "wrong # args: should be \"fo fum foo fee fi\""
 115
 116 test indexObj-6.1 {Tcl_GetIndexFromObjStruct} testindexobj {
 117     set x a
 118     testgetindexfromobjstruct $x 0
 119 } "wrong # args: should be \"testgetindexfromobjstruct a 0\""
 120 test 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\""
 125 test indexObj-6.3 {Tcl_GetIndexFromObjStruct} testindexobj {
 126     set x c
 127     testgetindexfromobjstruct $x 1
 128 } "wrong # args: should be \"testgetindexfromobjstruct c 1\""
 129 test 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
 135 test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs {
 136     testparseargs
 137 } {0 1 testparseargs}
 138 test indexObj-7.2 {Tcl_ParseArgsObjv} testparseargs {
 139     testparseargs -bool
 140 } {1 1 testparseargs}
 141 test indexObj-7.3 {Tcl_ParseArgsObjv} testparseargs {
 142     testparseargs -bool bar
 143 } {1 2 {testparseargs bar}}
 144 test indexObj-7.4 {Tcl_ParseArgsObjv} testparseargs {
 145     testparseargs bar
 146 } {0 2 {testparseargs bar}}
 147 test 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}
 153 test indexObj-7.6 {Tcl_ParseArgsObjv} testparseargs {
 154     testparseargs -- -bool -help
 155 } {0 3 {testparseargs -bool -help}}
 156 test 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 \f
 160 # cleanup
 161 ::tcltest::cleanupTests
 162 return
 163
 164 # Local Variables:
 165 # mode: tcl
 166 # End: