#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
# RCS: @(#) $Id$
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
+
if {[lsearch [image types] test] < 0} {
puts "This application hasn't been compiled with the \"test\""
puts "image, so I can't run this test. Are you sure you're using"
puts "tktest instead of wish?"
+ ::tcltest::cleanupTests
return
}
-if {[info procs test] != "test"} {
- source defs
-}
-
foreach i [winfo children .] {
destroy $i
}
entry .e -bd 2 -relief sunken
pack .e
update
+
set i 1
foreach test {
{-background #ff0000 #ff0000 non-existent
{-insertofftime 100 100 3.2 {expected integer but got "3.2"}}
{-insertontime 100 100 3.2 {expected integer but got "3.2"}}
{-justify right right bogus {bad justification "bogus": must be left, right, or center}}
- {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
+ {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
{-selectbackground #110022 #110022 bogus {unknown color name "bogus"}}
{-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}}
{-selectforeground #654321 #654321 bogus {unknown color name "bogus"}}
{-show * * {} {}}
- {-state normal normal bogus {bad state value "bogus": must be normal or disabled}}
+ {-state n normal bogus {bad state "bogus": must be disabled or normal}}
{-takefocus "any string" "any string" {} {}}
{-textvariable i i {} {}}
{-width 402 402 3p {expected integer but got "3p"}}
{-xscrollcommand {Some command} {Some command} {} {}}
} {
set name [lindex $test 0]
- test entry-1.1 {configuration options} {
+ test entry-1.$i {configuration options} {
.e configure $name [lindex $test 1]
list [lindex [.e configure $name] 4] [.e cget $name]
} [list [lindex $test 2] [lindex $test 2]]
incr i
if {[lindex $test 3] != ""} {
- test entry-1.2 {configuration options} {
+ test entry-1.$i {configuration options} {
list [catch {.e configure $name [lindex $test 3]} msg] $msg
} [list 1 [lindex $test 4]]
}
set cx [font measure $fixed a]
set cy [font metrics $fixed -linespace]
+set ux [font measure $fixed \u4e4e]
test entry-3.1 {EntryWidgetCmd procedure} {
list [catch {.e} msg] $msg
.e delete 0 end
.e bbox 0
} [list 5 5 0 $cy]
-test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} {fonts} {
+test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} {
+ # Tcl_UtfAtIndex(): no utf chars
+
+ .e delete 0 end
+ .e insert 0 "abc"
+ list [.e bbox 3] [.e bbox end]
+} [list "[expr 5+2*$cx] 5 $cx $cy" "[expr 5+2*$cx] 5 $cx $cy"]
+test entry-3.7 {EntryWidgetCmd procedure, "bbox" widget command} {
+ # Tcl_UtfAtIndex(): utf at end
.e delete 0 end
- .e insert 0 "abcdefghijklmnop"
- list [.e bbox 0] [.e bbox 1] [.e bbox end]
-} [list "5 5 $cx $cy" "[expr 5+$cx] 5 $cx $cy" "[expr 5+15*$cx] 5 $cx $cy"]
-test entry-3.7 {EntryWidgetCmd procedure, "cget" widget command} {
+ .e insert 0 "ab\u4e4e"
+ .e bbox end
+} "[expr 5+2*$cx] 5 $ux $cy"
+test entry-3.8 {EntryWidgetCmd procedure, "bbox" widget command} {
+ # Tcl_UtfAtIndex(): utf before index
+ .e delete 0 end
+ .e insert 0 "ab\u4e4ec"
+ .e bbox 3
+} "[expr 5+2*$cx+$ux] 5 $cx $cy"
+test entry-3.9 {EntryWidgetCmd procedure, "bbox" widget command} {
+ # Tcl_UtfAtIndex(): no chars
+ .e delete 0 end
+ .e bbox end
+} "5 5 0 $cy"
+test entry-3.10 {EntryWidgetCmd procedure, "bbox" widget command} {
+ .e delete 0 end
+ .e insert 0 "abcdefghij\u4e4eklmnop"
+ list [.e bbox 0] [.e bbox 1] [.e bbox 10] [.e bbox end]
+} [list "5 5 $cx $cy" "[expr 5+$cx] 5 $cx $cy" "[expr 5+10*$cx] 5 $ux $cy" "[expr 5+$ux+15*$cx] 5 $cx $cy"]
+test entry-3.11 {EntryWidgetCmd procedure, "cget" widget command} {
list [catch {.e cget} msg] $msg
} {1 {wrong # args: should be ".e cget option"}}
-test entry-3.8 {EntryWidgetCmd procedure, "cget" widget command} {
+test entry-3.12 {EntryWidgetCmd procedure, "cget" widget command} {
list [catch {.e cget a b} msg] $msg
} {1 {wrong # args: should be ".e cget option"}}
-test entry-3.9 {EntryWidgetCmd procedure, "cget" widget command} {
+test entry-3.13 {EntryWidgetCmd procedure, "cget" widget command} {
list [catch {.e cget -gorp} msg] $msg
} {1 {unknown option "-gorp"}}
-test entry-3.10 {EntryWidgetCmd procedure, "cget" widget command} {
+test entry-3.14 {EntryWidgetCmd procedure, "cget" widget command} {
.e configure -bd 4
.e cget -bd
} {4}
-test entry-3.11 {EntryWidgetCmd procedure, "configure" widget command} {
+test entry-3.15 {EntryWidgetCmd procedure, "configure" widget command} {
llength [.e configure]
-} {28}
-test entry-3.12 {EntryWidgetCmd procedure, "configure" widget command} {
+} {33}
+test entry-3.16 {EntryWidgetCmd procedure, "configure" widget command} {
list [catch {.e configure -foo} msg] $msg
} {1 {unknown option "-foo"}}
-test entry-3.13 {EntryWidgetCmd procedure, "configure" widget command} {
+test entry-3.17 {EntryWidgetCmd procedure, "configure" widget command} {
.e configure -bd 4
.e configure -bg #ffffff
lindex [.e configure -bd] 4
} {4}
-test entry-3.14 {EntryWidgetCmd procedure, "delete" widget command} {
+test entry-3.18 {EntryWidgetCmd procedure, "delete" widget command} {
list [catch {.e delete} msg] $msg
} {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}}
-test entry-3.15 {EntryWidgetCmd procedure, "delete" widget command} {
+test entry-3.19 {EntryWidgetCmd procedure, "delete" widget command} {
list [catch {.e delete a b c} msg] $msg
} {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}}
-test entry-3.16 {EntryWidgetCmd procedure, "delete" widget command} {
+test entry-3.20 {EntryWidgetCmd procedure, "delete" widget command} {
list [catch {.e delete foo} msg] $msg
} {1 {bad entry index "foo"}}
-test entry-3.17 {EntryWidgetCmd procedure, "delete" widget command} {
+test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} {
list [catch {.e delete 0 bar} msg] $msg
} {1 {bad entry index "bar"}}
-test entry-3.18 {EntryWidgetCmd procedure, "delete" widget command} {
+test entry-3.22 {EntryWidgetCmd procedure, "delete" widget command} {
.e delete 0 end
.e insert end "01234567890"
.e delete 2 4
.e get
} {014567890}
-test entry-3.19 {EntryWidgetCmd procedure, "delete" widget command} {
+test entry-3.23 {EntryWidgetCmd procedure, "delete" widget command} {
.e delete 0 end
.e insert end "01234567890"
.e delete 6
.e get
} {0123457890}
-test entry-3.20 {EntryWidgetCmd procedure, "delete" widget command} {
+test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} {
+ # UTF
+ set x {}
+ .e delete 0 end
+ .e insert end "01234\u4e4e67890"
+ .e delete 6
+ lappend x [.e get]
+ .e delete 0 end
+ .e insert end "012345\u4e4e7890"
+ .e delete 6
+ lappend x [.e get]
+ .e delete 0 end
+ .e insert end "0123456\u4e4e890"
+ .e delete 6
+ lappend x [.e get]
+} [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"]
+test entry-3.25 {EntryWidgetCmd procedure, "delete" widget command} {
.e delete 0 end
.e insert end "01234567890"
.e delete 6 5
.e get
} {01234567890}
-test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} {
+test entry-3.26 {EntryWidgetCmd procedure, "delete" widget command} {
.e delete 0 end
.e insert end "01234567890"
.e configure -state disabled
.e configure -state normal
.e get
} {01234567890}
-test entry-3.22 {EntryWidgetCmd procedure, "get" widget command} {
+test entry-3.27 {EntryWidgetCmd procedure, "get" widget command} {
list [catch {.e get foo} msg] $msg
} {1 {wrong # args: should be ".e get"}}
-test entry-3.23 {EntryWidgetCmd procedure, "icursor" widget command} {
+test entry-3.28 {EntryWidgetCmd procedure, "icursor" widget command} {
list [catch {.e icursor} msg] $msg
} {1 {wrong # args: should be ".e icursor pos"}}
-test entry-3.24 {EntryWidgetCmd procedure, "icursor" widget command} {
+test entry-3.29 {EntryWidgetCmd procedure, "icursor" widget command} {
list [catch {.e icursor foo} msg] $msg
} {1 {bad entry index "foo"}}
-test entry-3.25 {EntryWidgetCmd procedure, "icursor" widget command} {
+test entry-3.30 {EntryWidgetCmd procedure, "icursor" widget command} {
.e delete 0 end
.e insert end "01234567890"
.e icursor 4
.e index insert
} {4}
-test entry-3.26 {EntryWidgetCmd procedure, "index" widget command} {
+test entry-3.31 {EntryWidgetCmd procedure, "index" widget command} {
list [catch {.e in} msg] $msg
-} {1 {bad option "in": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, or xview}}
-test entry-3.27 {EntryWidgetCmd procedure, "index" widget command} {
+} {1 {ambiguous option "in": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview}}
+test entry-3.32 {EntryWidgetCmd procedure, "index" widget command} {
list [catch {.e index} msg] $msg
} {1 {wrong # args: should be ".e index string"}}
-test entry-3.28 {EntryWidgetCmd procedure, "index" widget command} {
+test entry-3.33 {EntryWidgetCmd procedure, "index" widget command} {
list [catch {.e index foo} msg] $msg
} {1 {bad entry index "foo"}}
-test entry-3.29 {EntryWidgetCmd procedure, "index" widget command} {
+test entry-3.34 {EntryWidgetCmd procedure, "index" widget command} {
list [catch {.e index 0} msg] $msg
} {0 0}
-test entry-3.30 {EntryWidgetCmd procedure, "insert" widget command} {
+test entry-3.35 {EntryWidgetCmd procedure, "index" widget command} {
+ # UTF
+ .e delete 0 end
+ .e insert 0 abc\u4e4e\u0153def
+ list [.e index 3] [.e index 4] [.e index end]
+} {3 4 8}
+test entry-3.36 {EntryWidgetCmd procedure, "insert" widget command} {
list [catch {.e insert a} msg] $msg
} {1 {wrong # args: should be ".e insert index text"}}
-test entry-3.31 {EntryWidgetCmd procedure, "insert" widget command} {
+test entry-3.37 {EntryWidgetCmd procedure, "insert" widget command} {
list [catch {.e insert a b c} msg] $msg
} {1 {wrong # args: should be ".e insert index text"}}
-test entry-3.32 {EntryWidgetCmd procedure, "insert" widget command} {
+test entry-3.38 {EntryWidgetCmd procedure, "insert" widget command} {
list [catch {.e insert foo Text} msg] $msg
} {1 {bad entry index "foo"}}
-test entry-3.33 {EntryWidgetCmd procedure, "insert" widget command} {
+test entry-3.39 {EntryWidgetCmd procedure, "insert" widget command} {
.e delete 0 end
.e insert end "01234567890"
.e insert 3 xxx
.e get
} {012xxx34567890}
-test entry-3.34 {EntryWidgetCmd procedure, "insert" widget command} {
+test entry-3.40 {EntryWidgetCmd procedure, "insert" widget command} {
.e delete 0 end
.e insert end "01234567890"
.e configure -state disabled
.e configure -state normal
.e get
} {01234567890}
-test entry-3.35 {EntryWidgetCmd procedure, "insert" widget command} {
+test entry-3.41 {EntryWidgetCmd procedure, "insert" widget command} {
list [catch {.e insert a b c} msg] $msg
} {1 {wrong # args: should be ".e insert index text"}}
-test entry-3.36 {EntryWidgetCmd procedure, "scan" widget command} {
+test entry-3.42 {EntryWidgetCmd procedure, "scan" widget command} {
list [catch {.e scan a} msg] $msg
} {1 {wrong # args: should be ".e scan mark|dragto x"}}
-test entry-3.37 {EntryWidgetCmd procedure, "scan" widget command} {
+test entry-3.43 {EntryWidgetCmd procedure, "scan" widget command} {
list [catch {.e scan a b c} msg] $msg
} {1 {wrong # args: should be ".e scan mark|dragto x"}}
-test entry-3.38 {EntryWidgetCmd procedure, "scan" widget command} {
+test entry-3.44 {EntryWidgetCmd procedure, "scan" widget command} {
list [catch {.e scan foobar 20} msg] $msg
} {1 {bad scan option "foobar": must be mark or dragto}}
-test entry-3.39 {EntryWidgetCmd procedure, "scan" widget command} {
+test entry-3.45 {EntryWidgetCmd procedure, "scan" widget command} {
list [catch {.e scan mark 20.1} msg] $msg
} {1 {expected integer but got "20.1"}}
# This test is non-portable because character sizes vary.
-test entry-3.40 {EntryWidgetCmd procedure, "scan" widget command} {fonts} {
+test entry-3.46 {EntryWidgetCmd procedure, "scan" widget command} {fonts} {
.e delete 0 end
update
.e insert end "This is quite a long string, in fact a "
.e scan dragto 28
.e index @0
} {2}
-test entry-3.41 {EntryWidgetCmd procedure, "select" widget command} {
+test entry-3.47 {EntryWidgetCmd procedure, "select" widget command} {
list [catch {.e select} msg] $msg
-} {1 {wrong # args: should be ".e select option ?index?"}}
-test entry-3.42 {EntryWidgetCmd procedure, "select" widget command} {
+} {1 {wrong # args: should be ".e selection option ?index?"}}
+test entry-3.48 {EntryWidgetCmd procedure, "select" widget command} {
list [catch {.e select foo} msg] $msg
} {1 {bad selection option "foo": must be adjust, clear, from, present, range, or to}}
-test entry-3.43 {EntryWidgetCmd procedure, "select clear" widget command} {
+test entry-3.49 {EntryWidgetCmd procedure, "select clear" widget command} {
list [catch {.e select clear gorp} msg] $msg
} {1 {wrong # args: should be ".e selection clear"}}
-test entry-3.44 {EntryWidgetCmd procedure, "select clear" widget command} {
+test entry-3.50 {EntryWidgetCmd procedure, "select clear" widget command} {
.e delete 0 end
.e insert end "0123456789"
.e select from 1
.e select clear
list [catch {selection get} msg] $msg [selection own]
} {1 {PRIMARY selection doesn't exist or form "STRING" not defined} .e}
-test entry-3.45 {EntryWidgetCmd procedure, "selection present" widget command} {
+test entry-3.51 {EntryWidgetCmd procedure, "selection present" widget command} {
list [catch {.e selection present foo} msg] $msg
} {1 {wrong # args: should be ".e selection present"}}
-test entry-3.46 {EntryWidgetCmd procedure, "selection present" widget command} {
+test entry-3.52 {EntryWidgetCmd procedure, "selection present" widget command} {
.e delete 0 end
.e insert end 0123456789
.e select from 3
.e select to 6
.e selection present
} {1}
-test entry-3.47 {EntryWidgetCmd procedure, "selection present" widget command} {
+test entry-3.53 {EntryWidgetCmd procedure, "selection present" widget command} {
.e delete 0 end
.e insert end 0123456789
.e select from 3
.e selection present
} {1}
.e configure -exportselection true
-test entry-3.48 {EntryWidgetCmd procedure, "selection present" widget command} {
+test entry-3.54 {EntryWidgetCmd procedure, "selection present" widget command} {
.e delete 0 end
.e insert end 0123456789
.e select from 3
.e delete 0 end
.e selection present
} {0}
-test entry-3.49 {EntryWidgetCmd procedure, "selection adjust" widget command} {
+test entry-3.55 {EntryWidgetCmd procedure, "selection adjust" widget command} {
list [catch {.e select adjust x} msg] $msg
} {1 {bad entry index "x"}}
-test entry-3.50 {EntryWidgetCmd procedure, "selection adjust" widget command} {
+test entry-3.56 {EntryWidgetCmd procedure, "selection adjust" widget command} {
list [catch {.e select adjust 2 3} msg] $msg
} {1 {wrong # args: should be ".e selection adjust index"}}
-test entry-3.51 {EntryWidgetCmd procedure, "selection adjust" widget command} {
+test entry-3.57 {EntryWidgetCmd procedure, "selection adjust" widget command} {
.e delete 0 end
.e insert end "0123456789"
.e select from 1
.e select adjust 4
selection get
} {123}
-test entry-3.52 {EntryWidgetCmd procedure, "selection adjust" widget command} {
+test entry-3.58 {EntryWidgetCmd procedure, "selection adjust" widget command} {
.e delete 0 end
.e insert end "0123456789"
.e select from 1
.e select adjust 2
selection get
} {234}
-test entry-3.53 {EntryWidgetCmd procedure, "selection from" widget command} {
+test entry-3.59 {EntryWidgetCmd procedure, "selection from" widget command} {
list [catch {.e select from 2 3} msg] $msg
} {1 {wrong # args: should be ".e selection from index"}}
-test entry-3.54 {EntryWidgetCmd procedure, "selection range" widget command} {
+test entry-3.60 {EntryWidgetCmd procedure, "selection range" widget command} {
list [catch {.e select range 2} msg] $msg
} {1 {wrong # args: should be ".e selection range start end"}}
-test entry-3.55 {EntryWidgetCmd procedure, "selection range" widget command} {
+test entry-3.61 {EntryWidgetCmd procedure, "selection range" widget command} {
list [catch {.e selection range 2 3 4} msg] $msg
} {1 {wrong # args: should be ".e selection range start end"}}
-test entry-3.56 {EntryWidgetCmd procedure, "selection range" widget command} {
+test entry-3.62 {EntryWidgetCmd procedure, "selection range" widget command} {
.e delete 0 end
.e insert end 0123456789
.e select from 1
.e select range 4 4
list [catch {.e index sel.first} msg] $msg
} {1 {selection isn't in entry}}
-test entry-3.57 {EntryWidgetCmd procedure, "selection range" widget command} {
+test entry-3.63 {EntryWidgetCmd procedure, "selection range" widget command} {
.e delete 0 end
.e insert end 0123456789
.e select from 3
.e delete 0 end
.e insert end "This is quite a long text string, so long that it "
.e insert end "runs off the end of the window quite a bit."
-test entry-3.58 {EntryWidgetCmd procedure, "selection to" widget command} {
+test entry-3.64 {EntryWidgetCmd procedure, "selection to" widget command} {
list [catch {.e select to 2 3} msg] $msg
} {1 {wrong # args: should be ".e selection to index"}}
-test entry-3.59 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} {
.e xview 5
.e xview
} {0.0537634 0.268817}
-test entry-3.60 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} {
list [catch {.e xview gorp} msg] $msg
} {1 {bad entry index "gorp"}}
-test entry-3.61 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} {
.e xview 0
.e icursor 10
.e xview insert
.e xview
} {0.107527 0.322581}
-test entry-3.62 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} {
list [catch {.e xview moveto foo bar} msg] $msg
} {1 {wrong # args: should be ".e xview moveto fraction"}}
-test entry-3.63 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} {
list [catch {.e xview moveto foo} msg] $msg
} {1 {expected floating-point number but got "foo"}}
-test entry-3.64 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} {
.e xview moveto 0.5
.e xview
} {0.505376 0.72043}
-test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} {
list [catch {.e xview scroll 24} msg] $msg
} {1 {wrong # args: should be ".e xview scroll number units|pages"}}
-test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} {
list [catch {.e xview scroll gorp units} msg] $msg
} {1 {expected integer but got "gorp"}}
-test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} {
.e xview moveto 0
.e xview scroll 1 pages
.e xview
} {0.193548 0.408602}
-test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} {
.e xview moveto .9
update
.e xview scroll -2 p
.e xview
} {0.397849 0.612903}
-test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.75 {EntryWidgetCmd procedure, "xview" widget command} {
.e xview 30
update
.e xview scroll 2 units
.e index @0
} {32}
-test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.76 {EntryWidgetCmd procedure, "xview" widget command} {
.e xview 30
update
.e xview scroll -1 units
.e index @0
} {29}
-test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.77 {EntryWidgetCmd procedure, "xview" widget command} {
list [catch {.e xview scroll 23 foobars} msg] $msg
} {1 {bad argument "foobars": must be units or pages}}
-test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.78 {EntryWidgetCmd procedure, "xview" widget command} {
list [catch {.e xview eat 23 hamburgers} msg] $msg
} {1 {unknown option "eat": must be moveto or scroll}}
-test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.79 {EntryWidgetCmd procedure, "xview" widget command} {
.e xview 0
update
.e xview -4
.e index @0
} {0}
-test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} {
+test entry-3.80 {EntryWidgetCmd procedure, "xview" widget command} {
.e xview 300
.e index @0
} {73}
-test entry-3.75 {EntryWidgetCmd procedure} {
+.e insert 10 \u4e4e
+test entry-3.81 {EntryWidgetCmd procedure, "xview" widget command} {
+ # UTF
+ # If Tcl_NumUtfChars wasn't used, wrong answer would be:
+ # 0.106383 0.117021 0.117021
+
+ set x {}
+ .e xview moveto .1
+ lappend x [lindex [.e xview] 0]
+ .e xview moveto .11
+ lappend x [lindex [.e xview] 0]
+ .e xview moveto .12
+ lappend x [lindex [.e xview] 0]
+} {0.0957447 0.106383 0.117021}
+test entry-3.82 {EntryWidgetCmd procedure} {
list [catch {.e gorp} msg] $msg
-} {1 {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, or xview}}
+} {1 {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview}}
# The test below doesn't actually check anything directly, but if run
# with Purify or some other memory-allocation-checking program it will
update
list [winfo reqwidth .e] [winfo reqheight .e]
} {25 39}
-test entry-6.10 {EntryComputeGeometry procedure} {fonts} {
+test entry-6.10 {EntryComputeGeometry procedure} {unixOnly fonts} {
catch {destroy .e}
entry .e -bd 1 -relief raised -width 0 -show .
.e insert 0 12345
.e configure -show ""
lappend x [winfo reqwidth .e]
} {23 53 43}
+test entry-6.11 {EntryComputeGeometry procedure} {pcOnly} {
+ catch {destroy .e}
+ entry .e -bd 1 -relief raised -width 0 -show . -font {helvetica 12}
+ .e insert 0 12345
+ pack .e
+ update
+ set x [winfo reqwidth .e]
+ .e configure -show X
+ lappend x [winfo reqwidth .e]
+ .e configure -show ""
+ lappend x [winfo reqwidth .e]
+} [list \
+ [expr 8+5*[font measure {helvetica 12} .]] \
+ [expr 8+5*[font measure {helvetica 12} X]] \
+ [expr 8+[font measure {helvetica 12} 12345]]]
catch {destroy .e}
entry .e -width 10 -font $fixed -textvariable contents -xscrollcommand scroll
list [.e index sel.first] [.e index sel.last]
} {1 6}
selection clear .e
-test entry-13.10 {GetEntryIndex procedure} {pc} {
- .e index sel.first
-} {1}
-test entry-13.11 {GetEntryIndex procedure} {!pc} {
+test entry-13.10 {GetEntryIndex procedure} {unixOnly} {
+ # On unix, when selection is cleared, entry widget's internal
+ # selection range is reset.
+
list [catch {.e index sel.first} msg] $msg
} {1 {selection isn't in entry}}
-test entry-13.12 {GetEntryIndex procedure} {pc} {
- list [catch {.e index sbogus} msg] $msg
-} {1 {bad entry index "sbogus"}}
-test entry-13.13 {GetEntryIndex procedure} {!pc} {
+test entry-13.11 {GetEntryIndex procedure} {macOrPc} {
+ # On mac and pc, when selection is cleared, entry widget remembers
+ # last selected range. When selection ownership is restored to
+ # entry, the old range will be rehighlighted.
+
+ list [catch {selection get}] [.e index sel.first]
+} {1 1}
+test entry-13.12 {GetEntryIndex procedure} {unixOnly} {
list [catch {.e index sbogus} msg] $msg
} {1 {selection isn't in entry}}
-test entry-13.14 {GetEntryIndex procedure} {
+test entry-13.13 {GetEntryIndex procedure} {macOrPc} {
+ list [catch {.e index sbogus} msg] $msg
+} {1 {bad entry index "sbogus"}}
+test entry-13.14 {GetEntryIndex procedure} {macOrPc} {
+ list [catch {selection get}] [catch {.e index sbogus}]
+} {1 1}
+test entry-13.15 {GetEntryIndex procedure} {
list [catch {.e index @xyz} msg] $msg
} {1 {bad entry index "@xyz"}}
-test entry-13.15 {GetEntryIndex procedure} {fonts} {
+test entry-13.16 {GetEntryIndex procedure} {fonts} {
.e index @4
} {4}
-test entry-13.16 {GetEntryIndex procedure} {fonts} {
+test entry-13.17 {GetEntryIndex procedure} {fonts} {
.e index @11
} {4}
-test entry-13.17 {GetEntryIndex procedure} {fonts} {
+test entry-13.18 {GetEntryIndex procedure} {fonts} {
.e index @12
} {5}
-test entry-13.18 {GetEntryIndex procedure} {fonts} {
+test entry-13.19 {GetEntryIndex procedure} {fonts} {
.e index @[expr [winfo width .e] - 6]
} {8}
-test entry-13.19 {GetEntryIndex procedure} {fonts} {
+test entry-13.20 {GetEntryIndex procedure} {fonts} {
.e index @[expr [winfo width .e] - 5]
} {9}
-test entry-13.20 {GetEntryIndex procedure} {
+test entry-13.21 {GetEntryIndex procedure} {
.e index @1000
} {9}
-test entry-13.21 {GetEntryIndex procedure} {
+test entry-13.22 {GetEntryIndex procedure} {
list [catch {.e index 1xyz} msg] $msg
} {1 {bad entry index "1xyz"}}
-test entry-13.22 {GetEntryIndex procedure} {
+test entry-13.23 {GetEntryIndex procedure} {
.e index -10
} {0}
-test entry-13.23 {GetEntryIndex procedure} {
+test entry-13.24 {GetEntryIndex procedure} {
.e index 12
} {12}
-test entry-13.24 {GetEntryIndex procedure} {
+test entry-13.25 {GetEntryIndex procedure} {
.e index 49
} {21}
-test entry-13.25 {GetEntryIndex procedure} {fonts} {
+test entry-13.26 {GetEntryIndex procedure} {fonts} {
catch {destroy .e}
entry .e -show .
.e insert 0 XXXYZZY
.e insert 0 .............................
.e xview
} {0 0.827586}
-test entry-16.2 {EntryVisibleRange procedure} {fonts} {
+test entry-15.2 {EntryVisibleRange procedure} {unixOnly fonts} {
.e configure -show X
.e delete 0 end
.e insert 0 .............................
.e xview
} {0 0.275862}
+test entry-15.3 {EntryVisibleRange procedure} {pcOnly} {
+ .e configure -show .
+ .e delete 0 end
+ .e insert 0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ .e xview
+} {0 0.827586}
.e configure -show ""
-test entry-16.3 {EntryVisibleRange procedure} {
+test entry-15.4 {EntryVisibleRange procedure} {
.e delete 0 end
.e xview
} {0 1}
set scrollInfo
} {0.315789 0.842105}
test entry-17.4 {EntryUpdateScrollbar procedure} {
- catch {destroy .e}
+ destroy .e
proc bgerror msg {
global x
set x $msg
}
- entry .e -width 5 -xscrollcommand bogus
+ entry .e -width 5 -xscrollcommand thisisnotacommand
pack .e
update
rename bgerror {}
list $x $errorInfo
-} {{invalid command name "bogus"} {invalid command name "bogus"
+} {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand"
while executing
-"bogus 0 1"
+"thisisnotacommand 0 1"
(horizontal scrolling command executed by entry)}}
set l [interp hidden]
eval destroy [winfo children .]
test entry-18.1 {Entry widget vs hiding} {
- catch {destroy .e}
+ destroy .e
entry .e
interp hide {} .e
destroy .e
list [winfo children .] [interp hidden]
} [list {} $l]
-
+
+##
+## Entry widget VALIDATION tests
+##
+
+destroy .e
+catch {unset ::e}
+catch {unset ::vVals}
+entry .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+pack .e
+proc doval {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ return 1
+}
+
+# The validation tests build each one upon the previous, so cascading
+# failures aren't good
+#
+test entry-19.1 {entry widget validation} {
+ .e insert 0 a
+ set ::vVals
+} {.e 1 0 a {} a all key}
+test entry-19.2 {entry widget validation} {
+ .e insert 1 b
+ set ::vVals
+} {.e 1 1 ab a b all key}
+test entry-19.3 {entry widget validation} {
+ .e insert end c
+ set ::vVals
+} {.e 1 2 abc ab c all key}
+test entry-19.4 {entry widget validation} {
+ .e insert 1 123
+ list $::vVals $::e
+} {{.e 1 1 a123bc abc 123 all key} a123bc}
+test entry-19.5 {entry widget validation} {
+ .e delete 2
+ set ::vVals
+} {.e 0 2 a13bc a123bc 2 all key}
+test entry-19.6 {entry widget validation} {
+ .e configure -validate key
+ .e delete 1 3
+ set ::vVals
+} {.e 0 1 abc a13bc 13 key key}
+test entry-19.7 {entry widget validation} {
+ set ::vVals {}
+ .e configure -validate focus
+ .e insert end d
+ set ::vVals
+} {}
+test entry-19.8 {entry widget validation} {
+ focus -force .e
+ # update necessary to process FocusIn event
+ update
+ set ::vVals
+} {.e -1 -1 abcd abcd {} focus focusin}
+test entry-19.9 {entry widget validation} {
+ focus -force .
+ # update necessary to process FocusOut event
+ update
+ set ::vVals
+} {.e -1 -1 abcd abcd {} focus focusout}
+.e configure -validate all
+test entry-19.10 {entry widget validation} {
+ focus -force .e
+ # update necessary to process FocusIn event
+ update
+ set ::vVals
+} {.e -1 -1 abcd abcd {} all focusin}
+test entry-19.11 {entry widget validation} {
+ focus -force .
+ # update necessary to process FocusOut event
+ update
+ set ::vVals
+} {.e -1 -1 abcd abcd {} all focusout}
+.e configure -validate focusin
+test entry-19.12 {entry widget validation} {
+ focus -force .e
+ # update necessary to process FocusIn event
+ update
+ set ::vVals
+} {.e -1 -1 abcd abcd {} focusin focusin}
+test entry-19.13 {entry widget validation} {
+ set ::vVals {}
+ focus -force .
+ # update necessary to process FocusOut event
+ update
+ set ::vVals
+} {}
+.e configure -validate focuso
+test entry-19.14 {entry widget validation} {
+ focus -force .e
+ # update necessary to process FocusIn event
+ update
+ set ::vVals
+} {}
+test entry-19.15 {entry widget validation} {
+ focus -force .
+ # update necessary to process FocusOut event
+ update
+ set ::vVals
+} {.e -1 -1 abcd abcd {} focusout focusout}
+test entry-19.16 {entry widget validation} {
+ list [.e validate] $::vVals
+} {1 {.e -1 -1 abcd abcd {} all forced}}
+test entry-19.17 {entry widget validation} {
+ set ::e newdata
+ list [.e cget -validate] $::vVals
+} {focusout {.e -1 -1 newdata abcd {} focusout forced}}
+
+proc doval {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ return 0
+}
+.e configure -validate all
+
+test entry-19.18 {entry widget validation} {
+ set ::e nextdata
+ list [.e cget -validate] $::vVals
+} {none {.e -1 -1 nextdata newdata {} all forced}}
+
+proc doval {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ set ::e mydata
+ return 1
+}
+.e configure -validate all
+
+## This sets validate to none because it shows that we prevent a possible
+## loop condition in the validation, when the entry textvar is also set
+test entry-19.19 {entry widget validation} {
+ .e validate
+ list [.e cget -validate] [.e get] $::vVals
+} {none mydata {.e -1 -1 nextdata nextdata {} all forced}}
+
+.e configure -validate all
+
+## This leaves validate alone because we trigger validation through the
+## textvar (a write trace), and the write during validation triggers
+## nothing (by definition of avoiding loops on var traces). This is
+## one of those "dangerous" conditions where the user will have a
+## different value in the entry widget shown as is in the textvar.
+test entry-19.20 {entry widget validation} {
+ set ::e testdata
+ list [.e cget -validate] [.e get] $::e $::vVals
+} {all testdata mydata {.e -1 -1 testdata mydata {} all forced}}
+
+destroy .e
+catch {unset ::e ::vVals}
+
+##
+## End validation tests
+##
+
# XXX Still need to write tests for EntryBlinkProc, EntryFocusProc,
# and EntryTextVarProc.
-
option clear
+
+# cleanup
+::tcltest::cleanupTests
+return
+
OSDN Git Service
