61 lines
1.6 KiB
Tcl
61 lines
1.6 KiB
Tcl
# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
|
|
#
|
|
# $Id: labentry.tcl,v 1.2 2002/11/13 21:12:18 idiscovery Exp $
|
|
#
|
|
# labentry.tcl
|
|
#
|
|
# Tests the TixLabelEntry widget.
|
|
#
|
|
# Copyright (c) 1996, Expert Interface Technologies
|
|
#
|
|
# See the file "license.terms" for information on usage and
|
|
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
#
|
|
|
|
proc About {} {
|
|
return "Testing the TixLabelEntry widget"
|
|
}
|
|
|
|
proc Test {} {
|
|
TestBlock labent-1.1 {LabelEntry focus management} {
|
|
set t [toplevel .t]
|
|
|
|
set w [tixLabelEntry .t.c -label "Stuff(c): "]
|
|
pack $w -padx 20 -pady 10
|
|
tixLabelEntry .t.d -label "Stuff(d): "
|
|
pack .t.d -padx 20 -pady 10
|
|
focus $w
|
|
update
|
|
|
|
set px [winfo pointerx $t]
|
|
set py [winfo pointery $t]
|
|
set W [winfo width $t]
|
|
set H [winfo height $t]
|
|
|
|
if {$W < 100} {
|
|
set W 100
|
|
}
|
|
if {$H < 100} {
|
|
set H 100
|
|
}
|
|
|
|
set mx [expr $px - $W / 2]
|
|
set my [expr $py - $H / 2]
|
|
|
|
# We must move the window under the cursor in order to test
|
|
# the current focus
|
|
#
|
|
wm geometry $t $W\x$H+$mx+$my
|
|
raise $t
|
|
update
|
|
|
|
# On some platforms (e.g. Red Hat Linux 5.2/x86), this fails
|
|
# because we get: LHS = .t.c, RHS = .t.c.frame.entry
|
|
# (not clear why).
|
|
#
|
|
Assert {[focus -lastfor $t] == [$w subwidget entry]}
|
|
|
|
destroy $t
|
|
}; # TestBlock
|
|
}; # Test
|