#
# 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
-}
-
-foreach i [winfo children .] {
- destroy $i
-}
-wm geometry . {}
-raise .
+package require tcltest 2.1
+namespace import -force tcltest::configure
+namespace import -force tcltest::testsDirectory
+configure -testdir [file join [pwd] [file dirname [info script]]]
+configure -loadfile [file join [testsDirectory] constraints.tcl]
+tcltest::loadTestedCommands
proc scroll args {
global scrollInfo
set i 1
foreach test {
{-background #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
+ {unknown color name "non-existent"}}
{-bd 4 4 badValue {bad screen distance "badValue"}}
{-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
{-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
{-cursor arrow arrow badValue {bad cursor spec "badValue"}}
+ {-disabledbackground green green non-existent
+ {unknown color name "non-existent"}}
+ {-disabledforeground blue blue non-existent
+ {unknown color name "non-existent"}}
{-exportselection yes 1 xyzzy {expected boolean value but got "xyzzy"}}
{-fg #110022 #110022 bogus {unknown color name "bogus"}}
{-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
{-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}}
{-insertofftime 100 100 3.2 {expected integer but got "3.2"}}
{-insertontime 100 100 3.2 {expected integer but got "3.2"}}
+ {-invalidcommand "any string" "any string" {} {}}
+ {-invcmd "any string" "any string" {} {}}
{-justify right right bogus {bad justification "bogus": must be left, right, or center}}
+ {-readonlybackground green green non-existent
+ {unknown color name "non-existent"}}
{-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 n normal bogus {bad state "bogus": must be disabled or normal}}
+ {-state n normal bogus
+ {bad state "bogus": must be disabled, normal, or readonly}}
{-takefocus "any string" "any string" {} {}}
{-textvariable i i {} {}}
{-width 402 402 3p {expected integer but got "3p"}}
} {4}
test entry-3.15 {EntryWidgetCmd procedure, "configure" widget command} {
llength [.e configure]
-} {33}
+} {36}
test entry-3.16 {EntryWidgetCmd procedure, "configure" widget command} {
list [catch {.e configure -foo} msg] $msg
} {1 {unknown option "-foo"}}
.e configure -state normal
.e get
} {01234567890}
+test entry-3.27 {EntryWidgetCmd procedure, "delete" widget command} {
+ .e delete 0 end
+ .e insert end "01234567890"
+ .e configure -state readonly
+ .e delete 2 8
+ .e configure -state normal
+ .e get
+} {01234567890}
test entry-3.27 {EntryWidgetCmd procedure, "get" widget command} {
list [catch {.e get foo} msg] $msg
} {1 {wrong # args: should be ".e get"}}
.e configure -state normal
.e get
} {01234567890}
+test entry-3.40 {EntryWidgetCmd procedure, "insert" widget command} {
+ .e delete 0 end
+ .e insert end "01234567890"
+ .e configure -state readonly
+ .e insert 3 xxx
+ .e configure -state normal
+ .e get
+} {01234567890}
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"}}
.e select to 5
.e select range 4 4
list [catch {.e index sel.first} msg] $msg
-} {1 {selection isn't in entry}}
+} {1 {selection isn't in widget .e}}
test entry-3.63 {EntryWidgetCmd procedure, "selection range" widget command} {
.e delete 0 end
.e insert end 0123456789
.e select range 2 9
list [.e index sel.first] [.e index sel.last] [.e index anchor]
} {2 9 3}
+test entry-3.64 {EntryWidgetCmd procedure, "selection" widget command} {
+ .e delete 0 end
+ .e insert end 0123456789
+ .e selection range 0 end
+ .e configure -state disabled
+ .e selection range 2 4
+ .e configure -state normal
+ list [.e index sel.first] [.e index sel.last]
+} {0 10}
+test entry-3.64 {EntryWidgetCmd procedure, "selection" widget command} {
+ .e delete 0 end
+ .e insert end 0123456789
+ .e selection range 0 end
+ .e configure -state readonly
+ .e selection range 2 4
+ .e configure -state normal
+ list [.e index sel.first] [.e index sel.last]
+} {2 4}
.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."
.e select to 8
.e delete 1 8
list [catch {.e index sel.first} msg] $msg
-} {1 {selection isn't in entry}}
+} {1 {selection isn't in widget .e}}
test entry-8.8 {DeleteChars procedure} {
.e delete 0 end
.e insert 0 0123456789abcde
.e select to 8
.e delete 3 8
list [catch {.e index sel.first} msg] $msg
-} {1 {selection isn't in entry}}
+} {1 {selection isn't in widget .e}}
test entry-8.10 {DeleteChars procedure} {
.e delete 0 end
.e insert 0 0123456789abcde
.e selection range 4 10
set x "a"
list [catch {.e index sel.first} msg] $msg
-} {1 {selection isn't in entry}}
+} {1 {selection isn't in widget .e}}
test entry-10.3 {EntrySetValue procedure, updating selection} {
catch {destroy .e}
entry .e -textvariable x
update
} {}
test entry-11.2 {EntryEventProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
entry .e1 -fg #112233
rename .e1 .e2
set x {}
} {.e1 #112233 {} {}}
test entry-12.1 {EntryCmdDeletedProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
button .e1 -text "xyz_123"
rename .e1 {}
list [info command .e*] [winfo children .]
# selection range is reset.
list [catch {.e index sel.first} msg] $msg
-} {1 {selection isn't in entry}}
+} {1 {selection isn't in widget .e}}
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
} {1 1}
test entry-13.12 {GetEntryIndex procedure} {unixOnly} {
list [catch {.e index sbogus} msg] $msg
-} {1 {selection isn't in entry}}
+} {1 {selection isn't in widget .e}}
test entry-13.13 {GetEntryIndex procedure} {macOrPc} {
list [catch {.e index sbogus} msg] $msg
} {1 {bad entry index "sbogus"}}
} {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand"
while executing
"thisisnotacommand 0 1"
- (horizontal scrolling command executed by entry)}}
+ (horizontal scrolling command executed by .e)}}
set l [interp hidden]
-eval destroy [winfo children .]
+deleteWindows
test entry-18.1 {Entry widget vs hiding} {
destroy .e
set ::vVals [list $W $d $i $P $s $S $v $V]
return 0
}
-.e configure -validate all
test entry-19.18 {entry widget validation} {
+ .e configure -validate all
set ::e nextdata
list [.e cget -validate] $::vVals
} {none {.e -1 -1 nextdata newdata {} all forced}}
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 configure -validate all
.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} {
+ .e configure -validate all
set ::e testdata
list [.e cget -validate] [.e get] $::e $::vVals
} {all testdata mydata {.e -1 -1 testdata mydata {} all forced}}
## End validation tests
##
+test entry-20.1 {widget deletion while active} {
+ destroy .e
+ entry .e -validate all \
+ -validatecommand { destroy %W ; return 1 } \
+ -invalidcommand bell
+ update
+ .e insert 0 abc
+ winfo exists .e
+} 0
+test entry-20.2 {widget deletion while active} {
+ destroy .e
+ entry .e -validate all \
+ -validatecommand { return 0 } \
+ -invalidcommand { destroy %W }
+ .e insert 0 abc
+ winfo exists .e
+} 0
+test entry-20.3 {widget deletion while active} {
+ destroy .e
+ entry .e -validate all \
+ -validatecommand { rename .e {} ; return 1 }
+ .e insert 0 abc
+ winfo exists .e
+} 0
+test entry-20.4 {widget deletion while active} {
+ destroy .e
+ entry .e -validate all \
+ -validatecommand { return 0 } \
+ -invalidcommand { rename .e {} }
+ .e insert 0 abc
+ winfo exists .e
+} 0
+test entry-20.5 {widget deletion while active} {
+ destroy .e
+ entry .e -validatecommand { destroy .e ; return 0 }
+ .e validate
+ winfo exists .e
+} 0
+test entry-20.6 {widget deletion while active} {
+ destroy .e
+ pack [entry .e]
+ update
+ .e config -xscrollcommand { destroy .e }
+ update idle
+ winfo exists .e
+} 0
+test entry-20.7 {widget deletion with textvariable active} {
+ # SF bugs 607390 and 617446
+ destroy .e
+ set FOO init
+ entry .e -textvariable FOO -validate all \
+ -vcmd {%W configure -bg white; format 1}
+ bind .e <Destroy> { set FOO hello }
+ destroy .e
+ winfo exists .e
+} 0
+
# XXX Still need to write tests for EntryBlinkProc, EntryFocusProc,
# and EntryTextVarProc.
# cleanup
::tcltest::cleanupTests
return
-
OSDN Git Service
