summaryrefslogtreecommitdiffstats
path: root/tk8.6/tests
diff options
context:
space:
mode:
authorWilliam Joye <wjoye@cfa.harvard.edu>2016-10-18 17:31:55 (GMT)
committerWilliam Joye <wjoye@cfa.harvard.edu>2016-10-18 17:31:55 (GMT)
commit39e34335fb6eb6eaf2b7ee51ccf172006dd46fbb (patch)
tree8e5374666c7f0b3017176ec9d6e6b6eae0dcabac /tk8.6/tests
parent066971b1e6e77991d9161bb0216a63ba94ea04f9 (diff)
parent6b095f3c8521ca7215e6ff5dcbada52b197ef7d0 (diff)
downloadblt-39e34335fb6eb6eaf2b7ee51ccf172006dd46fbb.zip
blt-39e34335fb6eb6eaf2b7ee51ccf172006dd46fbb.tar.gz
blt-39e34335fb6eb6eaf2b7ee51ccf172006dd46fbb.tar.bz2
Merge commit '6b095f3c8521ca7215e6ff5dcbada52b197ef7d0' as 'tk8.6'
Diffstat (limited to 'tk8.6/tests')
-rw-r--r--tk8.6/tests/README5
-rw-r--r--tk8.6/tests/all.tcl19
-rw-r--r--tk8.6/tests/arc.tcl151
-rw-r--r--tk8.6/tests/bell.test53
-rw-r--r--tk8.6/tests/bevel.tcl158
-rw-r--r--tk8.6/tests/bgerror.test67
-rw-r--r--tk8.6/tests/bind.test6124
-rw-r--r--tk8.6/tests/bitmap.test111
-rw-r--r--tk8.6/tests/border.test199
-rw-r--r--tk8.6/tests/bugs.tcl41
-rw-r--r--tk8.6/tests/busy.test477
-rw-r--r--tk8.6/tests/butGeom.tcl126
-rw-r--r--tk8.6/tests/butGeom2.tcl124
-rw-r--r--tk8.6/tests/button.test3935
-rw-r--r--tk8.6/tests/canvImg.test796
-rw-r--r--tk8.6/tests/canvMoveto.test56
-rw-r--r--tk8.6/tests/canvPs.test196
-rw-r--r--tk8.6/tests/canvPsArc.tcl43
-rw-r--r--tk8.6/tests/canvPsBmap.tcl84
-rw-r--r--tk8.6/tests/canvPsGrph.tcl98
-rw-r--r--tk8.6/tests/canvPsImg.tcl84
-rw-r--r--tk8.6/tests/canvPsText.tcl94
-rw-r--r--tk8.6/tests/canvRect.test475
-rw-r--r--tk8.6/tests/canvText.test950
-rw-r--r--tk8.6/tests/canvWind.test144
-rw-r--r--tk8.6/tests/canvas.test960
-rw-r--r--tk8.6/tests/choosedir.test172
-rw-r--r--tk8.6/tests/clipboard.test361
-rw-r--r--tk8.6/tests/clrpick.test216
-rw-r--r--tk8.6/tests/cmap.tcl72
-rw-r--r--tk8.6/tests/cmds.test60
-rw-r--r--tk8.6/tests/color.test282
-rw-r--r--tk8.6/tests/config.test1929
-rw-r--r--tk8.6/tests/constraints.tcl282
-rw-r--r--tk8.6/tests/cursor.test843
-rw-r--r--tk8.6/tests/dialog.test67
-rw-r--r--tk8.6/tests/earth.gifbin0 -> 51712 bytes
-rw-r--r--tk8.6/tests/embed.test88
-rw-r--r--tk8.6/tests/entry.test3518
-rw-r--r--tk8.6/tests/event.test837
-rw-r--r--tk8.6/tests/face.xbm173
-rw-r--r--tk8.6/tests/filebox.test476
-rw-r--r--tk8.6/tests/flagdown.xbm27
-rw-r--r--tk8.6/tests/flagup.xbm27
-rw-r--r--tk8.6/tests/focus.test739
-rw-r--r--tk8.6/tests/focusTcl.test485
-rw-r--r--tk8.6/tests/font.test2382
-rw-r--r--tk8.6/tests/fontchooser.test201
-rw-r--r--tk8.6/tests/frame.test1529
-rw-r--r--tk8.6/tests/geometry.test291
-rw-r--r--tk8.6/tests/get.test138
-rw-r--r--tk8.6/tests/grab.test188
-rw-r--r--tk8.6/tests/grid.test2008
-rw-r--r--tk8.6/tests/image.test626
-rw-r--r--tk8.6/tests/imgBmap.test519
-rw-r--r--tk8.6/tests/imgPNG.test1116
-rw-r--r--tk8.6/tests/imgPPM.test239
-rw-r--r--tk8.6/tests/imgPhoto.test1169
-rw-r--r--tk8.6/tests/listbox.test3190
-rw-r--r--tk8.6/tests/main.test120
-rw-r--r--tk8.6/tests/menu.test3890
-rw-r--r--tk8.6/tests/menuDraw.test717
-rw-r--r--tk8.6/tests/menubut.test762
-rw-r--r--tk8.6/tests/message.test474
-rw-r--r--tk8.6/tests/msgbox.test449
-rw-r--r--tk8.6/tests/obj.test28
-rw-r--r--tk8.6/tests/oldpack.test552
-rw-r--r--tk8.6/tests/option.file118
-rw-r--r--tk8.6/tests/option.file22
-rwxr-xr-xtk8.6/tests/option.file318
-rw-r--r--tk8.6/tests/option.test425
-rw-r--r--tk8.6/tests/pack.test1635
-rw-r--r--tk8.6/tests/packgrid.test250
-rw-r--r--tk8.6/tests/panedwindow.test5551
-rw-r--r--tk8.6/tests/place.test504
-rw-r--r--tk8.6/tests/pwrdLogo150.gifbin0 -> 2489 bytes
-rw-r--r--tk8.6/tests/raise.test320
-rw-r--r--tk8.6/tests/safe.test248
-rw-r--r--tk8.6/tests/scale.test1511
-rw-r--r--tk8.6/tests/scrollbar.test707
-rw-r--r--tk8.6/tests/select.test1160
-rw-r--r--tk8.6/tests/send.test624
-rw-r--r--tk8.6/tests/spinbox.test3832
-rw-r--r--tk8.6/tests/teapot.ppm31
-rw-r--r--tk8.6/tests/text.test7302
-rw-r--r--tk8.6/tests/textBTree.test1247
-rw-r--r--tk8.6/tests/textDisp.test4249
-rw-r--r--tk8.6/tests/textImage.test473
-rw-r--r--tk8.6/tests/textIndex.test963
-rw-r--r--tk8.6/tests/textMark.test306
-rw-r--r--tk8.6/tests/textTag.test1775
-rw-r--r--tk8.6/tests/textWind.test1482
-rw-r--r--tk8.6/tests/tk.test184
-rw-r--r--tk8.6/tests/ttk/all.tcl20
-rw-r--r--tk8.6/tests/ttk/checkbutton.test64
-rw-r--r--tk8.6/tests/ttk/combobox.test68
-rw-r--r--tk8.6/tests/ttk/entry.test283
-rw-r--r--tk8.6/tests/ttk/image.test50
-rw-r--r--tk8.6/tests/ttk/labelframe.test130
-rw-r--r--tk8.6/tests/ttk/layout.test25
-rw-r--r--tk8.6/tests/ttk/notebook.test514
-rw-r--r--tk8.6/tests/ttk/panedwindow.test291
-rw-r--r--tk8.6/tests/ttk/progressbar.test85
-rw-r--r--tk8.6/tests/ttk/radiobutton.test48
-rw-r--r--tk8.6/tests/ttk/scrollbar.test69
-rw-r--r--tk8.6/tests/ttk/spinbox.test280
-rw-r--r--tk8.6/tests/ttk/treetags.test221
-rw-r--r--tk8.6/tests/ttk/treeview.test639
-rw-r--r--tk8.6/tests/ttk/ttk.test647
-rw-r--r--tk8.6/tests/ttk/validate.test277
-rw-r--r--tk8.6/tests/ttk/vsapi.test47
-rw-r--r--tk8.6/tests/unixButton.test255
-rw-r--r--tk8.6/tests/unixEmbed.test717
-rw-r--r--tk8.6/tests/unixFont.test318
-rw-r--r--tk8.6/tests/unixMenu.test1275
-rw-r--r--tk8.6/tests/unixSelect.test437
-rw-r--r--tk8.6/tests/unixWm.test2537
-rw-r--r--tk8.6/tests/util.test68
-rw-r--r--tk8.6/tests/visual.test570
-rw-r--r--tk8.6/tests/visual_bb.test116
-rw-r--r--tk8.6/tests/winButton.test203
-rw-r--r--tk8.6/tests/winClipboard.test122
-rwxr-xr-xtk8.6/tests/winDialog.test1057
-rw-r--r--tk8.6/tests/winFont.test392
-rw-r--r--tk8.6/tests/winMenu.test1385
-rw-r--r--tk8.6/tests/winMsgbox.test300
-rw-r--r--tk8.6/tests/winSend.test407
-rw-r--r--tk8.6/tests/winWm.test577
-rw-r--r--tk8.6/tests/window.test351
-rw-r--r--tk8.6/tests/winfo.test485
-rw-r--r--tk8.6/tests/wm.test2321
-rw-r--r--tk8.6/tests/xmfbox.test166
132 files changed, 99446 insertions, 0 deletions
diff --git a/tk8.6/tests/README b/tk8.6/tests/README
new file mode 100644
index 0000000..677e76c
--- /dev/null
+++ b/tk8.6/tests/README
@@ -0,0 +1,5 @@
+README -- Tk test suite design document.
+
+This directory contains a set of validation tests for the Tk commands.
+Please see the tests/README file in the Tcl source distribution for
+information about the test suite.
diff --git a/tk8.6/tests/all.tcl b/tk8.6/tests/all.tcl
new file mode 100644
index 0000000..d15e5ca
--- /dev/null
+++ b/tk8.6/tests/all.tcl
@@ -0,0 +1,19 @@
+# all.tcl --
+#
+# This file contains a top-level script to run all of the Tk
+# tests. Execute it by invoking "source all.tcl" when running tktest
+# in this directory.
+#
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tk ;# This is the Tk test suite; fail early if no Tk!
+package require tcltest 2.2
+tcltest::configure {*}$argv
+tcltest::configure -testdir [file normalize [file dirname [info script]]]
+tcltest::configure -loadfile \
+ [file join [tcltest::testsDirectory] constraints.tcl]
+tcltest::configure -singleproc 1
+tcltest::runAllTests
diff --git a/tk8.6/tests/arc.tcl b/tk8.6/tests/arc.tcl
new file mode 100644
index 0000000..d0a93ea
--- /dev/null
+++ b/tk8.6/tests/arc.tcl
@@ -0,0 +1,151 @@
+# This file creates a visual test for arcs. It is part of the Tk
+# visual test suite, which is invoked via the "visual" script.
+
+catch {destroy .t}
+toplevel .t
+wm title .t "Visual Tests for Canvas Arcs"
+wm iconname .t "Arcs"
+wm geom .t +0+0
+wm minsize .t 1 1
+
+canvas .t.c -width 650 -height 600 -relief raised
+pack .t.c -expand yes -fill both
+button .t.quit -text Quit -command {destroy .t}
+pack .t.quit -side bottom -pady 3 -ipadx 4 -ipady 2
+
+puts "depth is [winfo depth .t]"
+if {[winfo depth .t] > 1} {
+ set fill1 aquamarine3
+ set fill2 aquamarine3
+ set fill3 IndianRed1
+ set outline2 IndianRed3
+} else {
+ set fill1 black
+ set fill2 white
+ set fill3 Black
+ set outline2 white
+}
+set outline black
+
+.t.c create arc 20 20 220 120 -start 30 -extent 270 -outline $fill1 -width 14 \
+ -style arc
+.t.c create arc 260 20 460 120 -start 30 -extent 270 -fill $fill2 -width 14 \
+ -style chord -outline $outline
+.t.c create arc 500 20 620 160 -start 30 -extent 270 -fill {} -width 14 \
+ -style chord -outline $outline -outlinestipple gray50
+.t.c create arc 20 260 140 460 -start 45 -extent 90 -fill $fill2 -width 14 \
+ -style pieslice -outline $outline
+.t.c create arc 180 260 300 460 -start 45 -extent 90 -fill {} -width 14 \
+ -style pieslice -outline $outline
+.t.c create arc 340 260 460 460 -start 30 -extent 150 -fill $fill2 -width 14 \
+ -style chord -outline $outline -stipple gray50 -outlinestipple gray25
+.t.c create arc 500 260 620 460 -start 30 -extent 150 -fill {} -width 14 \
+ -style chord -outline $outline
+.t.c create arc 20 450 140 570 -start 135 -extent 270 -fill $fill1 -width 14 \
+ -style pieslice -outline {}
+.t.c create arc 180 450 300 570 -start 30 -extent -90 -fill $fill1 -width 14 \
+ -style pieslice -outline {}
+.t.c create arc 340 450 460 570 -start 320 -extent 270 -fill $fill1 -width 14 \
+ -style chord -outline {}
+.t.c create arc 500 450 620 570 -start 350 -extent -110 -fill $fill1 -width 14 \
+ -style chord -outline {}
+.t.c addtag arc withtag all
+.t.c addtag circle withtag [.t.c create oval 320 200 340 220 -fill MistyRose3]
+
+.t.c bind arc <Any-Enter> {
+ set prevFill [lindex [.t.c itemconf current -fill] 4]
+ set prevOutline [lindex [.t.c itemconf current -outline] 4]
+ if {($prevFill != "") || ($prevOutline == "")} {
+ .t.c itemconf current -fill $fill3
+ }
+ if {$prevOutline != ""} {
+ .t.c itemconf current -outline $outline2
+ }
+}
+.t.c bind arc <Any-Leave> {.t.c itemconf current -fill $prevFill -outline $prevOutline}
+
+bind .t.c <1> {markarea %x %y}
+bind .t.c <B1-Motion> {strokearea %x %y}
+
+proc markarea {x y} {
+ global areaX1 areaY1
+ set areaX1 $x
+ set areaY1 $y
+}
+
+proc strokearea {x y} {
+ global areaX1 areaY1 areaX2 areaY2
+ if {($areaX1 != $x) && ($areaY1 != $y)} {
+ .t.c delete area
+ .t.c addtag area withtag [.t.c create rect $areaX1 $areaY1 $x $y \
+ -outline black]
+ set areaX2 $x
+ set areaY2 $y
+ }
+}
+
+bind .t.c <Control-f> {
+ puts stdout "Enclosed: [.t.c find enclosed $areaX1 $areaY1 $areaX2 $areaY2]"
+ puts stdout "Overlapping: [.t.c find overl $areaX1 $areaY1 $areaX2 $areaY2]"
+}
+
+bind .t.c <3> {puts stdout "%x %y"}
+
+# The code below allows the circle to be move by shift-dragging.
+
+bind .t.c <Shift-1> {
+ set curx %x
+ set cury %y
+}
+
+bind .t.c <Shift-B1-Motion> {
+ .t.c move circle [expr %x-$curx] [expr %y-$cury]
+ set curx %x
+ set cury %y
+}
+
+# The binding below flashes the closest item to the mouse.
+
+bind .t.c <Control-c> {
+ set closest [.t.c find closest %x %y]
+ set oldfill [lindex [.t.c itemconf $closest -fill] 4]
+ .t.c itemconf $closest -fill IndianRed1
+ after 200 [list .t.c itemconfig $closest -fill $oldfill]
+}
+
+proc c {option value} {.t.c itemconf 2 $option $value}
+
+bind .t.c a {
+ set go 1
+ set i 1
+ while {$go} {
+ if {$i >= 50} {
+ set delta -5
+ }
+ if {$i <= 5} {
+ set delta 5
+ }
+ incr i $delta
+ c -start $i
+ c -extent [expr 360-2*$i]
+ after 20
+ update
+ }
+}
+
+bind .t.c b {set go 0}
+
+bind .t.c <Control-x> {.t.c delete current}
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tk8.6/tests/bell.test b/tk8.6/tests/bell.test
new file mode 100644
index 0000000..4f7df97
--- /dev/null
+++ b/tk8.6/tests/bell.test
@@ -0,0 +1,53 @@
+# This file is a Tcl script to test out Tk's "bell" command.
+# It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1998-2000 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test bell-1.1 {bell command} -body {
+ bell a
+} -returnCodes {error} -result {bad option "a": must be -displayof or -nice}
+
+test bell-1.2 {bell command} -body {
+ bell a b
+} -returnCodes {error} -result {bad option "a": must be -displayof or -nice}
+
+test bell-1.3 {bell command} -body {
+ bell -displayof gorp
+} -returnCodes {error} -result {bad window path name "gorp"}
+
+test bell-1.4 {bell command} -body {
+ bell -nice -displayof
+} -returnCodes {error} -result {wrong # args: should be "bell ?-displayof window? ?-nice?"}
+
+test bell-1.5 {bell command} -body {
+ bell -nice -nice -nice
+} -returnCodes {ok} -result {} ;#keep -result {} and -retutnCodes {ok} for clarity?
+
+test bell-1.6 {bell command} -body {
+ bell -displayof . -nice
+} -returnCodes {ok} -result {}
+
+test bell-1.7 {bell command} -body {
+ bell -nice -displayof . -nice
+} -returnCodes {error} -result {wrong # args: should be "bell ?-displayof window? ?-nice?"}
+
+test bell-1.8 {bell command} -body {
+ puts "Bell should ring now ..."
+ flush stdout
+ after 200
+ bell -displayof .
+ after 200
+ bell -nice
+ after 200
+ bell
+} -result {}
+
+cleanupTests
+return
diff --git a/tk8.6/tests/bevel.tcl b/tk8.6/tests/bevel.tcl
new file mode 100644
index 0000000..4af60f3
--- /dev/null
+++ b/tk8.6/tests/bevel.tcl
@@ -0,0 +1,158 @@
+# This file creates a visual test for bevels drawn around text in text
+# widgets. It is part of the Tk visual test suite, which is invoked
+# via the "visual" script.
+
+catch {destroy .t}
+toplevel .t
+wm title .t "Visual Tests for Borders in Text Widgets"
+wm iconname .t "Text Borders"
+wm geom .t +0+0
+
+text .t.t -width 60 -height 30 -setgrid true -xscrollcommand {.t.h set} \
+ -font {Courier 12} \
+ -yscrollcommand {.t.v set} -wrap none -relief raised -bd 2
+scrollbar .t.v -orient vertical -command ".t.t yview"
+scrollbar .t.h -orient horizontal -command ".t.t xview"
+button .t.quit -text Quit -command {destroy .t}
+pack .t.quit -side bottom -pady 3 -ipadx 4 -ipady 2
+pack .t.h -side bottom -fill x
+pack .t.v -side right -fill y
+pack .t.t -expand yes -fill both
+wm minsize .t 1 1
+
+if {[winfo depth .t] > 1} {
+ .t.t tag configure r1 -relief raised -borderwidth 2 -background #b2dfee
+ .t.t tag configure r2 -relief raised -borderwidth 2 -background #b2dfee \
+ -offset 2
+ .t.t tag configure s1 -relief sunken -borderwidth 2 -background #b2dfee
+} else {
+ .t.t tag configure r1 -relief raised -borderwidth 2 -background white
+ .t.t tag configure r2 -relief raised -borderwidth 2 -background white \
+ -offset 2
+ .t.t tag configure s1 -relief sunken -borderwidth 2 -background white
+}
+.t.t tag configure indent1 -lmargin1 100
+.t.t tag configure indent2 -lmargin1 200
+
+.t.t insert end {This display contains a bunch of raised and sunken
+regions to exercise the bevel-drawing facilities of
+DisplayLineBackground. The letters have the following
+significance:
+
+r - should appear raised
+u - should appear raised and also slightly offset vertically
+s - should appear sunken
+S - should appear solid
+n - preceding relief should extend right to end of line.
+* - should appear "normal"
+x - extra long lines to allow horizontal scrolling.
+
+Try scrolling the text both vertically and horizontally to
+be sure that the bevels are still drawn correctly.
+
+xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+
+Pass 1 (side bevels):
+
+}
+.t.t insert end ****
+.t.t insert end rrrrrrr r1
+.t.t insert end uuuu r2
+.t.t insert end ************
+.t.t insert end ssssssssssssssssss s1
+.t.t insert end \n\n****************
+.t.t insert end rrrrrrrrrrrrrrn\n r1
+
+.t.t insert end "\nPass 2 (top bevels):\n\n"
+.t.t insert end rrrrrrrrrrrrrr r1
+.t.t insert end rrrrr {r1 dummy}
+.t.t insert end rrrrrrrrrrrrrrrrrrr r1
+.t.t insert end \n************
+.t.t insert end rrrrrrrrrrrrrrrrr r1
+.t.t insert end ***********\n
+.t.t insert end rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr r1
+.t.t insert end \n\n***
+.t.t insert end rrrrrrrrrrrrrrrrrrr r1
+.t.t insert end ***********\n*
+.t.t insert end rrrrrrrrr r1
+.t.t insert end ********
+.t.t insert end rrrrrrrrrrrrrrrrrrrrrrrrr r1
+.t.t insert end \n\n*
+.t.t insert end *** dummy
+.t.t insert end rrrrrrrrrrrrrrrrrrrrrrrrr r1
+.t.t insert end n\nrrrrrrrrrrrrrrr {r1 indent1}
+.t.t insert end \n\n***
+.t.t insert end rrr r1
+.t.t insert end \n
+.t.t insert end rrrr {r1 indent1}
+
+.t.t insert end \n\nxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n\n
+.t.t insert end "Pass 3 (bottom bevels):\n\n"
+.t.t insert end *******
+.t.t insert end ********** dummy
+.t.t insert end rrrrrrrrrrrrrrrr r1
+.t.t insert end **********\n
+.t.t insert end rrrrrrrrr r1
+.t.t insert end uuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuu r2
+.t.t insert end \n********************
+.t.t insert end rrrrrrrrrrrrrrr r1
+.t.t insert end ************\n\n*
+.t.t insert end rrrrrrrrrrrr r1
+.t.t insert end ********
+.t.t insert end rrrrrrrrrrrrrrrrrrrrrrrrr r1
+.t.t insert end \n*****
+.t.t insert end rrrrrrrrrrrrrrrrrrrr r1
+.t.t insert end **********\n\n
+.t.t insert end rrrrrrrrrrrrrrr {r1 indent1}
+.t.t insert end \n** dummy
+.t.t insert end **
+.t.t insert end rrrrrrrrrrrrrrrrrrrrn\n r1
+.t.t insert end \n
+.t.t insert end rrrr {r1 indent1}
+.t.t insert end \n***
+.t.t insert end rrr r1
+
+.t.t insert end \n\nMiscellaneous:\n\n
+.t.t insert end rrr r1
+.t.t insert end *****
+.t.t insert end rrr r1
+foreach i {1 2 3} {
+ .t.t insert end \n
+ .t.t insert end ***
+ .t.t insert end rrrrr r1
+}
+.t.t insert end \n
+.t.t insert end rrr r1
+.t.t insert end *****
+.t.t insert end rrr r1
+
+font configure TkFixedFont -size 20
+.t.t tag configure sol100 -relief solid -borderwidth 100 \
+ -foreground red -font TkFixedFont
+.t.t tag configure sol12 -relief solid -borderwidth 12 \
+ -foreground red -font TkFixedFont
+.t.t tag configure big -font TkFixedFont
+set ind [.t.t index end]
+
+.t.t insert end "\n\nBorders do not leak on the neighbour chars"
+.t.t insert end "\nOnly \"S\" is on dark background"
+.t.t insert end {
+ xxx
+ x} {} S sol100 {x
+ xxx}
+
+.t.t insert end "\n\nA very thick border grows toward the inside of the tagged area only"
+.t.t insert end "\nOnly \"S\" is on dark background"
+.t.t insert end {
+ xxxx} {} SSSSS sol100 {xxxx
+ x} {} SSSSSSSSSSSSSSSSSS sol100 {x
+ xxx} {} SSSSSSSSS sol100 xxxx {}
+
+.t.t insert end "\n\nA thinner border is continuous"
+.t.t insert end {
+ xxxx} {} SSSSS sol12 {xxxx
+ x} {} SSSSSSSSSSSSSSSSSS sol12 {x
+ xxx} {} SSSSSSSSS sol12 xxxx {}
+
+.t.t tag add big $ind end
+
diff --git a/tk8.6/tests/bgerror.test b/tk8.6/tests/bgerror.test
new file mode 100644
index 0000000..fd9594a
--- /dev/null
+++ b/tk8.6/tests/bgerror.test
@@ -0,0 +1,67 @@
+# This file is a Tcl script to test the bgerror command.
+# It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test bgerror-1.1 {bgerror / tkerror compat} -setup {
+ set errRes {}
+ proc tkerror {err} {
+ global errRes;
+ set errRes $err;
+ }
+} -body {
+ after 0 {error err1}
+ vwait errRes;
+ return $errRes;
+} -cleanup {
+ catch {rename tkerror {}}
+} -result {err1}
+
+test bgerror-1.2 {bgerror / tkerror compat / accumulation} -setup {
+ set errRes {}
+ proc tkerror {err} {
+ global errRes;
+ lappend errRes $err;
+ }
+} -body {
+ after 0 {error err1}
+ after 0 {error err2}
+ after 0 {error err3}
+ update
+ return $errRes;
+} -cleanup {
+ catch {rename tkerror {}}
+} -result {err1 err2 err3}
+
+test bgerror-1.3 {bgerror / tkerror compat / accumulation / break} -setup {
+ set errRes {}
+ proc tkerror {err} {
+ global errRes;
+ lappend errRes $err;
+ return -code break "skip!";
+ }
+} -body {
+ after 0 {error err1}
+ after 0 {error err2}
+ after 0 {error err3}
+ update
+ return $errRes;
+} -cleanup {
+ catch {rename tkerror {}}
+} -result {err1}
+
+
+# some testing of the default error dialog
+# would be needed too, but that's not easy at all
+# to emulate.
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/bind.test b/tk8.6/tests/bind.test
new file mode 100644
index 0000000..892ba36
--- /dev/null
+++ b/tk8.6/tests/bind.test
@@ -0,0 +1,6124 @@
+# This file is a Tcl script to test out Tk's "bind" and "bindtags"
+# commands plus the procedures in tkBind.c. It is organized in the
+# standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+tk useinputmethods 0
+
+toplevel .t -width 100 -height 50
+wm geom .t +0+0
+update idletasks
+
+foreach p [event info] {event delete $p}
+foreach event [bind Test] {
+ bind Test $event {}
+}
+foreach event [bind all] {
+ bind all $event {}
+}
+
+proc unsetBindings {} {
+ bind all <Enter> {}
+ bind Test <Enter> {}
+ bind Toplevel <Enter> {}
+ bind xyz <Enter> {}
+ bind {a b} <Enter> {}
+ bind .t <Enter> {}
+}
+
+# move the mouse pointer away of the testing area
+# otherwise some spurious events may pollute the tests
+toplevel .top
+wm geometry .top 50x50-50-50
+update
+event generate .top <Button-1> -warp 1
+update
+destroy .top
+
+test bind-1.1 {bind command} -body {
+ bind
+} -returnCodes error -result {wrong # args: should be "bind window ?pattern? ?command?"}
+test bind-1.2 {bind command} -body {
+ bind a b c d
+} -returnCodes error -result {wrong # args: should be "bind window ?pattern? ?command?"}
+test bind-1.3 {bind command} -body {
+ bind .gorp
+} -returnCodes error -result {bad window path name ".gorp"}
+test bind-1.4 {bind command} -body {
+ bind foo
+} -returnCodes ok -result {}
+test bind-1.5 {bind command} -body {
+ bind .t <gorp-> {}
+} -returnCodes ok -result {}
+test bind-1.6 {bind command} -body {
+ frame .t.f
+ bind .t.f <Enter> {test script}
+ set result [bind .t.f <Enter>]
+ bind .t.f <Enter> {}
+ list $result [bind .t.f <Enter>]
+} -cleanup {
+ destroy .t.f
+} -result {{test script} {}}
+test bind-1.7 {bind command} -body {
+ frame .t.f
+ bind .t.f <Enter> {test script}
+ bind .t.f <Enter> {+more text}
+ bind .t.f <Enter>
+} -cleanup {
+ destroy .t.f
+} -result {test script
+more text}
+test bind-1.8 {bind command} -body {
+ bind .t <gorp-> {test script}
+} -returnCodes error -result {bad event type or keysym "gorp"}
+test bind-1.9 {bind command} -body {
+ catch {bind .t <gorp-> {test script}}
+ bind .t
+} -result {}
+test bind-1.10 {bind command} -body {
+ bind .t <gorp->
+} -returnCodes ok -result {}
+test bind-1.11 {bind command} -body {
+ frame .t.f
+ bind .t.f <Enter> {script 1}
+ bind .t.f <Leave> {script 2}
+ bind .t.f a {script for a}
+ bind .t.f b {script for b}
+ lsort [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {<Enter> <Leave> a b}
+
+test bind-2.1 {bindtags command} -body {
+ bindtags
+} -returnCodes error -result {wrong # args: should be "bindtags window ?taglist?"}
+test bind-2.2 {bindtags command} -body {
+ bindtags a b c
+} -returnCodes error -result {wrong # args: should be "bindtags window ?taglist?"}
+test bind-2.3 {bindtags command} -body {
+ bindtags .foo
+} -returnCodes error -result {bad window path name ".foo"}
+test bind-2.4 {bindtags command} -body {
+ bindtags .t
+} -result {.t Toplevel all}
+test bind-2.5 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f
+} -cleanup {
+ destroy .t.f
+} -result {.t.f Frame .t all}
+test bind-2.6 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {{x y z} b c d}
+ bindtags .t.f
+} -cleanup {
+ destroy .t.f
+} -result {{x y z} b c d}
+test bind-2.7 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {x y z}
+ bindtags .t.f {}
+ bindtags .t.f
+} -cleanup {
+ destroy .t.f
+} -result {.t.f Frame .t all}
+test bind-2.8 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {x y z}
+ bindtags .t.f {a b c d}
+ bindtags .t.f
+} -cleanup {
+ destroy .t.f
+} -result {a b c d}
+test bind-2.9 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {a b c}
+ bindtags .t.f "\{"
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {unmatched open brace in list}
+test bind-2.10 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {a b c}
+ catch {bindtags .t.f "\{"}
+ bindtags .t.f
+} -cleanup {
+ destroy .t.f
+} -result {.t.f Frame .t all}
+test bind-2.11 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {a b c}
+ bindtags .t.f "a .gorp b"
+} -cleanup {
+ destroy .t.f
+} -returnCodes ok
+test bind-2.12 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {a b c}
+ catch {bindtags .t.f "a .gorp b"}
+ bindtags .t.f
+} -cleanup {
+ destroy .t.f
+} -result {a .gorp b}
+
+
+test bind-3.1 {TkFreeBindingTags procedure} -body {
+ frame .t.f
+ bindtags .t.f "a b c d"
+ destroy .t.f
+} -cleanup {
+ destroy .t.f
+} -result {}
+test bind-3.2 {TkFreeBindingTags procedure} -body {
+ frame .t.f
+ catch {bindtags .t.f "a .gorp b .t.f"}
+ destroy .t.f
+} -cleanup {
+ destroy .t.f
+} -result {}
+
+
+test bind-4.1 {TkBindEventProc procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ update
+ set x {}
+} -body {
+ bind all <Enter> {lappend x "%W enter all"}
+ bind Test <Enter> {lappend x "%W enter frame"}
+ bind Toplevel <Enter> {lappend x "%W enter toplevel"}
+ bind xyz <Enter> {lappend x "%W enter xyz"}
+ bind {a b} <Enter> {lappend x "%W enter {a b}"}
+ bind .t <Enter> {lappend x "%W enter .t"}
+ bind .t.f <Enter> {lappend x "%W enter .t.f"}
+
+ event generate .t.f <Enter>
+ return $x
+} -cleanup {
+ destroy .t.f
+ unsetBindings
+} -result {{.t.f enter .t.f} {.t.f enter frame} {.t.f enter .t} {.t.f enter all}}
+test bind-4.2 {TkBindEventProc procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ update
+ set x {}
+} -body {
+ bind all <Enter> {lappend x "%W enter all"}
+ bind Test <Enter> {lappend x "%W enter frame"}
+ bind Toplevel <Enter> {lappend x "%W enter toplevel"}
+ bind xyz <Enter> {lappend x "%W enter xyz"}
+ bind {a b} <Enter> {lappend x "%W enter {a b}"}
+ bind .t <Enter> {lappend x "%W enter .t"}
+ bind .t.f <Enter> {lappend x "%W enter .t.f"}
+
+ bindtags .t.f {.t.f {a b} xyz}
+ event generate .t.f <Enter>
+ return $x
+} -cleanup {
+ destroy .t.f
+ unsetBindings
+} -result {{.t.f enter .t.f} {.t.f enter {a b}} {.t.f enter xyz}}
+test bind-4.3 {TkBindEventProc procedure} -body {
+ set x {}
+ bind all <Enter> {lappend x "%W enter all"}
+ bind Test <Enter> {lappend x "%W enter frame"}
+ bind Toplevel <Enter> {lappend x "%W enter toplevel"}
+ bind xyz <Enter> {lappend x "%W enter xyz"}
+ bind {a b} <Enter> {lappend x "%W enter {a b}"}
+ bind .t <Enter> {lappend x "%W enter .t"}
+
+ event generate .t <Enter>
+ return $x
+} -cleanup {
+ unsetBindings
+} -result {{.t enter .t} {.t enter toplevel} {.t enter all}}
+test bind-4.4 {TkBindEventProc procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ frame .t.f3 -width 50 -height 50
+ pack .t.f3
+ update
+ set x {}
+} -body {
+ bind all <Enter> {lappend x "%W enter all"}
+ bind Test <Enter> {lappend x "%W enter frame"}
+ bind Toplevel <Enter> {lappend x "%W enter toplevel"}
+ bind xyz <Enter> {lappend x "%W enter xyz"}
+ bind {a b} <Enter> {lappend x "%W enter {a b}"}
+ bind .t <Enter> {lappend x "%W enter .t"}
+
+ bindtags .t.f {.t.f .t.f2 .t.f3}
+ bind .t.f <Enter> {lappend x "%W enter .t.f"}
+ bind .t.f3 <Enter> {lappend x "%W enter .t.f3"}
+ event generate .t.f <Enter>
+ return $x
+} -cleanup {
+ destroy .t.f .t.f3
+ unsetBindings
+} -result {{.t.f enter .t.f} {.t.f enter .t.f3}}
+test bind-4.5 {TkBindEventProc procedure} -setup {
+ # This tests memory allocation for objPtr; it won't serve any useful
+ # purpose unless run with some sort of allocation checker turned on.
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ update
+} -body {
+ bind all <Enter> {lappend x "%W enter all"}
+ bind Test <Enter> {lappend x "%W enter frame"}
+ bind Toplevel <Enter> {lappend x "%W enter toplevel"}
+ bind xyz <Enter> {lappend x "%W enter xyz"}
+ bind {a b} <Enter> {lappend x "%W enter {a b}"}
+ bind .t <Enter> {lappend x "%W enter .t"}
+ bindtags .t.f {a b c d e f g h i j k l m n o p q r s t u v w x y z}
+
+ event generate .t.f <Enter>
+} -cleanup {
+ destroy .t.f
+ unsetBindings
+} -result {}
+
+
+test bind-5.1 {Tk_CreateBindingTable procedure} -body {
+ canvas .t.c
+ .t.c bind foo
+} -cleanup {
+ destroy .t.c
+} -result {}
+
+
+test bind-6.1 {Tk_DeleteBindTable procedure} -body {
+ canvas .t.c
+ .t.c bind foo <1> {string 1}
+ .t.c create rectangle 0 0 100 100
+ .t.c bind 1 <2> {string 2}
+ destroy .t.c
+} -cleanup {
+ destroy .t.c
+} -result {}
+test bind-7.1 {Tk_CreateBinding procedure: bad binding} -body {
+ canvas .t.c
+ .t.c bind foo <
+} -cleanup {
+ destroy .t.c
+} -returnCodes error -result {no event type or button # or keysym}
+test bind-7.3 {Tk_CreateBinding procedure: append} -body {
+ canvas .t.c
+ .t.c bind foo <1> "button 1"
+ .t.c bind foo <1> "+more button 1"
+ .t.c bind foo <1>
+} -cleanup {
+ destroy .t.c
+} -result {button 1
+more button 1}
+test bind-7.4 {Tk_CreateBinding procedure: append to non-existing} -body {
+ canvas .t.c
+ .t.c bind foo <1> "+button 1"
+ .t.c bind foo <1>
+} -cleanup {
+ destroy .t.c
+} -result {button 1}
+
+test bind-8.1 {Tk_CreateBinding: error} -body {
+ bind . <xyz> "xyz"
+} -returnCodes error -result {bad event type or keysym "xyz"}
+
+test bind-9.1 {Tk_DeleteBinding procedure} -body {
+ frame .t.f -class Test -width 150 -height 100
+ bind .t.f <
+} -cleanup {
+ destroy .t.f
+} -returnCodes ok
+test bind-9.2 {Tk_DeleteBinding procedure} -setup {
+ set result {}
+} -body {
+ frame .t.f -class Test -width 150 -height 100
+ foreach i {a b c d} {
+ bind .t.f $i "binding for $i"
+ }
+ foreach i {b d a c} {
+ bind .t.f $i {}
+ lappend result [lsort [bind .t.f]]
+ }
+ return $result
+} -cleanup {
+ destroy .t.f
+} -result {{a c d} {a c} c {}}
+test bind-9.3 {Tk_DeleteBinding procedure} -setup {
+ set result {}
+} -body {
+ frame .t.f -class Test -width 150 -height 100
+ foreach i {<1> <Meta-1> <Control-1> <Double-Alt-1>} {
+ bind .t.f $i "binding for $i"
+ }
+ foreach i {<Control-1> <Double-Alt-1> <1> <Meta-1>} {
+ bind .t.f $i {}
+ lappend result [lsort [bind .t.f]]
+ }
+ return $result
+} -cleanup {
+ destroy .t.f
+} -result {{<Button-1> <Double-Alt-Button-1> <Meta-Button-1>} {<Button-1> <Meta-Button-1>} <Meta-Button-1> {}}
+
+test bind-10.1 {Tk_GetBinding procedure} -body {
+ canvas .t.c
+ .t.c bind foo <
+} -cleanup {
+ destroy .t.c
+} -returnCodes error -result {no event type or button # or keysym}
+test bind-10.2 {Tk_GetBinding procedure} -body {
+ canvas .t.c
+ .t.c bind foo a Test
+ .t.c bind foo a
+} -cleanup {
+ destroy .t.c
+} -result {Test}
+
+test bind-11.1 {Tk_GetAllBindings procedure} -body {
+ frame .t.f
+ foreach i "! a \\\{ ~ <Delete> <space> <<Paste>> <Tab> <Linefeed> <less> <Meta-a> <Acircumflex>" {
+ bind .t.f $i Test
+ }
+ lsort [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {! <<Paste>> <Key-Acircumflex> <Key-Delete> <Key-Linefeed> <Key-Tab> <Key-less> <Key-space> <Meta-Key-a> a \{ ~}
+test bind-11.2 {Tk_GetAllBindings procedure} -body {
+ frame .t.f
+ foreach i "<Double-1> <Triple-1> <Meta-Control-a> <Double-Alt-Enter> <1>" {
+ bind .t.f $i Test
+ }
+ lsort [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {<Button-1> <Control-Meta-Key-a> <Double-Alt-Enter> <Double-Button-1> <Triple-Button-1>}
+test bind-11.3 {Tk_GetAllBindings procedure} -body {
+ frame .t.f
+ foreach i "<Double-Triple-1> abcd a<Leave>b" {
+ bind .t.f $i Test
+ }
+ lsort [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {<Triple-Button-1> a<Leave>b abcd}
+
+
+test bind-12.1 {Tk_DeleteAllBindings procedure} -body {
+ frame .t.f -class Test -width 150 -height 100
+ destroy .t.f
+} -result {}
+test bind-12.2 {Tk_DeleteAllBindings procedure} -body {
+ frame .t.f -class Test -width 150 -height 100
+ foreach i "a b c <Meta-1> <Alt-a> <Control-a>" {
+ bind .t.f $i x
+ }
+ destroy .t.f
+} -result {}
+
+test bind-13.1 {Tk_BindEvent procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind Test <KeyPress> {lappend x "%W %K Test KeyPress"}
+ bind all <KeyPress> {lappend x "%W %K all KeyPress"}
+ bind Test : {lappend x "%W %K Test :"}
+ bind all _ {lappend x "%W %K all _"}
+ bind .t.f : {lappend x "%W %K .t.f :"}
+
+ event generate .t.f <Key-colon>
+ event generate .t.f <Key-plus>
+ event generate .t.f <Key-underscore>
+ return $x
+} -cleanup {
+ destroy .t.f
+ bind all <KeyPress> {}
+ bind Test <KeyPress> {}
+ bind all _ {}
+ bind Test : {}
+} -result {{.t.f colon .t.f :} {.t.f colon Test :} {.t.f colon all KeyPress} {.t.f plus Test KeyPress} {.t.f plus all KeyPress} {.t.f underscore Test KeyPress} {.t.f underscore all _}}
+
+test bind-13.2 {Tk_BindEvent procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind Test <KeyPress> {lappend x "%W %K Test press any"; break}
+ bind all <KeyPress> {continue; lappend x "%W %K all press any"}
+ bind .t.f : {lappend x "%W %K .t.f pressed colon"}
+
+ event generate .t.f <Key-colon>
+ return $x
+} -cleanup {
+ destroy .t.f
+ bind all <KeyPress> {}
+ bind Test <KeyPress> {}
+} -result {{.t.f colon .t.f pressed colon} {.t.f colon Test press any}}
+
+test bind-13.3 {Tk_BindEvent procedure} -setup {
+ proc bgerror args {}
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind Test <KeyPress> {lappend x "%W %K Test press any"; error Test}
+ bind .t.f : {lappend x "%W %K .t.f pressed colon"}
+ event generate .t.f <Key-colon>
+ update
+ list $x $errorInfo
+} -cleanup {
+ destroy .t.f
+ bind Test <KeyPress> {}
+ rename bgerror {}
+} -result {{{.t.f colon .t.f pressed colon} {.t.f colon Test press any}} {Test
+ while executing
+"error Test"
+ (command bound to event)}}
+test bind-13.4 {Tk_BindEvent procedure} -setup {
+ proc foo {} {
+ set x 44
+ event generate .t.f <Key-colon>
+ }
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind Test : {lappend x "%W %K Test"}
+ bind .t.f : {lappend x "%W %K .t.f"}
+ foo
+ return $x
+} -cleanup {
+ destroy .t.f
+ bind Test : {}
+} -result {{.t.f colon .t.f} {.t.f colon Test}}
+
+test bind-13.5 {Tk_BindEvent procedure} -body {
+ bind all <Destroy> {lappend x "%W destroyed"}
+ set x {}
+ frame .t.g -gorp foo
+} -cleanup {
+ bind all <Destroy> {}
+} -returnCodes error -result {unknown option "-gorp"}
+test bind-13.6 {Tk_BindEvent procedure} -body {
+ bind all <Destroy> {lappend x "%W destroyed"}
+ set x {}
+ catch {frame .t.g -gorp foo}
+ return $x
+} -cleanup {
+ bind all <Destroy> {}
+} -result {{.t.g destroyed}}
+
+test bind-13.7 {Tk_BindEvent procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f : {lappend x "%W (.t.f binding)"}
+ bind Test : {lappend x "%W (Test binding)"}
+ bind all : {bind .t.f : {}; lappend x "%W (all binding)"}
+ event generate .t.f <Key-colon>
+ return $x
+} -cleanup {
+ bind Test : {}
+ bind all : {}
+ destroy .t.f
+} -result {{.t.f (.t.f binding)} {.t.f (Test binding)} {.t.f (all binding)}}
+test bind-13.8 {Tk_BindEvent procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f : {lappend x "%W (.t.f binding)"}
+ bind Test : {lappend x "%W (Test binding)"}
+ bind all : {destroy .t.f; lappend x "%W (all binding)"}
+ event generate .t.f <Key-colon>
+ return $x
+} -cleanup {
+ bind Test : {}
+ bind all : {}
+ destroy .t.f
+} -result {{.t.f (.t.f binding)} {.t.f (Test binding)} {.t.f (all binding)}}
+
+test bind-13.9 {Tk_BindEvent procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <1> {lappend x "%W z (.t.f <1> binding)"}
+ bind .t.f <ButtonPress> {lappend x "%W z (.t.f <ButtonPress> binding)"}
+ event generate .t.f <Button-1>
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {{.t.f z (.t.f <1> binding)} {.t.f z (.t.f <ButtonPress> binding)}}
+test bind-13.10 {Tk_BindEvent procedure: ignore NotifyInferior} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x Enter%#"
+ bind .t.f <Leave> "lappend x Leave%#"
+ event generate .t.f <Enter> -serial 100 -detail NotifyAncestor
+ event generate .t.f <Enter> -serial 101 -detail NotifyInferior
+ event generate .t.f <Leave> -serial 102 -detail NotifyAncestor
+ event generate .t.f <Leave> -serial 103 -detail NotifyInferior
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Enter100 Leave102}
+test bind-13.11 {Tk_BindEvent procedure: collapse Motions} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Motion> "lappend x Motion%#(%x,%y)"
+ event generate .t.f <Motion> -serial 100 -x 100 -y 200 -when tail
+ update
+ event generate .t.f <Motion> -serial 101 -x 200 -y 300 -when tail
+ event generate .t.f <Motion> -serial 102 -x 300 -y 400 -when tail
+ update
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Motion100(100,200) Motion102(300,400)}
+test bind-13.12 {Tk_BindEvent procedure: collapse repeating modifiers} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key> "lappend x %K%#"
+ bind .t.f <KeyRelease> "lappend x %K%#"
+ event generate .t.f <Key-Shift_L> -serial 100 -when tail
+ event generate .t.f <KeyRelease-Shift_L> -serial 101 -when tail
+ event generate .t.f <Key-Shift_L> -serial 102 -when tail
+ event generate .t.f <KeyRelease-Shift_L> -serial 103 -when tail
+ update
+} -cleanup {
+ destroy .t.f
+} -result {}
+test bind-13.13 {Tk_BindEvent procedure: valid key detail} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x Key%K"
+ bind .t.f <KeyRelease> "lappend x Release%K"
+ event generate .t.f <Key> -keysym colon
+ event generate .t.f <KeyRelease> -keysym colon
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Keycolon Releasecolon}
+test bind-13.14 {Tk_BindEvent procedure: invalid key detail} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x Key%K"
+ bind .t.f <KeyRelease> "lappend x Release%K"
+ event generate .t.f <Key> -keycode 0
+ event generate .t.f <KeyRelease> -keycode 0
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Key?? Release??}
+test bind-13.15 {Tk_BindEvent procedure: button detail} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x Button%b"
+ bind .t.f <ButtonRelease> "lappend x Release%b"
+ event generate .t.f <Button> -button 1
+ event generate .t.f <ButtonRelease> -button 3
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {Button1 Release3}
+test bind-13.16 {Tk_BindEvent procedure: virtual detail} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> "lappend x Paste"
+ event generate .t.f <<Paste>>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Paste}
+test bind-13.17 {Tk_BindEvent procedure: virtual event in event stream} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> "lappend x Paste"
+ event generate .t.f <<Paste>>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Paste}
+test bind-13.18 {Tk_BindEvent procedure: match detail physical} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-2> {set x Button-2}
+ event add <<Paste>> <Button-2>
+ bind .t.f <<Paste>> {set x Paste}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-2>
+} -result {Button-2}
+
+test bind-13.19 {Tk_BindEvent procedure: no match detail physical} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ event add <<Paste>> <Button-2>
+ bind .t.f <<Paste>> {set x Paste}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-2>
+} -result {Paste}
+test bind-13.20 {Tk_BindEvent procedure: match detail virtual} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ event add <<Paste>> <Button-2>
+ bind .t.f <<Paste>> "lappend x Paste"
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-2>
+} -result {Paste}
+test bind-13.21 {Tk_BindEvent procedure: no match detail virtual} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ event add <<Paste>> <Button-2>
+ bind .t.f <<Paste>> "lappend x Paste"
+ event generate .t.f <Button>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-2>
+} -result {}
+test bind-13.22 {Tk_BindEvent procedure: match no-detail physical} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> {set x Button}
+ event add <<Paste>> <Button>
+ bind .t.f <<Paste>> {set x Paste}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button>
+} -result {Button}
+test bind-13.23 {Tk_BindEvent procedure: no match no-detail physical} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ event add <<Paste>> <Button>
+ bind .t.f <<Paste>> {set x Paste}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button>
+} -result {Paste}
+test bind-13.24 {Tk_BindEvent procedure: match no-detail virtual} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ event add <<Paste>> <Button>
+ bind .t.f <<Paste>> "lappend x Paste"
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button>
+} -result {Paste}
+test bind-13.25 {Tk_BindEvent procedure: no match no-detail virtual} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ event add <<Paste>> <Key>
+ bind .t.f <<Paste>> "lappend x Paste"
+ event generate .t.f <Button>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Key>
+} -result {}
+test bind-13.26 {Tk_BindEvent procedure: precedence} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ event add <<Paste>> <Button-2>
+ event add <<Copy>> <Button>
+ bind .t.f <Button-2> "lappend x Button-2"
+ bind .t.f <<Paste>> "lappend x Paste"
+ bind .t.f <Button> "lappend x Button"
+ bind .t.f <<Copy>> "lappend x Copy"
+
+ event generate .t.f <Button-2>
+ bind .t.f <Button-2> {}
+ event generate .t.f <Button-2>
+ bind .t.f <<Paste>> {}
+ event generate .t.f <Button-2>
+ bind .t.f <Button> {}
+ event generate .t.f <Button-2>
+ bind .t.f <<Copy>> {}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-2>
+ event delete <<Copy>> <Button>
+} -result {Button-2 Paste Button Copy}
+test bind-13.27 {Tk_BindEvent procedure: no detail virtual pattern list} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-2> {set x Button-2}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Button-2}
+test bind-13.28 {Tk_BindEvent procedure: detail virtual pattern list} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ event add <<Paste>> <Button-2>
+ bind .t.f <<Paste>> {set x Paste}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-2>
+} -result {Paste}
+test bind-13.29 {Tk_BindEvent procedure: no no-detail virtual pattern list} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> {set x Button}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Button}
+test bind-13.30 {Tk_BindEvent procedure: no-detail virtual pattern list} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ event add <<Paste>> <Button>
+ bind .t.f <<Paste>> {set x Paste}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button>
+} -result {Paste}
+test bind-13.31 {Tk_BindEvent procedure: no match} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ event generate .t.f <Button-2>
+} -cleanup {
+ destroy .t.f
+} -result {}
+test bind-13.32 {Tk_BindEvent procedure: match} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-2> {set x Button-2}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Button-2}
+test bind-13.33 {Tk_BindEvent procedure: many C bindings cause realloc} -setup {
+ # this test might not be useful anymore [#3009998]
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bindtags .t.f {a b c d e f g h i j k l m n o p}
+ foreach p [bindtags .t.f] {
+ bind $p <1> "lappend x $p"
+ }
+ event generate .t.f <1>
+ return $x
+} -cleanup {
+ foreach p [bindtags .t.f] {bind $p <1> {}}
+ destroy .t.f
+} -result {a b c d e f g h i j k l m n o p}
+test bind-13.34 {Tk_BindEvent procedure: multiple tags} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-2> {lappend x .t.f}
+ bind Test <Button-2> {lappend x Button}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ bind Test <Button-2> {}
+} -result {.t.f Button}
+test bind-13.35 {Tk_BindEvent procedure: execute binding} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <1> {lappend x 1}
+ event generate .t.f <1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-13.38 {Tk_BindEvent procedure: binding gets to run} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind Test <1> {lappend x Test}
+ bind .t.f <1> {lappend x .t.f}
+ event generate .t.f <1>
+ return $x
+} -cleanup {
+ destroy .t.f
+ bind Test <1> {}
+} -result {.t.f Test}
+test bind-13.41 {Tk_BindEvent procedure: continue in script} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-2> {lappend x b1; continue; lappend x b2}
+ bind Test <Button-2> {lappend x B1; continue; lappend x B2}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ bind Test <Button-2> {}
+} -result {b1 B1}
+test bind-13.43 {Tk_BindEvent procedure: break in script} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-2> {lappend x b1; break; lappend x b2}
+ bind Test <Button-2> {lappend x B1; break; lappend x B2}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ bind Test <Button-2> {}
+} -result {b1}
+test bind-13.45 {Tk_BindEvent procedure: error in script} -setup {
+ proc bgerror msg {
+ global x
+ lappend x $msg
+ }
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-2> {lappend x b1; blap}
+ bind Test <Button-2> {lappend x B1}
+ event generate .t.f <Button-2>
+ update
+ return $x
+} -cleanup {
+ destroy .t.f
+ bind Test <Button-2> {}
+ proc bgerror args {}
+} -result {b1 {invalid command name "blap"}}
+
+test bind-15.1 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f 12 {set x 1}
+ set x 0
+ event generate .t.f <Key-1>
+ event generate .t.f <KeyRelease-1>
+ event generate .t.f <Key-2>
+ event generate .t.f <KeyRelease-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.2 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f 12 {set x 1}
+ set x 0
+ event generate .t.f <Key-1>
+ event generate .t.f <Enter>
+ event generate .t.f <KeyRelease-1>
+ event generate .t.f <Leave>
+ event generate .t.f <Key-2>
+ event generate .t.f <KeyRelease-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.3 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f 12 {set x 1}
+ set x 0
+ event generate .t.f <Key-1>
+ event generate .t.f <Button-1>
+ event generate .t.f <Key-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.4 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
+ set x 0
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.5 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-ButtonRelease> {set x 1}
+ set x 0
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.6 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
+ set x 0
+ event generate .t.f <Button-1>
+ event generate .t.f <Key-a>
+ event generate .t.f <ButtonRelease-1>
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.7 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
+ set x 0
+ event generate .t.f <Button-1>
+ event generate .t.f <Key-Shift_L>
+ event generate .t.f <ButtonRelease-1>
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.8 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f ab {set x 1}
+ set x 0
+ event generate .t.f <Key-a>
+ event generate .t.f <Key-c>
+ event generate .t.f <Key-b>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.9 {MatchPatterns procedure, modifier checks} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <M1-M2-Key> {set x 1}
+ set x 0
+ event generate .t.f <Key-a> -state 0x18
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.10 {MatchPatterns procedure, modifier checks} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <M1-M2-Key> {set x 1}
+ set x 0
+ event generate .t.f <Key-a> -state 0xfc
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.11 {MatchPatterns procedure, modifier checks} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <M1-M2-Key> {set x 1}
+ set x 0
+ event generate .t.f <Key-a> -state 0x8
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.12 {MatchPatterns procedure, ignore modifier presses and releases} -constraints {
+ nonPortable
+} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ # This test is non-portable because the Shift_L keysym may behave
+ # differently on some platforms.
+ bind .t.f aB {set x 1}
+ set x 0
+ event generate .t.f <Key-a>
+ event generate .t.f <Key-Shift_L>
+ event generate .t.f <Key-b> -state 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.13 {MatchPatterns procedure, checking detail} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f ab {set x 1}
+ set x 0
+ event generate .t.f <Key-a>
+ event generate .t.f <Key-c>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.14 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
+ set x 0
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -x 30 -y 40
+ event generate .t.f <Button-1> -x 31 -y 39
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.15 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
+ set x 0
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -x 30 -y 40
+ event generate .t.f <Button-1> -x 29 -y 41
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.16 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
+ set x 0
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -x 30 -y 40
+ event generate .t.f <Button-1> -x 40 -y 40
+ event generate .t.f <ButtonRelease-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.17 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
+ set x 0
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -x 30 -y 40
+ event generate .t.f <Button-1> -x 20 -y 40
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.18 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
+ set x 0
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -x 30 -y 40
+ event generate .t.f <Button-1> -x 30 -y 30
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.19 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
+ set x 0
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -x 30 -y 40
+ event generate .t.f <Button-1> -x 30 -y 50
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.20 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
+ set x 0
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -time 300
+ event generate .t.f <Button-1> -time 700
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.21 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
+ set x 0
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -time 300
+ event generate .t.f <Button-1> -time 900
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.22 {MatchPatterns procedure, time wrap-around} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
+ set x 0
+ event generate .t.f <Button-1> -time [expr -100]
+ event generate .t.f <Button-1> -time 200
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.23 {MatchPatterns procedure, time wrap-around} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
+ set x 0
+ event generate .t.f <Button-1> -time -100
+ event generate .t.f <Button-1> -time 500
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+
+test bind-15.24 {MatchPatterns procedure, virtual event} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ event add <<Paste>> <Button-1>
+ bind .t.f <<Paste>> {lappend x paste}
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ set x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-1>
+} -result {paste}
+test bind-15.25 {MatchPatterns procedure, reject a virtual event} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ event add <<Paste>> <Shift-Button-1>
+ bind .t.f <<Paste>> {lappend x paste}
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ set x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Shift-Button-1>
+} -result {}
+test bind-15.26 {MatchPatterns procedure, reject a virtual event} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ event add <<V1>> <Button>
+ event add <<V2>> <Button-1>
+ event add <<V3>> <Shift-Button-1>
+ bind .t.f <<V2>> "lappend x V2%#"
+ event generate .t.f <Button> -serial 101
+ event generate .t.f <Button-1> -serial 102
+ event generate .t.f <Shift-Button-1> -serial 103
+ event generate .t.f <ButtonRelease-1>
+ bind .t.f <Shift-Button-1> "lappend x Shift-Button-1"
+ event generate .t.f <Button> -serial 104
+ event generate .t.f <Button-1> -serial 105
+ event generate .t.f <Shift-Button-1> -serial 106
+ event generate .t.f <ButtonRelease-1>
+ set x
+} -cleanup {
+ destroy .t.f
+ event delete <<V1>> <Button>
+ event delete <<V2>> <Button-1>
+ event delete <<V3>> <Shift-Button-1>
+} -result {V2102 V2103 V2105 Shift-Button-1}
+test bind-15.27 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <KeyPress> {set x 0}
+ bind .t.f 1 {set x 1}
+ set x none
+ event generate .t.f <Key-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.28 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <KeyPress> {set x 0}
+ bind .t.f 1 {set x 1}
+ set x none
+ event generate .t.f <Key-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.29 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <KeyPress> {lappend x 0}
+ bind .t.f 1 {lappend x 1}
+ bind .t.f 21 {lappend x 2}
+ set x none
+ event generate .t.f <Key-2>
+ event generate .t.f <KeyRelease-2>
+ event generate .t.f <Key-1>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {none 0 2}
+test bind-15.30 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <ButtonPress> {set x 0}
+ bind .t.f <1> {set x 1}
+ set x none
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.31 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <M1-Key> {set x 0}
+ bind .t.f <M2-Key> {set x 1}
+ event generate .t.f <Key-a> -state 0x18
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.32 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <M2-Key> {set x 0}
+ bind .t.f <M1-Key> {set x 1}
+ set x none
+ event generate .t.f <Key-a> -state 0x18
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.33 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <1> {lappend x single}
+ bind Test <1> {lappend x single(Test)}
+ bind Test <Double-1> {lappend x double(Test)}
+ event generate .t.f <Button-1>
+ event generate .t.f <Button-1>
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ set x
+} -cleanup {
+ destroy .t.f
+ bind Test <1> {}
+ bind Test <Double-1> {}
+} -result {single single(Test) single double(Test) single double(Test)}
+
+
+test bind-16.1 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x abcd}
+ set x none
+ event generate .t.f <Enter>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {abcd}
+test bind-16.2 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %#}
+ set x none
+ event generate .t.f <Enter> -serial 1234
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {1234}
+test bind-16.3 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Configure> {set x %a}
+ set x none
+ event generate .t.f <Configure> -above .t -window .t.f
+ set x
+} -cleanup {
+ destroy .t.f
+} -result [winfo id .t]
+test bind-16.4 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button> {set x %b}
+ set x none
+ event generate .t.f <Button-3>
+ event generate .t.f <ButtonRelease-3>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {3}
+test bind-16.5 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Expose> {set x %c}
+ set x none
+ event generate .t.f <Expose> -count 47
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {47}
+test bind-16.6 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
+ set x none
+ event generate .t.f <Enter> -detail NotifyAncestor
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyAncestor}
+test bind-16.7 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
+ set x none
+ event generate .t.f <Enter> -detail NotifyVirtual
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyVirtual}
+test bind-16.8 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
+ set x none
+ event generate .t.f <Enter> -detail NotifyNonlinear
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyNonlinear}
+test bind-16.9 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
+ set x none
+ event generate .t.f <Enter> -detail NotifyNonlinearVirtual
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyNonlinearVirtual}
+test bind-16.10 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
+ set x none
+ event generate .t.f <Enter> -detail NotifyPointer
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyPointer}
+test bind-16.11 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
+ set x none
+ event generate .t.f <Enter> -detail NotifyPointerRoot
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyPointerRoot}
+test bind-16.12 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
+ set x none
+ event generate .t.f <Enter> -detail NotifyDetailNone
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyDetailNone}
+test bind-16.13 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %f}
+ set x none
+ event generate .t.f <Enter> -focus 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-16.14 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Expose> {set x "%x %y %w %h"}
+ set x none
+ event generate .t.f <Expose> -x 24 -y 18 -width 147 -height 61
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {24 18 147 61}
+test bind-16.15 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Configure> {set x "%x %y %w %h"}
+ set x none
+ event generate .t.f <Configure> -x 24 -y 18 -width 147 -height 61 -window .t.f
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {24 18 147 61}
+test bind-16.16 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key> {set x "%k"}
+ set x none
+ event generate .t.f <Key> -keycode 146
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {146}
+test bind-16.17 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x "%m"}
+ set x none
+ event generate .t.f <Enter> -mode NotifyNormal
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyNormal}
+test bind-16.18 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x "%m"}
+ set x none
+ event generate .t.f <Enter> -mode NotifyGrab
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyGrab}
+test bind-16.19 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x "%m"}
+ set x none
+ event generate .t.f <Enter> -mode NotifyUngrab
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyUngrab}
+test bind-16.20 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> {set x "%m"}
+ set x none
+ event generate .t.f <Enter> -mode NotifyWhileGrabbed
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyWhileGrabbed}
+test bind-16.21 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Map> {set x "%o"}
+ set x none
+ event generate .t.f <Map> -override 1 -window .t.f
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-16.22 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Reparent> {set x "%o"}
+ set x none
+ event generate .t.f <Reparent> -override true -window .t.f
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-16.23 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Configure> {set x "%o"}
+ set x none
+ event generate .t.f <Configure> -override 1 -window .t.f
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-16.24 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Circulate> {set x "%p"}
+ set x none
+ event generate .t.f <Circulate> -place PlaceOnTop -window .t.f
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {PlaceOnTop}
+test bind-16.25 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Circulate> {set x "%p"}
+ set x none
+ event generate .t.f <Circulate> -place PlaceOnBottom -window .t.f
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {PlaceOnBottom}
+test bind-16.26 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <1> {set x "%s"}
+ set x none
+ event generate .t.f <Button-1> -state 1402
+ event generate .t.f <ButtonRelease-1>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {1402}
+test bind-16.27 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x "%s"}
+ set x none
+ event generate .t.f <Enter> -state 0x3ff
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {1023}
+test bind-16.28 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Visibility> {set x "%s"}
+ set x none
+ event generate .t.f <Visibility> -state VisibilityPartiallyObscured
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {VisibilityPartiallyObscured}
+test bind-16.29 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Visibility> {set x "%s"}
+ set x none
+ event generate .t.f <Visibility> -state VisibilityUnobscured
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {VisibilityUnobscured}
+test bind-16.30 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Visibility> {set x "%s"}
+ set x none
+ event generate .t.f <Visibility> -state VisibilityFullyObscured
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {VisibilityFullyObscured}
+test bind-16.31 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button> {set x "%t"}
+ set x none
+ event generate .t.f <Button> -time 4294
+ event generate .t.f <ButtonRelease>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {4294}
+test bind-16.32 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button> {set x "%x %y"}
+ set x none
+ event generate .t.f <Button> -x 881 -y 432
+ event generate .t.f <ButtonRelease>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {881 432}
+test bind-16.33 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Reparent> {set x "%x %y"}
+ set x none
+ event generate .t.f <Reparent> -x 882 -y 431 -window .t.f
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {882 431}
+test bind-16.34 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x "%x %y"}
+ set x none
+ event generate .t.f <Enter> -x 781 -y 632
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {781 632}
+test bind-16.35 {ExpandPercents procedure} -constraints {
+ nonPortable
+} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> {lappend x "%A"}
+ event generate .t.f <Key-a>
+ event generate .t.f <Key-A> -state 1
+ event generate .t.f <Key-Tab>
+ event generate .t.f <Key-Return>
+ event generate .t.f <Key-F1>
+ event generate .t.f <Key-Shift_L>
+ event generate .t.f <Key-space>
+ event generate .t.f <Key-dollar> -state 1
+ event generate .t.f <Key-braceleft> -state 1
+ event generate .t.f <Key-Multi_key>
+ event generate .t.f <Key-e>
+ event generate .t.f <Key-apostrophe>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {a A { } {\r} {{}} {{}} { } {\$} \\\{ {{}} {{}} \u00e9}
+test bind-16.36 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Configure> {set x "%B"}
+ set x none
+ event generate .t.f <Configure> -borderwidth 24 -window .t.f
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {24}
+test bind-16.37 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x "%E"}
+ set x none
+ event generate .t.f <Enter> -sendevent 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-16.38 {ExpandPercents procedure} -constraints {
+ nonPortable
+} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> {lappend x %K}
+ event generate .t.f <Key-a>
+ event generate .t.f <Key-A> -state 1
+ event generate .t.f <Key-Tab>
+ event generate .t.f <Key-F1>
+ event generate .t.f <Key-Shift_L>
+ event generate .t.f <Key-space>
+ event generate .t.f <Key-dollar> -state 1
+ event generate .t.f <Key-braceleft> -state 1
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {a A Tab F1 Shift_L space dollar braceleft}
+test bind-16.39 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key> {set x "%N"}
+ set x none
+ event generate .t.f <Key-space>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {32}
+test bind-16.40 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key> {set x "%S"}
+ set x none
+ event generate .t.f <Key-space> -subwindow .t
+ set x
+} -cleanup {
+ destroy .t.f
+} -result [winfo id .t]
+test bind-16.41 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key> {set x "%T"}
+ set x none
+ event generate .t.f <Key>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {2}
+test bind-16.42 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> {set x "%W"}
+ set x none
+ event generate .t.f <Key>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {.t.f}
+test bind-16.43 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button> {set x "%X %Y"}
+ set x none
+ event generate .t.f <Button> -rootx 422 -rooty 13
+ event generate .t.f <ButtonRelease>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {422 13}
+test bind-16.44 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Gravity> {set x "%R %S"}
+ set x none
+ event generate .t.f <Gravity>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {?? ??}
+
+test bind-16.45 {ExpandPercents procedure} -setup {
+ set savedBind(Entry) [bind Entry <Key>]
+ set savedBind(All) [bind all <Key>]
+ entry .t.e
+ pack .t.e
+ focus -force .t.e
+ foreach p [event info] {event delete $p}
+ update
+} -body {
+ bind .t.e <Key> {set x "%M"}
+ bind Entry <Key> {set y "%M"}
+ bind all <Key> {set z "%M"}
+ set x none; set y none; set z none
+ event gen .t.e <Key-a>
+ list $x $y $z
+} -cleanup {
+ destroy .t.e
+ bind all <Key> $savedBind(All)
+ bind Entry <Key> $savedBind(Entry)
+ unset savedBind
+} -result {0 1 2}
+test bind-16.46 {ExpandPercents procedure} -setup {
+ set savedBind(All) [bind all <Key>]
+ set savedBind(Entry) [bind Entry <Key>]
+ entry .t.e
+ pack .t.e
+ focus -force .t.e
+ foreach p [event info] {event delete $p}
+ update
+} -body {
+ bind all <Key> {set z "%M"}
+ bind Entry <Key> {set y "%M"}
+ bind .t.e <Key> {set x "%M"}
+ set x none; set y none; set z none
+ event gen .t.e <Key-a>
+ list $x $y $z
+} -cleanup {
+ destroy .t.e
+ bind Entry <Key> $savedBind(Entry)
+ bind all <Key> $savedBind(All)
+ unset savedBind
+} -result {0 1 2}
+
+test bind-17.1 {event command} -body {
+ event
+} -returnCodes error -result {wrong # args: should be "event option ?arg?"}
+test bind-17.2 {event command} -body {
+ event xyz
+} -returnCodes error -result {bad option "xyz": must be add, delete, generate, or info}
+test bind-17.3 {event command: add} -body {
+ event add
+} -returnCodes error -result {wrong # args: should be "event add virtual sequence ?sequence ...?"}
+test bind-17.4 {event command: add 1} -body {
+ event delete <<Paste>>
+ event add <<Paste>> <Control-v>
+ event info <<Paste>>
+} -cleanup {
+ event delete <<Paste>> <Control-v>
+} -result {<Control-Key-v>}
+test bind-17.5 {event command: add 2} -body {
+ event delete <<Paste>>
+ event add <<Paste>> <Control-v> <Button-2>
+ lsort [event info <<Paste>>]
+} -cleanup {
+ event delete <<Paste>> <Control-v> <Button-2>
+} -result {<Button-2> <Control-Key-v>}
+
+test bind-17.6 {event command: add with error} -body {
+ event add <<Paste>> <Control-v> <Button-2> abc <xyz> <1>
+} -cleanup {
+ event delete <<Paste>>
+} -returnCodes error -result {bad event type or keysym "xyz"}
+test bind-17.7 {event command: add with error} -body {
+ event delete <<Paste>>
+ catch {event add <<Paste>> <Control-v> <Button-2> abc <xyz> <1>}
+ lsort [event info <<Paste>>]
+} -cleanup {
+ event delete <<Paste>>
+} -result {<Button-2> <Control-Key-v> abc}
+
+test bind-17.8 {event command: delete} -body {
+ event delete
+} -returnCodes error -result {wrong # args: should be "event delete virtual ?sequence ...?"}
+test bind-17.9 {event command: delete many} -body {
+ event delete <<Paste>>
+ event add <<Paste>> <3> <1> <2> t
+ event delete <<Paste>> <1> <2>
+ lsort [event info <<Paste>>]
+} -cleanup {
+ event delete <<Paste>> <3> t
+} -result {<Button-3> t}
+test bind-17.10 {event command: delete all} -body {
+ event add <<Paste>> a b
+ event delete <<Paste>>
+ event info <<Paste>>
+} -cleanup {
+ event delete <<Paste>> a b
+} -result {}
+test bind-17.11 {event command: delete 1} -body {
+ event delete <<Paste>>
+ event add <<Paste>> a b c
+ event delete <<Paste>> b
+ lsort [event info <<Paste>>]
+} -cleanup {
+ event delete <<Paste>>
+} -result {a c}
+test bind-17.12 {event command: info name} -body {
+ event delete <<Paste>>
+ event add <<Paste>> a b c
+ lsort [event info <<Paste>>]
+} -cleanup {
+ event delete <<Paste>>
+} -result {a b c}
+test bind-17.13 {event command: info all} -body {
+ foreach p [event info] {event delete $p}
+ event add <<Paste>> a
+ event add <<Alive>> b
+ lsort [event info]
+} -cleanup {
+ event delete <<Paste>>
+ event delete <<Alive>>
+} -result {<<Alive>> <<Paste>>}
+
+test bind-17.14 {event command: info error} -body {
+ event info <<Paste>> <Control-v>
+} -returnCodes error -result {wrong # args: should be "event info ?virtual?"}
+test bind-17.15 {event command: generate} -body {
+ event generate
+} -returnCodes error -result {wrong # args: should be "event generate window event ?-option value ...?"}
+
+test bind-17.16 {event command: generate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <1> "lappend x 1"
+ event generate .t.f <1>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-17.17 {event command: generate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ event generate .t.f <xyz>
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad event type or keysym "xyz"}
+test bind-17.18 {event command} -body {
+ event foo
+} -returnCodes error -result {bad option "foo": must be add, delete, generate, or info}
+
+
+test bind-18.1 {CreateVirtualEvent procedure: GetVirtualEventUid} -body {
+ event add asd <Ctrl-v>
+} -returnCodes error -result {virtual event "asd" is badly formed}
+test bind-18.2 {CreateVirtualEvent procedure: FindSequence} -body {
+ event add <<asd>> <Ctrl-v>
+} -returnCodes error -result {bad event type or keysym "Ctrl"}
+test bind-18.3 {CreateVirtualEvent procedure: new physical} -body {
+ event delete <<xyz>>
+ event add <<xyz>> <Control-v>
+ event info <<xyz>>
+} -cleanup {
+ event delete <<xyz>>
+} -result {<Control-Key-v>}
+test bind-18.4 {CreateVirtualEvent procedure: duplicate physical} -body {
+ event delete <<xyz>>
+ event add <<xyz>> <Control-v>
+ event add <<xyz>> <Control-v>
+ event info <<xyz>>
+} -cleanup {
+ event delete <<xyz>>
+} -result {<Control-Key-v>}
+test bind-18.5 {CreateVirtualEvent procedure: existing physical} -body {
+ foreach p [event info] {event delete $p}
+ event add <<xyz>> <Control-v>
+ event add <<abc>> <Control-v>
+ list [lsort [event info]] [event info <<xyz>>] [event info <<abc>>]
+} -cleanup {
+ event delete <<xyz>>
+ event delete <<abc>>
+} -result {{<<abc>> <<xyz>>} <Control-Key-v> <Control-Key-v>}
+test bind-18.6 {CreateVirtualEvent procedure: new virtual} -body {
+ foreach p [event info] {event delete $p}
+ event add <<xyz>> <Control-v>
+ list [event info] [event info <<xyz>>]
+} -cleanup {
+ event delete <<abc>>
+} -result {<<xyz>> <Control-Key-v>}
+test bind-18.7 {CreateVirtualEvent procedure: existing virtual} -body {
+ foreach p [event info] {event delete $p}
+ event add <<xyz>> <Control-v>
+ event add <<xyz>> <Button-2>
+ list [event info] [lsort [event info <<xyz>>]]
+} -cleanup {
+ event delete <<xyz>>
+} -result {<<xyz>> {<Button-2> <Control-Key-v>}}
+
+
+test bind-19.1 {DeleteVirtualEvent procedure: GetVirtualEventUid} -body {
+ event add xyz {}
+} -returnCodes error -result {virtual event "xyz" is badly formed}
+test bind-19.2 {DeleteVirtualEvent procedure: non-existent virtual} -setup {
+ foreach p [event info] {event delete $p}
+} -body {
+ event delete <<xyz>>
+ event info
+} -result {}
+test bind-19.3 {DeleteVirtualEvent procedure: delete 1} -setup {
+ event delete <<xyz>>
+} -body {
+ event add <<xyz>> <Control-v>
+ event delete <<xyz>> <Control-v>
+ event info <<xyz>>
+} -result {}
+test bind-19.4 {DeleteVirtualEvent procedure: delete 1, not owned} -setup {
+ event delete <<xyz>>
+} -body {
+ event add <<xyz>> <Control-v>
+ event delete <<xyz>> <Button-1>
+ event info <<xyz>>
+} -result {<Control-Key-v>}
+test bind-19.5 {DeleteVirtualEvent procedure: delete 1, badly formed} -body {
+ event add <<xyz>> <Control-v>
+ event delete <<xyz>> <xyz>
+} -cleanup {
+ event delete <<xyz>>
+} -returnCodes error -result {bad event type or keysym "xyz"}
+test bind-19.6 {DeleteVirtualEvent procedure: delete 1, badly formed} -body {
+ event add <<xyz>> <Control-v>
+ event delete <<xyz>> <<Paste>>
+} -cleanup {
+ event delete <<xyz>>
+} -returnCodes error -result {virtual event not allowed in definition of another virtual event}
+test bind-19.7 {DeleteVirtualEvent procedure: owns 1, delete all} -body {
+ foreach p [event info] {event delete $p}
+ event add <<xyz>> <Control-v>
+ event delete <<xyz>>
+ event info
+} -result {}
+test bind-19.8 {DeleteVirtualEvent procedure: owns 1, delete 1} -body {
+ foreach p [event info] {event delete $p}
+ event add <<xyz>> <Control-v>
+ event delete <<xyz>> <Control-v>
+ event info
+} -result {}
+test bind-19.9 {DeleteVirtualEvent procedure: owns many, delete all} -body {
+ foreach p [event info] {event delete $p}
+ event add <<xyz>> <Control-v> <Control-w> <Control-x>
+ event delete <<xyz>>
+ event info
+} -result {}
+test bind-19.10 {DeleteVirtualEvent procedure: owns many, delete 1} -body {
+ event delete <<xyz>>
+ event add <<xyz>> <Control-v> <Control-w> <Control-x>
+ event delete <<xyz>> <Control-w>
+ lsort [event info <<xyz>>]
+} -cleanup {
+ event delete <<xyz>>
+} -result {<Control-Key-v> <Control-Key-x>}
+test bind-19.11 {DeleteVirtualEvent procedure: owned by 1, only} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+ event delete <<xyz>>
+} -body {
+ event add <<xyz>> <Button-2>
+ bind .t.f <<xyz>> {lappend x %#}
+ event generate .t.f <Button-2> -serial 101
+ event generate .t.f <ButtonRelease-2>
+ event delete <<xyz>>
+ event generate .t.f <Button-2> -serial 102
+ event generate .t.f <ButtonRelease-2>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {101}
+test bind-19.12 {DeleteVirtualEvent procedure: owned by 1, first in chain} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+ event delete <<xyz>>
+ event delete <<abc>>
+} -body {
+ event add <<abc>> <Control-Button-2>
+ event add <<xyz>> <Button-2>
+ bind .t.f <<xyz>> {lappend x xyz}
+ bind .t.f <<abc>> {lappend x abc}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Control-Button-2>
+ event generate .t.f <Control-ButtonRelease-2>
+ event delete <<xyz>>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Control-Button-2>
+ event generate .t.f <Control-ButtonRelease-2>
+ list $x [event info <<abc>>]
+} -cleanup {
+ destroy .t.f
+ event delete <<abc>>
+} -result {{xyz abc abc} <Control-Button-2>}
+test bind-19.13 {DeleteVirtualEvent procedure: owned by 1, second in chain} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+ event delete <<def>>
+ event delete <<xyz>>
+ event delete <<abc>>
+} -body {
+ event add <<def>> <Shift-Button-2>
+ event add <<xyz>> <Button-2>
+ event add <<abc>> <Control-Button-2>
+ bind .t.f <<xyz>> {lappend x xyz}
+ bind .t.f <<abc>> {lappend x abc}
+ bind .t.f <<def>> {lappend x def}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Control-Button-2>
+ event generate .t.f <Control-ButtonRelease-2>
+ event generate .t.f <Shift-Button-2>
+ event generate .t.f <Shift-ButtonRelease-2>
+ event delete <<xyz>>
+ event generate .t.f <Button-2>
+ event generate .t.f <Control-Button-2>
+ event generate .t.f <Shift-Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Control-ButtonRelease-2>
+ event generate .t.f <Shift-ButtonRelease-2>
+ list $x [event info <<def>>] [event info <<xyz>>] [event info <<abc>>]
+} -cleanup {
+ destroy .t.f
+ event delete <<abc>>
+ event delete <<def>>
+} -result {{xyz abc def abc def} <Shift-Button-2> {} <Control-Button-2>}
+test bind-19.14 {DeleteVirtualEvent procedure: owned by 1, last in chain} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+ event delete <<def>>
+ event delete <<xyz>>
+ event delete <<abc>>
+} -body {
+ event add <<xyz>> <Button-2>
+ event add <<abc>> <Control-Button-2>
+ event add <<def>> <Shift-Button-2>
+ bind .t.f <<xyz>> {lappend x xyz}
+ bind .t.f <<abc>> {lappend x abc}
+ bind .t.f <<def>> {lappend x def}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Control-Button-2>
+ event generate .t.f <Control-ButtonRelease-2>
+ event generate .t.f <Shift-Button-2>
+ event generate .t.f <Shift-ButtonRelease-2>
+ event delete <<xyz>>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Control-Button-2>
+ event generate .t.f <Control-ButtonRelease-2>
+ event generate .t.f <Shift-Button-2>
+ event generate .t.f <Shift-ButtonRelease-2>
+ list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>]
+} -cleanup {
+ destroy .t.f
+ event delete <<def>>
+ event delete <<abc>>
+} -result {{xyz abc def abc def} {} <Control-Button-2> <Shift-Button-2>}
+test bind-19.15 {DeleteVirtualEvent procedure: owned by many, first} -setup {
+ pack [frame .t.f -class Test -width 150 -height 100]
+ pack [frame .t.g -class Test -width 150 -height 100]
+ pack [frame .t.h -class Test -width 150 -height 100]
+ focus -force .t.f
+ update
+ set x {}
+ event delete <<def>>
+ event delete <<xyz>>
+ event delete <<abc>>
+} -body {
+ event add <<xyz>> <Button-2>
+ event add <<abc>> <Button-2>
+ event add <<def>> <Button-2>
+ bind .t.f <<xyz>> {lappend x xyz}
+ bind .t.g <<abc>> {lappend x abc}
+ bind .t.h <<def>> {lappend x def}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.g <Button-2>
+ event generate .t.g <ButtonRelease-2>
+ event generate .t.h <Button-2>
+ event generate .t.h <ButtonRelease-2>
+ event delete <<xyz>>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.g <Button-2>
+ event generate .t.g <ButtonRelease-2>
+ event generate .t.h <Button-2>
+ event generate .t.h <ButtonRelease-2>
+ list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>]
+} -cleanup {
+ destroy .t.f .t.g .t.h
+ event delete <<def>>
+ event delete <<abc>>
+} -result {{xyz abc def abc def} {} <Button-2> <Button-2>}
+test bind-19.16 {DeleteVirtualEvent procedure: owned by many, middle} -setup {
+ pack [frame .t.f -class Test -width 150 -height 100]
+ pack [frame .t.g -class Test -width 150 -height 100]
+ pack [frame .t.h -class Test -width 150 -height 100]
+ focus -force .t.f
+ update
+ set x {}
+ event delete <<def>>
+ event delete <<xyz>>
+ event delete <<abc>>
+} -body {
+ event add <<xyz>> <Button-2>
+ event add <<abc>> <Button-2>
+ event add <<def>> <Button-2>
+ bind .t.f <<xyz>> {lappend x xyz}
+ bind .t.g <<abc>> {lappend x abc}
+ bind .t.h <<def>> {lappend x def}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.g <Button-2>
+ event generate .t.g <ButtonRelease-2>
+ event generate .t.h <Button-2>
+ event generate .t.h <ButtonRelease-2>
+ event delete <<abc>>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.g <Button-2>
+ event generate .t.g <ButtonRelease-2>
+ event generate .t.h <Button-2>
+ event generate .t.h <ButtonRelease-2>
+ list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>]
+} -cleanup {
+ destroy .t.f .t.g .t.h
+ event delete <<def>>
+ event delete <<xyz>>
+} -result {{xyz abc def xyz def} <Button-2> {} <Button-2>}
+test bind-19.17 {DeleteVirtualEvent procedure: owned by many, last} -setup {
+ pack [frame .t.f -class Test -width 150 -height 100]
+ pack [frame .t.g -class Test -width 150 -height 100]
+ pack [frame .t.h -class Test -width 150 -height 100]
+ focus -force .t.f
+ update
+ set x {}
+ event delete <<def>>
+ event delete <<xyz>>
+ event delete <<abc>>
+} -body {
+ event add <<xyz>> <Button-2>
+ event add <<abc>> <Button-2>
+ event add <<def>> <Button-2>
+ bind .t.f <<xyz>> {lappend x xyz}
+ bind .t.g <<abc>> {lappend x abc}
+ bind .t.h <<def>> {lappend x def}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.g <Button-2>
+ event generate .t.g <ButtonRelease-2>
+ event generate .t.h <Button-2>
+ event generate .t.h <ButtonRelease-2>
+ event delete <<def>>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.g <Button-2>
+ event generate .t.g <ButtonRelease-2>
+ event generate .t.h <Button-2>
+ event generate .t.h <ButtonRelease-2>
+ list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>]
+} -cleanup {
+ destroy .t.f .t.g .t.h
+ event delete <<xyz>>
+ event delete <<abc>>
+} -result {{xyz abc def xyz abc} <Button-2> <Button-2> {}}
+
+
+test bind-20.1 {GetVirtualEvent procedure: GetVirtualEventUid} -body {
+ event info asd
+} -returnCodes error -result {virtual event "asd" is badly formed}
+test bind-20.2 {GetVirtualEvent procedure: non-existent event} -body {
+ event delete <<asd>>
+ event info <<asd>>
+} -result {}
+test bind-20.3 {GetVirtualEvent procedure: owns 1} -setup {
+ event delete <<xyz>>
+} -body {
+ event add <<xyz>> <Control-Key-v>
+ event info <<xyz>>
+} -cleanup {
+ event delete <<xyz>>
+} -result {<Control-Key-v>}
+test bind-20.4 {GetVirtualEvent procedure: owns many} -setup {
+ event delete <<xyz>>
+} -body {
+ event add <<xyz>> <Control-v> <Button-2> spack
+ event info <<xyz>>
+} -cleanup {
+ event delete <<xyz>>
+} -result {<Control-Key-v> <Button-2> spack}
+
+
+test bind-21.1 {GetAllVirtualEvents procedure: no events} -body {
+ foreach p [event info] {event delete $p}
+ event info
+} -result {}
+test bind-21.2 {GetAllVirtualEvents procedure: 1 event} -body {
+ foreach p [event info] {event delete $p}
+ event add <<xyz>> <Control-v>
+ event info
+} -cleanup {
+ event delete <<xyz>>
+} -result {<<xyz>>}
+test bind-21.3 {GetAllVirtualEvents procedure: many events} -body {
+ foreach p [event info] {event delete $p}
+ event add <<xyz>> <Control-v>
+ event add <<xyz>> <Button-2>
+ event add <<abc>> <Control-v>
+ event add <<def>> <Key-F6>
+ lsort [event info]
+} -cleanup {
+ event delete <<xyz>>
+ event delete <<abc>>
+ event delete <<def>>
+} -result {<<abc>> <<def>> <<xyz>>}
+
+test bind-22.1 {HandleEventGenerate} -setup {
+ destroy .xyz
+} -body {
+ event generate .xyz <Control-v>
+} -returnCodes error -result {bad window path name ".xyz"}
+test bind-22.2 {HandleEventGenerate} -body {
+ event generate zzz <Control-v>
+} -returnCodes error -result {bad window name/identifier "zzz"}
+test bind-22.3 {HandleEventGenerate} -body {
+ event generate 47 <Control-v>
+} -returnCodes error -result {bad window name/identifier "47"}
+test bind-22.4 {HandleEventGenerate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> {set x "%s %b"}
+ event generate [winfo id .t.f] <Control-Button-1> -state 260
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {260 1}
+test bind-22.5 {HandleEventGenerate} -body {
+ event generate . <xyz>
+} -returnCodes error -result {bad event type or keysym "xyz"}
+test bind-22.6 {HandleEventGenerate} -body {
+ event generate . <Double-Button-1>
+} -returnCodes error -result {Double or Triple modifier not allowed}
+test bind-22.7 {HandleEventGenerate} -body {
+ event generate . xyz
+} -returnCodes error -result {only one event specification allowed}
+test bind-22.8 {HandleEventGenerate} -body {
+ event generate . <Button> -button
+} -returnCodes error -result {value for "-button" missing}
+test bind-22.9 {HandleEventGenerate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> {set x "%s %b"}
+ event generate .t.f <ButtonRelease-1>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <ButtonRelease-3>
+ event generate .t.f <Control-Button-1>
+ event generate .t.f <Control-ButtonRelease-1>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {4 1}
+test bind-22.10 {HandleEventGenerate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> {set x "%s %K"}
+ event generate .t.f <Control-Key-space>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {4 space}
+test bind-22.11 {HandleEventGenerate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> {set x "%s"}
+ event generate .t.f <<Paste>> -state 1
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-22.12 {HandleEventGenerate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Motion> {set x "%s"}
+ event generate .t.f <Control-Motion>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {4}
+test bind-22.13 {HandleEventGenerate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> {lappend x %#}
+ event generate .t.f <Button> -when now -serial 100
+ event generate .t.f <ButtonRelease> -when now
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {100}
+test bind-22.14 {HandleEventGenerate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> {lappend x %#}
+ event generate .t.f <Button> -when head -serial 100
+ event generate .t.f <Button> -when head -serial 101
+ event generate .t.f <Button> -when head -serial 102
+ event generate .t.f <ButtonRelease> -when tail
+ lappend x foo
+ update
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {foo 102 101 100}
+test bind-22.15 {HandleEventGenerate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> {lappend x %#}
+ event generate .t.f <Button> -when head -serial 99
+ event generate .t.f <Button> -when mark -serial 100
+ event generate .t.f <Button> -when mark -serial 101
+ event generate .t.f <Button> -when mark -serial 102
+ event generate .t.f <ButtonRelease> -when tail
+ lappend x foo
+ update
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {foo 100 101 102 99}
+test bind-22.16 {HandleEventGenerate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> {lappend x %#}
+ event generate .t.f <Button> -when head -serial 99
+ event generate .t.f <Button> -when tail -serial 100
+ event generate .t.f <Button> -when tail -serial 101
+ event generate .t.f <Button> -when tail -serial 102
+ event generate .t.f <ButtonRelease> -when tail
+ lappend x foo
+ update
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {foo 99 100 101 102}
+test bind-22.17 {HandleEventGenerate} -body {
+ event generate . <Button> -when xyz
+} -returnCodes error -result {bad -when value "xyz": must be now, head, mark, or tail}
+test bind-22.18 {HandleEventGenerate} -body {
+ # Bug 411307
+ event generate . <a> -root 98765
+} -returnCodes error -result {bad window name/identifier "98765"}
+
+test bind-22.19 {HandleEventGenerate: options <Configure> -above .xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %a"
+ event generate .t.f <Configure> -above .xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad window path name ".xyz"}
+test bind-22.20 {HandleEventGenerate: options <Configure> -above .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %a"
+ event generate .t.f <Configure> -above .t
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result [winfo id .t]
+test bind-22.21 {HandleEventGenerate: options <Configure> -above xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %a"
+ event generate .t.f <Configure> -above xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad window name/identifier "xyz"}
+test bind-22.22 {HandleEventGenerate: options <Configure> -above [winfo id .t]} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %a"
+ event generate .t.f <Configure> -above [winfo id .t]
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result [winfo id .t]
+
+test bind-22.23 {HandleEventGenerate: options <Key> -above .} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %b"
+ event generate .t.f <Key> -above .
+ return $x
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Key> event doesn't accept "-above" option}
+
+test bind-22.24 {HandleEventGenerate: options <Configure> -borderwidth xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %B"
+ event generate .t.f <Configure> -borderwidth xyz
+ return $x
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad screen distance "xyz"}
+
+test bind-22.25 {HandleEventGenerate: options <Configure> -borderwidth 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %B"
+ event generate .t.f <Configure> -borderwidth 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.26 {HandleEventGenerate: options <Key> -borderwidth 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %k"
+ event generate .t.f <Key> -borderwidth 2i
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Key> event doesn't accept "-borderwidth" option}
+
+test bind-22.27 {HandleEventGenerate: options <Button> -button xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x %b"
+ event generate .t.f <Button> -button xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {expected integer but got "xyz"}
+
+test bind-22.28 {HandleEventGenerate: options <Button> -button 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x %b"
+ event generate .t.f <Button> -button 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result 1
+
+test bind-22.29 {HandleEventGenerate: options <ButtonRelease> -button 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <ButtonRelease> "lappend x %b"
+ event generate .t.f <ButtonRelease> -button 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result 1
+
+test bind-22.30 {HandleEventGenerate: options <Key> -button 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %k"
+ event generate .t.f <Key> -button 1
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Key> event doesn't accept "-button" option}
+
+test bind-22.31 {HandleEventGenerate: options <Expose> -count xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Expose> "lappend x %c"
+ event generate .t.f <Expose> -count xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {expected integer but got "xyz"}
+
+test bind-22.32 {HandleEventGenerate: options <Expose> -count 20} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Expose> "lappend x %c"
+ event generate .t.f <Expose> -count 20
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {20}
+
+test bind-22.33 {HandleEventGenerate: options <Key> -count 20} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %b"
+ event generate .t.f <Key> -count 20
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Key> event doesn't accept "-count" option}
+
+test bind-22.34 {HandleEventGenerate: options <Enter> -detail xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %d"
+ event generate .t.f <Enter> -detail xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad -detail value "xyz": must be NotifyAncestor, NotifyVirtual, NotifyInferior, NotifyNonlinear, NotifyNonlinearVirtual, NotifyPointer, NotifyPointerRoot, or NotifyDetailNone}
+
+test bind-22.35 {HandleEventGenerate: options <FocusIn> -detail NotifyVirtual} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <FocusIn> "lappend x FocusIn %d"
+ event generate .t.f <FocusIn> -detail NotifyVirtual
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {FocusIn NotifyVirtual}
+
+test bind-22.35.1 {HandleEventGenerate: options <FocusOut> -detail NotifyVirtual} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <FocusOut> "lappend x FocusOut %d"
+ event generate .t.f <FocusOut> -detail NotifyVirtual
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {FocusOut NotifyVirtual}
+
+test bind-22.36 {HandleEventGenerate: options <Enter> -detail NotifyVirtual} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %d"
+ event generate .t.f <Enter> -detail NotifyVirtual
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyVirtual}
+
+test bind-22.37 {HandleEventGenerate: options <Key> -detail NotifyVirtual} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %k"
+ event generate .t.f <Key> -detail NotifyVirtual
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Key> event doesn't accept "-detail" option}
+
+test bind-22.38 {HandleEventGenerate: options <Enter> -focus xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %f"
+ event generate .t.f <Enter> -focus xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {expected boolean value but got "xyz"}
+
+test bind-22.39 {HandleEventGenerate: options <Enter> -focus 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %f"
+ event generate .t.f <Enter> -focus 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.40 {HandleEventGenerate: options <Key> -focus 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %k"
+ event generate .t.f <Key> -focus 1
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Key> event doesn't accept "-focus" option}
+
+test bind-22.41 {HandleEventGenerate: options <Expose> -height xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Expose> "lappend x %h"
+ event generate .t.f <Expose> -height xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad screen distance "xyz"}
+
+test bind-22.42 {HandleEventGenerate: options <Expose> -height 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Expose> "lappend x %h"
+ event generate .t.f <Expose> -height 2i
+ expr {$x eq [winfo pixels .t.f 2i]}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.43 {HandleEventGenerate: options <Configure> -height 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %h"
+ event generate .t.f <Configure> -height 2i
+ expr {$x eq [winfo pixels .t.f 2i]}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.44 {HandleEventGenerate: options <Key> -height 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %k"
+ event generate .t.f <Key> -height 2i
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Key> event doesn't accept "-height" option}
+
+test bind-22.45 {HandleEventGenerate: options <Key> -keycode xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %k"
+ event generate .t.f <Key> -keycode xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {expected integer but got "xyz"}
+
+test bind-22.46 {HandleEventGenerate: options <Key> -keycode 20} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %k"
+ event generate .t.f <Key> -keycode 20
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {20}
+
+test bind-22.47 {HandleEventGenerate: options <Button> -keycode 20} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x %b"
+ event generate .t.f <Button> -keycode 20
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Button> event doesn't accept "-keycode" option}
+
+test bind-22.48 {HandleEventGenerate: options <Key> -keysym xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %K"
+ event generate .t.f <Key> -keysym xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {unknown keysym "xyz"}
+
+test bind-22.49 {HandleEventGenerate: options <Key> -keysym space} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %K"
+ event generate .t.f <Key> -keysym space
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {space}
+
+test bind-22.50 {HandleEventGenerate: options <Button> -keysym space} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x %b"
+ event generate .t.f <Button> -keysym space
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Button> event doesn't accept "-keysym" option}
+
+test bind-22.51 {HandleEventGenerate: options <Enter> -mode xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %m"
+ event generate .t.f <Enter> -mode xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad -mode value "xyz": must be NotifyNormal, NotifyGrab, NotifyUngrab, or NotifyWhileGrabbed}
+
+test bind-22.52 {HandleEventGenerate: options <Enter> -mode NotifyNormal} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %m"
+ event generate .t.f <Enter> -mode NotifyNormal
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyNormal}
+
+test bind-22.53 {HandleEventGenerate: options <FocusIn> -mode NotifyNormal} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <FocusIn> "lappend x %m"
+ event generate .t.f <FocusIn> -mode NotifyNormal
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {NotifyNormal}
+
+test bind-22.54 {HandleEventGenerate: options <Key> -mode NotifyNormal} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %k"
+ event generate .t.f <Key> -mode NotifyNormal
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Key> event doesn't accept "-mode" option}
+test bind-22.55 {HandleEventGenerate: options <Map> -override xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Map> "lappend x %o"
+ event generate .t.f <Map> -override xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {expected boolean value but got "xyz"}
+
+test bind-22.56 {HandleEventGenerate: options <Map> -override 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Map> "lappend x %o"
+ event generate .t.f <Map> -override 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.57 {HandleEventGenerate: options <Reparent> -override 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Reparent> "lappend x %o"
+ event generate .t.f <Reparent> -override 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.58 {HandleEventGenerate: options <Configure> -override 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %o"
+ event generate .t.f <Configure> -override 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.59 {HandleEventGenerate: options <Key> -override 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %k"
+ event generate .t.f <Key> -override 1
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Key> event doesn't accept "-override" option}
+
+test bind-22.60 {HandleEventGenerate: options <Circulate> -place xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Circulate> "lappend x %p"
+ event generate .t.f <Circulate> -place xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad -place value "xyz": must be PlaceOnTop, or PlaceOnBottom}
+
+test bind-22.61 {HandleEventGenerate: options <Circulate> -place PlaceOnTop} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Circulate> "lappend x %p"
+ event generate .t.f <Circulate> -place PlaceOnTop
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {PlaceOnTop}
+
+test bind-22.62 {HandleEventGenerate: options <Key> -place PlaceOnTop} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %k"
+ event generate .t.f <Key> -place PlaceOnTop
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Key> event doesn't accept "-place" option}
+
+test bind-22.63 {HandleEventGenerate: options <Key> -root .xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %R"
+ event generate .t.f <Key> -root .xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad window path name ".xyz"}
+
+test bind-22.64 {HandleEventGenerate: options <Key> -root .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %R"
+ event generate .t.f <Key> -root .t
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.65 {HandleEventGenerate: options <Key> -root xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %R"
+ event generate .t.f <Key> -root xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad window name/identifier "xyz"}
+
+test bind-22.66 {HandleEventGenerate: options <Key> -root [winfo id .t]} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %R"
+ event generate .t.f <Key> -root [winfo id .t]
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.67 {HandleEventGenerate: options <Button> -root .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x %R"
+ event generate .t.f <Button> -root .t
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.68 {HandleEventGenerate: options <ButtonRelease> -root .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <ButtonRelease> "lappend x %R"
+ event generate .t.f <ButtonRelease> -root .t
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.69 {HandleEventGenerate: options <Motion> -root .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Motion> "lappend x %R"
+ event generate .t.f <Motion> -root .t
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.70 {HandleEventGenerate: options <<Paste>> -root .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> "lappend x %R"
+ event generate .t.f <<Paste>> -root .t
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.71 {HandleEventGenerate: options <Enter> -root .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %R"
+ event generate .t.f <Enter> -root .t
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.72 {HandleEventGenerate: options <Configure> -root .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %R"
+ event generate .t.f <Configure> -root .t
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Configure> event doesn't accept "-root" option}
+
+test bind-22.73 {HandleEventGenerate: options <Key> -rootx xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %X"
+ event generate .t.f <Key> -rootx xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad screen distance "xyz"}
+
+test bind-22.74 {HandleEventGenerate: options <Key> -rootx 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %X"
+ event generate .t.f <Key> -rootx 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.75 {HandleEventGenerate: options <Button> -rootx 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x %X"
+ event generate .t.f <Button> -rootx 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.76 {HandleEventGenerate: options <ButtonRelease> -rootx 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <ButtonRelease> "lappend x %X"
+ event generate .t.f <ButtonRelease> -rootx 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.77 {HandleEventGenerate: options <Motion> -rootx 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Motion> "lappend x %X"
+ event generate .t.f <Motion> -rootx 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.78 {HandleEventGenerate: options <<Paste>> -rootx 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> "lappend x %X"
+ event generate .t.f <<Paste>> -rootx 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.79 {HandleEventGenerate: options <Enter> -rootx 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %X"
+ event generate .t.f <Enter> -rootx 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.80 {HandleEventGenerate: options <Configure> -rootx 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %X"
+ event generate .t.f <Configure> -rootx 2i
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Configure> event doesn't accept "-rootx" option}
+
+test bind-22.81 {HandleEventGenerate: options <Key> -rooty xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %Y"
+ event generate .t.f <Key> -rooty xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad screen distance "xyz"}
+
+test bind-22.82 {HandleEventGenerate: options <Key> -rooty 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %Y"
+ event generate .t.f <Key> -rooty 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.83 {HandleEventGenerate: options <Button> -rooty 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x %Y"
+ event generate .t.f <Button> -rooty 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.84 {HandleEventGenerate: options <ButtonRelease> -rooty 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <ButtonRelease> "lappend x %Y"
+ event generate .t.f <ButtonRelease> -rooty 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.85 {HandleEventGenerate: options <Motion> -rooty 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Motion> "lappend x %Y"
+ event generate .t.f <Motion> -rooty 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.86 {HandleEventGenerate: options <<Paste>> -rooty 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> "lappend x %Y"
+ event generate .t.f <<Paste>> -rooty 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.87 {HandleEventGenerate: options <Enter> -rooty 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %Y"
+ event generate .t.f <Enter> -rooty 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.88 {HandleEventGenerate: options <Configure> -rooty 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %Y"
+ event generate .t.f <Configure> -rooty 2i
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Configure> event doesn't accept "-rooty" option}
+
+test bind-22.89 {HandleEventGenerate: options <Key> -sendevent xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %E"
+ event generate .t.f <Key> -sendevent xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {expected boolean value but got "xyz"}
+
+test bind-22.90 {HandleEventGenerate: options <Key> -sendevent 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %E"
+ event generate .t.f <Key> -sendevent 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.91 {HandleEventGenerate: options <Key> -sendevent yes} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %E"
+ event generate .t.f <Key> -sendevent yes
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.92 {HandleEventGenerate: options <Key> -sendevent 43} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %E"
+ event generate .t.f <Key> -sendevent 43
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {43}
+
+test bind-22.93 {HandleEventGenerate: options <Key> -serial xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %#"
+ event generate .t.f <Key> -serial xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {expected integer but got "xyz"}
+
+test bind-22.94 {HandleEventGenerate: options <Key> -serial 100} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %#"
+ event generate .t.f <Key> -serial 100
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {100}
+
+test bind-22.95 {HandleEventGenerate: options <Key> -state xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %s"
+ event generate .t.f <Key> -state xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {expected integer but got "xyz"}
+
+test bind-22.96 {HandleEventGenerate: options <Key> -state 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %s"
+ event generate .t.f <Key> -state 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.97 {HandleEventGenerate: options <Button> -state 1025} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x %s"
+ event generate .t.f <Button> -state 1025
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1025}
+
+test bind-22.98 {HandleEventGenerate: options <ButtonRelease> -state 1025} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <ButtonRelease> "lappend x %s"
+ event generate .t.f <ButtonRelease> -state 1025
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1025}
+
+test bind-22.99 {HandleEventGenerate: options <Motion> -state 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Motion> "lappend x %s"
+ event generate .t.f <Motion> -state 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.100 {HandleEventGenerate: options <<Paste>> -state 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> "lappend x %s"
+ event generate .t.f <<Paste>> -state 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.101 {HandleEventGenerate: options <Enter> -state 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %s"
+ event generate .t.f <Enter> -state 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.102 {HandleEventGenerate: options <Visibility> -state xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Visibility> "lappend x %s"
+ event generate .t.f <Visibility> -state xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad -state value "xyz": must be VisibilityUnobscured, VisibilityPartiallyObscured, or VisibilityFullyObscured}
+
+test bind-22.103 {HandleEventGenerate: options <Visibility> -state VisibilityUnobscured} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Visibility> "lappend x %s"
+ event generate .t.f <Visibility> -state VisibilityUnobscured
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {VisibilityUnobscured}
+
+test bind-22.104 {HandleEventGenerate: options <Configure> -state xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %s"
+ event generate .t.f <Configure> -state xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Configure> event doesn't accept "-state" option}
+
+test bind-22.105 {HandleEventGenerate: options <Key> -subwindow .xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %S"
+ event generate .t.f <Key> -subwindow .xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad window path name ".xyz"}
+
+test bind-22.106 {HandleEventGenerate: options <Key> -subwindow .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %S"
+ event generate .t.f <Key> -subwindow .t
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.107 {HandleEventGenerate: options <Key> -subwindow xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %S"
+ event generate .t.f <Key> -subwindow xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad window name/identifier "xyz"}
+
+test bind-22.108 {HandleEventGenerate: options <Key> -subwindow [winfo id .t]} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %S"
+ event generate .t.f <Key> -subwindow [winfo id .t]
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.109 {HandleEventGenerate: options <Button> -subwindow .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x %S"
+ event generate .t.f <Button> -subwindow .t
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.110 {HandleEventGenerate: options <ButtonRelease> -subwindow .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <ButtonRelease> "lappend x %S"
+ event generate .t.f <ButtonRelease> -subwindow .t
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.111 {HandleEventGenerate: options <Motion> -subwindow .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Motion> "lappend x %S"
+ event generate .t.f <Motion> -subwindow .t
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.112 {HandleEventGenerate: options <<Paste>> -subwindow .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> "lappend x %S"
+ event generate .t.f <<Paste>> -subwindow .t
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.113 {HandleEventGenerate: options <Enter> -subwindow .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %S"
+ event generate .t.f <Enter> -subwindow .t
+ expr {[winfo id .t] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.114 {HandleEventGenerate: options <Configure> -subwindow .t} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %S"
+ event generate .t.f <Configure> -subwindow .t
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Configure> event doesn't accept "-subwindow" option}
+
+test bind-22.115 {HandleEventGenerate: options <Key> -time xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %t"
+ event generate .t.f <Key> -time xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {expected integer but got "xyz"}
+
+test bind-22.116 {HandleEventGenerate: options <Key> -time 100} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %t"
+ event generate .t.f <Key> -time 100
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {100}
+
+test bind-22.117 {HandleEventGenerate: options <Button> -time 100} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x %t"
+ event generate .t.f <Button> -time 100
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {100}
+
+test bind-22.118 {HandleEventGenerate: options <ButtonRelease> -time 100} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <ButtonRelease> "lappend x %t"
+ event generate .t.f <ButtonRelease> -time 100
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {100}
+
+test bind-22.119 {HandleEventGenerate: options <Motion> -time 100} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Motion> "lappend x %t"
+ event generate .t.f <Motion> -time 100
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {100}
+
+test bind-22.120 {HandleEventGenerate: options <<Paste>> -time 100} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> "lappend x %t"
+ event generate .t.f <<Paste>> -time 100
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {100}
+
+test bind-22.121 {HandleEventGenerate: options <Enter> -time 100} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %t"
+ event generate .t.f <Enter> -time 100
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {100}
+
+test bind-22.122 {HandleEventGenerate: options <Property> -time 100} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Property> "lappend x %t"
+ event generate .t.f <Property> -time 100
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {100}
+
+test bind-22.123 {HandleEventGenerate: options <Configure> -time 100} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %t"
+ event generate .t.f <Configure> -time 100
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Configure> event doesn't accept "-time" option}
+
+test bind-22.124 {HandleEventGenerate: options <Expose> -width xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Expose> "lappend x %w"
+ event generate .t.f <Expose> -width xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad screen distance "xyz"}
+
+test bind-22.125 {HandleEventGenerate: options <Expose> -width 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Expose> "lappend x %w"
+ event generate .t.f <Expose> -width 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.126 {HandleEventGenerate: options <Configure> -width 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %w"
+ event generate .t.f <Configure> -width 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.127 {HandleEventGenerate: options <Key> -width 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %k"
+ event generate .t.f <Key> -width 2i
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Key> event doesn't accept "-width" option}
+
+test bind-22.128 {HandleEventGenerate: options <Unmap> -window .xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Unmap> "lappend x %W"
+ event generate .t.f <Unmap> -window .xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad window path name ".xyz"}
+
+test bind-22.129 {HandleEventGenerate: options <Unmap> -window .t.f} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Unmap> "lappend x %W"
+ event generate .t.f <Unmap> -window .t.f
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {.t.f}
+
+test bind-22.130 {HandleEventGenerate: options <Unmap> -window xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Unmap> "lappend x %W"
+ event generate .t.f <Unmap> -window xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad window name/identifier "xyz"}
+
+test bind-22.131 {HandleEventGenerate: options <Unmap> -window [winfo id .t.f]} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Unmap> "lappend x %W"
+ event generate .t.f <Unmap> -window [winfo id .t.f]
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {.t.f}
+
+test bind-22.132 {HandleEventGenerate: options <Unmap> -window .t.f} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Unmap> "lappend x %W"
+ event generate .t.f <Unmap> -window .t.f
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {.t.f}
+
+test bind-22.133 {HandleEventGenerate: options <Map> -window .t.f} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Map> "lappend x %W"
+ event generate .t.f <Map> -window .t.f
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {.t.f}
+
+test bind-22.134 {HandleEventGenerate: options <Reparent> -window .t.f} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Reparent> "lappend x %W"
+ event generate .t.f <Reparent> -window .t.f
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {.t.f}
+
+test bind-22.135 {HandleEventGenerate: options <Configure> -window .t.f} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %W"
+ event generate .t.f <Configure> -window .t.f
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {.t.f}
+
+test bind-22.136 {HandleEventGenerate: options <Gravity> -window .t.f} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Gravity> "lappend x %W"
+ event generate .t.f <Gravity> -window .t.f
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {.t.f}
+
+test bind-22.137 {HandleEventGenerate: options <Circulate> -window .t.f} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Circulate> "lappend x %W"
+ event generate .t.f <Circulate> -window .t.f
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {.t.f}
+
+test bind-22.138 {HandleEventGenerate: options <Key> -window .t.f} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %W"
+ event generate .t.f <Key> -window .t.f
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Key> event doesn't accept "-window" option}
+
+test bind-22.139 {HandleEventGenerate: options <Key> -x xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %x"
+ event generate .t.f <Key> -x xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad screen distance "xyz"}
+
+test bind-22.140 {HandleEventGenerate: options <Key> -x 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %x"
+ event generate .t.f <Key> -x 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.141 {HandleEventGenerate: options <Button> -x 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x %x"
+ event generate .t.f <Button> -x 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.142 {HandleEventGenerate: options <ButtonRelease> -x 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <ButtonRelease> "lappend x %x"
+ event generate .t.f <ButtonRelease> -x 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.143 {HandleEventGenerate: options <Motion> -x 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Motion> "lappend x %x"
+ event generate .t.f <Motion> -x 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.144 {HandleEventGenerate: options <<Paste>> -x 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> "lappend x %x"
+ event generate .t.f <<Paste>> -x 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.145 {HandleEventGenerate: options <Enter> -x 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %x"
+ event generate .t.f <Enter> -x 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.146 {HandleEventGenerate: options <Expose> -x 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Expose> "lappend x %x"
+ event generate .t.f <Expose> -x 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.147 {HandleEventGenerate: options <Configure> -x 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %x"
+ event generate .t.f <Configure> -x 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.148 {HandleEventGenerate: options <Gravity> -x 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Gravity> "lappend x %x"
+ event generate .t.f <Gravity> -x 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.149 {HandleEventGenerate: options <Reparent> -x 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Reparent> "lappend x %x"
+ event generate .t.f <Reparent> -x 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.150 {HandleEventGenerate: options <Map> -x 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Map> "lappend x %x"
+ event generate .t.f <Map> -x 2i
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Map> event doesn't accept "-x" option}
+
+test bind-22.151 {HandleEventGenerate: options <Key> -y xyz} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %y"
+ event generate .t.f <Key> -y xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad screen distance "xyz"}
+
+test bind-22.152 {HandleEventGenerate: options <Key> -y 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %y"
+ event generate .t.f <Key> -y 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.153 {HandleEventGenerate: options <Button> -y 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x %y"
+ event generate .t.f <Button> -y 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.154 {HandleEventGenerate: options <ButtonRelease> -y 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <ButtonRelease> "lappend x %y"
+ event generate .t.f <ButtonRelease> -y 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.155 {HandleEventGenerate: options <Motion> -y 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Motion> "lappend x %y"
+ event generate .t.f <Motion> -y 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.156 {HandleEventGenerate: options <<Paste>> -y 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> "lappend x %y"
+ event generate .t.f <<Paste>> -y 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.157 {HandleEventGenerate: options <Enter> -y 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x %y"
+ event generate .t.f <Enter> -y 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.158 {HandleEventGenerate: options <Expose> -y 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Expose> "lappend x %y"
+ event generate .t.f <Expose> -y 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.159 {HandleEventGenerate: options <Configure> -y 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Configure> "lappend x %y"
+ event generate .t.f <Configure> -y 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.160 {HandleEventGenerate: options <Gravity> -y 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Gravity> "lappend x %y"
+ event generate .t.f <Gravity> -y 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.161 {HandleEventGenerate: options <Reparent> -y 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Reparent> "lappend x %y"
+ event generate .t.f <Reparent> -y 2i
+ expr {[winfo pixels .t.f 2i] eq $x}
+} -cleanup {
+ destroy .t.f
+} -result {1}
+
+test bind-22.162 {HandleEventGenerate: options <Map> -y 2i} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Map> "lappend x %y"
+ event generate .t.f <Map> -y 2i
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<Map> event doesn't accept "-y" option}
+
+test bind-22.163 {HandleEventGenerate: options <Key> -xyz 1} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x %k"
+ event generate .t.f <Key> -xyz 1
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad option "-xyz": must be -when, -above, -borderwidth, -button, -count, -data, -delta, -detail, -focus, -height, -keycode, -keysym, -mode, -override, -place, -root, -rootx, -rooty, -sendevent, -serial, -state, -subwindow, -time, -warp, -width, -window, -x, or -y}
+# Note that the -data option is tested in bind-32.* because it has
+# more demanding requirements in memory handling
+
+
+test bind-23.1 {GetVirtualEventUid procedure} -body {
+ event info <<asd
+} -returnCodes error -result {virtual event "<<asd" is badly formed}
+test bind-23.2 {GetVirtualEventUid procedure} -body {
+ event info <<>>
+} -returnCodes error -result {virtual event "<<>>" is badly formed}
+test bind-23.3 {GetVirtualEventUid procedure} -body {
+ event info <<asd>
+} -returnCodes error -result {virtual event "<<asd>" is badly formed}
+test bind-23.4 {GetVirtualEventUid procedure} -setup {
+ event delete <<asd>>
+} -body {
+ event info <<asd>>
+} -result {}
+
+
+test bind-24.1 {FindSequence procedure: no event} -body {
+ bind .t {} test
+} -returnCodes error -result {no events specified in binding}
+test bind-24.2 {FindSequence procedure: bad event} -body {
+ bind .t <xyz> test
+} -returnCodes error -result {bad event type or keysym "xyz"}
+test bind-24.3 {FindSequence procedure: virtual allowed} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> test
+} -cleanup {
+ destroy .t.f
+} -result {}
+test bind-24.4 {FindSequence procedure: virtual not allowed} -body {
+ event add <<Paste>> <<Alive>>
+} -returnCodes error -result {virtual event not allowed in definition of another virtual event}
+test bind-24.5 {FindSequence procedure, multiple bindings} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <1> {lappend x single}
+ bind .t.f <Double-1> {lappend x double}
+ bind .t.f <Triple-1> {lappend x triple}
+ bind .t.f <Quadruple-1> {lappend x quadruple}
+ set x press
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ lappend x press
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ lappend x press
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ lappend x press
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ lappend x press
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {press single press double press triple press quadruple press quadruple}
+test bind-24.6 {FindSequence procedure: virtual composed} -body {
+ bind .t <Control-b><<Paste>> "puts hi"
+} -returnCodes error -result {virtual events may not be composed}
+test bind-24.7 {FindSequence procedure: new pattern sequence} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-1><Button-2> {lappend x 1-2}
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {1-2}
+test bind-24.8 {FindSequence procedure: similar pattern sequence} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-1><Button-2> {lappend x 1-2}
+ bind .t.f <Button-2> {lappend x 2}
+ event generate .t.f <Button-3>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {2 1-2}
+test bind-24.9 {FindSequence procedure: similar pattern sequence} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-1><Button-2> {lappend x 1-2}
+ bind .t.f <Button-2><Button-2> {lappend x 2-2}
+ event generate .t.f <Button-3>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {2-2 1-2}
+test bind-24.10 {FindSequence procedure: similar pattern sequence} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-2><Button-2> {lappend x 2-2}
+ bind .t.f <Double-Button-2> {lappend x d-2}
+ event generate .t.f <Button-3>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ event generate .t.f <Button-2> -x 100
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-2> -x 200
+ event generate .t.f <ButtonRelease-2>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {d-2 2-2}
+test bind-24.11 {FindSequence procedure: new sequence, don't create} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button-2>
+} -cleanup {
+ destroy .t.f
+} -result {}
+test bind-24.12 {FindSequence procedure: not new sequence, don't create} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Control-Button-2> "foo"
+ bind .t.f <Button-2>
+} -cleanup {
+ destroy .t.f
+} -result {}
+test bind-24.13 {FindSequence procedure: no binding} -body {
+ frame .t.f -class Test -width 150 -height 100
+ bind .t.f <a>
+} -cleanup {
+ destroy .t.f
+} -returnCodes ok
+test bind-24.14 {FindSequence procedure: no binding} -body {
+ canvas .t.c
+ set i [.t.c create rect 10 10 100 100]
+ .t.c bind $i <a>
+} -cleanup {
+ destroy .t.c
+} -returnCodes ok
+
+test bind-25.1 {ParseEventDescription procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f a test
+ bind .t.f a
+} -cleanup {
+ destroy .t.f
+} -result test
+test bind-25.2 {ParseEventDescription procedure: misinterpreted modifier} -setup {
+ button .b
+} -body {
+ bind .b <Control-M> a
+ bind .b <M-M> b
+ lsort [bind .b]
+} -cleanup {
+ destroy .b
+} -result {<Control-Key-M> <Meta-Key-M>}
+test bind-25.3 {ParseEventDescription procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <a---> {nothing}
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result a
+test bind-25.4 {ParseEventDescription} -body {
+ bind .t <<Shift-Paste>> {puts hi}
+ bind .t
+} -result {<<Shift-Paste>>}
+
+# Assorted error cases in event sequence parsing
+test bind-25.5 {ParseEventDescription procedure error cases} -body {
+ bind .t \x7 {puts hi}
+} -returnCodes error -result {bad ASCII character 0x7}
+test bind-25.6 {ParseEventDescription procedure error cases} -body {
+ bind .t \x7f {puts hi}
+} -returnCodes error -result {bad ASCII character 0x7f}
+test bind-25.7 {ParseEventDescription procedure error cases} -body {
+ bind .t \x4 {puts hi}
+} -returnCodes error -result {bad ASCII character 0x4}
+test bind-25.8 {ParseEventDescription procedure error cases} -body {
+ bind .t <<>> {puts hi}
+} -returnCodes error -result {virtual event "<<>>" is badly formed}
+test bind-25.9 {ParseEventDescription procedure error cases} -body {
+ bind .t <<Paste {puts hi}
+} -returnCodes error -result {missing ">" in virtual binding}
+test bind-25.10 {ParseEventDescription procedure error cases} -body {
+ bind .t <<Paste> {puts hi}
+} -returnCodes error -result {missing ">" in virtual binding}
+test bind-25.11 {ParseEventDescription procedure error cases} -body {
+ bind .t <<Paste>>h {puts hi}
+} -returnCodes error -result {virtual events may not be composed}
+test bind-25.12 {ParseEventDescription procedure error cases} -body {
+ bind .t <> {puts hi}
+} -returnCodes error -result {no event type or button # or keysym}
+test bind-25.13 {ParseEventDescription procedure error cases} -body {
+ bind .t <a-- {puts hi}
+} -returnCodes error -result {missing ">" in binding}
+test bind-25.14 {ParseEventDescription procedure error cases} -body {
+ bind .t <a-b> {puts hi}
+} -returnCodes error -result {extra characters after detail in binding}
+test bind-25.15 {ParseEventDescription procedure error cases} -body {
+ bind .t <<abc {puts hi}
+} -returnCodes error -result {missing ">" in virtual binding}
+test bind-25.16 {ParseEventDescription procedure error cases} -body {
+ bind .t <<abc> {puts hi}
+} -returnCodes error -result {missing ">" in virtual binding}
+test bind-25.17 {ParseEventDescription} -body {
+ event add <<xyz>> <<abc>>
+} -returnCodes error -result {virtual event not allowed in definition of another virtual event}
+
+# Modifier canonicalization tests
+
+test bind-25.18 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f {<Control- a>} foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Control-Key-a>
+
+test bind-25.19 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Shift-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Shift-Key-a>
+
+test bind-25.20 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Lock-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Lock-Key-a>
+
+test bind-25.21 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Meta---a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Meta-Key-a>
+
+test bind-25.22 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <M-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Meta-Key-a>
+
+test bind-25.23 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Alt-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Alt-Key-a>
+
+test bind-25.24 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <B1-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <B1-Key-a>
+
+test bind-25.25 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <B2-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <B2-Key-a>
+
+test bind-25.26 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <B3-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <B3-Key-a>
+
+test bind-25.27 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <B4-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <B4-Key-a>
+
+test bind-25.28 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <B5-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <B5-Key-a>
+
+test bind-25.29 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Button1-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <B1-Key-a>
+
+test bind-25.30 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Button2-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <B2-Key-a>
+
+test bind-25.31 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Button3-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <B3-Key-a>
+
+test bind-25.32 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Button4-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <B4-Key-a>
+
+test bind-25.33 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Button5-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <B5-Key-a>
+
+test bind-25.34 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <M1-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Mod1-Key-a>
+
+test bind-25.35 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <M2-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Mod2-Key-a>
+
+test bind-25.36 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <M3-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Mod3-Key-a>
+
+test bind-25.37 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <M4-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Mod4-Key-a>
+
+test bind-25.38 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <M5-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Mod5-Key-a>
+
+test bind-25.39 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Mod1-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Mod1-Key-a>
+
+test bind-25.40 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Mod2-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Mod2-Key-a>
+
+test bind-25.41 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Mod3-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Mod3-Key-a>
+
+test bind-25.42 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Mod4-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Mod4-Key-a>
+
+test bind-25.43 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Mod5-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Mod5-Key-a>
+
+test bind-25.44 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Double-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Double-Key-a>
+
+test bind-25.45 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Triple-a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Triple-Key-a>
+
+test bind-25.46 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f {<Double 1>} foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Double-Button-1>
+
+test bind-25.47 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Triple-1> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Triple-Button-1>
+
+test bind-25.48 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f {<M1-M2 M3-M4 B1-Control-a>} foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Control-B1-Mod1-Mod2-Mod3-Mod4-Key-a>
+
+test bind-25.49 {modifier names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <Extended-Return> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <Extended-Key-Return>
+
+
+
+test bind-26.1 {event names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <FocusIn> {nothing}
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <FocusIn>
+test bind-26.2 {event names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+} -body {
+ bind .t.f <FocusOut> {nothing}
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result <FocusOut>
+test bind-26.3 {event names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Destroy> {lappend x "destroyed"}
+ set x [bind .t.f]
+ destroy .t.f
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {<Destroy> destroyed}
+
+test bind-26.4 {event names: Motion} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Motion> "set x {event Motion}"
+ set x xyzzy
+ event generate .t.f <Motion>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Motion} <Motion>}
+
+test bind-26.5 {event names: Button} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button> "set x {event Button}"
+ set x xyzzy
+ event generate .t.f <Button>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Button} <Button>}
+
+test bind-26.6 {event names: ButtonPress} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <ButtonPress> "set x {event ButtonPress}"
+ set x xyzzy
+ event generate .t.f <ButtonPress>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event ButtonPress} <Button>}
+
+test bind-26.7 {event names: ButtonRelease} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <ButtonRelease> "set x {event ButtonRelease}"
+ set x xyzzy
+ event generate .t.f <ButtonRelease>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event ButtonRelease} <ButtonRelease>}
+
+test bind-26.8 {event names: Colormap} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Colormap> "set x {event Colormap}"
+ set x xyzzy
+ event generate .t.f <Colormap>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Colormap} <Colormap>}
+
+test bind-26.9 {event names: Enter} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> "set x {event Enter}"
+ set x xyzzy
+ event generate .t.f <Enter>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Enter} <Enter>}
+
+test bind-26.10 {event names: Leave} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Leave> "set x {event Leave}"
+ set x xyzzy
+ event generate .t.f <Leave>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Leave} <Leave>}
+
+test bind-26.11 {event names: Expose} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Expose> "set x {event Expose}"
+ set x xyzzy
+ event generate .t.f <Expose>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Expose} <Expose>}
+
+test bind-26.12 {event names: Key} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key> "set x {event Key}"
+ set x xyzzy
+ event generate .t.f <Key>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Key} <Key>}
+
+test bind-26.13 {event names: KeyPress} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <KeyPress> "set x {event KeyPress}"
+ set x xyzzy
+ event generate .t.f <KeyPress>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event KeyPress} <Key>}
+
+test bind-26.14 {event names: KeyRelease} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <KeyRelease> "set x {event KeyRelease}"
+ set x xyzzy
+ event generate .t.f <KeyRelease>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event KeyRelease} <KeyRelease>}
+
+test bind-26.15 {event names: Property} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Property> "set x {event Property}"
+ set x xyzzy
+ event generate .t.f <Property>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Property} <Property>}
+
+test bind-26.16 {event names: Visibility} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Visibility> "set x {event Visibility}"
+ set x xyzzy
+ event generate .t.f <Visibility>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Visibility} <Visibility>}
+
+test bind-26.17 {event names: Activate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Activate> "set x {event Activate}"
+ set x xyzzy
+ event generate .t.f <Activate>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Activate} <Activate>}
+
+test bind-26.18 {event names: Deactivate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Deactivate> "set x {event Deactivate}"
+ set x xyzzy
+ event generate .t.f <Deactivate>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Deactivate} <Deactivate>}
+
+
+# These events require an extra argument to [event generate]
+test bind-26.19 {event names: Circulate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Circulate> "set x {event Circulate}"
+ set x xyzzy
+ event generate .t.f <Circulate>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Circulate} <Circulate>}
+
+test bind-26.20 {event names: Configure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Configure> "set x {event Configure}"
+ set x xyzzy
+ event generate .t.f <Configure>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Configure} <Configure>}
+
+test bind-26.21 {event names: Gravity} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Gravity> "set x {event Gravity}"
+ set x xyzzy
+ event generate .t.f <Gravity>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Gravity} <Gravity>}
+
+test bind-26.22 {event names: Map} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Map> "set x {event Map}"
+ set x xyzzy
+ event generate .t.f <Map>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Map} <Map>}
+
+test bind-26.23 {event names: Reparent} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Reparent> "set x {event Reparent}"
+ set x xyzzy
+ event generate .t.f <Reparent>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Reparent} <Reparent>}
+
+test bind-26.24 {event names: Unmap} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Unmap> "set x {event Unmap}"
+ set x xyzzy
+ event generate .t.f <Unmap>
+ list $x [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {{event Unmap} <Unmap>}
+
+
+test bind-27.1 {button names} -body {
+ bind .t <Expose-1> foo
+} -returnCodes error -result {specified button "1" for non-button event}
+test bind-27.2 {button names} -body {
+ bind .t <Button-6> foo
+} -returnCodes error -result {specified keysym "6" for non-key event}
+test bind-27.3 {button names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button-1> {lappend x "button 1"}
+ set x [bind .t.f]
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {<Button-1> {button 1}}
+test bind-27.4 {button names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button-2> {lappend x "button 2"}
+ set x [bind .t.f]
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {<Button-2> {button 2}}
+test bind-27.5 {button names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button-3> {lappend x "button 3"}
+ set x [bind .t.f]
+ event generate .t.f <Button-3>
+ event generate .t.f <ButtonRelease-3>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {<Button-3> {button 3}}
+test bind-27.6 {button names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button-4> {lappend x "button 4"}
+ set x [bind .t.f]
+ event generate .t.f <Button-4>
+ event generate .t.f <ButtonRelease-4>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {<Button-4> {button 4}}
+test bind-27.7 {button names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button-5> {lappend x "button 5"}
+ set x [bind .t.f]
+ event generate .t.f <Button-5>
+ event generate .t.f <ButtonRelease-5>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {<Button-5> {button 5}}
+
+test bind-28.1 {keysym names} -body {
+ bind .t <Expose-a> foo
+} -returnCodes error -result {specified keysym "a" for non-key event}
+test bind-28.2 {keysym names} -body {
+ bind .t <Gorp> foo
+} -returnCodes error -result {bad event type or keysym "Gorp"}
+test bind-28.3 {keysym names} -body {
+ bind .t <Key-Stupid> foo
+} -returnCodes error -result {bad event type or keysym "Stupid"}
+test bind-28.4 {keysym names} -body {
+ frame .t.f -class Test -width 150 -height 100
+ bind .t.f <a> foo
+ bind .t.f
+} -cleanup {
+ destroy .t.f
+} -result {a}
+
+test bind-28.5 {keysym names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key-colon> "lappend x \"keysym received\""
+ bind .t.f <Key-underscore> "lappend x {bad binding match}"
+ set x [lsort [bind .t.f]]
+ event generate .t.f <Key-colon> ;# -state 0
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {: _ {keysym received}}
+test bind-28.6 {keysym names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key-Return> "lappend x \"keysym Return\""
+ bind .t.f <Key-x> "lappend x {bad binding match}"
+ set x [lsort [bind .t.f]]
+ event generate .t.f <Key-Return> -state 0
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {<Key-Return> x {keysym Return}}
+test bind-28.7 {keysym names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key-X> "lappend x \"keysym X\""
+ bind .t.f <Key-x> "lappend x {bad binding match}"
+ set x [lsort [bind .t.f]]
+ event generate .t.f <Key-X> -state 1
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {X x {keysym X}}
+test bind-28.8 {keysym names} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key-X> "lappend x \"keysym X\""
+ bind .t.f <Key-x> "lappend x {bad binding match}"
+ set x [lsort [bind .t.f]]
+ event generate .t.f <Key-X> -state 1
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {X x {keysym X}}
+
+
+test bind-29.1 {Tk_BackgroundError procedure} -setup {
+ proc bgerror msg {
+ global x errorInfo
+ set x [list $msg $errorInfo]
+ }
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button> {error "This is a test"}
+ set x none
+ event generate .t.f <Button>
+ event generate .t.f <ButtonRelease>
+ update
+ set x
+} -cleanup {
+ destroy .t.f
+ rename bgerror {}
+} -result {{This is a test} {This is a test
+ while executing
+"error "This is a test""
+ (command bound to event)}}
+
+test bind-29.2 {Tk_BackgroundError procedure} -setup {
+ proc do {} {
+ event generate .t.f <Button>
+ event generate .t.f <ButtonRelease>
+ }
+ proc bgerror msg {
+ global x errorInfo
+ set x [list $msg $errorInfo]
+ }
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button> {error Message2}
+ set x none
+ do
+ update
+ set x
+} -cleanup {
+ destroy .t.f
+ rename bgerror {}
+ rename do {}
+} -result {Message2 {Message2
+ while executing
+"error Message2"
+ (command bound to event)}}
+
+
+test bind-30.1 {MouseWheel events} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <MouseWheel> {set x Wheel}
+ event generate .t.f <MouseWheel>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {Wheel}
+test bind-30.2 {MouseWheel events} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <MouseWheel> {set x %D}
+ event generate .t.f <MouseWheel> -delta 120
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {120}
+test bind-30.3 {MouseWheel events} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <MouseWheel> {set x "%D %x %y"}
+ event generate .t.f <MouseWheel> -delta 240 -x 10 -y 30
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {240 10 30}
+
+
+test bind-31.1 {virtual event user_data field - bad generation} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+# Check no confusion, since Focus events use %d for something else
+ event generate .t.f <FocusIn> -data foo
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<FocusIn> event doesn't accept "-data" option}
+test bind-31.2 {virtual event user_data field - NULL, synch} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<TestUserData>> {set x "TestUserData >%d<"}
+ event generate .t.f <<TestUserData>>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {TestUserData >{}<}
+test bind-31.3 {virtual event user_data field - shared, synch} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<TestUserData>> {set x "TestUserData >%d<"}
+ event generate .t.f <<TestUserData>> -data "foo bar"
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {TestUserData >foo bar<}
+test bind-31.4 {virtual event user_data field - unshared, synch} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<TestUserData>> {set x "TestUserData >%d<"}
+ event generate .t.f <<TestUserData>> -data [string index abc 1]
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {TestUserData >b<}
+# Note that asynch event handling can only really catch any potential
+# extra errors when used in combination with a tool like Purify or
+# Valgrind. Such testing is rarely done, but at least any problem with
+# reference handling will eventually show up with these tests...
+test bind-31.5 {virtual event user_data field - NULL, asynch} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<TestUserData>> {set x "TestUserData >%d<"}
+ event generate .t.f <<TestUserData>> -when head
+ list $x [update] $x
+} -cleanup {
+ destroy .t.f
+} -result {{} {} {TestUserData >{}<}}
+test bind-31.6 {virtual event user_data field - shared, asynch} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<TestUserData>> {set x "TestUserData >%d<"}
+ event generate .t.f <<TestUserData>> -data "foo bar" -when head
+ list $x [update] $x
+} -cleanup {
+ destroy .t.f
+} -result {{} {} {TestUserData >foo bar<}}
+test bind-31.7 {virtual event user_data field - unshared, asynch} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<TestUserData>> {set x "TestUserData >%d<"}
+ event generate .t.f <<TestUserData>> -data [string index abc 1] -when head
+ list $x [update] $x
+} -cleanup {
+ destroy .t.f
+} -result {{} {} {TestUserData >b<}}
+
+test bind-32 {-warp, window was destroyed before the idle callback DoWarp} -setup {
+ frame .t.f
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ event generate .t.f <Button-1> -warp 1
+ event generate .t.f <ButtonRelease-1>
+ destroy .t.f
+ update ; # shall simply not crash
+} -cleanup {
+} -result {}
+
+
+# cleanup
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/bitmap.test b/tk8.6/tests/bitmap.test
new file mode 100644
index 0000000..6e2573f
--- /dev/null
+++ b/tk8.6/tests/bitmap.test
@@ -0,0 +1,111 @@
+# This file is a Tcl script to test out the procedures in the file
+# tkBitmap.c. It is organized in the standard white-box fashion for
+# Tcl tests.
+#
+# Copyright (c) 1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} -constraints {
+ testbitmap
+} -body {
+ set x gray25
+ lindex $x 0
+ button .b -bitmap $x
+ lindex $x 0
+ testbitmap gray25
+} -cleanup {
+ destroy .b
+} -result {{1 0}}
+test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} -constraints {
+ testbitmap
+} -setup {
+ set result {}
+} -body {
+ set x gray25
+ button .b1 -bitmap $x
+ destroy .b1
+ lappend result [testbitmap gray25]
+ button .b2 -bitmap $x
+ lappend result [testbitmap gray25]
+} -cleanup {
+ destroy .b1 .b2
+} -result {{} {{1 1}}}
+test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} -constraints {
+ testbitmap
+} -setup {
+ set result {}
+} -body {
+ set x gray25
+ button .b1 -bitmap $x
+ lappend result [testbitmap gray25]
+ button .b2 -bitmap $x
+ pack .b1 .b2 -side top
+ lappend result [testbitmap gray25]
+} -cleanup {
+ destroy .b1 .b2
+} -result {{{1 1}} {{2 1}}}
+
+test bitmap-2.1 {Tk_GetBitmap procedure} -body {
+ button .b1 -bitmap bad_name
+} -cleanup {
+ destroy .b1
+} -returnCodes error -result {bitmap "bad_name" not defined}
+test bitmap-2.2 {Tk_GetBitmap procedure} -body {
+ button .b1 -bitmap @xyzzy
+} -cleanup {
+ destroy .b1
+} -returnCodes error -result {error reading bitmap file "xyzzy"}
+
+test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} -constraints {
+ testbitmap
+} -setup {
+ set result {}
+} -body {
+ set x questhead
+ button .b1 -bitmap $x
+ button .b3 -bitmap $x
+ button .b2 -bitmap $x
+ lappend result [testbitmap questhead]
+ destroy .b1
+ lappend result [testbitmap questhead]
+ destroy .b2
+ lappend result [testbitmap questhead]
+ destroy .b3
+ lappend result [testbitmap questhead]
+} -cleanup {
+ destroy .b1 .b2 .b3 ;# destroying just in case
+} -result {{{3 1}} {{2 1}} {{1 1}} {}}
+
+test bitmap-4.1 {FreeBitmapObjProc} -constraints {
+ testbitmap
+} -body {
+ set x [join questhead]
+ button .b -bitmap $x
+ set y [join questhead]
+ .b configure -bitmap $y
+ set z [join questhead]
+ .b configure -bitmap $z
+ set result {}
+ lappend result [testbitmap questhead]
+ set x red
+ lappend result [testbitmap questhead]
+ set z 32
+ lappend result [testbitmap questhead]
+ destroy .b
+ lappend result [testbitmap questhead]
+ set y bogus
+ return $result
+} -cleanup {
+ destroy .b
+} -result {{{1 3}} {{1 2}} {{1 1}} {}}
+
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/border.test b/tk8.6/tests/border.test
new file mode 100644
index 0000000..981e640
--- /dev/null
+++ b/tk8.6/tests/border.test
@@ -0,0 +1,199 @@
+# This file is a Tcl script to test out the procedures in the file
+# tkBorder.c. It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} -constraints {
+ testborder
+} -body {
+ set x orange
+ lindex $x 0
+ button .b1 -bg $x -text .b1
+ lindex $x 0
+ testborder orange
+} -cleanup {
+ destroy .b1
+} -result {{1 0}}
+test border-1.2 {Tk_AllocBorderFromObj - discard stale border} -constraints {
+ testborder
+} -setup {
+ set result {}
+} -body {
+ set x orange
+ button .b1 -bg $x -text First
+ destroy .b1
+ lappend result [testborder orange]
+ button .b2 -bg $x -text Second
+ lappend result [testborder orange]
+} -cleanup {
+ destroy .b1 .b2
+} -result {{} {{1 1}}}
+test border-1.3 {Tk_AllocBorderFromObj - reuse existing border} -constraints {
+ testborder
+} -setup {
+ set result {}
+} -body {
+ set x orange
+ button .b1 -bg $x -text First
+ lappend result [testborder orange]
+ button .b2 -bg $x -text Second
+ pack .b1 .b2 -side top
+ lappend result [testborder orange]
+} -cleanup {
+ destroy .b1 .b2
+} -result {{{1 1}} {{2 1}}}
+test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} -constraints {
+ testborder pseudocolor8
+} -setup {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ wm geom .t +0+0
+ set result {}
+} -body {
+ set x purple
+ button .b1 -bg $x -text First
+ pack .b1 -side top
+ lappend result [testborder purple]
+ button .t.b -bg $x -text Second
+ pack .t.b -side top
+ lappend result [testborder purple]
+ button .b2 -bg $x -text Third
+ pack .b2 -side top
+ lappend result [testborder purple]
+} -cleanup {
+ destroy .b1 .b2 .t
+} -result {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
+
+test border-2.1 {Tk_Free3DBorder - reference counts} -constraints {
+ testborder pseudocolor8
+} -setup {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ wm geom .t +0+0
+ set result {}
+} -body {
+ set x purple
+ button .b1 -bg $x -text First
+ pack .b1 -side top
+ button .t.b -bg $x -text Second
+ pack .t.b -side top
+ button .b2 -bg $x -text Third
+ pack .b2 -side top
+ lappend result [testborder purple]
+ destroy .b1
+ lappend result [testborder purple]
+ destroy .b2
+ lappend result [testborder purple]
+ destroy .t.b
+ lappend result [testborder purple]
+} -cleanup {
+ destroy .b1 .b2 .t
+} -result {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
+test border-2.2 {Tk_Free3DBorder - unlinking from list} -constraints {
+ testborder pseudocolor8
+} -setup {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ wm geom .t +0+0
+ toplevel .t2 -visual {pseudocolor 8} -colormap new
+ toplevel .t3 -visual {pseudocolor 8} -colormap new
+ set result {}
+} -body {
+ set x purple
+ button .b -bg $x -text .b1
+ button .t.b1 -bg $x -text .t.b1
+ button .t.b2 -bg $x -text .t.b2
+ button .t2.b1 -bg $x -text .t2.b1
+ button .t2.b2 -bg $x -text .t2.b2
+ button .t2.b3 -bg $x -text .t2.b3
+ button .t3.b1 -bg $x -text .t3.b1
+ button .t3.b2 -bg $x -text .t3.b2
+ button .t3.b3 -bg $x -text .t3.b3
+ button .t3.b4 -bg $x -text .t3.b4
+ lappend result [testborder purple]
+ destroy .t2
+ lappend result [testborder purple]
+ destroy .b
+ lappend result [testborder purple]
+ destroy .t3
+ lappend result [testborder purple]
+ destroy .t
+ lappend result [testborder purple]
+} -cleanup {
+ destroy .b .t2 .t3 .t
+} -result {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
+
+test border-3.1 {FreeBorderObjProc} -constraints {
+ testborder
+} -setup {
+ set result {}
+} -body {
+ set x [join purple]
+ button .b -bg $x -text .b1
+ set y [join purple]
+ .b configure -bg $y
+ set z [join purple]
+ .b configure -bg $z
+ lappend result [testborder purple]
+ set x red
+ lappend result [testborder purple]
+ set z 32
+ lappend result [testborder purple]
+ destroy .b
+ lappend result [testborder purple]
+ set y bogus
+ return $result
+} -cleanup {
+ destroy .b
+} -result {{{1 3}} {{1 2}} {{1 1}} {}}
+
+test border-4.1 {Tk_GetReliefFromObj} -body {
+ button .b -relief flat
+ .b cget -relief
+} -cleanup {
+ destroy .b
+} -result {flat}
+test border-4.2 {Tk_GetReliefFromObj} -body {
+ button .b -relief groove
+ .b cget -relief
+} -cleanup {
+ destroy .b
+} -result {groove}
+test border-4.3 {Tk_GetReliefFromObj} -body {
+ button .b -relief raised
+ .b cget -relief
+} -cleanup {
+ destroy .b
+} -result {raised}
+test border-4.4 {Tk_GetReliefFromObj} -body {
+ button .b -relief ridge
+ .b cget -relief
+} -cleanup {
+ destroy .b
+} -result {ridge}
+test border-4.5 {Tk_GetReliefFromObj} -body {
+ button .b -relief solid
+ .b cget -relief
+} -cleanup {
+ destroy .b
+} -result {solid}
+test border-4.6 {Tk_GetReliefFromObj} -body {
+ button .b -relief sunken
+ .b cget -relief
+} -cleanup {
+ destroy .b
+} -result {sunken}
+test border-4.7 {Tk_GetReliefFromObj - error} -body {
+ button .b -relief upanddown
+} -cleanup {
+ destroy .b
+} -returnCodes error -result {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}
+
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/bugs.tcl b/tk8.6/tests/bugs.tcl
new file mode 100644
index 0000000..55e5f84
--- /dev/null
+++ b/tk8.6/tests/bugs.tcl
@@ -0,0 +1,41 @@
+# This file is a Tcl script to test out various known bugs that will
+# cause Tk to crash. This file ends with .tcl instead of .test to make
+# sure it isn't run when you type "source all". We currently are not
+# shipping this file with the rest of the source release.
+#
+# Copyright (c) 1996 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+if {[info procs test] != "test"} {
+ source defs
+}
+
+test crash-1.0 {imgPhoto} {
+ image create photo p1
+ image create photo p2
+ catch {image create photo p2 -file bogus}
+ p1 copy p2
+ label .l -image p1
+ destroy .l
+ set foo ""
+} {}
+
+test crash-1.1 {color} {
+ . configure -bg rgb:345
+ set foo ""
+} {}
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tk8.6/tests/busy.test b/tk8.6/tests/busy.test
new file mode 100644
index 0000000..304c2eb
--- /dev/null
+++ b/tk8.6/tests/busy.test
@@ -0,0 +1,477 @@
+# Tests for the tk busy command.
+#
+# This file contains a collection of tests for one or more of the Tk built-in
+# commands. Sourcing this file runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Jos Decoster. All rights reserved.
+
+package require tcltest 2.1
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+# There's currently no way to test the actual grab effect, per se, in an
+# automated test. Therefore, this test suite only covers the interface to the
+# grab command (ie, error messages, etc.)
+
+test busy-1.1 {Tk_BusyObjCmd} -returnCodes error -body {
+ tk busy
+} -result {wrong # args: should be "tk busy options ?arg arg ...?"}
+
+test busy-2.1 {tk busy hold} -returnCodes error -body {
+ tk busy hold
+} -result {wrong # args: should be "tk busy hold window ?option value ...?"}
+test busy-2.2 {tk busy hold root window} -body {
+ tk busy hold .
+ update
+} -cleanup {
+ tk busy forget .
+} -result {}
+test busy-2.3 {tk busy hold root window with shortcut} -body {
+ tk busy .
+ update
+} -cleanup {
+ tk busy forget .
+} -result {}
+test busy-2.4 {tk busy hold nested window} -setup {
+ pack [frame .f]
+} -body {
+ tk busy hold .f
+ update
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {}
+test busy-2.5 {tk busy hold nested window with shortcut} -setup {
+ pack [frame .f]
+} -body {
+ tk busy .f
+ update
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {}
+test busy-2.6 {tk busy hold toplevel window} -setup {
+ toplevel .f
+} -body {
+ tk busy hold .f
+ update
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {}
+test busy-2.7 {tk busy hold toplevel window with shortcut} -setup {
+ toplevel .f
+} -body {
+ tk busy .f
+ update
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {}
+test busy-2.8 {tk busy hold non existing window} -body {
+ tk busy hold .f
+ update
+} -returnCodes error -result {bad window path name ".f"}
+test busy-2.9 {tk busy hold (shortcut) non existing window} -body {
+ tk busy .f
+ update
+} -returnCodes {error} -result {bad window path name ".f"}
+test busy-2.10 {tk busy hold root window with cursor} -body {
+ tk busy hold . -cursor arrow
+ update
+} -cleanup {
+ tk busy forget .
+} -result {}
+test busy-2.11 {tk busy hold (shortcut) root window, cursor} -body {
+ tk busy . -cursor arrow
+ update
+} -cleanup {
+ tk busy forget .
+} -result {}
+test busy-2.12 {tk busy hold root window, invalid cursor} -body {
+ tk busy hold . -cursor nonExistingCursor
+ update
+} -constraints tempNotMac -returnCodes error -cleanup {
+ tk busy forget .
+} -result {bad cursor spec "nonExistingCursor"}
+test busy-2.13 {tk busy hold (shortcut) root window, invalid cursor} -body {
+ tk busy . -cursor nonExistingCursor
+ update
+} -constraints tempNotMac -returnCodes error -cleanup {
+ tk busy forget .
+} -result {bad cursor spec "nonExistingCursor"}
+test busy-2.14 {tk busy hold root window, invalid option} -body {
+ tk busy hold . -invalidOption 1
+ update
+} -constraints tempNotMac -returnCodes error -cleanup {
+ tk busy forget .
+} -result {unknown option "-invalidOption"}
+test busy-2.15 {tk busy hold (shortcut) root window, invalid option} -body {
+ tk busy . -invalidOption 1
+ update
+} -constraints tempNotMac -returnCodes error -cleanup {
+ tk busy forget .
+} -result {unknown option "-invalidOption"}
+
+test busy-3.1 {tk busy cget no window} -returnCodes error -body {
+ tk busy cget
+} -result {wrong # args: should be "tk busy cget window option"}
+test busy-3.2 {tk busy cget no option} -returnCodes error -body {
+ tk busy cget
+} -result {wrong # args: should be "tk busy cget window option"}
+test busy-3.3 {tk busy cget invalid window} -returnCodes error -body {
+ tk busy cget .f -cursor
+} -result {bad window path name ".f"}
+test busy-3.4 {tk busy cget non-busy window} -setup {
+ pack [frame .f]
+} -body {
+ tk busy cget .f -cursor
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {can't find busy window ".f"}
+test busy-3.5 {tk busy cget invalid option} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy cget .f -invalidOption
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -returnCodes error -result {unknown option "-invalidOption"}
+test busy-3.6unix {tk busy cget unix} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy cget .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {watch} -constraints unix
+test busy-3.6win {tk busy cget win} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy cget .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {wait} -constraints win
+test busy-3.7 {tk busy cget unix} -setup {
+ pack [frame .f]
+ tk busy hold .f -cursor hand1
+ update
+} -body {
+ tk busy cget .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {hand1} -constraints tempNotMac
+
+test busy-4.1 {tk busy configure no window} -returnCodes error -body {
+ tk busy configure
+} -result {wrong # args: should be "tk busy configure window ?option? ?value ...?"}
+
+test busy-4.2 {tk busy configure invalid window} -body {
+ tk busy configure .f
+} -returnCodes error -result {bad window path name ".f"}
+
+test busy-4.3 {tk busy configure non-busy window} -setup {
+ pack [frame .f]
+} -body {
+ tk busy configure .f
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {can't find busy window ".f"}
+
+test busy-4.4 {tk busy configure} -constraints {nonwin} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {{-cursor cursor Cursor watch watch}}
+
+test busy-4.4-win {tk busy configure} -constraints {win} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {{-cursor cursor Cursor wait wait}}
+
+test busy-4.5 {tk busy configure} -constraints {nonwin tempNotMac} -setup {
+ pack [frame .f]
+ tk busy hold .f -cursor hand2
+ update
+} -body {
+ tk busy configure .f
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {{-cursor cursor Cursor watch hand2}}
+
+test busy-4.5-win {tk busy configure} -constraints win -setup {
+ pack [frame .f]
+ tk busy hold .f -cursor hand2
+ update
+} -body {
+ tk busy configure .f
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {{-cursor cursor Cursor wait hand2}}
+
+test busy-4.6 {tk busy configure invalid option} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f -invalidOption
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -returnCodes error -result {unknown option "-invalidOption"}
+
+test busy-4.7 {tk busy configure valid option} -constraints {nonwin} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {-cursor cursor Cursor watch watch}
+
+test busy-4.7-win {tk busy configure valid option} -constraints {win} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {-cursor cursor Cursor wait wait}
+
+test busy-4.8 {tk busy configure valid option} -constraints {
+ nonwin tempNotMac
+} -setup {
+ pack [frame .f]
+ tk busy hold .f -cursor circle
+ update
+} -body {
+ tk busy configure .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {-cursor cursor Cursor watch circle}
+
+test busy-4.8-win {tk busy configure valid option} -constraints win -setup {
+ pack [frame .f]
+ tk busy hold .f -cursor circle
+ update
+} -body {
+ tk busy configure .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {-cursor cursor Cursor wait circle}
+
+test busy-4.9 {tk busy configure valid option with value} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f -cursor pencil
+ tk busy cget .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {pencil} -constraints tempNotMac
+
+test busy-4.10 {tk busy configure valid option with invalid value} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f -cursor nonExistingCursor
+} -constraints tempNotMac -returnCodes error -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {bad cursor spec "nonExistingCursor"}
+
+test busy-5.1 {tk busy forget} -returnCodes error -body {
+ tk busy forget
+} -result {wrong # args: should be "tk busy forget window"}
+test busy-5.2 {tk busy forget non existing window} -body {
+ tk busy forget .f
+} -returnCodes error -result {bad window path name ".f"}
+test busy-5.3 {tk busy forget non busy window} -setup {
+ pack [frame .f]
+} -body {
+ tk busy forget .f
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {can't find busy window ".f"}
+test busy-5.4 {tk busy forget window} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ set r [tk busy status .f]
+ tk busy forget .f
+ lappend r [tk busy status .f]
+} -cleanup {
+ destroy .f
+} -result {1 0}
+
+test busy-6.1 {tk busy status} -returnCodes error -body {
+ tk busy status
+} -result {wrong # args: should be "tk busy status window"}
+test busy-6.2 {tk busy status non existing window} -body {
+ tk busy status .f
+} -result {0}
+test busy-6.3 {tk busy status non busy window} -setup {
+ pack [frame .f]
+} -body {
+ tk busy status .f
+} -cleanup {
+ destroy .f
+} -result {0}
+test busy-6.4 {tk busy status busy window} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy status .f
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {1}
+test busy-6.5 {tk busy status forgotten busy window} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+ tk busy forget .f
+} -body {
+ tk busy status .f
+} -cleanup {
+ destroy .f
+} -result {0}
+
+test busy-7.1 {tk busy current no busy} -body {
+ tk busy current
+} -result {}
+test busy-7.2 {tk busy current 1 busy} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy current
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {.f}
+test busy-7.3 {tk busy current 2 busy} -setup {
+ pack [frame .f1]
+ pack [frame .f2]
+ tk busy hold .f1
+ tk busy hold .f2
+ update
+} -body {
+ lsort [tk busy current]
+} -cleanup {
+ tk busy forget .f1
+ tk busy forget .f2
+ destroy .f1 .f2
+} -result {.f1 .f2}
+test busy-7.4 {tk busy current 2 busy with matching filter} -setup {
+ pack [frame .f1]
+ pack [frame .f2]
+ tk busy hold .f1
+ tk busy hold .f2
+ update
+} -body {
+ lsort [tk busy current *2*]
+} -cleanup {
+ tk busy forget .f1
+ tk busy forget .f2
+ destroy .f1 .f2
+} -result {.f2}
+test busy-7.5 {tk busy current 2 busy with non matching filter} -setup {
+ pack [frame .f1]
+ pack [frame .f2]
+ tk busy hold .f1
+ tk busy hold .f2
+ update
+} -body {
+ lsort [tk busy current *3*]
+} -cleanup {
+ tk busy forget .f1
+ tk busy forget .f2
+ destroy .f1 .f2
+} -result {}
+test busy-7.6 {tk busy current 1 busy after forget} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+ tk busy forget .f
+} -body {
+ tk busy current
+} -cleanup {
+ destroy .f
+} -result {}
+test busy-7.7 {tk busy current 2 busy after forget} -setup {
+ pack [frame .f1]
+ pack [frame .f2]
+ tk busy hold .f1
+ tk busy hold .f2
+ update
+ tk busy forget .f1
+} -body {
+ lsort [tk busy current]
+} -cleanup {
+ tk busy forget .f2
+ destroy .f1 .f2
+} -result {.f2}
+test busy-7.8 {tk busy current 2 busy with matching filter after forget} -setup {
+ pack [frame .f1]
+ pack [frame .f2]
+ tk busy hold .f1
+ tk busy hold .f2
+ update
+ tk busy forget .f1
+} -body {
+ lsort [tk busy current *2*]
+} -cleanup {
+ tk busy forget .f2
+ destroy .f1 .f2
+} -result {.f2}
+test busy-7.9 {tk busy current 2 busy with non matching filter after forget} -setup {
+ pack [frame .f1]
+ pack [frame .f2]
+ tk busy hold .f1
+ tk busy hold .f2
+ update
+ tk busy forget .f1
+} -body {
+ lsort [tk busy current *3*]
+} -cleanup {
+ tk busy forget .f2
+ destroy .f1 .f2
+} -result {}
+
+::tcltest::cleanupTests
+return
diff --git a/tk8.6/tests/butGeom.tcl b/tk8.6/tests/butGeom.tcl
new file mode 100644
index 0000000..2ee8fdc
--- /dev/null
+++ b/tk8.6/tests/butGeom.tcl
@@ -0,0 +1,126 @@
+# This file creates a visual test for button layout. It is part of
+# the Tk visual test suite, which is invoked via the "visual" script.
+
+catch {destroy .t}
+toplevel .t
+wm title .t "Visual Tests for Button Geometry"
+wm iconname .t "Button Geometry"
+wm geom .t +0+0
+wm minsize .t 1 1
+
+label .t.l -text {This screen exercises the layout mechanisms for various flavors of buttons. Select display options below, and they will be applied to all of the button widgets. In order to see the effects of different anchor positions, expand the window so that there is extra space in the buttons. The letter "o" in "automatically" should be underlined in the right column of widgets.} -wraplength 5i
+pack .t.l -side top -fill both
+
+button .t.quit -text Quit -command {destroy .t}
+pack .t.quit -side bottom -pady 2m
+
+set sepId 1
+proc sep {} {
+ global sepId
+ frame .t.sep$sepId -height 2 -bd 1 -relief sunken
+ pack .t.sep$sepId -side top -padx 2m -pady 2m -fill x
+ incr sepId
+}
+
+# Create buttons that control configuration options.
+
+frame .t.control
+pack .t.control -side top -fill x -pady 3m
+frame .t.control.left
+frame .t.control.right
+pack .t.control.left .t.control.right -side left -expand 1 -fill x
+label .t.anchorLabel -text "Anchor:"
+frame .t.control.left.f -width 6c -height 3c
+pack .t.anchorLabel .t.control.left.f -in .t.control.left -side top
+foreach anchor {nw n ne w center e sw s se} {
+ button .t.anchor-$anchor -text $anchor -command "config -anchor $anchor"
+}
+place .t.anchor-nw -in .t.control.left.f -relx 0 -relwidth 0.333 \
+ -rely 0 -relheight 0.333
+place .t.anchor-n -in .t.control.left.f -relx 0.333 -relwidth 0.333 \
+ -rely 0 -relheight 0.333
+place .t.anchor-ne -in .t.control.left.f -relx 0.666 -relwidth 0.333 \
+ -rely 0 -relheight 0.333
+place .t.anchor-w -in .t.control.left.f -relx 0 -relwidth 0.333 \
+ -rely 0.333 -relheight 0.333
+place .t.anchor-center -in .t.control.left.f -relx 0.333 -relwidth 0.333 \
+ -rely 0.333 -relheight 0.333
+place .t.anchor-e -in .t.control.left.f -relx 0.666 -relwidth 0.333 \
+ -rely 0.333 -relheight 0.333
+place .t.anchor-sw -in .t.control.left.f -relx 0 -relwidth 0.333 \
+ -rely 0.666 -relheight 0.333
+place .t.anchor-s -in .t.control.left.f -relx 0.333 -relwidth 0.333 \
+ -rely 0.666 -relheight 0.333
+place .t.anchor-se -in .t.control.left.f -relx 0.666 -relwidth 0.333 \
+ -rely 0.666 -relheight 0.333
+
+set justify center
+radiobutton .t.justify-left -text "Justify Left" -relief flat \
+ -command "config -justify left" -variable justify \
+ -value left
+radiobutton .t.justify-center -text "Justify Center" -relief flat \
+ -command "config -justify center" -variable justify \
+ -value center
+radiobutton .t.justify-right -text "Justify Right" -relief flat \
+ -command "config -justify right" -variable justify \
+ -value right
+pack .t.justify-left .t.justify-center .t.justify-right \
+ -in .t.control.right -anchor w
+
+sep
+frame .t.f1
+pack .t.f1 -side top -expand 1 -fill both
+sep
+frame .t.f2
+pack .t.f2 -side top -expand 1 -fill both
+sep
+frame .t.f3
+pack .t.f3 -side top -expand 1 -fill both
+sep
+frame .t.f4
+pack .t.f4 -side top -expand 1 -fill both
+sep
+
+label .t.l1 -text Label -bd 2 -relief sunken
+label .t.l2 -text "Explicit\nnewlines\n\nin the text" -bd 2 -relief sunken
+label .t.l3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -bd 2 -relief sunken -underline 50
+pack .t.l1 .t.l2 .t.l3 -in .t.f1 -side left -padx 5m -pady 3m \
+ -expand y -fill both
+
+button .t.b1 -text Button
+button .t.b2 -text "Explicit\nnewlines\n\nin the text"
+button .t.b3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -underline 50
+pack .t.b1 .t.b2 .t.b3 -in .t.f2 -side left -padx 5m -pady 3m \
+ -expand y -fill both
+
+checkbutton .t.c1 -text Checkbutton -variable a
+checkbutton .t.c2 -text "Explicit\nnewlines\n\nin the text" -variable b
+checkbutton .t.c3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -variable c -underline 50
+pack .t.c1 .t.c2 .t.c3 -in .t.f3 -side left -padx 5m -pady 3m \
+ -expand y -fill both
+
+radiobutton .t.r1 -text Radiobutton -value a
+radiobutton .t.r2 -text "Explicit\nnewlines\n\nin the text" -value b
+radiobutton .t.r3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -value c -underline 50
+pack .t.r1 .t.r2 .t.r3 -in .t.f4 -side left -padx 5m -pady 3m \
+ -expand y -fill both
+
+proc config {option value} {
+ foreach w {.t.l1 .t.l2 .t.l3 .t.b1 .t.b2 .t.b3 .t.c1 .t.c2 .t.c3
+ .t.r1 .t.r2 .t.r3} {
+ $w configure $option $value
+ }
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tk8.6/tests/butGeom2.tcl b/tk8.6/tests/butGeom2.tcl
new file mode 100644
index 0000000..096225c
--- /dev/null
+++ b/tk8.6/tests/butGeom2.tcl
@@ -0,0 +1,124 @@
+# This file creates a visual test for button layout. It is part of
+# the Tk visual test suite, which is invoked via the "visual" script.
+
+catch {destroy .t}
+toplevel .t
+wm title .t "Visual Tests for Button Geometry"
+wm iconname .t "Button Geometry"
+wm geom .t +0+0
+wm minsize .t 1 1
+
+label .t.l -text {This screen exercises the color options for various flavors of buttons. Select display options below, and they will be applied to the appropiate button widgets.} -wraplength 5i
+pack .t.l -side top -fill both
+
+button .t.quit -text Quit -command {destroy .t}
+pack .t.quit -side bottom -pady 2m
+
+set sepId 1
+proc sep {} {
+ global sepId
+ frame .t.sep$sepId -height 2 -bd 1 -relief sunken
+ pack .t.sep$sepId -side top -padx 2m -pady 2m -fill x
+ incr sepId
+}
+
+# Create buttons that control configuration options.
+
+frame .t.control
+pack .t.control -side top -fill x -pady 3m
+frame .t.control.left
+frame .t.control.right
+pack .t.control.left .t.control.right -side left -expand 1 -fill x
+label .t.anchorLabel -text "Color:"
+frame .t.control.left.f -width 6c -height 3c
+pack .t.anchorLabel .t.control.left.f -in .t.control.left -side top -anchor w
+foreach opt {activebackground activeforeground background disabledforeground foreground highlightbackground highlightcolor } {
+ #button .t.color-$opt -text $opt -command "config -$opt \[tk_chooseColor]"
+ menubutton .t.color-$opt -text $opt -menu .t.color-$opt.m -indicatoron 1 \
+ -relief raised -bd 2
+ menu .t.color-$opt.m -tearoff 0
+ .t.color-$opt.m add command -label Red -command "config -$opt red"
+ .t.color-$opt.m add command -label Green -command "config -$opt green"
+ .t.color-$opt.m add command -label Blue -command "config -$opt blue"
+ .t.color-$opt.m add command -label Other... \
+ -command "config -$opt \[tk_chooseColor]"
+ pack .t.color-$opt -in .t.control.left.f -fill x
+}
+
+set default disabled
+label .t.default -text Default:
+radiobutton .t.default-normal -text "Default normal" -relief flat \
+ -command "config-but -default normal" -variable default \
+ -value normal
+radiobutton .t.default-active -text "Default active" -relief flat \
+ -command "config-but -default active" -variable default \
+ -value active
+radiobutton .t.default-disabled -text "Default disabled" -relief flat \
+ -command "config-but -default disabled" -variable default \
+ -value disabled
+pack .t.default .t.default-normal .t.default-active .t.default-disabled \
+ -in .t.control.right -anchor w
+
+sep
+frame .t.f1
+pack .t.f1 -side top -expand 1 -fill both
+sep
+frame .t.f2
+pack .t.f2 -side top -expand 1 -fill both
+sep
+frame .t.f3
+pack .t.f3 -side top -expand 1 -fill both
+sep
+frame .t.f4
+pack .t.f4 -side top -expand 1 -fill both
+sep
+
+label .t.l1 -text Label -bd 2 -relief sunken
+label .t.l2 -text "Explicit\nnewlines\n\nin the text" -bd 2 -relief sunken
+label .t.l3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -bd 2 -relief sunken -underline 50
+pack .t.l1 .t.l2 .t.l3 -in .t.f1 -side left -padx 5m -pady 3m \
+ -expand y -fill both
+
+button .t.b1 -text Button
+button .t.b2 -text "Explicit\nnewlines\n\nin the text"
+button .t.b3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -underline 50
+pack .t.b1 .t.b2 .t.b3 -in .t.f2 -side left -padx 5m -pady 3m \
+ -expand y -fill both
+
+checkbutton .t.c1 -text Checkbutton -variable a
+checkbutton .t.c2 -text "Explicit\nnewlines\n\nin the text" -variable b
+checkbutton .t.c3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -variable c -underline 50
+pack .t.c1 .t.c2 .t.c3 -in .t.f3 -side left -padx 5m -pady 3m \
+ -expand y -fill both
+
+radiobutton .t.r1 -text Radiobutton -value a
+radiobutton .t.r2 -text "Explicit\nnewlines\n\nin the text" -value b
+radiobutton .t.r3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -value c -underline 50
+pack .t.r1 .t.r2 .t.r3 -in .t.f4 -side left -padx 5m -pady 3m \
+ -expand y -fill both
+
+proc config {option value} {
+ foreach w {.t.l1 .t.l2 .t.l3 .t.b1 .t.b2 .t.b3 .t.c1 .t.c2 .t.c3
+ .t.r1 .t.r2 .t.r3} {
+ catch {$w configure $option $value}
+ }
+}
+
+proc config-but {option value} {
+ foreach w {.t.b1 .t.b2 .t.b3} {
+ $w configure $option $value
+ }
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tk8.6/tests/button.test b/tk8.6/tests/button.test
new file mode 100644
index 0000000..708fc30
--- /dev/null
+++ b/tk8.6/tests/button.test
@@ -0,0 +1,3935 @@
+# This file is a Tcl script to test labels, buttons, checkbuttons, and
+# radiobuttons in Tk (i.e., all the widgets defined in tkButton.c). It is
+# organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+imageInit
+
+proc bogusTrace args {
+ error "trace aborted"
+}
+
+test button-1.1 {configuration option: "activebackground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -activebackground #012345
+ .l cget -activebackground
+} -cleanup {
+ destroy .l
+} -result {#012345}
+test button-1.2 {configuration option: "activebackground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -activebackground non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.3 {configuration option: "activebackground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -activebackground #012345
+ .b cget -activebackground
+} -cleanup {
+ destroy .b
+} -result {#012345}
+test button-1.4 {configuration option: "activebackground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -activebackground non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.5 {configuration option: "activebackground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -activebackground #012345
+ .c cget -activebackground
+} -cleanup {
+ destroy .c
+} -result {#012345}
+test button-1.6 {configuration option: "activebackground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -activebackground non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.7 {configuration option: "activebackground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -activebackground #012345
+ .r cget -activebackground
+} -cleanup {
+ destroy .r
+} -result {#012345}
+test button-1.8 {configuration option: "activebackground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -activebackground non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.9 {configuration option: "activeforeground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -activeforeground #ff0000
+ .l cget -activeforeground
+} -cleanup {
+ destroy .l
+} -result {#ff0000}
+test button-1.10 {configuration option: "activeforeground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -activeforeground non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.11 {configuration option: "activeforeground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -activeforeground #ff0000
+ .b cget -activeforeground
+} -cleanup {
+ destroy .b
+} -result {#ff0000}
+test button-1.12 {configuration option: "activeforeground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -activeforeground non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.13 {configuration option: "activeforeground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -activeforeground #ff0000
+ .c cget -activeforeground
+} -cleanup {
+ destroy .c
+} -result {#ff0000}
+test button-1.14 {configuration option: "activeforeground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -activeforeground non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.15 {configuration option: "activeforeground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -activeforeground #ff0000
+ .r cget -activeforeground
+} -cleanup {
+ destroy .r
+} -result {#ff0000}
+test button-1.16 {configuration option: "activeforeground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -activeforeground non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.17 {configuration option: "anchor" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -anchor nw
+ .l cget -anchor
+} -cleanup {
+ destroy .l
+} -result {nw}
+test button-1.18 {configuration option: "anchor" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -anchor bogus
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+test button-1.19 {configuration option: "anchor" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -anchor nw
+ .b cget -anchor
+} -cleanup {
+ destroy .b
+} -result {nw}
+test button-1.20 {configuration option: "anchor" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -anchor bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+test button-1.21 {configuration option: "anchor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -anchor nw
+ .c cget -anchor
+} -cleanup {
+ destroy .c
+} -result {nw}
+test button-1.22 {configuration option: "anchor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -anchor bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+test button-1.23 {configuration option: "anchor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -anchor nw
+ .r cget -anchor
+} -cleanup {
+ destroy .r
+} -result {nw}
+test button-1.24 {configuration option: "anchor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -anchor bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+
+test button-1.25 {configuration option: "background" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -background #ff0000
+ .l cget -background
+} -cleanup {
+ destroy .l
+} -result {#ff0000}
+test button-1.26 {configuration option: "background" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -background non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.27 {configuration option: "background" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -background #ff0000
+ .b cget -background
+} -cleanup {
+ destroy .b
+} -result {#ff0000}
+test button-1.28 {configuration option: "background" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -background non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.29 {configuration option: "background" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -background #ff0000
+ .c cget -background
+} -cleanup {
+ destroy .c
+} -result {#ff0000}
+test button-1.30 {configuration option: "background" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -background non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.31 {configuration option: "background" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -background #ff0000
+ .r cget -background
+} -cleanup {
+ destroy .r
+} -result {#ff0000}
+test button-1.32 {configuration option: "background" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -background non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.33 {configuration option: "bd" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -bd 4
+ .l cget -bd
+} -cleanup {
+ destroy .l
+} -result {4}
+test button-1.34 {configuration option: "bd" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -bd badValue
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.35 {configuration option: "bd" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -bd 4
+ .b cget -bd
+} -cleanup {
+ destroy .b
+} -result {4}
+test button-1.36 {configuration option: "bd" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -bd badValue
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.37 {configuration option: "bd" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -bd 4
+ .c cget -bd
+} -cleanup {
+ destroy .c
+} -result {4}
+test button-1.38 {configuration option: "bd" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -bd badValue
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.39 {configuration option: "bd" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -bd 4
+ .r cget -bd
+} -cleanup {
+ destroy .r
+} -result {4}
+test button-1.40 {configuration option: "bd" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -bd badValue
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test button-1.41 {configuration option: "bg" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -bg #ff0000
+ .l cget -bg
+} -cleanup {
+ destroy .l
+} -result {#ff0000}
+test button-1.42 {configuration option: "bg" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -bg non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.43 {configuration option: "bg" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -bg #ff0000
+ .b cget -bg
+} -cleanup {
+ destroy .b
+} -result {#ff0000}
+test button-1.44 {configuration option: "bg" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -bg non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.45 {configuration option: "bg" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -bg #ff0000
+ .c cget -bg
+} -cleanup {
+ destroy .c
+} -result {#ff0000}
+test button-1.46 {configuration option: "bg" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -bg non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.47 {configuration option: "bg" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -bg #ff0000
+ .r cget -bg
+} -cleanup {
+ destroy .r
+} -result {#ff0000}
+test button-1.48 {configuration option: "bg" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -bg non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.49 {configuration option: "bitmap" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -bitmap questhead
+ .l cget -bitmap
+} -cleanup {
+ destroy .l
+} -result {questhead}
+test button-1.50 {configuration option: "bitmap" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -bitmap badValue
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bitmap "badValue" not defined}
+test button-1.51 {configuration option: "bitmap" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -bitmap questhead
+ .b cget -bitmap
+} -cleanup {
+ destroy .b
+} -result {questhead}
+test button-1.52 {configuration option: "bitmap" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -bitmap badValue
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bitmap "badValue" not defined}
+test button-1.53 {configuration option: "bitmap" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -bitmap questhead
+ .c cget -bitmap
+} -cleanup {
+ destroy .c
+} -result {questhead}
+test button-1.54 {configuration option: "bitmap" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -bitmap badValue
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bitmap "badValue" not defined}
+test button-1.55 {configuration option: "bitmap" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -bitmap questhead
+ .r cget -bitmap
+} -cleanup {
+ destroy .r
+} -result {questhead}
+test button-1.56 {configuration option: "bitmap" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -bitmap badValue
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bitmap "badValue" not defined}
+
+test button-1.57 {configuration option: "borderwidth" for label} -setup {
+ label .l -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -borderwidth 1.3
+ .l cget -borderwidth
+} -cleanup {
+ destroy .l
+} -result {1.3}
+test button-1.58 {configuration option: "borderwidth" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -borderwidth badValue
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.59 {configuration option: "borderwidth" for button} -setup {
+ button .b -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -borderwidth 1.3
+ .b cget -borderwidth
+} -cleanup {
+ destroy .b
+} -result {1.3}
+test button-1.60 {configuration option: "borderwidth" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -borderwidth badValue
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.61 {configuration option: "borderwidth" for checkbutton} -setup {
+ checkbutton .c -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -borderwidth 1.3
+ .c cget -borderwidth
+} -cleanup {
+ destroy .c
+} -result {1.3}
+test button-1.62 {configuration option: "borderwidth" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -borderwidth badValue
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.63 {configuration option: "borderwidth" for radiobutton} -setup {
+ radiobutton .r -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -borderwidth 1.3
+ .r cget -borderwidth
+} -cleanup {
+ destroy .r
+} -result {1.3}
+test button-1.64 {configuration option: "borderwidth" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -borderwidth badValue
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test button-1.65 {configuration option: "command" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -command {set x}
+ .b cget -command
+} -cleanup {
+ destroy .b
+} -result {set x}
+test button-1.66 {configuration option: "command" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -command {set x}
+ .b cget -command
+} -cleanup {
+ destroy .b
+} -result {set x}
+test button-1.67 {configuration option: "command" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -command {set x}
+ .c cget -command
+} -cleanup {
+ destroy .c
+} -result {set x}
+test button-1.68 {configuration option: "command" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -command {set x}
+ .r cget -command
+} -cleanup {
+ destroy .r
+} -result {set x}
+
+test button-1.69 {configuration option: "compound" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -compound left
+ .l cget -compound
+} -cleanup {
+ destroy .l
+} -result {left}
+test button-1.70 {configuration option: "compound" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -compound bogus
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad compound "bogus": must be bottom, center, left, none, right, or top}
+test button-1.71 {configuration option: "compound" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -compound left
+ .b cget -compound
+} -cleanup {
+ destroy .b
+} -result {left}
+test button-1.72 {configuration option: "compound" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -compound bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad compound "bogus": must be bottom, center, left, none, right, or top}
+test button-1.73 {configuration option: "compound" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -compound left
+ .c cget -compound
+} -cleanup {
+ destroy .c
+} -result {left}
+test button-1.74 {configuration option: "compound" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -compound bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad compound "bogus": must be bottom, center, left, none, right, or top}
+test button-1.75 {configuration option: "compound" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -compound left
+ .r cget -compound
+} -cleanup {
+ destroy .r
+} -result {left}
+test button-1.76 {configuration option: "compound" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -compound bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad compound "bogus": must be bottom, center, left, none, right, or top}
+
+test button-1.77 {configuration option: "cursor" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -cursor arrow
+ .l cget -cursor
+} -cleanup {
+ destroy .l
+} -result {arrow}
+test button-1.78 {configuration option: "cursor" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -cursor badValue
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+test button-1.79 {configuration option: "cursor" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -cursor arrow
+ .b cget -cursor
+} -cleanup {
+ destroy .b
+} -result {arrow}
+test button-1.80 {configuration option: "cursor" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -cursor badValue
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+test button-1.81 {configuration option: "cursor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -cursor arrow
+ .c cget -cursor
+} -cleanup {
+ destroy .c
+} -result {arrow}
+test button-1.82 {configuration option: "cursor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -cursor badValue
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+test button-1.83 {configuration option: "cursor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -cursor arrow
+ .r cget -cursor
+} -cleanup {
+ destroy .r
+} -result {arrow}
+test button-1.84 {configuration option: "cursor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -cursor badValue
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+
+test button-1.85 {configuration option: "default" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -default active
+ .b cget -default
+} -cleanup {
+ destroy .b
+} -result {active}
+test button-1.86 {configuration option: "default" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -default huh?
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad default "huh?": must be active, disabled, or normal}
+
+test button-1.87 {configuration option: "disabledforeground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -disabledforeground #00ff00
+ .l cget -disabledforeground
+} -cleanup {
+ destroy .l
+} -result {#00ff00}
+test button-1.88 {configuration option: "disabledforeground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -disabledforeground non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.89 {configuration option: "disabledforeground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -disabledforeground #00ff00
+ .b cget -disabledforeground
+} -cleanup {
+ destroy .b
+} -result {#00ff00}
+test button-1.90 {configuration option: "disabledforeground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -disabledforeground non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.91 {configuration option: "disabledforeground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -disabledforeground #00ff00
+ .c cget -disabledforeground
+} -cleanup {
+ destroy .c
+} -result {#00ff00}
+test button-1.92 {configuration option: "disabledforeground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -disabledforeground non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.93 {configuration option: "disabledforeground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -disabledforeground #00ff00
+ .r cget -disabledforeground
+} -cleanup {
+ destroy .r
+} -result {#00ff00}
+test button-1.94 {configuration option: "disabledforeground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -disabledforeground non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.95 {configuration option: "fg" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -fg #110022
+ .l cget -fg
+} -cleanup {
+ destroy .l
+} -result {#110022}
+test button-1.96 {configuration option: "fg" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -fg non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.97 {configuration option: "fg" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -fg #110022
+ .b cget -fg
+} -cleanup {
+ destroy .b
+} -result {#110022}
+test button-1.98 {configuration option: "fg" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -fg non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.99 {configuration option: "fg" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -fg #110022
+ .c cget -fg
+} -cleanup {
+ destroy .c
+} -result {#110022}
+test button-1.100 {configuration option: "fg" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -fg non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.101 {configuration option: "fg" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -fg #110022
+ .r cget -fg
+} -cleanup {
+ destroy .r
+} -result {#110022}
+test button-1.102 {configuration option: "fg" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -fg non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.103 {configuration option: "font" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2
+ pack .l
+ update
+} -body {
+ .l configure -font {Helvetica -12}
+ .l cget -font
+} -cleanup {
+ destroy .l
+} -result {Helvetica -12}
+test button-1.104 {configuration option: "activebackground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2
+ pack .l
+ update
+} -body {
+ .l configure -font {}
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {font "" doesn't exist}
+test button-1.105 {configuration option: "font" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2
+ pack .b
+ update
+} -body {
+ .b configure -font {Helvetica -12}
+ .b cget -font
+} -cleanup {
+ destroy .b
+} -result {Helvetica -12}
+test button-1.106 {configuration option: "activebackground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2
+ pack .b
+ update
+} -body {
+ .b configure -font {}
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {font "" doesn't exist}
+test button-1.107 {configuration option: "font" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2
+ pack .c
+ update
+} -body {
+ .c configure -font {Helvetica -12}
+ .c cget -font
+} -cleanup {
+ destroy .c
+} -result {Helvetica -12}
+test button-1.108 {configuration option: "activebackground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2
+ pack .c
+ update
+} -body {
+ .c configure -font {}
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {font "" doesn't exist}
+test button-1.109 {configuration option: "font" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2
+ pack .r
+ update
+} -body {
+ .r configure -font {Helvetica -12}
+ .r cget -font
+} -cleanup {
+ destroy .r
+} -result {Helvetica -12}
+test button-1.110 {configuration option: "activebackground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2
+ pack .r
+ update
+} -body {
+ .r configure -font {}
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {font "" doesn't exist}
+
+test button-1.111 {configuration option: "foreground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -foreground #110022
+ .l cget -foreground
+} -cleanup {
+ destroy .l
+} -result {#110022}
+test button-1.112 {configuration option: "foreground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -foreground non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.113 {configuration option: "foreground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -foreground #110022
+ .b cget -foreground
+} -cleanup {
+ destroy .b
+} -result {#110022}
+test button-1.114 {configuration option: "foreground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -foreground non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.115 {configuration option: "foreground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -foreground #110022
+ .c cget -foreground
+} -cleanup {
+ destroy .c
+} -result {#110022}
+test button-1.116 {configuration option: "foreground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -foreground non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.117 {configuration option: "foreground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -foreground #110022
+ .r cget -foreground
+} -cleanup {
+ destroy .r
+} -result {#110022}
+test button-1.118 {configuration option: "foreground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -foreground non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.119 {configuration option: "height" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -height 18
+ .l cget -height
+} -cleanup {
+ destroy .l
+} -result {18}
+test button-1.120 {configuration option: "height" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -height 20.0
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {expected integer but got "20.0"}
+test button-1.121 {configuration option: "height" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -height 18
+ .b cget -height
+} -cleanup {
+ destroy .b
+} -result {18}
+test button-1.122 {configuration option: "height" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -height 20.0
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "20.0"}
+test button-1.123 {configuration option: "height" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -height 18
+ .c cget -height
+} -cleanup {
+ destroy .c
+} -result {18}
+test button-1.124 {configuration option: "height" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -height 20.0
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {expected integer but got "20.0"}
+test button-1.125 {configuration option: "height" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -height 18
+ .r cget -height
+} -cleanup {
+ destroy .r
+} -result {18}
+test button-1.126 {configuration option: "height" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -height 20.0
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {expected integer but got "20.0"}
+
+test button-1.127 {configuration option: "highlightbackground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -highlightbackground #110022
+ .l cget -highlightbackground
+} -cleanup {
+ destroy .l
+} -result {#110022}
+test button-1.128 {configuration option: "highlightbackground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -highlightbackground non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.129 {configuration option: "highlightbackground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -highlightbackground #110022
+ .b cget -highlightbackground
+} -cleanup {
+ destroy .b
+} -result {#110022}
+test button-1.130 {configuration option: "highlightbackground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -highlightbackground non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.131 {configuration option: "highlightbackground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -highlightbackground #110022
+ .c cget -highlightbackground
+} -cleanup {
+ destroy .c
+} -result {#110022}
+test button-1.132 {configuration option: "highlightbackground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -highlightbackground non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.133 {configuration option: "highlightbackground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -highlightbackground #110022
+ .r cget -highlightbackground
+} -cleanup {
+ destroy .r
+} -result {#110022}
+test button-1.134 {configuration option: "highlightbackground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -highlightbackground non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.135 {configuration option: "highlightcolor" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -highlightcolor #110022
+ .l cget -highlightcolor
+} -cleanup {
+ destroy .l
+} -result {#110022}
+test button-1.136 {configuration option: "highlightcolor" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -highlightcolor non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.137 {configuration option: "highlightcolor" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -highlightcolor #110022
+ .b cget -highlightcolor
+} -cleanup {
+ destroy .b
+} -result {#110022}
+test button-1.138 {configuration option: "highlightcolor" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -highlightcolor non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.139 {configuration option: "highlightcolor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -highlightcolor #110022
+ .c cget -highlightcolor
+} -cleanup {
+ destroy .c
+} -result {#110022}
+test button-1.140 {configuration option: "highlightcolor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -highlightcolor non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.141 {configuration option: "highlightcolor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -highlightcolor #110022
+ .r cget -highlightcolor
+} -cleanup {
+ destroy .r
+} -result {#110022}
+test button-1.142 {configuration option: "highlightcolor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -highlightcolor non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.143 {configuration option: "highlightthickness" for label} -setup {
+ label .l -borderwidth 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -highlightthickness 6m
+ .l cget -highlightthickness
+} -cleanup {
+ destroy .l
+} -result {6m}
+test button-1.144 {configuration option: "highlightthickness" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -highlightthickness badValue
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.145 {configuration option: "highlightthickness" for button} -setup {
+ button .b -borderwidth 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -highlightthickness 6m
+ .b cget -highlightthickness
+} -cleanup {
+ destroy .b
+} -result {6m}
+test button-1.146 {configuration option: "highlightthickness" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -highlightthickness badValue
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.147 {configuration option: "highlightthickness" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -highlightthickness 6m
+ .c cget -highlightthickness
+} -cleanup {
+ destroy .c
+} -result {6m}
+test button-1.148 {configuration option: "highlightthickness" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -highlightthickness badValue
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.149 {configuration option: "highlightthickness" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -highlightthickness 6m
+ .r cget -highlightthickness
+} -cleanup {
+ destroy .r
+} -result {6m}
+test button-1.150 {configuration option: "highlightthickness" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -highlightthickness badValue
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test button-1.151 {configuration option: "image" for label} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -image image1
+ .l cget -image
+} -cleanup {
+ destroy .l
+ image delete image1
+} -result {image1}
+test button-1.152 {configuration option: "image" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -image bogus
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+test button-1.153 {configuration option: "image" for button} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -image image1
+ .b cget -image
+} -cleanup {
+ destroy .b
+ image delete image1
+} -result {image1}
+test button-1.154 {configuration option: "image" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -image bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+test button-1.155 {configuration option: "image" for checkbutton} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -image image1
+ .c cget -image
+} -cleanup {
+ destroy .c
+ image delete image1
+} -result {image1}
+test button-1.156 {configuration option: "image" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -image bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+test button-1.157 {configuration option: "image" for radiobutton} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -image image1
+ .r cget -image
+} -cleanup {
+ destroy .r
+ image delete image1
+} -result {image1}
+test button-1.158 {configuration option: "image" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -image bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+
+test button-1.159 {configuration option: "indicatoron" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -indicatoron yes
+ .c cget -indicatoron
+} -cleanup {
+ destroy .c
+} -result {1}
+test button-1.160 {configuration option: "indicatoron" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -indicatoron no_way
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {expected boolean value but got "no_way"}
+test button-1.161 {configuration option: "indicatoron" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -indicatoron yes
+ .r cget -indicatoron
+} -cleanup {
+ destroy .r
+} -result {1}
+test button-1.162 {configuration option: "indicatoron" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -indicatoron no_way
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {expected boolean value but got "no_way"}
+
+test button-1.163 {configuration option: "justify" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -justify right
+ .l cget -justify
+} -cleanup {
+ destroy .l
+} -result {right}
+test button-1.164 {configuration option: "justify" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -justify bogus
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+test button-1.165 {configuration option: "justify" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -justify right
+ .b cget -justify
+} -cleanup {
+ destroy .b
+} -result {right}
+test button-1.166 {configuration option: "justify" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -justify bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+test button-1.167 {configuration option: "justify" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -justify right
+ .c cget -justify
+} -cleanup {
+ destroy .c
+} -result {right}
+test button-1.168 {configuration option: "justify" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -justify bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+test button-1.169 {configuration option: "justify" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -justify right
+ .r cget -justify
+} -cleanup {
+ destroy .r
+} -result {right}
+test button-1.170 {configuration option: "justify" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -justify bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+
+test button-1.171 {configuration option: "offrelief" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -offrelief flat
+ .c cget -offrelief
+} -cleanup {
+ destroy .c
+} -result {flat}
+test button-1.172 {configuration option: "offrelief" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -offrelief 1.5
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test button-1.173 {configuration option: "offrelief" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -offrelief flat
+ .r cget -offrelief
+} -cleanup {
+ destroy .r
+} -result {flat}
+test button-1.174 {configuration option: "offrelief" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -offrelief 1.5
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+
+test button-1.175 {configuration option: "offvalue" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -offvalue lousy
+ .c cget -offvalue
+} -cleanup {
+ destroy .c
+} -result {lousy}
+
+test button-1.176 {configuration option: "onvalue" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -onvalue fantastic
+ .c cget -onvalue
+} -cleanup {
+ destroy .c
+} -result {fantastic}
+
+test button-1.177 {configuration option: "overrelief" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -overrelief ""
+ .b cget -overrelief
+} -cleanup {
+ destroy .b
+} -result {}
+test button-1.178 {configuration option: "overrelief" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -overrelief 1.5
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test button-1.179 {configuration option: "overrelief" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -overrelief ""
+ .c cget -overrelief
+} -cleanup {
+ destroy .c
+} -result {}
+test button-1.180 {configuration option: "overrelief" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -overrelief 1.5
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test button-1.181 {configuration option: "overrelief" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -overrelief ""
+ .r cget -overrelief
+} -cleanup {
+ destroy .r
+} -result {}
+test button-1.182 {configuration option: "overrelief" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -overrelief 1.5
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+
+test button-1.183 {configuration option: "padx" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -padx 12m
+ .l cget -padx
+} -cleanup {
+ destroy .l
+} -result {12m}
+test button-1.184 {configuration option: "padx" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -padx 420x
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad screen distance "420x"}
+test button-1.185 {configuration option: "padx" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -padx 12m
+ .b cget -padx
+} -cleanup {
+ destroy .b
+} -result {12m}
+test button-1.186 {configuration option: "padx" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -padx 420x
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "420x"}
+test button-1.187 {configuration option: "padx" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -padx 12m
+ .c cget -padx
+} -cleanup {
+ destroy .c
+} -result {12m}
+test button-1.188 {configuration option: "padx" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -padx 420x
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad screen distance "420x"}
+test button-1.189 {configuration option: "padx" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -padx 12m
+ .r cget -padx
+} -cleanup {
+ destroy .r
+} -result {12m}
+test button-1.190 {configuration option: "padx" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -padx 420x
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad screen distance "420x"}
+
+test button-1.191 {configuration option: "pady" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -pady 12m
+ .l cget -pady
+} -cleanup {
+ destroy .l
+} -result {12m}
+test button-1.192 {configuration option: "pady" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -pady 420x
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad screen distance "420x"}
+test button-1.193 {configuration option: "pady" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -pady 12m
+ .b cget -pady
+} -cleanup {
+ destroy .b
+} -result {12m}
+test button-1.194 {configuration option: "pady" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -pady 420x
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "420x"}
+test button-1.195 {configuration option: "pady" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -pady 12m
+ .c cget -pady
+} -cleanup {
+ destroy .c
+} -result {12m}
+test button-1.196 {configuration option: "pady" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -pady 420x
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad screen distance "420x"}
+test button-1.197 {configuration option: "pady" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -pady 12m
+ .r cget -pady
+} -cleanup {
+ destroy .r
+} -result {12m}
+test button-1.198 {configuration option: "pady" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -pady 420x
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad screen distance "420x"}
+
+test button-1.199 {configuration option: "repeatdelay" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -repeatdelay 100
+ .b cget -repeatdelay
+} -cleanup {
+ destroy .b
+} -result {100}
+test button-1.200 {configuration option: "repeatdelay" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -repeatdelay foo
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "foo"}
+
+test button-1.201 {configuration option: "repeatinterval" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -repeatinterval 100
+ .b cget -repeatinterval
+} -cleanup {
+ destroy .b
+} -result {100}
+test button-1.202 {configuration option: "repeatinterval" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -repeatinterval foo
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "foo"}
+
+test button-1.203 {configuration option: "relief" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -relief flat
+ .l cget -relief
+} -cleanup {
+ destroy .l
+} -result {flat}
+test button-1.204 {configuration option: "relief" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -relief 1.5
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test button-1.205 {configuration option: "relief" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -relief flat
+ .b cget -relief
+} -cleanup {
+ destroy .b
+} -result {flat}
+test button-1.206 {configuration option: "relief" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -relief 1.5
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test button-1.207 {configuration option: "relief" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -relief flat
+ .c cget -relief
+} -cleanup {
+ destroy .c
+} -result {flat}
+test button-1.208 {configuration option: "relief" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -relief 1.5
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test button-1.209 {configuration option: "relief" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -relief flat
+ .r cget -relief
+} -cleanup {
+ destroy .r
+} -result {flat}
+test button-1.210 {configuration option: "relief" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -relief 1.5
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+
+test button-1.211 {configuration option: "selectcolor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -selectcolor #110022
+ .c cget -selectcolor
+} -cleanup {
+ destroy .c
+} -result {#110022}
+test button-1.212 {configuration option: "selectcolor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -selectcolor non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.213 {configuration option: "selectcolor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -selectcolor #110022
+ .r cget -selectcolor
+} -cleanup {
+ destroy .r
+} -result {#110022}
+test button-1.214 {configuration option: "selectcolor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -selectcolor non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.215 {configuration option: "selectimage" for checkbutton} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -selectimage image1
+ .c cget -selectimage
+} -cleanup {
+ destroy .c
+ image delete image1
+} -result {image1}
+test button-1.216 {configuration option: "selectimage" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -selectimage bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+test button-1.217 {configuration option: "selectimage" for radiobutton} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -selectimage image1
+ .r cget -selectimage
+} -cleanup {
+ destroy .r
+ image delete image1
+} -result {image1}
+test button-1.218 {configuration option: "selectimage" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -selectimage bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+
+test button-1.219 {configuration option: "state" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -state normal
+ .l cget -state
+} -cleanup {
+ destroy .l
+} -result {normal}
+test button-1.220 {configuration option: "state" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -state bogus
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad state "bogus": must be active, disabled, or normal}
+test button-1.221 {configuration option: "state" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -state normal
+ .b cget -state
+} -cleanup {
+ destroy .b
+} -result {normal}
+test button-1.222 {configuration option: "state" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -state bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad state "bogus": must be active, disabled, or normal}
+test button-1.223 {configuration option: "state" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -state normal
+ .c cget -state
+} -cleanup {
+ destroy .c
+} -result {normal}
+test button-1.224 {configuration option: "state" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -state bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad state "bogus": must be active, disabled, or normal}
+test button-1.225 {configuration option: "state" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -state normal
+ .r cget -state
+} -cleanup {
+ destroy .r
+} -result {normal}
+test button-1.226 {configuration option: "state" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -state bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad state "bogus": must be active, disabled, or normal}
+
+test button-1.227 {configuration option: "takefocus" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -takefocus "any string"
+ .l cget -takefocus
+} -cleanup {
+ destroy .l
+} -result {any string}
+test button-1.228 {configuration option: "takefocus" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -takefocus "any string"
+ .b cget -takefocus
+} -cleanup {
+ destroy .b
+} -result {any string}
+test button-1.229 {configuration option: "takefocus" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -takefocus "any string"
+ .c cget -takefocus
+} -cleanup {
+ destroy .c
+} -result {any string}
+test button-1.230 {configuration option: "takefocus" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -takefocus "any string"
+ .r cget -takefocus
+} -cleanup {
+ destroy .r
+} -result {any string}
+
+test button-1.231 {configuration option: "text" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -text "Sample text"
+ .l cget -text
+} -cleanup {
+ destroy .l
+} -result {Sample text}
+test button-1.232 {configuration option: "text" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -text "Sample text"
+ .b cget -text
+} -cleanup {
+ destroy .b
+} -result {Sample text}
+test button-1.233 {configuration option: "text" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -text "Sample text"
+ .c cget -text
+} -cleanup {
+ destroy .c
+} -result {Sample text}
+test button-1.234 {configuration option: "text" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -text "Sample text"
+ .r cget -text
+} -cleanup {
+ destroy .r
+} -result {Sample text}
+
+test button-1.235 {configuration option: "textvariable" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -textvariable i
+ .l cget -textvariable
+} -cleanup {
+ destroy .l
+} -result {i}
+test button-1.236 {configuration option: "textvariable" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -textvariable i
+ .b cget -textvariable
+} -cleanup {
+ destroy .b
+} -result {i}
+test button-1.237 {configuration option: "textvariable" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -textvariable i
+ .c cget -textvariable
+} -cleanup {
+ destroy .c
+} -result {i}
+test button-1.238 {configuration option: "textvariable" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -textvariable i
+ .r cget -textvariable
+} -cleanup {
+ destroy .r
+} -result {i}
+
+test button-1.239 {configuration option: "tristateimage" for checkbutton} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -tristateimage image1
+ .c cget -tristateimage
+} -cleanup {
+ destroy .c
+ image delete image1
+} -result {image1}
+test button-1.240 {configuration option: "tristateimage" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -tristateimage bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+test button-1.241 {configuration option: "tristateimage" for radiobutton} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -tristateimage image1
+ .r cget -tristateimage
+} -cleanup {
+ destroy .r
+ image delete image1
+} -result {image1}
+test button-1.242 {configuration option: "tristateimage" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -tristateimage bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+
+test button-1.243 {configuration option: "underline" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -underline 5
+ .l cget -underline
+} -cleanup {
+ destroy .l
+} -result {5}
+test button-1.244 {configuration option: "underline" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -underline 3p
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {expected integer but got "3p"}
+test button-1.245 {configuration option: "underline" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -underline 5
+ .b cget -underline
+} -cleanup {
+ destroy .b
+} -result {5}
+test button-1.246 {configuration option: "underline" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -underline 3p
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "3p"}
+test button-1.247 {configuration option: "underline" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -underline 5
+ .c cget -underline
+} -cleanup {
+ destroy .c
+} -result {5}
+test button-1.248 {configuration option: "underline" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -underline 3p
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {expected integer but got "3p"}
+test button-1.249 {configuration option: "underline" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -underline 5
+ .r cget -underline
+} -cleanup {
+ destroy .r
+} -result {5}
+test button-1.250 {configuration option: "underline" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -underline 3p
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {expected integer but got "3p"}
+
+test button-1.251 {configuration option: "tristatevalue" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -tristatevalue unknowable
+ .c cget -tristatevalue
+} -cleanup {
+ destroy .c
+} -result {unknowable}
+test button-1.252 {configuration option: "tristatevalue" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -tristatevalue unknowable
+ .r cget -tristatevalue
+} -cleanup {
+ destroy .r
+} -result {unknowable}
+
+test button-1.253 {configuration option: "value" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -value anyString
+ .r cget -value
+} -cleanup {
+ destroy .r
+} -result {anyString}
+
+test button-1.254 {configuration option: "width" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -width 402
+ .l cget -width
+} -cleanup {
+ destroy .l
+} -result {402}
+test button-1.255 {configuration option: "width" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -width 3p
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {expected integer but got "3p"}
+test button-1.256 {configuration option: "width" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -width 402
+ .b cget -width
+} -cleanup {
+ destroy .b
+} -result {402}
+test button-1.257 {configuration option: "width" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -width 3p
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "3p"}
+test button-1.258 {configuration option: "width" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -width 402
+ .c cget -width
+} -cleanup {
+ destroy .c
+} -result {402}
+test button-1.259 {configuration option: "width" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -width 3p
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {expected integer but got "3p"}
+test button-1.260 {configuration option: "width" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -width 402
+ .r cget -width
+} -cleanup {
+ destroy .r
+} -result {402}
+test button-1.261 {configuration option: "width" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -width 3p
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {expected integer but got "3p"}
+
+test button-1.262 {configuration option: "wraplength" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -wraplength 100
+ .l cget -wraplength
+} -cleanup {
+ destroy .l
+} -result {100}
+test button-1.263 {configuration option: "wraplength" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -wraplength 6x
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad screen distance "6x"}
+test button-1.264 {configuration option: "wraplength" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -wraplength 100
+ .b cget -wraplength
+} -cleanup {
+ destroy .b
+} -result {100}
+test button-1.265 {configuration option: "wraplength" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -wraplength 6x
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "6x"}
+test button-1.266 {configuration option: "wraplength" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -wraplength 100
+ .c cget -wraplength
+} -cleanup {
+ destroy .c
+} -result {100}
+test button-1.267 {configuration option: "wraplength" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -wraplength 6x
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad screen distance "6x"}
+test button-1.268 {configuration option: "wraplength" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -wraplength 100
+ .r cget -wraplength
+} -cleanup {
+ destroy .r
+} -result {100}
+test button-1.269 {configuration option: "wraplength" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -wraplength 6x
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad screen distance "6x"}
+
+test button-1.270 {configuration options} -body {
+# Additional check to make sure that -selectcolor may be empty in
+# checkbox widgets
+ checkbutton .c
+ .c configure -selectcolor {}
+} -cleanup {
+ destroy .c
+} -result {}
+
+# ex-tests 3.*
+test button-2.1 {ButtonCreate - not enough arguments} -body {
+ button
+} -returnCodes {error} -result {wrong # args: should be "button pathName ?-option value ...?"}
+
+test button-2.2 {ButtonCreate procedure - setting label class} -body {
+ label .x
+ winfo class .x
+} -cleanup {
+ destroy .x
+} -result {Label}
+test button-2.3 {ButtonCreate - setting button class} -body {
+ button .x
+ winfo class .x
+} -cleanup {
+ destroy .x
+} -result {Button}
+test button-2.4 {ButtonCreate - setting checkbutton class} -body {
+ checkbutton .x
+ winfo class .x
+} -cleanup {
+ destroy .x
+} -result {Checkbutton}
+test button-2.5 {ButtonCreate - setting radiobutton class} -body {
+ radiobutton .x
+ winfo class .x
+} -cleanup {
+ destroy .x
+} -result {Radiobutton}
+test button-2.6 {ButtonCreate - setting class} -body {
+ rename button gorp
+ gorp .x
+ winfo class .x
+} -cleanup {
+ destroy .x
+ rename gorp button
+} -result {Button}
+
+test button-2.7 {ButtonCreate - bad window name} -body {
+ button foo
+} -cleanup {
+ destroy foo
+} -returnCodes {error} -result {bad window path name "foo"}
+######### test ex 3.8
+test button-2.8 {ButtonCreate procedure - error in default option value} -body {
+ option add *funny.background bogus
+ button .funny
+} -cleanup {
+ option clear
+ destroy .funny
+} -returnCodes {error} -result {unknown color name "bogus"}
+test button-2.9 {ButtonCreate procedure - error in default option value} -body {
+ option add *funny.background bogus
+ catch {button .funny}
+ return $errorInfo
+} -cleanup {
+ option clear
+ destroy .funny
+} -result {unknown color name "bogus"
+ (database entry for "-background" in widget ".funny")
+ invoked from within
+"button .funny"}
+
+test button-2.10 {ButtonCreate procedure - option error} -body {
+ button .x -gorp foo
+} -cleanup {
+ destroy .x
+} -returnCodes {error} -result {unknown option "-gorp"}
+test button-2.11 {ButtonCreate procedure - option error} -body {
+ catch {button .x -gorp foo}
+ winfo exists .x
+} -cleanup {
+ destroy .x
+} -result 0
+######### ex 3.10
+test button-2.12 {ButtonCreate procedure - return value} -body {
+ set x [button .abcd]
+ return $x
+} -cleanup {
+ destroy .abcd
+} -result {.abcd}
+
+######### ex 4.*
+test button-3.1 {ButtonWidgetCmd - too few arguments} -body {
+ button .b
+ .b
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {wrong # args: should be ".b option ?arg ...?"}
+test button-3.2 {ButtonWidgetCmd - bad option name} -body {
+ button .b
+ .b c
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {ambiguous option "c": must be cget, configure, flash, or invoke}
+test button-3.3 {ButtonWidgetCmd - bad option name} -body {
+ button .b
+ .b bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad option "bogus": must be cget, configure, flash, or invoke}
+test button-3.4 {ButtonWidgetCmd procedure, "cget" option} -body {
+ button .b
+ .b cget a b
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {wrong # args: should be ".b cget option"}
+test button-3.5 {ButtonWidgetCmd procedure, "cget" option} -body {
+ button .b
+ .b cget -gorp
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown option "-gorp"}
+
+#ex 4.7
+test button-3.6 {ButtonWidgetCmd procedure, "cget" option} -body {
+ label .l
+ .l cget -disabledforeground
+} -cleanup {
+ destroy .l
+} -returnCodes {ok} -match {glob} -result {*}
+test button-3.7 {ButtonWidgetCmd procedure, "cget" option} -body {
+ button .b
+ .b cget -disabledforeground
+} -cleanup {
+ destroy .b
+} -returnCodes {ok} -match {glob} -result {*}
+test button-3.8 {ButtonWidgetCmd procedure, "cget" option} -body {
+ button .b
+ .b cget -variable
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown option "-variable"}
+
+test button-3.9 {ButtonWidgetCmd procedure, "cget" option} -body {
+ checkbutton .c
+ .c cget -variable
+} -cleanup {
+ destroy .c
+} -returnCodes {ok} -match {glob} -result {*}
+test button-3.10 {ButtonWidgetCmd procedure, "cget" option} -body {
+ checkbutton .c
+ .c cget -value
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown option "-value"}
+
+test button-3.11 {ButtonWidgetCmd procedure, "cget" option} -body {
+ radiobutton .r
+ .r cget -value
+} -cleanup {
+ destroy .r
+} -returnCodes {ok} -match {glob} -result {*}
+test button-3.12 {ButtonWidgetCmd procedure, "cget" option} -body {
+ radiobutton .r
+ .r cget -onvalue
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown option "-onvalue"}
+
+# ex 4.6
+test button-3.13 {ButtonWidgetCmd procedure, "configure" option} -body {
+ button .b -highlightthickness 3
+ lindex [.b configure -highlightthickness] 4
+} -cleanup {
+ destroy .b
+} -result {3}
+test button-3.14 {ButtonWidgetCmd procedure, "configure" option} -body {
+ checkbutton .c
+ llength [.c configure]
+} -cleanup {
+ destroy .c
+} -result {41}
+test button-3.15 {ButtonWidgetCmd procedure, "configure" option} -body {
+ button .b
+ .b configure -gorp
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown option "-gorp"}
+test button-3.16 {ButtonWidgetCmd procedure, "configure" option} -setup {
+ button .b
+} -body {
+ .b co -bg #ffffff -fg
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {value for "-fg" missing}
+test button-3.17 {ButtonWidgetCmd procedure, "configure" option} -setup {
+ button .b
+} -body {
+ .b configure -fg #123456
+ .b configure -bg #654321
+ lindex [.b configure -fg] 4
+} -cleanup {
+ destroy .b
+} -result {#123456}
+test button-3.18 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ checkbutton .c
+ .c deselect foo
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {wrong # args: should be ".c deselect"}
+test button-3.19 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ label .l
+ .l deselect
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad option "deselect": must be cget or configure}
+test button-3.20 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ button .b
+ .b deselect
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad option "deselect": must be cget, configure, flash, or invoke}
+
+test button-3.21 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ checkbutton .c -variable checkvar -onvalue 1 -offvalue 0
+ set checkvar 1
+ .c d
+ return $checkvar
+} -cleanup {
+ destroy .c
+} -result {0}
+test button-3.22 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar green
+ .r deselect
+ return $radiovar
+} -cleanup {
+ destroy .r
+} -result {green}
+test button-3.23 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar red
+ .r deselect
+ return $radiovar
+} -cleanup {
+ destroy .r
+} -result {}
+
+test button-3.24 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ checkbutton .c -variable checkvar -onvalue 1 -offvalue 0
+ set checkvar 1
+ trace variable checkvar w bogusTrace
+ .c deselect
+} -cleanup {
+ destroy .c
+ trace vdelete checkvar w bogusTrace
+} -returnCodes {error} -result {can't set "checkvar": trace aborted}
+test button-3.25 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ checkbutton .c -variable checkvar -onvalue 1 -offvalue 0
+ set checkvar 1
+ trace variable checkvar w bogusTrace
+ catch {.c deselect}
+ list $errorInfo $checkvar
+} -cleanup {
+ trace vdelete checkvar w bogusTrace
+ destroy .c
+} -match {glob} -result {{*trace aborted
+ while executing
+*
+".c deselect"} 0}
+test button-3.26 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar red
+ trace variable radiovar w bogusTrace
+ .r deselect
+} -cleanup {
+ destroy .r
+ trace vdelete radiovar w bogusTrace
+} -match {glob} -returnCodes {error} -result {can't set "radiovar": trace aborted}
+test button-3.27 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar red
+ trace variable radiovar w bogusTrace
+ catch {.r deselect}
+ list $errorInfo $radiovar
+} -cleanup {
+ destroy .r
+ trace vdelete radiovar w bogusTrace
+} -match glob -result {{*trace aborted
+ while executing
+*
+".r deselect"} {}}
+
+test button-3.28 {ButtonWidgetCmd procedure, "flash" option} -body {
+ button .b
+ .b flash foo
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {wrong # args: should be ".b flash"}
+test button-3.29 {ButtonWidgetCmd procedure, "flash" option} -body {
+ label .l
+ .l flash
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad option "flash": must be cget or configure}
+test button-3.30 {ButtonWidgetCmd procedure, "flash" option} -body {
+ button .b
+ catch {.b flash}
+} -cleanup {
+ destroy .b
+} -returnCodes {ok} -match {glob} -result {*}
+test button-3.31 {ButtonWidgetCmd procedure, "flash" option} -body {
+ checkbutton .c
+ catch {.c flash}
+} -cleanup {
+ destroy .c
+} -returnCodes {ok} -match {glob} -result {*}
+test button-3.32 {ButtonWidgetCmd procedure, "flash" option} -body {
+ radiobutton .r
+ catch {.r f}
+} -cleanup {
+ destroy .r
+} -returnCodes {ok} -match {glob} -result {*}
+
+test button-3.33 {ButtonWidgetCmd procedure, "invoke" option} -body {
+ label .l
+ .l invoke
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad option "invoke": must be cget or configure}
+test button-3.34 {ButtonWidgetCmd procedure, "invoke" option} -body {
+ button .b
+ .b invoke foo
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {wrong # args: should be ".b invoke"}
+test button-3.35 {ButtonWidgetCmd procedure, "invoke" option} -body {
+ button .b
+ .b configure -command {set x invoked}
+ set x "not invoked"
+ .b invoke
+ return $x
+} -cleanup {
+ destroy .b
+} -result {invoked}
+test button-3.36 {ButtonWidgetCmd procedure, "invoke" option} -body {
+ button .b
+ .b configure -command {set x invoked} -state disabled
+ set x "not invoked"
+ .b invoke
+ return $x
+} -cleanup {
+ destroy .b
+} -result {not invoked}
+test button-3.37 {ButtonWidgetCmd procedure, "invoke" option} -body {
+ checkbutton .c -variable checkvar -onvalue 1 -offvalue 0 \
+ -command {set x invoked}
+ set checkvar bogus
+ set x "not invoked"
+ .c invoke
+ list $x $checkvar
+} -cleanup {
+ destroy .c
+} -result {invoked 1}
+test button-3.38 {ButtonWidgetCmd procedure, "invoke" option} -body {
+ radiobutton .r -command {set x invoked} -variable radiovar -value red
+ set radiovar green
+ set x "not invoked"
+ .r i
+ list $x $radiovar
+} -cleanup {
+ destroy .r
+} -result {invoked red}
+
+test button-3.39 {ButtonWidgetCmd procedure, "select" option} -body {
+ label .l
+ .l select
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad option "select": must be cget or configure}
+test button-3.40 {ButtonWidgetCmd procedure, "select" option} -body {
+ button .b
+ .b select
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad option "select": must be cget, configure, flash, or invoke}
+test button-3.41 {ButtonWidgetCmd procedure, "select" option} -body {
+ checkbutton .c
+ .c select foo
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {wrong # args: should be ".c select"}
+test button-3.42 {ButtonWidgetCmd procedure, "select" option} -body {
+ checkbutton .c -variable checkvar -onvalue lovely -offvalue 0
+ set checkvar bogus
+ .c s
+ return $checkvar
+} -cleanup {
+ destroy .c
+} -result {lovely}
+test button-3.43 {ButtonWidgetCmd procedure, "select" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar green
+ .r select
+ return $radiovar
+} -cleanup {
+ destroy .r
+} -result {red}
+test button-3.44 {ButtonWidgetCmd procedure, "select" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar yellow
+ trace variable radiovar w bogusTrace
+ .r select
+} -cleanup {
+ destroy .r
+ trace vdelete radiovar w bogusTrace
+} -returnCodes {error} -result {can't set "radiovar": trace aborted}
+test button-3.45 {ButtonWidgetCmd procedure, "select" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar yellow
+ trace variable radiovar w bogusTrace
+ catch {.r select}
+ list $errorInfo $radiovar
+} -cleanup {
+ destroy .r
+ trace vdelete radiovar w bogusTrace
+} -match {glob} -result {{*trace aborted
+ while executing
+*
+".r select"} red}
+
+# ex 4.43
+test button-3.46 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ label .l
+ .l toggle
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad option "toggle": must be cget or configure}
+test button-3.47 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ button .b
+ .b toggle
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad option "toggle": must be cget, configure, flash, or invoke}
+test button-3.48 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ radiobutton .r
+ .r toggle
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad option "toggle": must be cget, configure, deselect, flash, invoke, or select}
+test button-3.49 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ checkbutton .c
+ .c toggle foo
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {wrong # args: should be ".c toggle"}
+test button-3.50 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ set checkvar bogus
+ checkbutton .c -variable checkvar -onvalue sunshine -offvalue rain
+ .c toggle
+ set result $checkvar
+ .c toggle
+ lappend result $checkvar
+ .c toggle
+ lappend result $checkvar
+ return $result
+} -cleanup {
+ destroy .c
+} -result {sunshine rain sunshine}
+test button-3.51 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ checkbutton .c -variable checkvar -onvalue xyz -offvalue abc
+ set checkvar xyz
+ trace variable checkvar w bogusTrace
+ .c toggle
+} -cleanup {
+ destroy .c
+ trace vdelete checkvar w bogusTrace
+} -returnCodes {error} -result {can't set "checkvar": trace aborted}
+test button-3.52 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ checkbutton .c -variable checkvar -onvalue xyz -offvalue abc
+ set checkvar xyz
+ trace variable checkvar w bogusTrace
+ catch {.c toggle}
+ list $errorInfo $checkvar
+} -cleanup {
+ trace vdelete checkvar w bogusTrace
+ destroy .c
+} -match {glob} -result {{*trace aborted
+ while executing
+*
+".c toggle"} abc}
+test button-3.53 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ checkbutton .c -variable checkvar -onvalue xyz -offvalue abc
+ set checkvar abc
+ trace variable checkvar w bogusTrace
+ .c toggle
+} -cleanup {
+ trace vdelete checkvar w bogusTrace
+ destroy .c
+} -returnCodes {error} -result {can't set "checkvar": trace aborted}
+test button-3.54 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ checkbutton .c -variable checkvar -onvalue xyz -offvalue abc
+ set checkvar abc
+ trace variable checkvar w bogusTrace
+ catch {.c toggle}
+ list $errorInfo $checkvar
+} -cleanup {
+ trace vdelete checkvar w bogusTrace
+ destroy .c
+} -match {glob} -result {{*trace aborted
+ while executing
+*
+".c toggle"} xyz}
+test button-3.55 {ButtonWidgetCmd procedure, "toggle" option} -setup {
+ unset -nocomplain checkvar
+} -body {
+ checkbutton .c -variable checkvar -onvalue xyz -offvalue abc
+ unset checkvar
+ set checkvar(1) 1
+ .c toggle
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {can't set "checkvar": variable is array}
+test button-3.56 {ButtonWidgetCmd procedure, "toggle" option} -setup {
+ unset -nocomplain checkvar
+} -body {
+ checkbutton .c -variable checkvar -onvalue xyz -offvalue abc
+ unset checkvar
+ set checkvar(1) 1
+ catch {.c toggle}
+ return $errorInfo
+} -cleanup {
+ destroy .c
+} -match {glob} -result {can't set "checkvar": variable is array
+ while executing
+".c toggle"}
+
+test button-4.1 {DestroyButton procedure} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ unset -nocomplain x
+} -body {
+ button .b1 -image image1
+ button .b2 -fg #ff0000 -text "Button 2"
+ button .b3 -state active -text "Button 3"
+ button .b4 -disabledforeground #0000ff -state disabled -text "Button 4"
+ checkbutton .b5 -variable x -text "Checkbutton 5"
+ set x 1
+ pack .b1 .b2 .b3 .b4 .b5
+ update
+ deleteWindows
+} -cleanup {
+ destroy .b1 .b2 .b3 .b4 .b5
+ image delete image1
+} -result {}
+
+test button-5.1 {ConfigureButton - textvariable trace} -body {
+ button .b -bd 4 -bg green
+ .b configure -bd 7 -bg red -fg bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "bogus"}
+test button-5.2 {ConfigureButton - textvariable trace} -body {
+ button .b -bd 4 -bg green
+ catch {.b configure -bd 7 -bg red -fg bogus}
+ list [.b cget -bd] [.b cget -bg]
+} -cleanup {
+ destroy .b
+} -result {4 green}
+test button-5.3 {ConfigureButton - textvariable trace} -body {
+ button .b -textvariable x
+ set x From-x
+ set y From-y
+ .b configure -textvariable y
+ set x New
+ lindex [.b configure -text] 4
+} -cleanup {
+ destroy .b
+} -result {From-y}
+test button-5.4 {ConfigureButton - variable trace} -body { ;# ex 6.2a
+ checkbutton .c -variable x
+ set x 1
+ set y 1
+ .c configure -textvariable y
+ set x 0
+ .c toggle
+ return $y
+} -cleanup {
+ destroy .c
+} -result {1}
+
+test button-5.5 {ConfigureButton - image handling} -constraints {
+ testImageType
+} -setup {
+ imageCleanup
+ image create test image1
+ image create test image2
+} -body {
+ button .b -image image1
+ image delete image1
+ .b configure -image image2
+ imageNames
+} -cleanup {
+ destroy .b
+ imageCleanup
+} -result {image2}
+
+test button-5.6 {ConfigureButton - default value for variable} -body {
+ checkbutton .c
+ .c cget -variable
+} -cleanup {
+ destroy .c
+} -result {c}
+test button-5.7 {ConfigureButton - setting selected state from variable} -body {
+ set x 0
+ set y Shiny
+ checkbutton .c -variable x
+ .c configure -variable y -onvalue Shiny
+ .c toggle
+ return $y
+} -cleanup {
+ destroy .c
+} -result {0}
+test button-5.8 {ConfigureButton - setting selected state from variable} -setup {
+ unset -nocomplain x
+} -body {
+ checkbutton .c -variable x -offvalue Bogus
+ return $x
+} -cleanup {
+ destroy .c
+} -result {Bogus}
+
+test button-5.9 {ConfigureButton - setting selected state from variable} -setup {
+ unset -nocomplain x
+} -body {
+ radiobutton .r -variable x
+ return $x
+} -cleanup {
+ destroy .r
+} -result {}
+
+test button-5.10 {ConfigureButton - error in setting variable} -setup {
+ unset -nocomplain x
+} -body {
+ trace variable x w bogusTrace
+ radiobutton .r -variable x
+} -cleanup {
+ destroy .r
+ trace vdelete x w bogusTrace
+} -returnCodes {error} -result {can't set "x": trace aborted}
+
+test button-5.11 {ConfigureButton - bad image name} -body {
+ button .b -image bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+
+test button-5.12 {ConfigureButton - setting variable from current text value} -setup {
+ unset -nocomplain x
+} -body {
+ button .b -textvariable x -text "Button 1"
+ return $x
+} -cleanup {
+ destroy .b
+} -result {Button 1}
+
+test button-5.13 {ConfigureButton - using current value of variable} -body {
+ set x Override
+ button .b -textvariable x -text "Button 1"
+ return $x
+} -cleanup {
+ destroy .b
+} -result {Override}
+
+test button-5.14 {ConfigureButton - variable handling} -setup {
+ unset -nocomplain x
+} -body {
+ trace variable x w bogusTrace
+ radiobutton .r -text foo -textvariable x
+} -cleanup {
+ trace vdelete x w bogusTrace
+ destroy .r
+} -returnCodes {error} -result {can't set "x": trace aborted}
+test button-5.15 {ConfigureButton - variable handling} -setup {
+ unset -nocomplain x
+} -body {
+ trace variable x w bogusTrace
+ catch {radiobutton .r -text foo -textvariable x}
+ return $x
+} -cleanup {
+ trace vdelete x w bogusTrace
+ destroy .r
+} -result {foo}
+
+#ex 6.14
+test button-5.16 {ConfigureButton - -width option} -body {
+ button .b -text "Button 1"
+ .b configure -width 1i
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "1i"}
+test button-5.17 {ConfigureButton - -width option} -body {
+ button .b -text "Button 1"
+ catch {.b configure -width 1i}
+ return $errorInfo
+} -cleanup {
+ destroy .b
+} -result {expected integer but got "1i"
+ (processing -width option)
+ invoked from within
+".b configure -width 1i"}
+test button-5.18 {ConfigureButton - -height option} -body {
+ button .b -text "Button 1"
+ .b configure -height 0.5c
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "0.5c"}
+test button-5.19 {ConfigureButton - -height option} -body {
+ button .b -text "Button 1"
+ catch {.b configure -height 0.5c}
+ return $errorInfo
+} -cleanup {
+ destroy .b
+} -result {expected integer but got "0.5c"
+ (processing -height option)
+ invoked from within
+".b configure -height 0.5c"}
+#ex 6.16
+test button-5.20 {ConfigureButton - -width option} -body {
+ button .b -bitmap questhead
+ .b configure -width abc
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "abc"}
+test button-5.21 {ConfigureButton - -width option} -body {
+ button .b -bitmap questhead
+ catch {.b configure -width abc}
+ return $errorInfo
+} -cleanup {
+ destroy .b
+} -result {bad screen distance "abc"
+ (processing -width option)
+ invoked from within
+".b configure -width abc"}
+test button-5.22 {ConfigureButton - -height option} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+} -body {
+ button .b -image image1
+ .b configure -height 0.5x
+} -cleanup {
+ destroy .b
+ image delete image1
+} -returnCodes {error} -result {bad screen distance "0.5x"}
+test button-5.23 {ConfigureButton - -height option} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+} -body {
+#ztestImageType
+ button .b -image image1
+ catch {.b configure -height 0.5x}
+ return $errorInfo
+} -cleanup {
+ destroy .b
+ image delete image1
+} -result {bad screen distance "0.5x"
+ (processing -height option)
+ invoked from within
+".b configure -height 0.5x"}
+#ex 6.18
+test button-5.24 {ConfigureButton - computing geometry} -constraints {
+ fonts
+} -body {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ .b configure -text "Sample text" -width 10 -height 2
+ pack .b
+ set result "[winfo reqwidth .b] [winfo reqheight .b]"
+ .b configure -bitmap questhead
+ lappend result [winfo reqwidth .b] [winfo reqheight .b]
+} -cleanup {
+ destroy .b
+} -result {104 46 20 12}
+
+test button-5.25 {ConfigureButton - computing geometry} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+} -body {
+ .b configure -text "Button 1"
+ set old [winfo reqwidth .b]
+ .b configure -text "Much longer text"
+ set new [winfo reqwidth .b]
+ expr {$old == $new}
+} -cleanup {
+ destroy .b
+} -result {0}
+
+test button-6.1 {ButtonEventProc procedure} -body {
+ button .b -text "Test Button" -command {
+ destroy .b
+ set x [list [winfo exists .b] [info commands .b]]
+}
+ .b invoke
+ return $x
+} -cleanup {
+ destroy .b
+} -result {0 {}}
+
+test button-6.2 {ButtonEventProc procedure} -setup {
+ set x {}
+} -body {
+ button .b1 -bg #543210
+ rename .b1 .b2
+ lappend x [winfo children .]
+ lappend x [.b2 cget -bg]
+ destroy .b1
+ lappend x [info command .b*] [winfo children .]
+} -cleanup {
+ destroy .b1
+} -result {.b1 #543210 {} {}}
+
+test button-7.1 {ButtonCmdDeletedProc procedure} -body {
+ button .b
+ rename .b {}
+ list [info command .b*] [winfo children .]
+} -cleanup {
+ destroy .b
+} -result {{} {}}
+
+test button-8.1 {TkInvokeButton procedure} -setup {
+ set x 0
+} -body {
+ checkbutton .c -variable x
+ set result $x
+ .c invoke
+ lappend result $x
+ .c invoke
+ lappend result $x
+} -cleanup {
+ destroy .c
+} -result {0 1 0}
+
+test button-8.2 {TkInvokeButton procedure} -setup {
+ set x 0
+} -body {
+ checkbutton .c -variable x
+ trace variable x w bogusTrace
+ .c invoke
+} -cleanup {
+ destroy .c
+ trace vdelete x w bogusTrace
+} -returnCodes {error} -result {can't set "x": trace aborted}
+test button-8.3 {TkInvokeButton procedure} -setup {
+ set x 0
+} -body {
+ checkbutton .c -variable x
+ trace variable x w bogusTrace
+ catch {.c invoke}
+ return $x
+} -cleanup {
+ destroy .c
+ trace vdelete x w bogusTrace
+} -result {1}
+test button-8.4 {TkInvokeButton procedure} -setup {
+ set x 1
+} -body {
+ checkbutton .c -variable x
+ trace variable x w bogusTrace
+ .c invoke
+} -cleanup {
+ destroy .c
+ trace vdelete x w bogusTrace
+} -returnCodes {error} -result {can't set "x": trace aborted}
+test button-8.5 {TkInvokeButton procedure} -setup {
+ set x 1
+} -body {
+ checkbutton .c -variable x
+ trace variable x w bogusTrace
+ catch {.c invoke}
+ return $x
+} -cleanup {
+ destroy .c
+ trace vdelete x w bogusTrace
+} -result {0}
+
+test button-8.6 {TkInvokeButton procedure} -setup {
+ set x 0
+} -body {
+ radiobutton .r -variable x -value red
+ set result $x
+ .r invoke
+ lappend result $x
+ .r invoke
+ lappend result $x
+} -cleanup {
+ destroy .r
+} -result {0 red red}
+
+test button-8.7 {TkInvokeButton procedure} -body {
+ radiobutton .r -variable x -value red
+ set x green
+ trace variable x w bogusTrace
+ .r invoke
+} -cleanup {
+ destroy .r
+ trace vdelete x w bogusTrace
+} -returnCodes {error} -result {can't set "x": trace aborted}
+test button-8.8 {TkInvokeButton procedure} -body {
+ radiobutton .r -variable x -value red
+ set x green
+ trace variable x w bogusTrace
+ catch {.r invoke}
+ list $errorInfo $x
+} -cleanup {
+ destroy .r
+ trace vdelete x w bogusTrace
+} -match {glob} -result {{*trace aborted
+ while executing
+*
+".r invoke"} red}
+
+#ex 9.6
+test button-8.9 {TkInvokeButton procedure} -setup {
+ set result untouched
+} -body {
+ button .b -command {set result invoked}
+ set msg [.b invoke]
+ list $msg $result
+} -cleanup {
+ destroy .b
+} -result {invoked invoked}
+test button-8.10 {TkInvokeButton procedure} -setup {
+ set result untouched
+ set x 0
+} -body {
+ checkbutton .c -variable x -command {set result "invoked $x"}
+ set msg [.c invoke]
+ list $msg $result
+} -cleanup {
+ destroy .c
+} -result {{invoked 1} {invoked 1}}
+test button-8.11 {TkInvokeButton procedure} -setup {
+ set result untouched
+ set x 0
+} -body {
+ radiobutton .r -variable x -value red -command {set result "invoked $x"}
+ set msg [.r invoke]
+ list $msg $result
+} -cleanup {
+ destroy .r
+} -result {{invoked red} {invoked red}}
+
+test button-9.1 {ButtonVarProc procedure} -body {
+ set x 1
+ checkbutton .c -variable x
+ unset x
+ set result [info exists x]
+ .c toggle
+ lappend result $x
+ set x 0
+ .c toggle
+ lappend result $x
+} -cleanup {
+ destroy .c
+} -result {0 1 1}
+test button-9.2 {ButtonVarProc procedure} -body {
+ set x 0
+ checkbutton .c -variable x
+ set x 44
+ .c toggle
+ return $x
+} -cleanup {
+ destroy .c
+} -result {1}
+test button-9.3 {ButtonVarProc procedure} -setup {
+ set x 1
+} -body {
+ checkbutton .c -variable x
+ set x 44
+ .c toggle
+ return $x
+} -cleanup {
+ destroy .c
+} -result {1}
+test button-9.4 {ButtonVarProc procedure} -setup {
+ set x 0
+} -body {
+ checkbutton .c -variable x
+ set x 1
+ .c toggle
+ return $x
+} -cleanup {
+ destroy .c
+} -result {0}
+test button-9.5 {ButtonVarProc procedure} -setup {
+ set x 1
+} -body {
+ checkbutton .c -variable x
+ set x 1
+ .c toggle
+ return $x
+} -cleanup {
+ destroy .c
+} -result {0}
+test button-9.6 {ButtonVarProc procedure} -setup {
+ set x 0
+} -body {
+ checkbutton .c -variable x
+ set x 0
+ .c toggle
+ return $x
+} -cleanup {
+ destroy .c
+} -result {1}
+test button-9.7 {ButtonVarProc procedure} -setup {
+ set x 1
+} -body {
+ checkbutton .c -variable x
+ set x 0
+ .c toggle
+ return $x
+} -cleanup {
+ destroy .c
+} -result {1}
+test button-9.8 {ButtonVarProc procedure, can't read variable} -setup {
+# This test does nothing but produce a core dump if there's a prbblem.
+ unset -nocomplain a
+} -body {
+ checkbutton .c -variable a
+ unset a
+ set a(32) 0
+ unset a
+} -cleanup {
+ destroy .c
+} -result {}
+
+test button-10.1 {ButtonTextVarProc procedure} -body {
+ set x Label
+ button .b -textvariable x
+ unset x
+ set result [list $x [.b cget -text]]
+ set x New
+ lappend result [.b cget -text]
+} -cleanup {
+ destroy .b
+} -result {Label Label New}
+test button-10.2 {ButtonTextVarProc procedure} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+} -body {
+# Windows buttons have a default min width, so we have to
+# set this to be longer to force the wider button.
+ set x ExtraLongLabel
+ .b configure -textvariable x
+ set old [winfo reqwidth .b]
+ set x New
+ set new [winfo reqwidth .b]
+ expr {$old == $new}
+} -cleanup {
+ destroy .b
+} -result {0}
+
+test button-11.1 {ButtonImageProc procedure} -constraints {
+ testImageType
+} -setup {
+ label .l -highlightthickness 0 -font {Helvetica -12 bold}
+ image create test image1
+} -body {
+ .l configure -image image1 -padx 0 -pady 0 -bd 0
+ pack .l
+ set result "[winfo reqwidth .l] [winfo reqheight .l]"
+ image1 changed 0 0 0 0 80 100
+ lappend result [winfo reqwidth .l] [winfo reqheight .l]
+} -cleanup {
+ destroy .l
+ image delete image1
+} -result {30 15 80 100}
+
+test button-12.1 {button widget vs hidden commands} -body {
+ button .b -text hello
+ set l [interp hidden]
+ interp hide {} .b
+ destroy .b
+
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 == $res2}
+} -cleanup {
+ destroy .b
+} -result {1}
+
+test button-13.1 {size behavior: label} -setup {
+ label .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ label .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ label .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+test button-13.2 {size behavior: label} -setup {
+ label .a -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ label .b -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ label .c -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+
+test button-13.3 {size behavior: button} -setup {
+ button .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ button .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+test button-13.4 {size behavior: button} -setup {
+ button .a -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ button .b -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ button .c -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+
+test button-13.5 {size behavior: radiobutton} -setup {
+ radiobutton .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ radiobutton .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ radiobutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+
+test button-13.6 {size behavior: radiobutton} -setup {
+ radiobutton .a -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ radiobutton .b -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ radiobutton .c -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+
+test button-13.7 {size behavior: checkbutton} -setup {
+ checkbutton .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ checkbutton .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+
+test button-13.8 {size behavior: checkbutton} -setup {
+ checkbutton .a -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ checkbutton .b -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+
+test button-14.1 {bug fix: [011706ec42] tk::ButtonInvoke unsafe wrt widget destruction} -body {
+ proc destroy_button {} {
+ if {[winfo exists .top.b]} {
+ destroy .top.b
+ }
+ }
+ toplevel .top
+ button .top.b -text Foo -command destroy_button
+ bind .top.b <space> destroy_button
+ pack .top.b
+ focus -force .top.b
+ update
+ event generate .top.b <space>
+ update ; # shall not trigger error invalid command name ".top.b"
+} -cleanup {
+ destroy .top.b .top
+} -result {}
+
+imageFinish
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/canvImg.test b/tk8.6/tests/canvImg.test
new file mode 100644
index 0000000..776d268
--- /dev/null
+++ b/tk8.6/tests/canvImg.test
@@ -0,0 +1,796 @@
+# This file is a Tcl script to test out the procedures in tkCanvImg.c,
+# which implement canvas "image" items. It is organized in the standard
+# fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+imageInit
+
+# Canvas used in every test case of the whole file
+canvas .c
+pack .c
+update
+
+
+test canvImg-1.1 {options for image items} -body {
+ .c create image 50 50 -anchor nw -tags i1
+ .c itemconfigure i1 -anchor
+} -cleanup {
+ .c delete all
+} -result {-anchor {} {} center nw}
+test canvImg-1.2 {options for image items} -body {
+ .c create image 50 50 -anchor gorp -tags i1
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center}
+test canvImg-1.3 {options for image items} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
+ .c create image 50 50 -image foo -tags i1
+ .c itemconfigure i1 -image
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {-image {} {} {} foo}
+test canvImg-1.4 {options for image items} -body {
+ .c create image 50 50 -image unknown -tags i1
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {image "unknown" doesn't exist}
+test canvImg-1.5 {options for image items} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
+ .c create image 50 50 -image foo -tags {i1 foo}
+ .c itemconfigure i1 -tags
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {-tags {} {} {} {i1 foo}}
+
+test canvImg-2.1 {CreateImage procedure} -body {
+ .c create image 40
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1}
+test canvImg-2.2 {CreateImage procedure} -body {
+ .c create image 40 50 60
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {unknown option "60"}
+test canvImg-2.3 {CreateImage procedure} -body {
+ .c delete all
+ set i [.c create image 50 50]
+ list [lindex [.c itemconf $i -anchor] 4] \
+ [lindex [.c itemconf $i -image] 4] \
+ [lindex [.c itemconf $i -tags] 4]
+} -cleanup {
+ .c delete all
+} -result {center {} {}}
+test canvImg-2.4 {CreateImage procedure} -body {
+ .c create image xyz 40
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvImg-2.5 {CreateImage procedure} -body {
+ .c create image 50 qrs
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad screen distance "qrs"}
+test canvImg-2.6 {CreateImage procedure} -constraints testImageType -body {
+ .c create image 50 50 -gorp foo
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {unknown option "-gorp"}
+
+
+test canvImg-3.1 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
+ .c create image 50 100 -image foo -tags i1
+ format {%.6g %.6g} {*}[.c coords i1]
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {50 100}
+test canvImg-3.2 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
+ .c create image 50 100 -image foo -tags i1
+ .c coords i1 dumb 100
+} -cleanup {
+ .c delete all
+ image delete foo
+} -returnCodes {error} -result {bad screen distance "dumb"}
+test canvImg-3.3 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
+ .c delete all
+ .c create image 50 100 -image foo -tags i1
+ .c coords i1 250 dumb0
+} -cleanup {
+ .c delete all
+ image delete foo
+} -returnCodes {error} -result {bad screen distance "dumb0"}
+test canvImg-3.4 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
+ .c delete all
+ .c create image 50 100 -image foo -tags i1
+ .c coords i1 250
+} -cleanup {
+ .c delete all
+ image delete foo
+} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1}
+test canvImg-3.5 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
+ .c delete all
+ .c create image 50 100 -image foo -tags i1
+ .c coords i1 250 300 400
+} -cleanup {
+ .c delete all
+ image delete foo
+} -returnCodes {error} -result {wrong # coordinates: expected 0 or 2, got 3}
+
+
+test canvImg-4.1 {ConfiugreImage procedure} -constraints testImageType -setup {
+ .c delete all
+} -body {
+ image create test foo -variable x
+ .c create image 50 100 -image foo -tags i1
+ update
+ set x {}
+ .c itemconfigure i1 -image {}
+ update
+ list $x [.c bbox i1]
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {{{foo free}} {}}
+test canvImg-4.2 {ConfiugreImage procedure} -constraints testImageType -setup {
+ .c delete all
+} -body {
+ image create test foo -variable x
+ image create test foo2 -variable y
+ foo2 changed 0 0 0 0 80 60
+ .c create image 50 100 -image foo -tags i1 -anchor nw
+ update
+ set x {}
+ set y {}
+ .c itemconfigure i1 -image foo2
+ update
+ list $x $y [.c bbox i1]
+} -cleanup {
+ .c delete all
+ image delete foo
+ image delete foo2
+} -result {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60 30 30}} {50 100 130 160}}
+test canvImg-4.3 {ConfiugreImage procedure} -constraints testImageType -setup {
+ .c delete all
+} -body {
+ image create test foo -variable x
+ image create test foo2 -variable y
+ foo2 changed 0 0 0 0 80 60
+ .c create image 50 100 -image foo -tags i1 -anchor nw
+ update
+ set x {}
+ set y {}
+ .c itemconfigure i1 -image lousy
+} -cleanup {
+ .c delete all
+ image delete foo foo2
+} -returnCodes {error} -result {image "lousy" doesn't exist}
+
+
+test canvImg-5.1 {DeleteImage procedure} -constraints testImageType -setup {
+ .c delete all
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ image create test foo2 -variable y
+ image create test xyzzy -variable z
+ .c create image 50 100 -image xyzzy -tags i1
+ update
+ set names [lsort [imageNames]]
+ image delete xyzzy
+ set z {}
+ set names2 [lsort [imageNames]]
+ .c delete i1
+ update
+ list $names $names2 $z [lsort [imageNames]]
+} -cleanup {
+ imageCleanup
+ .c delete all
+} -result {{foo foo2 xyzzy} {foo foo2} {} {foo foo2}}
+test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} -body {
+ .c delete all
+ .c create image 50 100 -tags i1
+ update
+ .c delete i1
+ update
+} -result {}
+
+
+test canvImg-6.1 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
+ .c create image 15.51 17.51 -image foo -tags i1 -anchor nw
+ .c bbox i1
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {16 18 46 33}
+test canvImg-6.2 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
+ .c create image 15.49 17.49 -image foo -tags i1 -anchor nw
+ .c bbox i1
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {15 17 45 32}
+test canvImg-6.3 {ComputeImageBbox procedure} -setup {
+ .c delete all
+} -body {
+ .c create image 20 30 -tags i1 -anchor nw
+ .c bbox i1
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-6.4 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
+ .c delete all
+ .c create image 20 30 -image foo -tags i1 -anchor nw
+ .c bbox i1
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {20 30 50 45}
+test canvImg-6.5 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
+ .c delete all
+ .c create image 20 30 -image foo -tags i1 -anchor n
+ .c bbox i1
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {5 30 35 45}
+test canvImg-6.6 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
+ .c delete all
+ .c create image 20 30 -image foo -tags i1 -anchor ne
+ .c bbox i1
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {-10 30 20 45}
+test canvImg-6.7 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
+ .c delete all
+ .c create image 20 30 -image foo -tags i1 -anchor e
+ .c bbox i1
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {-10 23 20 38}
+test canvImg-6.8 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
+ .c delete all
+ .c create image 20 30 -image foo -tags i1 -anchor se
+ .c bbox i1
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {-10 15 20 30}
+test canvImg-6.9 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
+ .c delete all
+ .c create image 20 30 -image foo -tags i1 -anchor s
+ .c bbox i1
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {5 15 35 30}
+test canvImg-6.10 {ComputeImageBbox procedure} -constraints {
+ testImageType
+} -setup {
+ image create test foo
+ .c delete all
+} -body {
+ .c delete all
+ .c create image 20 30 -image foo -tags i1 -anchor sw
+ .c bbox i1
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {20 15 50 30}
+test canvImg-6.11 {ComputeImageBbox procedure} -constraints {
+ testImageType
+} -setup {
+ image create test foo
+ .c delete all
+} -body {
+ .c delete all
+ .c create image 20 30 -image foo -tags i1 -anchor w
+ .c bbox i1
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {20 23 50 38}
+test canvImg-6.12 {ComputeImageBbox procedure} -constraints {
+ testImageType
+} -setup {
+ image create test foo
+ .c delete all
+} -body {
+ .c delete all
+ .c create image 20 30 -image foo -tags i1 -anchor center
+ .c bbox i1
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {5 23 35 38}
+
+# The following test is non-portable because of differences in
+# coordinate rounding on some machines (does 0.5 round up?).
+
+test canvImg-7.1 {DisplayImage procedure} -constraints {
+ nonPortable testImageType
+} -setup {
+ .c delete all
+} -body {
+ image create test foo -variable x
+ .c create image 50 100 -image foo -tags i1 -anchor nw
+ update
+ set x {}
+ .c create rect 55 110 65 115 -width 1 -outline black -fill white
+ update
+ set x
+} -result {{foo display 4 9 12 6 30 30}}
+test canvImg-7.2 {DisplayImage procedure, no image} -body {
+ .c delete all
+ .c create image 50 100 -tags i1
+ update
+ .c create rect 55 110 65 115 -width 1 -outline black -fill white
+ update
+} -result {}
+
+
+# image used in 8.* test cases
+if {[testConstraint testImageType]} {
+ image create test foo
+}
+test canvImg-8.1 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect 50 70 80 81
+ .c gettags [.c find closest 70 90]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.2 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{50 70 80 79}
+ .c gettags [.c find closest {*}{70 90}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.3 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{99 70 110 81}
+ .c gettags [.c find closest {*}{90 90}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.4 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{101 70 110 79}
+ .c gettags [.c find closest {*}{90 90}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.5 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{99 100 110 115}
+ .c gettags [.c find closest {*}{90 110}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.6 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{101 100 110 115}
+ .c gettags [.c find closest {*}{90 110}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.7 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{99 134 110 145}
+ .c gettags [.c find closest {*}{90 125}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.8 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{101 136 110 145}
+ .c gettags [.c find closest {*}{90 125}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.9 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{50 134 80 145}
+ .c gettags [.c find closest {*}{70 125}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.10 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{50 136 80 145}
+ .c gettags [.c find closest {*}{70 125}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.11 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 134 31 145}
+ .c gettags [.c find closest {*}{40 125}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.12 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 136 29 145}
+ .c gettags [.c find closest {*}{40 125}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.13 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 100 31 115}
+ .c gettags [.c find closest {*}{40 110}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.14 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 100 29 115}
+ .c gettags [.c find closest {*}{40 110}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.15 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 70 31 80}
+ .c gettags [.c find closest {*}{40 90}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.16 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 70 29 79}
+ .c gettags [.c find closest {*}{40 90}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.17 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{60 70 69 109}
+ .c gettags [.c find closest {*}{70 110}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.18 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{60 70 71 111}
+ .c gettags [.c find closest {*}{70 110}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+.c delete all
+
+test canvImg-8.19 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 60 0 70 99]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.20 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 60 0 70 99.999]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.21 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 60 0 70 101]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.22 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 81 105 120 115]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.23 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 80.001 105 120 115]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.24 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 79 105 120 115]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.25 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 60 116 70 150]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.26 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 60 115.001 70 150]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.27 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 60 114 70 150]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.28 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 0 105 49 115]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.29 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 0 105 50 114.999]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.30 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 0 105 51 115]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.31 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 0 0 49.999 99.999]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.32 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 0 0 51 101]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.33 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 80 0 150 100]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.34 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 79 0 150 101]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.35 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 80.001 115.001 150 180]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.36 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 79 114 150 180]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.37 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 0 115 50 180]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.38 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find overlapping 0 114 51 180]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.39 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find enclosed 0 0 200 200]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.40 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find enclosed 49.999 99.999 80.001 115.001]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.41 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find enclosed 51 100 80 115]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.42 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find enclosed 50 101 80 115]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.43 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find enclosed 50 100 79 115]
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.44 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c gettags [.c find enclosed 50 100 80 114]
+} -cleanup {
+ .c delete all
+} -result {}
+if {[testConstraint testImageType]} {
+ image delete foo
+}
+
+
+test canvImg-9.1 {DisplayImage procedure} -constraints testImageType -setup {
+ .c delete all
+ image create test foo
+} -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c scale image 25 0 2.0 1.5
+ .c bbox image
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {75 150 105 165}
+
+test canvImg-10.1 {TranslateImage procedure} -constraints testImageType -setup {
+ .c delete all
+} -body {
+ image create test foo -variable x
+ .c create image 50 100 -image foo -tags image -anchor nw
+ update
+ set x {}
+ foo changed 2 4 6 8 30 15
+ update
+ return $x
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {{foo display 2 4 6 8 30 30}}
+
+test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup {
+ .c delete all
+} -body {
+ image create test foo -variable x
+ .c create image 50 100 -image foo -tags image -anchor nw
+ update
+ set x {}
+ foo changed 2 4 6 8 40 50
+ update
+ return $x
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {{foo display 0 0 40 50 30 30}}
+test canvImg-11.2 {ImageChangedProc procedure} -constraints {
+ testImageType
+} -setup {
+ .c delete all
+} -body {
+ image create test foo -variable x
+ .c create image 50 100 -image foo -tags image -anchor center
+ update
+ set x {}
+ foo changed 0 0 0 0 40 50
+ .c bbox image
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {30 75 70 125}
+test canvImg-11.3 {ImageChangedProc procedure} -constraints {
+ testImageType
+} -setup {
+ .c delete all
+} -body {
+ image create test foo -variable x
+ image create test foo2 -variable y
+ foo changed 0 0 0 0 40 50
+ foo2 changed 0 0 0 0 80 60
+
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create image 70 110 -image foo2 -anchor nw
+ update
+ set y {}
+ image create test foo -variable x
+ update
+ return $y
+} -cleanup {
+ .c delete all
+ image delete foo foo2
+} -result {{foo2 display 0 0 20 40 50 40}}
+
+# cleanup
+imageFinish
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/canvMoveto.test b/tk8.6/tests/canvMoveto.test
new file mode 100644
index 0000000..79761a4
--- /dev/null
+++ b/tk8.6/tests/canvMoveto.test
@@ -0,0 +1,56 @@
+# This file is a Tcl script to test out the canvas "moveto" command. It is
+# derived from canvRect.test.
+#
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2004 Neil McKay.
+# All rights reserved.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+canvas .c -width 400 -height 300 -bd 2 -relief sunken
+.c create rectangle 20 20 80 80 -tag {test rect1}
+.c create rectangle 40 40 90 100 -tag {test rect2}
+
+test canvMoveto-1.1 {Bad args handling for "moveto" command} -body {
+ .c moveto test
+} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
+test canvMoveto-1.2 {Bad args handling for "moveto" command} -body {
+ .c moveto rect
+} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
+test canvMoveto-1.3 {Bad args handling for "moveto" command} -body {
+ .c moveto test 12
+} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
+test canvMoveto-1.4 {Bad args handling for "moveto" command} -body {
+ .c moveto test 12 y
+} -returnCodes error -result {bad screen distance "y"}
+test canvMoveto-1.5 {Bad args handling for "moveto" command} -body {
+ .c moveto test 12 20 -anchor
+} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
+
+test canvMoveto-2.1 {Canvas "moveto" command coordinates} {
+ .c moveto test 200 150
+ .c bbox test
+} {200 150 272 232}
+test canvMoveto-2.2 {Canvas "moveto" command, blank y coordinate} {
+ .c moveto test 200 150
+ .c moveto test 150 {}
+ .c bbox test
+} {150 150 222 232}
+test canvMoveto-2.3 {Canvas "moveto" command, blank x coordinate} {
+ .c moveto test 200 150
+ .c moveto test {} 200
+ .c bbox test
+} {200 200 272 282}
+
+.c delete withtag all
+
+# cleanup
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/canvPs.test b/tk8.6/tests/canvPs.test
new file mode 100644
index 0000000..c7ba958
--- /dev/null
+++ b/tk8.6/tests/canvPs.test
@@ -0,0 +1,196 @@
+# This file is a Tcl script to test out procedures to write postscript
+# for canvases to files and channels. It exercises the procedure
+# TkCanvPostscriptCmd in generic/tkCanvPs.c
+#
+# Copyright (c) 1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+imageInit
+
+# canvas used in 1.* and 2.* test cases
+canvas .c -width 400 -height 300 -bd 2 -relief sunken
+.c create rectangle 20 20 80 80 -fill red
+pack .c
+update
+
+test canvPs-1.1 {test writing to a file} -constraints {
+ unixOrPc
+} -setup {
+ set foo [makeFile {} foo.ps]
+} -body {
+ .c postscript -file $foo
+ file exists $foo
+} -cleanup {
+ removeFile foo.ps
+} -result 1
+test canvPs-1.2 {test writing to a file, idempotency} -constraints {
+ unixOrPc
+} -setup {
+ set foo [makeFile {} foo.ps]
+ set bar [makeFile {} bar.ps]
+} -body {
+ .c postscript -file $foo
+ .c postscript -file $bar
+ set status ok
+ if {[file size $bar] != [file size $foo]} {
+ set status broken
+ }
+ set status
+} -cleanup {
+ removeFile foo.ps
+ removeFile bar.ps
+} -result ok
+
+
+test canvPs-2.1 {test writing to a channel} -constraints {
+ unixOrPc
+} -setup {
+ set foo [makeFile {} foo.ps]
+ file delete $foo
+} -body {
+ set chan [open $foo w]
+ fconfigure $chan -translation lf
+ .c postscript -channel $chan
+ close $chan
+ file exists $foo
+} -cleanup {
+ removeFile foo.ps
+} -result 1
+test canvPs-2.2 {test writing to channel, idempotency} -constraints {
+ unixOrPc
+} -setup {
+ set foo [makeFile {} foo.ps]
+ set bar [makeFile {} bar.ps]
+ file delete $foo
+ file delete $bar
+} -body {
+ set c1 [open $foo w]
+ set c2 [open $bar w]
+ fconfigure $c1 -translation lf
+ fconfigure $c2 -translation lf
+ .c postscript -channel $c1
+ .c postscript -channel $c2
+ close $c1
+ close $c2
+ set status ok
+ if {[file size $bar] != [file size $foo]} {
+ set status broken
+ }
+ set status
+} -cleanup {
+ removeFile foo.ps
+ removeFile bar.ps
+} -result ok
+test canvPs-2.3 {test writing to channel and file, same output} -constraints {
+ unix
+} -setup {
+ set foo [makeFile {} foo.ps]
+ set bar [makeFile {} bar.ps]
+ file delete $foo
+ file delete $bar
+} -body {
+ set c1 [open $foo w]
+ fconfigure $c1 -translation lf
+ .c postscript -channel $c1
+ close $c1
+ .c postscript -file $bar
+ set status ok
+ if {[file size $foo] != [file size $bar]} {
+ set status broken
+ }
+ set status
+} -cleanup {
+ removeFile foo.ps
+ removeFile bar.ps
+} -result ok
+test canvPs-2.4 {test writing to channel and file, same output} -constraints {
+ win
+} -setup {
+ set foo [makeFile {} foo.ps]
+ set bar [makeFile {} bar.ps]
+ file delete $foo
+ file delete $bar
+} -body {
+ set c1 [open $foo w]
+ fconfigure $c1 -translation crlf
+ .c postscript -channel $c1
+ close $c1
+ .c postscript -file $bar
+ set status ok
+ if {[file size $foo] != [file size $bar]} {
+ set status broken
+ }
+ set status
+} -cleanup {
+ removeFile foo.ps
+ removeFile bar.ps
+} -result ok
+destroy .c
+
+
+test canvPs-3.1 {test ps generation with an embedded window} -constraints {
+ notAqua
+} -setup {
+ set bar [makeFile {} bar.ps]
+ file delete $bar
+} -body {
+ pack [canvas .c -width 200 -height 200 -background white]
+ .c create rect 20 20 150 150 -tags rect0 -dash . -width 2
+ .c create arc 0 50 200 200 -tags arc0 \
+ -dash {4 4} -stipple question -outline red -fill green
+
+ image create photo logo \
+ -file [file join [file dirname [info script]] pwrdLogo150.gif]
+ .c create image 200 50 -image logo -anchor nw
+
+ entry .c.e -background pink -foreground blue -width 14
+ .c.e insert 0 "we gonna be postscripted"
+ .c create window 50 180 -anchor nw -window .c.e
+ update
+ .c postscript -file $bar
+ file exists $bar
+} -cleanup {
+ destroy .c
+ imageCleanup
+ removeFile bar.ps
+} -result {1}
+test canvPs-3.2 {test ps generation with an embedded window not mapped} -setup {
+ set bar [makeFile {} bar.ps]
+ file delete $bar
+} -body {
+ pack [canvas .c -width 200 -height 200 -background white]
+ entry .c.e -background pink -foreground blue -width 14
+ .c.e insert 0 "we gonna be postscripted"
+ .c create window 50 180 -anchor nw -window .c.e
+ .c postscript -file $bar
+ file exists $bar
+} -cleanup {
+ destroy .c
+ removeFile bar.ps
+} -result {1}
+
+
+test canvPs-4.1 {test ps generation with single-point uncolored poly, bug 734498} -body {
+ pack [canvas .c]
+ .c create poly 10 20 10 20
+ .c postscript
+} -cleanup {
+ destroy .c
+} -returnCodes ok -match glob -result *
+
+
+# cleanup
+unset -nocomplain foo bar
+imageFinish
+deleteWindows
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/canvPsArc.tcl b/tk8.6/tests/canvPsArc.tcl
new file mode 100644
index 0000000..ef7ca6c
--- /dev/null
+++ b/tk8.6/tests/canvPsArc.tcl
@@ -0,0 +1,43 @@
+# This file creates a screen to exercise Postscript generation
+# for bitmaps in canvases. It is part of the Tk visual test suite,
+# which is invoked via the "visual" script.
+
+catch {destroy .t}
+toplevel .t
+wm title .t "Postscript Tests for Canvases"
+wm iconname .t "Postscript"
+wm geom .t +0+0
+wm minsize .t 1 1
+
+set c .t.c
+
+message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for arcs. Click on "Print" to print the canvas to your default printer. You can click on items in the canvas to delete them.} -width 6i
+pack .t.m -side top -fill both
+
+frame .t.bot
+pack .t.bot -side bottom -fill both
+button .t.bot.quit -text Quit -command {destroy .t}
+button .t.bot.print -text Print -command "lpr $c"
+pack .t.bot.print .t.bot.quit -side left -pady 1m -expand 1
+
+canvas $c -width 6i -height 6i -bd 2 -relief sunken
+pack $c -expand yes -fill both -padx 2m -pady 2m
+
+$c create arc .5i .5i 2i 2i -style pieslice -start 20 -extent 90 \
+ -fill black -outline {}
+$c create arc 2.5i 0 4.5i 1i -style pieslice -start -45 -extent -135 \
+ -fill {} -outline black -outlinestipple gray50 -width 3m
+$c create arc 5.0i .5i 6.5i 2i -style pieslice -start 45 -extent 315 \
+ -fill black -stipple gray25 -outline black -width 1m
+
+$c create arc -.5i 2.5i 2.0i 3.5i -style chord -start 90 -extent 270 \
+ -fill black -outline {}
+$c create arc 2.5i 2i 4i 6i -style chord -start 20 -extent 140 \
+ -fill black -stipple gray50 -outline black -width 2m
+$c create arc 4i 2.5i 8i 4.5i -style chord -start 60 -extent 60 \
+ -fill {} -outline black
+
+$c create arc .5i 4.5i 2i 6i -style arc -start 135 -extent 315 -width 3m \
+ -outline black -outlinestipple gray25
+$c create arc 3.5i 4.5i 5.5i 5.5i -style arc -start 45 -extent -90 -width 1m \
+ -outline black
diff --git a/tk8.6/tests/canvPsBmap.tcl b/tk8.6/tests/canvPsBmap.tcl
new file mode 100644
index 0000000..4a7a7e2
--- /dev/null
+++ b/tk8.6/tests/canvPsBmap.tcl
@@ -0,0 +1,84 @@
+# This file creates a screen to exercise Postscript generation
+# for bitmaps in canvases. It is part of the Tk visual test suite,
+# which is invoked via the "visual" script.
+
+catch {destroy .t}
+toplevel .t
+wm title .t "Postscript Tests for Canvases"
+wm iconname .t "Postscript"
+wm geom .t +0+0
+wm minsize .t 1 1
+
+set c .t.c
+
+message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for bitmaps. Click on "Print" to print the canvas to your default printer. You can click on items in the canvas to delete them.} -width 6i
+pack .t.m -side top -fill both
+
+frame .t.bot
+pack .t.bot -side bottom -fill both
+button .t.bot.quit -text Quit -command {destroy .t}
+button .t.bot.print -text Print -command "lpr $c"
+pack .t.bot.print .t.bot.quit -side left -pady 1m -expand 1
+
+canvas $c -width 6i -height 6i -bd 2 -relief sunken
+pack $c -expand yes -fill both -padx 2m -pady 2m
+
+set canvPsBmapImageDir [file join [file dirname [info script]] images]
+
+$c create bitmap 0.5i 0.5i \
+ -bitmap @[file join $canvPsBmapImageDir flagdown.xbm] \
+ -background {} -foreground black -anchor nw
+$c create rect 0.47i 0.47i 0.53i 0.53i -fill {} -outline black
+
+$c create bitmap 3.0i 0.5i \
+ -bitmap @[file join $canvPsBmapImageDir flagdown.xbm] \
+ -background {} -foreground black -anchor n
+$c create rect 2.97i 0.47i 3.03i 0.53i -fill {} -outline black
+
+$c create bitmap 5.5i 0.5i \
+ -bitmap @[file join $canvPsBmapImageDir flagdown.xbm] \
+ -background black -foreground white -anchor ne
+$c create rect 5.47i 0.47i 5.53i 0.53i -fill {} -outline black
+
+$c create bitmap 0.5i 3.0i \
+ -bitmap @[file join $canvPsBmapImageDir face.xbm] \
+ -background {} -foreground black -anchor w
+$c create rect 0.47i 2.97i 0.53i 3.03i -fill {} -outline black
+
+$c create bitmap 3.0i 3.0i \
+ -bitmap @[file join $canvPsBmapImageDir face.xbm] \
+ -background {} -foreground black -anchor center
+$c create rect 2.97i 2.97i 3.03i 3.03i -fill {} -outline black
+
+$c create bitmap 5.5i 3.0i \
+ -bitmap @[file join $canvPsBmapImageDir face.xbm] \
+ -background blue -foreground black -anchor e
+$c create rect 5.47i 2.97i 5.53i 3.03i -fill {} -outline black
+
+$c create bitmap 0.5i 5.5i \
+ -bitmap @[file join $canvPsBmapImageDir flagup.xbm] \
+ -background black -foreground white -anchor sw
+$c create rect 0.47i 5.47i 0.53i 5.53i -fill {} -outline black
+
+$c create bitmap 3.0i 5.5i \
+ -bitmap @[file join $canvPsBmapImageDir flagup.xbm] \
+ -background green -foreground white -anchor s
+$c create rect 2.97i 5.47i 3.03i 5.53i -fill {} -outline black
+
+$c create bitmap 5.5i 5.5i \
+ -bitmap @[file join $canvPsBmapImageDir flagup.xbm] \
+ -background {} -foreground black -anchor se
+$c create rect 5.47i 5.47i 5.53i 5.53i -fill {} -outline black
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tk8.6/tests/canvPsGrph.tcl b/tk8.6/tests/canvPsGrph.tcl
new file mode 100644
index 0000000..08ccd74
--- /dev/null
+++ b/tk8.6/tests/canvPsGrph.tcl
@@ -0,0 +1,98 @@
+# This file creates a screen to exercise Postscript generation
+# for some of the graphical objects in canvases. It is part of the Tk
+# visual test suite, which is invoked via the "visual" script.
+
+catch {destroy .t}
+toplevel .t
+wm title .t "Postscript Tests for Canvases"
+wm iconname .t "Postscript"
+wm geom .t +0+0
+wm minsize .t 1 1
+
+set c .t.mid.c
+
+message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets. Select what you want to display with the buttons below, then click on "Print" to print it to your default printer. You can click on items in the canvas to delete them.} -width 4i
+pack .t.m -side top -fill both
+
+frame .t.top
+pack .t.top -side top -fill both
+set what rect
+radiobutton .t.top.rect -text Rectangles -variable what -value rect \
+ -command "mkObjs $c" -relief flat
+radiobutton .t.top.oval -text Ovals -variable what -value oval \
+ -command "mkObjs $c" -relief flat
+radiobutton .t.top.poly -text Polygons -variable what -value poly \
+ -command "mkObjs $c" -relief flat
+radiobutton .t.top.line -text Lines -variable what -value line \
+ -command "mkObjs $c" -relief flat
+pack .t.top.rect .t.top.oval .t.top.poly .t.top.line \
+ -side left -pady 2m -ipadx 2m -ipady 1m -expand 1
+
+frame .t.bot
+pack .t.bot -side bottom -fill both
+button .t.bot.quit -text Quit -command {destroy .t}
+button .t.bot.print -text Print -command "lpr $c"
+pack .t.bot.print .t.bot.quit -side left -pady 1m -expand 1
+
+frame .t.mid -relief sunken -bd 2
+pack .t.mid -side top -expand yes -fill both -padx 2m -pady 2m
+canvas $c -width 400 -height 350 -bd 0 -relief sunken
+pack $c -expand yes -fill both -padx 1 -pady 1
+
+proc mkObjs c {
+ global what
+ $c delete all
+ if {$what == "rect"} {
+ $c create rect 0 0 400 350 -outline black
+ $c create rect 2 2 100 50 -fill black -stipple gray25
+ $c create rect -20 180 80 320 -fill black -stipple gray50 -width .5c
+ $c create rect 200 -20 240 20 -fill black
+ $c create rect 380 200 420 240 -fill black
+ $c create rect 200 330 240 370 -fill black
+ }
+
+ if {$what == "oval"} {
+ $c create oval 50 10 150 80 -fill black -stipple gray25 -outline {}
+ $c create oval 100 100 200 150 -outline {} -fill black -stipple gray50
+ $c create oval 250 100 400 300 -width .5c
+ }
+
+ if {$what == "poly"} {
+ $c create poly 100 200 200 50 300 200 -smooth yes -stipple gray25 \
+ -outline black -width 4
+ $c create poly 100 300 100 250 350 250 350 300 350 300 100 300 100 300 \
+ -fill red -smooth yes
+ $c create poly 20 10 40 10 40 60 80 60 80 25 30 25 30 \
+ 35 50 35 50 45 20 45
+ $c create poly 300 20 300 120 380 80 320 100 -fill blue -outline black
+ $c create poly 20 200 100 220 90 100 40 250 \
+ -fill {} -outline brown -width 3
+ }
+
+ if {$what == "line"} {
+ $c create line 20 20 120 20 -arrow both -width 5
+ $c create line 20 80 150 80 20 200 150 200 -smooth yes
+ $c create line 150 20 150 150 250 150 -width .5c -smooth yes \
+ -arrow both -arrowshape {.75c 1.0c .5c} -stipple gray25
+ $c create line 50 340 100 250 150 340 -join round -cap round -width 10
+ $c create line 200 340 250 250 300 340 -join bevel -cap project \
+ -width 10
+ $c create line 300 20 380 20 300 150 380 150 -join miter -cap butt \
+ -width 10 -stipple gray25
+ }
+}
+
+mkObjs $c
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tk8.6/tests/canvPsImg.tcl b/tk8.6/tests/canvPsImg.tcl
new file mode 100644
index 0000000..1f46eca
--- /dev/null
+++ b/tk8.6/tests/canvPsImg.tcl
@@ -0,0 +1,84 @@
+# This file creates a screen to exercise Postscript generation
+# for images in canvases. It is part of the Tk visual test suite,
+# which is invoked via the "visual" script.
+
+# Build a test image in a canvas
+proc BuildTestImage {} {
+ global BitmapImage PhotoImage visual level
+ catch {destroy .t.f}
+ frame .t.f -visual $visual -colormap new
+ pack .t.f -side top -after .t.top
+ bind .t.f <Enter> {wm colormapwindows .t {.t.f .t}}
+ bind .t.f <Leave> {wm colormapwindows .t {.t .t.f}}
+ canvas .t.f.c -width 550 -height 350 -borderwidth 2 -relief raised
+ pack .t.f.c
+ .t.f.c create rectangle 25 25 525 325 -fill {} -outline black
+ .t.f.c create image 50 50 -anchor nw -image $BitmapImage
+ .t.f.c create image 250 50 -anchor nw -image $PhotoImage
+}
+
+# Put postscript in a file
+proc FilePostscript { canvas } {
+ global level
+ $canvas postscript -file /tmp/test.ps -colormode $level
+}
+
+# Send postscript output to printer
+proc PrintPostcript { canvas } {
+ global level
+ $canvas postscript -file tmp.ps -colormode $level
+ exec lpr tmp.ps
+}
+
+catch {destroy .t}
+toplevel .t
+wm title .t "Postscript Tests for Canvases: Images"
+wm iconname .t "Postscript"
+
+message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for images. Click the buttons below to select a Visual type for the canvas and colormode for the Postscript output. Then click "Print" to send the results to the default printer, or "Print to file" to put the Postscript output in a file called "/tmp/test.ps". You can also click on items in the canvas to delete them.
+NOTE: Some Postscript printers may not be able to handle Postscript generated in color mode.} -width 6i
+pack .t.m -side top -fill both
+
+frame .t.top
+pack .t.top -side top
+frame .t.top.l -relief raised -borderwidth 2
+frame .t.top.r -relief raised -borderwidth 2
+pack .t.top.l .t.top.r -side left -fill both -expand 1
+
+label .t.visuals -text "Visuals"
+pack .t.visuals -in .t.top.l
+
+set visual [lindex [winfo visualsavailable .] 0]
+foreach v [winfo visualsavailable .] {
+ # The hack below is necessary for some systems, which have more than one
+ # visual of the same type...
+ if {![winfo exists .t.$v]} {
+ radiobutton .t.$v -text $v -variable visual -value $v \
+ -command BuildTestImage
+ pack .t.$v -in .t.top.l -anchor w
+ }
+}
+
+label .t.levels -text "Color Levels"
+pack .t.levels -in .t.top.r
+set level monochrome
+foreach l { monochrome gray color } {
+ radiobutton .t.$l -text $l -variable level -value $l
+ pack .t.$l -in .t.top.r -anchor w
+}
+
+set BitmapImage [image create bitmap \
+ -file [file join [file dirname [info script]] face.xbm] \
+ -background white -foreground black]
+set PhotoImage [image create photo \
+ -file [file join [file dirname [info script]] teapot.ppm]]
+
+BuildTestImage
+
+frame .t.bot
+pack .t.bot -side top -fill x -expand 1
+
+button .t.file -text "Print to File" -command { FilePostscript .t.f.c }
+button .t.print -text "Print" -command { PrintPostscript .t.f.c }
+button .t.quit -text "Quit" -command { destroy .t }
+pack .t.file .t.print .t.quit -in .t.bot -side left -fill x -expand 1
diff --git a/tk8.6/tests/canvPsText.tcl b/tk8.6/tests/canvPsText.tcl
new file mode 100644
index 0000000..08c9d27
--- /dev/null
+++ b/tk8.6/tests/canvPsText.tcl
@@ -0,0 +1,94 @@
+# This file creates a screen to exercise Postscript generation
+# for text in canvases. It is part of the Tk visual test suite,
+# which is invoked via the "visual" script.
+
+catch {destroy .t}
+toplevel .t
+wm title .t "Postscript Tests for Canvases"
+wm iconname .t "Postscript"
+wm geom .t +0+0
+wm minsize .t 1 1
+
+set c .t.c
+
+message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for text. Click on "Print" to print the canvas to your default printer. The "Stipple" button can be used to turn stippling on and off for the text, but beware: many Postscript printers cannot handle stippled text. You can click on items in the canvas to delete them.} -width 6i
+pack .t.m -side top -fill both
+
+set stipple {}
+checkbutton .t.stipple -text Stippling -variable stipple -onvalue gray50 \
+ -offvalue {} -command "setStipple $c" -relief flat
+pack .t.stipple -side top -pady 2m -expand 1 -anchor w
+
+frame .t.bot
+pack .t.bot -side bottom -fill both
+button .t.bot.quit -text Quit -command {destroy .t}
+button .t.bot.print -text Print -command "lpr $c"
+pack .t.bot.print .t.bot.quit -side left -pady 1m -expand 1
+
+canvas $c -width 6i -height 7i -bd 2 -relief sunken
+pack $c -expand yes -fill both -padx 2m -pady 2m
+
+$c create rect 2.95i 0.45i 3.05i 0.55i -fill {} -outline black
+$c create text 3.0i 0.5i -text "Center Courier Oblique 24" \
+ -anchor center -tags text -font {Courier 24 italic} -stipple $stipple
+$c create rect 2.95i 0.95i 3.05i 1.05i -fill {} -outline black
+$c create text 3.0i 1.0i -text "Northwest Helvetica 24" \
+ -anchor nw -tags text -font {Helvetica 24} -stipple $stipple
+$c create rect 2.95i 1.45i 3.05i 1.55i -fill {} -outline black
+$c create text 3.0i 1.5i -text "North Helvetica Oblique 12 " \
+ -anchor n -tags text -font {Helvetica 12 italic} -stipple $stipple
+$c create rect 2.95i 1.95i 3.05i 2.05i -fill {} -outline blue
+$c create text 3.0i 2.0i -text "Northeast Helvetica Bold 24" \
+ -anchor ne -tags text -font {Helvetica 24 bold} -stipple $stipple
+$c create rect 2.95i 2.45i 3.05i 2.55i -fill {} -outline black
+$c create text 3.0i 2.5i -text "East Helvetica Bold Oblique 18" \
+ -anchor e -tags text -font {Helvetica 18 {bold italic}} -stipple $stipple
+$c create rect 2.95i 2.95i 3.05i 3.05i -fill {} -outline black
+$c create text 3.0i 3.0i -text "Southeast Times 10" \
+ -anchor se -tags text -font {Times 10} -stipple $stipple
+$c create rect 2.95i 3.45i 3.05i 3.55i -fill {} -outline black
+$c create text 3.0i 3.5i -text "South Times Italic 24" \
+ -anchor s -tags text -font {Times 24 italic} -stipple $stipple
+$c create rect 2.95i 3.95i 3.05i 4.05i -fill {} -outline black
+$c create text 3.0i 4.0i -text "Southwest Times Bold 18" \
+ -anchor sw -tags text -font {Times 18 bold} -stipple $stipple
+$c create rect 2.95i 4.45i 3.05i 4.55i -fill {} -outline black
+$c create text 3.0i 4.5i -text "West Times Bold Italic 24"\
+ -anchor w -tags text -font {Times 24 {bold italic}} -stipple $stipple
+
+$c create rect 0.95i 5.20i 1.05i 5.30i -fill {} -outline black
+$c create text 1.0i 5.25i -width 1.9i -anchor c -justify left -tags text \
+ -font {Times 18 bold} -stipple $stipple \
+ -text "This is a sample text item to see how left justification works"
+$c create rect 2.95i 5.20i 3.05i 5.30i -fill {} -outline black
+$c create text 3.0i 5.25i -width 1.8i -anchor c -justify center -tags text \
+ -font {Times 18 bold} -stipple $stipple \
+ -text "This is a sample text item to see how center justification works"
+$c create rect 4.95i 5.20i 5.05i 5.30i -fill {} -outline black
+$c create text 5.0i 5.25i -width 1.8i -anchor c -justify right -tags text \
+ -font {Times 18 bold} -stipple $stipple \
+ -text "This is a sample text item to see how right justification works"
+
+$c create text 3.0i 6.0i -width 5.0i -anchor n -justify right -tags text \
+ -text "This text is\nright justified\nwith a line length equal to\n\
+ the size of the enclosing rectangle.\nMake sure it prints right\
+ justified as well."
+$c create rect 0.5i 6.0i 5.5i 6.9i -fill {} -outline black
+
+proc setStipple c {
+ global stipple
+ $c itemconfigure text -stipple $stipple
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tk8.6/tests/canvRect.test b/tk8.6/tests/canvRect.test
new file mode 100644
index 0000000..a2cc51c
--- /dev/null
+++ b/tk8.6/tests/canvRect.test
@@ -0,0 +1,475 @@
+# This file is a Tcl script to test out the procedures in tkRectOval.c,
+# which implement canvas "rectangle" and "oval" items. It is organized
+# in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# Canvas used in every test case of the whole file
+canvas .c -width 400 -height 300 -bd 2 -relief sunken
+pack .c
+update
+
+# Rectangle used in canvRect-1.* tests
+.c create rectangle 20 20 80 80 -tag test
+test canvRect-1.1 {configuration options: good value for -fill} -body {
+ .c itemconfigure test -fill #ff0000
+ list [.c itemcget test -fill] [lindex [.c itemconfigure test -fill] 4]
+} -result {{#ff0000} #ff0000}
+test canvRect-1.2 {configuration options: bad value for -fill} -body {
+ .c itemconfigure test -fill non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test canvRect-1.3 {configuration options: good value for -outline} -body {
+ .c itemconfigure test -outline #123456
+ list [.c itemcget test -outline] [lindex [.c itemconfigure test -outline] 4]
+} -result {{#123456} #123456}
+test canvRect-1.4 {configuration options: bad value for -outline} -body {
+ .c itemconfigure test -outline non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test canvRect-1.5 {configuration options: good value for -stipple } -body {
+ .c itemconfigure test -stipple gray50
+ list [.c itemcget test -stipple ] [lindex [.c itemconfigure test -stipple ] 4]
+} -result {gray50 gray50}
+test canvRect-1.6 {configuration options: bad value for -stipple } -body {
+ .c itemconfigure test -stipple bogus
+} -returnCodes error -result {bitmap "bogus" not defined}
+test canvRect-1.7 {configuration options: good value for -tags} -body {
+ .c itemconfigure test -tags {test a b c}
+ list [.c itemcget test -tags] [lindex [.c itemconfigure test -tags] 4]
+} -result {{test a b c} {test a b c}}
+test canvRect-1.8 {configuration options} -body {
+ .c itemconfigure test -tags {test xyz}
+ .c itemcget xyz -tags
+} -result {test xyz}
+test canvRect-1.9 {configuration options: good value for -width} -body {
+ .c itemconfigure test -width 6.0
+ list [.c itemcget test -width] [lindex [.c itemconfigure test -width] 4]
+} -result {6.0 6.0}
+test canvRect-1.10 {configuration options: bad value for -width} -body {
+ .c itemconfigure test -width abc
+} -returnCodes error -result {bad screen distance "abc"}
+.c delete withtag all
+
+
+test canvRect-2.1 {CreateRectOval procedure} -body {
+ .c create rect
+} -returnCodes error -result {wrong # args: should be ".c create rect coords ?arg ...?"}
+test canvRect-2.2 {CreateRectOval procedure} -body {
+ .c create oval x y z
+} -returnCodes error -result {wrong # coordinates: expected 0 or 4, got 3}
+test canvRect-2.3 {CreateRectOval procedure} -body {
+ .c create rectangle x 2 3 4
+} -returnCodes error -result {bad screen distance "x"}
+test canvRect-2.4 {CreateRectOval procedure} -body {
+ .c create rectangle 1 y 3 4
+} -returnCodes error -result {bad screen distance "y"}
+test canvRect-2.5 {CreateRectOval procedure} -body {
+ .c create rectangle 1 2 z 4
+} -returnCodes error -result {bad screen distance "z"}
+test canvRect-2.6 {CreateRectOval procedure} -body {
+ .c create rectangle 1 2 3 q
+} -returnCodes error -result {bad screen distance "q"}
+test canvRect-2.7 {CreateRectOval procedure} -body {
+ .c create rectangle 1 2 3 4 -tags x
+ set result {}
+ foreach element [.c coords x] {
+ lappend result [format %.1f $element]
+ }
+ set result
+} -result {1.0 2.0 3.0 4.0}
+test canvRect-2.8 {CreateRectOval procedure} -body {
+ .c create rectangle 1 2 3 4 -gorp foo
+} -returnCodes error -result {unknown option "-gorp"}
+.c delete withtag all
+
+
+test canvRect-3.1 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ set result {}
+ foreach element [.c coords x] {
+ lappend result [format %.1f $element]
+ }
+ return $result
+} -cleanup {
+ .c delete withtag all
+} -result {10.0 20.0 30.0 40.0}
+test canvRect-3.2 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x a 2 3 4
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "a"}
+test canvRect-3.3 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x 1 b 3 4
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "b"}
+test canvRect-3.4 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x 1 2 c 4
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "c"}
+test canvRect-3.5 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x 1 2 3 d
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "d"}
+test canvRect-3.6 {RectOvalCoords procedure} -constraints {
+ nonPortable
+} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ # Non-portable due to rounding differences.
+ .c coords x 10 25 15 40
+ .c bbox x
+} -cleanup {
+ .c delete withtag all
+} -result {9 24 16 41}
+test canvRect-3.7 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x 1 2 3 4 5
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {wrong # coordinates: expected 0 or 4, got 5}
+
+
+test canvRect-4.1 {ConfigureRectOval procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x -width 1
+ .c itemconfigure x -width abc
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "abc"}
+test canvRect-4.2 {ConfigureRectOval procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x -width 1
+ catch {.c itemconfigure x -width abc}
+ .c itemcget x -width
+} -cleanup {
+ .c delete withtag all
+} -result {1.0}
+test canvRect-4.3 {ConfigureRectOval procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x -width 1
+ .c itemconfigure x -width -5
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "-5"}
+test canvRect-4.4 {ConfigureRectOval procedure} -constraints nonPortable -body {
+ # Non-portable due to rounding differences
+ .c create rectangle 10 20 30 40 -tags x -width 1
+ .c itemconfigure x -width 10
+ .c bbox x
+} -cleanup {
+ .c delete withtag all
+} -result {5 15 35 45}
+
+# I can't come up with any good tests for DeleteRectOval.
+
+test canvRect-5.1 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
+ # Non-portable due to rounding differences:
+ .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
+ .c coords x 20 15 10 5
+ .c bbox x
+} -cleanup {
+ .c delete withtag all
+} -result {10 5 20 15}
+test canvRect-5.2 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
+ # Non-portable due to rounding differences:
+ .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
+ .c coords x 10 20 30 10
+ .c itemconfigure x -width 1 -outline red
+ .c bbox x
+} -cleanup {
+ .c delete withtag all
+} -result {9 9 31 21}
+test canvRect-5.3 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
+ # Non-portable due to rounding differences:
+ .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
+ .c coords x 10 20 30 10
+ .c itemconfigure x -width 2 -outline red
+ .c bbox x
+} -cleanup {
+ .c delete withtag all
+} -result {9 9 31 21}
+test canvRect-5.4 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
+ # Non-portable due to rounding differences:
+ .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
+ .c coords x 10 20 30 10
+ .c itemconfigure x -width 3 -outline red
+ .c bbox x
+} -cleanup {
+ .c delete withtag all
+} -result {8 8 32 22}
+
+# I can't come up with any good tests for DisplayRectOval.
+
+test canvRect-6.1 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
+ .c itemconfigure y -outline {}
+ list [expr {[.c find closest 14.9 28] eq $xId}] \
+ [expr {[.c find closest 15.1 28] eq $yId}] \
+ [expr {[.c find closest 24.9 28] eq $yId}] \
+ [expr {[.c find closest 25.1 28] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+test canvRect-6.2 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
+ .c itemconfigure y -outline {}
+ list [expr {[.c find closest 20 24.9] eq $xId}] \
+ [expr {[.c find closest 20 25.1] eq $yId}] \
+ [expr {[.c find closest 20 29.9] eq $yId}] \
+ [expr {[.c find closest 20 30.1] eq $xId}]
+
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+test canvRect-6.3 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
+ .c itemconfigure y -width 1 -outline black
+ list [expr {[.c find closest 14.4 28] eq $xId}] \
+ [expr {[.c find closest 14.6 28] eq $yId}] \
+ [expr {[.c find closest 25.4 28] eq $yId}] \
+ [expr {[.c find closest 25.6 28] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+test canvRect-6.4 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
+ .c itemconfigure y -width 1 -outline black
+ list [expr {[.c find closest 20 24.4] eq $xId}] \
+ [expr {[.c find closest 20 24.6] eq $yId}] \
+ [expr {[.c find closest 20 30.4] eq $yId}] \
+ [expr {[.c find closest 20 30.6] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+
+test canvRect-6.5 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
+ .c itemconfigure x -fill {} -outline black -width 3
+ .c itemconfigure y -outline {}
+ list [expr {[.c find closest 13.2 28] eq $xId}] \
+ [expr {[.c find closest 13.3 28] eq $yId}] \
+ [expr {[.c find closest 26.7 28] eq $yId}] \
+ [expr {[.c find closest 26.8 28] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+test canvRect-6.6 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
+ .c itemconfigure x -fill {} -outline black -width 3
+ .c itemconfigure y -outline {}
+ list [expr {[.c find closest 20 23.2] eq $xId}] \
+ [expr {[.c find closest 20 23.3] eq $yId}] \
+ [expr {[.c find closest 20 31.7] eq $yId}] \
+ [expr {[.c find closest 20 31.8] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+
+test canvRect-6.7 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 40 -outline {} -fill black]
+ set yId [.c create rectangle 40 40 50 50 -outline {} -fill black]
+ list [expr {[.c find closest 35 35] eq $xId}] \
+ [expr {[.c find closest 36 36] eq $yId}] \
+ [expr {[.c find closest 37 37] eq $yId}] \
+ [expr {[.c find closest 38 38] eq $yId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+
+
+test canvRect-7.1 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 20 50 38 60] eq {}}] \
+ [expr {[.c find overlapping 20 50 39 60] eq $yId}] \
+ [expr {[.c find overlapping 20 50 70 60] eq $yId}] \
+ [expr {[.c find overlapping 61 50 70 60] eq $yId}] \
+ [expr {[.c find overlapping 62 50 70 60] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+test canvRect-7.2 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 45 20 55 43] eq {}}] \
+ [expr {[.c find overlapping 45 20 55 44] eq $yId}] \
+ [expr {[.c find overlapping 45 20 55 80] eq $yId}] \
+ [expr {[.c find overlapping 45 71 55 80] eq $yId}] \
+ [expr {[.c find overlapping 45 72 55 80] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+test canvRect-7.3 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 5 25 9.9 30] eq {}}] \
+ [expr {[.c find overlapping 5 25 10.1 30] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1}
+test canvRect-7.4 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 102 152 118 168] eq {}}]\
+ [expr {[.c find overlapping 101 152 118 168] eq $zId}] \
+ [expr {[.c find overlapping 102 151 118 168] eq $zId}] \
+ [expr {[.c find overlapping 102 152 119 168] eq $zId}] \
+ [expr {[.c find overlapping 102 152 118 169] eq $zId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+test canvRect-7.5 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find enclosed 20 40 38 80] eq {}}] \
+ [expr {[.c find enclosed 20 40 39 80] eq {}}] \
+ [expr {[.c find enclosed 20 40 70 80] eq $yId}] \
+ [expr {[.c find enclosed 61 40 70 80] eq {}}] \
+ [expr {[.c find enclosed 62 40 70 80] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+test canvRect-7.6 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find enclosed 20 20 65 43] eq {}}] \
+ [expr {[.c find enclosed 20 20 65 44] eq {}}] \
+ [expr {[.c find enclosed 20 20 65 80] eq $yId}] \
+ [expr {[.c find enclosed 20 71 65 80] eq {}}] \
+ [expr {[.c find enclosed 20 72 65 80] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+
+
+test canvRect-8.1 {OvalToArea procedure} -body {
+ set xId [.c create oval 50 100 200 150 -fill green -outline {}]
+ set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3]
+ set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 20 120 48 130] eq {}}] \
+ [expr {[.c find overlapping 20 120 49 130] eq "$yId $zId"}] \
+ [expr {[.c find overlapping 20 120 50.2 130] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 20 120 300 130] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 60 120 190 130] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 199.9 120 300 130] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 201 120 300 130] eq "$yId $zId"}] \
+ [expr {[.c find overlapping 202 120 300 130] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1 1 1 1}
+test canvRect-8.2 {OvalToArea procedure} -body {
+ set xId [.c create oval 50 100 200 150 -fill green -outline {}]
+ set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3]
+ set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 100 50 150 98] eq {}}] \
+ [expr {[.c find overlapping 100 50 150 99] eq "$yId $zId"}] \
+ [expr {[.c find overlapping 100 50 150 100.1] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 100 50 150 200] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 100 110 150 140] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 100 149.9 150 200] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 100 151 150 200] eq "$yId $zId"}] \
+ [expr {[.c find overlapping 100 152 150 200] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1 1 1 1}
+test canvRect-8.3 {OvalToArea procedure} -body {
+ set xId [.c create oval 50 100 200 150 -fill green -outline {}]
+ set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3]
+ set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 176 104 177 105] eq {}}] \
+ [expr {[.c find overlapping 187 116 188 117] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 192 142 193 143] eq {}}] \
+ [expr {[.c find overlapping 180 138 181 139] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 61 142 62 143] eq {}}] \
+ [expr {[.c find overlapping 65 137 66 136] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 62 108 63 109] eq {}}] \
+ [expr {[.c find overlapping 68 115 69 116] eq "$xId $yId"}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1 1 1 1}
+
+
+test canvRect-9.1 {ScaleRectOval procedure} -setup {
+ .c delete withtag all
+} -body {
+ .c create rect 100 300 200 350 -tags x
+ .c scale x 50 100 2 4
+ format {%.6g %.6g %.6g %.6g} {*}[.c coords x]
+} -result {150 900 350 1100}
+
+test canvRect-10.1 {TranslateRectOval procedure} -setup {
+ .c delete withtag all
+} -body {
+ .c create rect 100 300 200 350 -tags x
+ .c move x 100 -10
+ format {%.6g %.6g %.6g %.6g} {*}[.c coords x]
+} -result {200 290 300 340}
+
+
+test canvRect-11.1 {RectOvalToPostscript procedure} -constraints {
+ nonPortable macCrash
+} -setup {
+ .c delete withtag all
+} -body {
+ # Crashes on Mac because the XGetImage() call isn't implemented, causing a
+ # dereference of NULL.
+ # This test is non-portable because different color information
+ # will get generated on different displays (e.g. mono displays
+ # vs. color).
+ .c configure -bd 0 -highlightthickness 0
+ .c create rect 50 60 90 80 -fill black -stipple gray50 -outline {}
+ .c create oval 100 150 200 200 -fill {} -outline #ff0000 -width 5
+ update
+ set x [.c postscript]
+ string range $x [string first "-200 -150 translate" $x] end
+} -result {-200 -150 translate
+0 300 moveto 400 300 lineto 400 0 lineto 0 0 lineto closepath clip newpath
+gsave
+50 240 moveto 40 0 rlineto 0 -20 rlineto -40 0 rlineto closepath
+0.000 0.000 0.000 setrgbcolor AdjustColor
+clip 16 16 <5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555
+aaaa> StippleFill
+grestore
+gsave
+matrix currentmatrix
+150 125 translate 50 25 scale 1 0 moveto 0 0 1 0 360 arc
+setmatrix
+5 setlinewidth 0 setlinejoin 2 setlinecap
+1.000 0.000 0.000 setrgbcolor AdjustColor
+stroke
+grestore
+restore showpage
+
+%%Trailer
+end
+%%EOF
+}
+
+# cleanup
+cleanupTests
+return
+
+
+
+
diff --git a/tk8.6/tests/canvText.test b/tk8.6/tests/canvText.test
new file mode 100644
index 0000000..ff5e4b9
--- /dev/null
+++ b/tk8.6/tests/canvText.test
@@ -0,0 +1,950 @@
+# This file is a Tcl script to test out the procedures in tkCanvText.c,
+# which implement canvas "text" items. It is organized in the standard
+# fashion for Tcl tests.
+#
+# Copyright (c) 1996-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# Canvas used in 1.* - 17.* tests
+canvas .c -width 400 -height 300 -bd 2 -relief sunken
+pack .c
+update
+
+# Item used in 1.* tests
+.c create text 20 20 -tag test
+test canvText-1.1 {configuration options: good value for "anchor"} -body {
+ .c itemconfigure test -anchor nw
+ list [lindex [.c itemconfigure test -anchor] 4] [.c itemcget test -anchor]
+} -result {nw nw}
+test canvasText-1.2 {configuration options: bad value for "anchor"} -body {
+ .c itemconfigure test -anchor xyz
+} -returnCodes error -result {bad anchor position "xyz": must be n, ne, e, se, s, sw, w, nw, or center}
+test canvText-1.3 {configuration options: good value for "fill"} -body {
+ .c itemconfigure test -fill #ff0000
+ list [lindex [.c itemconfigure test -fill] 4] [.c itemcget test -fill]
+} -result {{#ff0000} #ff0000}
+test canvasText-1.4 {configuration options: bad value for "fill"} -body {
+ .c itemconfigure test -fill xyz
+} -returnCodes error -result {unknown color name "xyz"}
+test canvText-1.5 {configuration options: good value for "fill"} -body {
+ .c itemconfigure test -fill {}
+ list [lindex [.c itemconfigure test -fill] 4] [.c itemcget test -fill]
+} -result {{} {}}
+test canvText-1.6 {configuration options: good value for "font"} -body {
+ .c itemconfigure test -font {Times 40}
+ list [lindex [.c itemconfigure test -font] 4] [.c itemcget test -font]
+} -result {{Times 40} {Times 40}}
+test canvasText-1.7 {configuration options: bad value for "font"} -body {
+ .c itemconfigure test -font {}
+} -returnCodes error -result {font "" doesn't exist}
+test canvText-1.8 {configuration options: good value for "justify"} -body {
+ .c itemconfigure test -justify left
+ list [lindex [.c itemconfigure test -justify] 4] [.c itemcget test -justify]
+} -result {left left}
+test canvasText-1.9 {configuration options: bad value for "justify"} -body {
+ .c itemconfigure test -justify xyz
+} -returnCodes error -result {bad justification "xyz": must be left, right, or center}
+test canvText-1.10 {configuration options: good value for "stipple"} -body {
+ .c itemconfigure test -stipple gray50
+ list [lindex [.c itemconfigure test -stipple] 4] [.c itemcget test -stipple]
+} -result {gray50 gray50}
+test canvasText-1.11 {configuration options: bad value for "stipple"} -body {
+ .c itemconfigure test -stipple xyz
+} -returnCodes error -result {bitmap "xyz" not defined}
+test canvText-1.12 {configuration options: good value for "underline"} -body {
+ .c itemconfigure test -underline 0
+ list [lindex [.c itemconfigure test -underline] 4] [.c itemcget test -underline]
+} -result {0 0}
+test canvasText-1.13 {configuration options: bad value for "underline"} -body {
+ .c itemconfigure test -underline xyz
+} -returnCodes error -result {expected integer but got "xyz"}
+test canvText-1.14 {configuration options: good value for "width"} -body {
+ .c itemconfigure test -width 6
+ list [lindex [.c itemconfigure test -width] 4] [.c itemcget test -width]
+} -result {6 6}
+test canvasText-1.15 {configuration options: bad value for "width"} -body {
+ .c itemconfigure test -width xyz
+} -returnCodes error -result {bad screen distance "xyz"}
+test canvText-1.16 {configuration options: good value for "tags"} -body {
+ .c itemconfigure test -tags {test a b c}
+ list [lindex [.c itemconfigure test -tags] 4] [.c itemcget test -tags]
+} -result {{test a b c} {test a b c}}
+test canvasText-1.17 {configuration options: bad value for "angle"} -body {
+ .c itemconfigure test -angle xyz
+} -returnCodes error -result {expected floating-point number but got "xyz"}
+test canvasText-1.18 {configuration options: good value for "angle"} -body {
+ .c itemconfigure test -angle 32.5
+ list [lindex [.c itemconfigure test -angle] 4] [.c itemcget test -angle]
+} -result {32.5 32.5}
+test canvasText-1.19 {configuration options: bounding of "angle"} -body {
+ .c itemconfigure test -angle 390
+ set result [.c itemcget test -angle]
+ .c itemconfigure test -angle -30
+ lappend result [.c itemcget test -angle]
+ .c itemconfigure test -angle -360
+ lappend result [.c itemcget test -angle]
+} -result {30.0 330.0 0.0}
+.c delete test
+
+
+test canvText-2.1 {CreateText procedure: args} -body {
+ .c create text
+} -returnCodes {error} -result {wrong # args: should be ".c create text coords ?arg ...?"}
+test canvText-2.2 {CreateText procedure: args} -body {
+ .c create text xyz 0
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvText-2.3 {CreateText procedure: args} -body {
+ .c create text 0 xyz
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvText-2.4 {CreateText procedure: args} -body {
+ .c create text 0 0 -xyz xyz
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {unknown option "-xyz"}
+test canvText-2.5 {CreateText procedure} -body {
+ .c create text 0 0 -tags x
+ .c coords x
+} -cleanup {
+ .c delete x
+} -result {0.0 0.0}
+
+
+test canvText-3.1 {TextCoords procedure} -body {
+ .c create text 20 20 -tag test
+ .c coords test 0 0
+ update
+ .c coords test
+} -cleanup {
+ .c delete test
+} -result {0.0 0.0}
+test canvText-3.2 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c coords test xyz 0
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvText-3.3 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c coords test 0 xyz
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvText-3.4 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c coords test 10 10
+ set result {}
+ foreach element [.c coords test] {
+ lappend result [format %.1f $element]
+ }
+ return $result
+} -cleanup {
+ .c delete test
+} -result {10.0 10.0}
+test canvText-3.5 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c coords test 10
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1}
+test canvText-3.6 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c coords test 10 10 10
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {wrong # coordinates: expected 0 or 2, got 3}
+
+
+test canvText-4.1 {ConfigureText procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c itemconfig test -fill xyz
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {unknown color name "xyz"}
+test canvText-4.2 {ConfigureText procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c itemconfig test -fill blue
+ .c itemcget test -fill
+} -cleanup {
+ .c delete test
+} -result {blue}
+test canvText-4.3 {ConfigureText procedure: construct font gcs} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c itemconfig test -font "times 20" -fill black -stipple gray50
+ list [.c itemcget test -font] [.c itemcget test -fill] [.c itemcget test -stipple]
+} -cleanup {
+ .c delete test
+} -result {{times 20} black gray50}
+test canvText-4.4 {ConfigureText procedure: construct cursor gc} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefg"
+ .c select from test 2
+ .c select to test 4
+ .c icursor test 3
+ # Both black -> cursor becomes white.
+ .c config -insertbackground black
+ .c config -selectbackground black
+ .c itemconfig test -just left
+ update
+ # Both same color (and not black) -> cursor becomes black.
+ .c config -insertbackground red
+ .c config -selectbackground red
+ .c itemconfig test -just left
+ update
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-4.5 {ConfigureText procedure: adjust selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+ set x {}
+} -body {
+ .c itemconfig test -text "abcdefghi"
+ .c select from test 2
+ .c select to test 6
+ lappend x [selection get]
+ .c dchars test 1 end
+ lappend x [catch {selection get}]
+ .c insert test end "bcdefghi"
+ .c select from test 2
+ .c select to test 6
+ lappend x [selection get]
+ .c dchars test 4 end
+ lappend x [selection get]
+ .c insert test end "efghi"
+ .c select from test 6
+ .c select to test 2
+ lappend x [selection get]
+ .c dchars test 4 end
+ lappend x [selection get]
+} -cleanup {
+ .c delete test
+} -result {cdefg 1 cdefg cd cdef cd}
+test canvText-4.6 {ConfigureText procedure: adjust cursor} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c itemconfig test -text "abcdefghi"
+ .c icursor test 6
+ .c dchars test 4 end
+ .c index test insert
+} -cleanup {
+ .c delete test
+} -result {4}
+
+
+test canvText-5.1 {ConfigureText procedure: adjust cursor} -body {
+ .c create text 10 10 -tag x -fill blue -font "times 40" -stipple gray50 \
+ -text "xyz"
+ .c delete x
+} -result {}
+
+
+test canvText-6.1 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor n; .c bbox test] \
+ eq "[expr -$ax/2-1] 0 [expr $ax/2+1] $ay"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.2 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor nw; .c bbox test] \
+ eq "-1 0 [expr $ax+1] $ay"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.3 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor w; .c bbox test] \
+ eq "-1 [expr -$ay/2] [expr $ax+1] [expr $ay/2]"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.4 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor sw; .c bbox test] \
+ eq "-1 -$ay [expr $ax+1] 0"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.5 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor s; .c bbox test] \
+ eq "[expr -$ax/2-1] -$ay [expr $ax/2+1] 0"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.6 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor se; .c bbox test] \
+ eq "[expr -$ax-1] -$ay 1 0"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.7 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor e; .c bbox test]\
+ eq "[expr -$ax-1] [expr -$ay/2] 1 [expr $ay/2]"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.8 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor ne; .c bbox test] \
+ eq "[expr -$ax-1] 0 1 $ay"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.9 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor center; .c bbox test] \
+ eq "[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]"}
+} -cleanup {
+ .c delete test
+} -result 1
+
+
+#.c delete test
+#.c create text 20 20 -tag test
+#focus -force .c
+#.c focus test
+focus .c
+.c focus test
+.c itemconfig test -text "abcd\nefghi\njklmnopq"
+test canvText-7.1 {DisplayText procedure: stippling} -body {
+ .c create text 20 20 -tag test
+ .c itemconfig test -stipple gray50
+ update
+ .c itemconfig test -stipple {}
+ update
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.2 {DisplayText procedure: draw selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ .c select from test 0
+ .c select to test end
+ update
+ selection get
+} -cleanup {
+ .c delete test
+} -result "abcd\nefghi\njklmnopq"
+test canvText-7.3 {DisplayText procedure: selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ .c select from test 0
+ .c select to test end
+ update
+ selection get
+} -cleanup {
+ .c delete test
+} -result "abcd\nefghi\njklmnopq"
+test canvText-7.4 {DisplayText procedure: one line selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ .c select from test 2
+ .c select to test 3
+ update
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.5 {DisplayText procedure: multi-line selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ .c select from test 2
+ .c select to test 12
+ update
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.6 {DisplayText procedure: draw cursor} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ .c icursor test 3
+ update
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.7 {DisplayText procedure: selected text different color} -setup {
+ .c create text 20 20 -tag test
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ focus .c
+ .c focus test
+} -body {
+ .c config -selectforeground blue
+ .c itemconfig test -anchor n
+ update
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.8 {DisplayText procedure: not selected} -setup {
+ .c create text 20 20 -tag test
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ focus .c
+ .c focus test
+} -body {
+ .c select clear
+ update
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.9 {DisplayText procedure: select end} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm geometry .t +0+0
+ canvas .t.c
+ pack .t.c
+ set id [.t.c create text 0 0 -text Dummy -anchor nw]
+ update
+ .t.c select from $id 0
+ .t.c select to $id end
+ update
+ #catch {destroy .t}
+ update
+} -cleanup {
+ destroy .t
+} -result {}
+
+test canvText-8.1 {TextInsert procedure: 0 length insert} -setup {
+ .c create text 20 20 -tag test
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ focus .c
+ .c focus test
+} -body {
+ .c insert test end {}
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-8.2 {TextInsert procedure: before beginning/after end} -body {
+ # Can't test this because GetTextIndex filters out those numbers.
+} -result {}
+test canvText-8.3 {TextInsert procedure: inserting in a selected item} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefg"
+ .c select from test 2
+ .c select to test 4
+ .c insert test 1 "xyz"
+ .c itemcget test -text
+} -result {axyzbcdefg}
+test canvText-8.4 {TextInsert procedure: inserting before selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefg"
+ .c select from test 2
+ .c select to test 4
+ .c insert test 1 "xyz"
+ list [.c index test sel.first] [.c index test sel.last]
+} -result {5 7}
+test canvText-8.5 {TextInsert procedure: inserting in selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefg"
+ .c select from test 2
+ .c select to test 4
+ .c insert test 3 "xyz"
+ list [.c index test sel.first] [.c index test sel.last]
+} -result {2 7}
+test canvText-8.6 {TextInsert procedure: inserting after selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefg"
+ .c select from test 2
+ .c select to test 4
+ .c insert test 5 "xyz"
+ list [.c index test sel.first] [.c index test sel.last]
+} -result {2 4}
+test canvText-8.7 {TextInsert procedure: inserting in unselected item} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefg"
+ .c select clear
+ .c insert test 5 "xyz"
+ .c itemcget test -text
+} -result {abcdexyzfg}
+test canvText-8.8 {TextInsert procedure: inserting before cursor} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefg"
+ .c icursor test 3
+ .c insert test 2 "xyz"
+ .c index test insert
+} -result {6}
+test canvText-8.9 {TextInsert procedure: inserting after cursor} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefg"
+ .c icursor test 3
+ .c insert test 4 "xyz"
+ .c index test insert
+} -result {3}
+
+# Item used in 9.* tests
+.c create text 20 20 -tag test
+test canvText-9.1 {TextInsert procedure: before beginning/after end} -body {
+ # Can't test this because GetTextIndex filters out those numbers.
+} -result {}
+test canvText-9.2 {TextInsert procedure: start > end} -body {
+ .c itemconfig test -text "abcdefg"
+ .c dchars test 4 2
+ .c itemcget test -text
+} -result {abcdefg}
+test canvText-9.3 {TextInsert procedure: deleting from a selected item} -body {
+ .c itemconfig test -text "abcdefg"
+ .c select from test 2
+ .c select to test 4
+ .c dchars test 3 5
+ .c itemcget test -text
+} -result {abcg}
+test canvText-9.4 {TextInsert procedure: deleting before start} -body {
+ .c itemconfig test -text "abcdefghijk"
+ .c select from test 4
+ .c select to test 8
+ .c dchars test 1 1
+ list [.c index test sel.first] [.c index test sel.last]
+} -result {3 7}
+test canvText-9.5 {TextInsert procedure: keep start > first char deleted} -body {
+ .c itemconfig test -text "abcdefghijk"
+ .c select from test 4
+ .c select to test 8
+ .c dchars test 2 6
+ list [.c index test sel.first] [.c index test sel.last]
+} -result {2 3}
+test canvText-9.6 {TextInsert procedure: deleting inside selection} -body {
+ .c itemconfig test -text "abcdefghijk"
+ .c select from test 4
+ .c select to test 8
+ .c dchars test 6 6
+ list [.c index test sel.first] [.c index test sel.last]
+} -result {4 7}
+test canvText-9.7 {TextInsert procedure: keep end > first char deleted} -body {
+ .c itemconfig test -text "abcdefghijk"
+ .c select from test 4
+ .c select to test 8
+ .c dchars test 6 10
+ list [.c index test sel.first] [.c index test sel.last]
+} -result {4 5}
+test canvText-9.8 {TextInsert procedure: selectFirst > selectLast: deselect} -body {
+ .c itemconfig test -text "abcdefghijk"
+ .c select from test 4
+ .c select to test 8
+ .c dchars test 3 10
+ .c index test sel.first
+} -returnCodes {error} -result {selection isn't in item}
+test canvText-9.9 {TextInsert procedure: selectFirst <= selectLast} -body {
+ .c itemconfig test -text "abcdefghijk"
+ .c select from test 4
+ .c select to test 8
+ .c dchars test 4 7
+ list [.c index test sel.first] [.c index test sel.last]
+} -result {4 4}
+test canvText-9.10 {TextInsert procedure: move anchor} -body {
+ .c itemconfig test -text "abcdefghijk"
+ .c select from test 6
+ .c select to test 8
+ .c dchars test 2 4
+ .c select to test 1
+ list [.c index test sel.first] [.c index test sel.last]
+} -result {1 2}
+test canvText-9.11 {TextInsert procedure: keep anchor >= first} -body {
+ .c itemconfig test -text "abcdefghijk"
+ .c select from test 6
+ .c select to test 8
+ .c dchars test 5 7
+ .c select to test 1
+ list [.c index test sel.first] [.c index test sel.last]
+} -result {1 4}
+test canvText-9.12 {TextInsert procedure: anchor doesn't move} -body {
+ .c itemconfig test -text "abcdefghijk"
+ .c select from test 2
+ .c select to test 5
+ .c dchars test 6 8
+ .c select to test 8
+ list [.c index test sel.first] [.c index test sel.last]
+} -result {2 8}
+test canvText-9.13 {TextInsert procedure: move cursor} -body {
+ .c itemconfig test -text "abcdefghijk"
+ .c icursor test 6
+ .c dchars test 2 4
+ .c index test insert
+} -result {3}
+test canvText-9.14 {TextInsert procedure: keep cursor >= first} -body {
+ .c itemconfig test -text "abcdefghijk"
+ .c icursor test 6
+ .c dchars test 2 10
+ .c index test insert
+} -result {2}
+test canvText-9.15 {TextInsert procedure: cursor doesn't move} -body {
+ .c itemconfig test -text "abcdefghijk"
+ .c icursor test 5
+ .c dchars test 7 9
+ .c index test insert
+} -result {5}
+.c delete test
+
+
+test canvText-10.1 {TextToPoint procedure} -body {
+ .c create text 0 0 -tag test
+ .c itemconfig test -text 0 -anchor center
+ .c index test @0,0
+} -cleanup {
+ .c delete test
+} -result {0}
+
+
+test canvText-11.1 {TextToArea procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text 0 -anchor center
+ set res1 [.c find overlapping 0 0 1 1]
+ set res2 [.c find withtag test]
+ expr {$res1 eq $res2}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-11.2 {TextToArea procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text 0 -anchor center
+ .c find overlapping 1000 1000 1001 1001
+} -cleanup {
+ .c delete test
+} -result {}
+
+
+test canvText-12.1 {ScaleText procedure} -body {
+ .c create text 100 100 -tag test
+ .c scale all 50 50 2 2
+ format {%.6g %.6g} {*}[.c coords test]
+} -cleanup {
+ .c delete test
+} -result {150 150}
+
+
+test canvText-13.1 {TranslateText procedure} -body {
+ .c create text 100 100 -tag test
+ .c move all 10 10
+ format {%.6g %.6g} {*}[.c coords test]
+} -cleanup {
+ .c delete test
+} -result {110 110}
+
+
+test canvText-14.1 {GetTextIndex procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefghijklmno" -anchor nw
+ .c select from test 5
+ .c select to test 8
+ .c icursor test 12
+ .c coords test 0 0
+ list [.c index test end] [.c index test insert] \
+ [.c index test sel.first] [.c index test sel.last] \
+ [.c index test @0,0] \
+ [.c index test -1] [.c index test 10] [.c index test 100]
+} -cleanup {
+ .c delete test
+} -result {15 12 5 8 0 0 10 15}
+test canvText-14.2 {GetTextIndex procedure: select error} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c select clear
+ .c index test sel.first
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {selection isn't in item}
+test canvText-14.3 {GetTextIndex procedure: select error} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c select clear
+ .c index test sel.last
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {selection isn't in item}
+test canvText-14.4 {GetTextIndex procedure: select error} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c select clear
+ .c index test sel.
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {bad index "sel."}
+test canvText-14.5 {GetTextIndex procedure: bad int or unknown index} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c index test xyz
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {bad index "xyz"}
+test canvText-14.6 {select clear errors} -setup {
+ .c create text 0 0 -tag test
+} -body {
+ .c select clear test
+} -cleanup {
+ .c delete test
+} -returnCodes error -result "wrong \# args: should be \".c select clear\""
+
+test canvText-15.1 {SetTextCursor procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefghijklmno" -anchor nw
+ .c itemconfig -text "abcdefg"
+ .c icursor test 3
+ .c index test insert
+} -cleanup {
+ .c delete test
+} -result {3}
+
+test canvText-16.1 {GetSelText procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefghijklmno" -anchor nw
+ .c select from test 5
+ .c select to test 8
+ selection get
+} -cleanup {
+ .c delete test
+} -result {fghi}
+
+test canvText-17.1 {TextToPostscript procedure} -setup {
+ .c delete all
+ set result {findfont [font actual $font -size] scalefont ISOEncode setfont
+0.000 0.000 0.000 setrgbcolor AdjustColor
+0 100 200 \[
+\[(000)\]
+\[(000)\]
+\[(00)\]
+\] $ay -0.5 0 0 false DrawText
+grestore
+restore showpage
+
+%%Trailer
+end
+%%EOF
+}
+} -body {
+ set font {Courier 12 italic}
+ set ax [font measure $font 0]
+ set ay [font metrics $font -linespace]
+ .c config -height 300 -highlightthickness 0 -bd 0
+ update
+ .c create text 100 100 -tags test
+ .c itemconfig test -font $font -text "00000000" -width [expr 3*$ax]
+ .c itemconfig test -anchor n -fill black
+ set x [.c postscript]
+ set x [string range $x [string first "findfont " $x] end]
+ expr {$x eq [subst $result] ? "ok" : $x}
+} -result ok
+
+test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} -setup {
+ destroy .c
+} -body {
+ pack [canvas .c]
+ .c create text 100 100 -text Hello\n -anchor nw
+ set bbox [.c bbox 1]
+ set x2 [lindex $bbox 2]
+ set y2 [lindex $bbox 3]
+ incr y2
+ update
+ .c find enclosed 99 99 [expr $x2 + 1] [expr $y2 + 1]
+} -cleanup {
+ destroy .c
+ unset -nocomplain bbox x2 y2
+} -result 1
+
+test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} -setup {
+ destroy .c
+ set c [canvas .c -bg black -width 964]
+ pack $c
+ $c delete all
+ after 100 "set done 1"; vwait done
+} -body {
+ set f {Arial 28 bold}
+ set s1 { Yeah-ah-ah-ah-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-Yow}
+ set s2 { Yeah ah ah ah oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh Yow}
+ $c create text 21 18 \
+ -font $f \
+ -text $s1 \
+ -fill white \
+ -width 922 \
+ -anchor nw \
+ -tags tbox1
+ $c create rect {*}[$c bbox tbox1] -outline red
+ $c create text 21 160 \
+ -font $f \
+ -text $s2 \
+ -fill white \
+ -width 922 \
+ -anchor nw \
+ -tags tbox2
+ $c create rect {*}[$c bbox tbox2] -outline red
+ after 500 "set done 1" ; vwait done
+ set results [list]
+ $c select from tbox2 4
+ $c select to tbox2 8
+ lappend results [selection get]
+ $c select from tbox1 4
+ $c select to tbox1 8
+ lappend results [selection get]
+ array set metrics [font metrics $f]
+ set x [expr {21 + [font measure $f " "] \
+ + ([font measure {Arial 28 bold} "Y"] / 2)}]
+ set y1 [expr {18 + ($metrics(-linespace) / 2)}]
+ set y2 [expr {160 + ($metrics(-linespace) / 2)}]
+ lappend results [$c index tbox1 @$x,$y1]
+ lappend results [$c index tbox2 @$x,$y2]
+} -cleanup {
+ destroy .c
+} -result {{Yeah } Yeah- 4 4}
+
+test canvText-20.1 {angled text bounding box} -setup {
+ destroy .c
+ canvas .c
+ proc transpose {bbox} {
+ lassign $bbox a b c d
+ list $b $a $d $c
+ }
+} -body {
+ .c create text 2 2 -tag t -anchor center -text 0 -font {Helvetica 24}
+ set bb0 [.c bbox t]
+ .c itemconf t -angle 90
+ set bb1 [.c bbox t]
+ .c itemconf t -angle 180
+ set bb2 [.c bbox t]
+ .c itemconf t -angle 270
+ set bb3 [.c bbox t]
+ list [expr {$bb0 eq $bb2 ? "ok" : "$bb0,$bb2"}] \
+ [expr {$bb1 eq $bb3 ? "ok" : "$bb1,$bb3"}] \
+ [expr {$bb0 eq [transpose $bb1] ? "ok" : "$bb0,$bb1"}] \
+} -cleanup {
+ destroy .c
+ rename transpose {}
+} -result {ok ok ok}
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/canvWind.test b/tk8.6/tests/canvWind.test
new file mode 100644
index 0000000..436ee2c
--- /dev/null
+++ b/tk8.6/tests/canvWind.test
@@ -0,0 +1,144 @@
+# This file is a Tcl script to test out the procedures in tkCanvWind.c,
+# which implement canvas "window" items. It is organized in the standard
+# fashion for Tcl tests.
+#
+# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \
+ -relief sunken -xscrollincrement 1 -yscrollincrement 1 \
+ -highlightthickness 1
+ pack .t.c -fill both -expand 1 -padx 20 -pady 20
+ wm geometry .t +0+0
+ set f .t.f
+ frame $f -width 80 -height 50 -bg red
+ .t.c create window 300 400 -window $f -anchor nw
+ .t.c xview moveto .3
+ .t.c yview moveto .50
+ update
+ set x [list [list [winfo ismapped $f] [winfo y $f]]]
+ .t.c yview scroll 52 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo y $f]]
+ .t.c yview scroll 1 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo y $f]]
+ .t.c yview scroll -255 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo y $f]]
+ .t.c yview scroll -1 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo y $f]]
+} -cleanup {
+ destroy .t
+} -result {{1 23} {1 -29} {0 -29} {1 225} {0 225}}
+
+test canvWind-1.2 {DisplayWinItem, windows off-screen vertically} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \
+ -relief sunken -xscrollincrement 1 -yscrollincrement 1 \
+ -highlightthickness 1
+ pack .t.c -fill both -expand 1 -padx 20 -pady 20
+ wm geometry .t +0+0
+ set f .t.c.f
+ frame $f -width 80 -height 50 -bg red
+ .t.c create window 300 400 -window $f -anchor nw
+ .t.c xview moveto .3
+ .t.c yview moveto .50
+ update
+ set x [list [list [winfo ismapped $f] [winfo y $f]]]
+ .t.c yview scroll 52 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo y $f]]
+ .t.c yview scroll 1 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo y $f]]
+ .t.c yview scroll -255 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo y $f]]
+ .t.c yview scroll -1 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo y $f]]
+} -cleanup {
+ destroy .t
+} -result {{1 3} {1 -49} {0 -49} {1 205} {0 205}}
+
+test canvWind-1.3 {DisplayWinItem, windows off-screen horizontally} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \
+ -relief sunken -xscrollincrement 1 -yscrollincrement 1 \
+ -highlightthickness 1
+ pack .t.c -fill both -expand 1 -padx 20 -pady 20
+ wm geometry .t +0+0
+ set f .t.f
+ frame $f -width 80 -height 50 -bg red
+ .t.c create window 300 400 -window $f -anchor nw
+ .t.c xview moveto .3
+ .t.c yview moveto .50
+ update
+ set x [list [list [winfo ismapped $f] [winfo x $f]]]
+ .t.c xview scroll 82 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo x $f]]
+ .t.c xview scroll 1 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo x $f]]
+ .t.c xview scroll -335 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo x $f]]
+ .t.c xview scroll -1 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo x $f]]
+} -cleanup {
+ destroy .t
+} -result {{1 23} {1 -59} {0 -59} {1 275} {0 275}}
+
+test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \
+ -relief sunken -xscrollincrement 1 -yscrollincrement 1 \
+ -highlightthickness 1
+ pack .t.c -fill both -expand 1 -padx 20 -pady 20
+ wm geometry .t +0+0
+ set f .t.c.f
+ frame $f -width 80 -height 50 -bg red
+ .t.c create window 300 400 -window $f -anchor nw
+ .t.c xview moveto .3
+ .t.c yview moveto .50
+ update
+ set x [list [list [winfo ismapped $f] [winfo x $f]]]
+ .t.c xview scroll 82 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo x $f]]
+ .t.c xview scroll 1 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo x $f]]
+ .t.c xview scroll -335 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo x $f]]
+ .t.c xview scroll -1 units
+ update
+ lappend x [list [winfo ismapped $f] [winfo x $f]]
+} -cleanup {
+ destroy .t
+} -result {{1 3} {1 -79} {0 -79} {1 255} {0 255}}
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/canvas.test b/tk8.6/tests/canvas.test
new file mode 100644
index 0000000..2b0da48
--- /dev/null
+++ b/tk8.6/tests/canvas.test
@@ -0,0 +1,960 @@
+# This file is a Tcl script to test out the procedures in tkCanvas.c, which
+# implements generic code for canvases. It is organized in the standard
+# fashion for Tcl tests.
+#
+# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-2000 Ajuba Solutions.
+# Copyright (c) 2008 Donal K. Fellows
+# All rights reserved.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+imageInit
+
+# XXX - This test file is woefully incomplete. At present, only a few of the
+# features are tested.
+
+# Canvas used in 1.* test cases
+canvas .c
+pack .c
+update
+
+test canvas-1.1 {configuration options: good value for "background"} -body {
+ .c configure -background #ff0000
+ .c cget -background
+} -result {#ff0000}
+test canvas-1.2 {configuration options: bad value for "background"} -body {
+ .c configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test canvas-1.3 {configuration options: good value for "bg"} -body {
+ .c configure -bg #ff0000
+ .c cget -bg
+} -result {#ff0000}
+test canvas-1.4 {configuration options: bad value for "bg"} -body {
+ .c configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test canvas-1.5 {configuration options: good value for "bd"} -body {
+ .c configure -bd 4
+ .c cget -bd
+} -result {4}
+test canvas-1.6 {configuration options: bad value for "bd"} -body {
+ .c configure -bd badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test canvas-1.7 {configuration options: good value for "borderwidth"} -body {
+ .c configure -borderwidth 1.3
+ .c cget -borderwidth
+} -result {1}
+test canvas-1.8 {configuration options: bad value for "borderwidth"} -body {
+ .c configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test canvas-1.9 {configuration options: good value for "closeenough"} -body {
+ .c configure -closeenough 24
+ .c cget -closeenough
+} -result {24.0}
+test canvas-1.10 {configuration options: bad value for "closeenough"} -body {
+ .c configure -closeenough bogus
+} -returnCodes error -result {expected floating-point number but got "bogus"}
+test canvas-1.11 {configuration options: good value for "confine"} -body {
+ .c configure -confine true
+ .c cget -confine
+} -result {1}
+test canvas-1.12 {configuration options: bad value for "confine"} -body {
+ .c configure -confine silly
+} -returnCodes error -result {expected boolean value but got "silly"}
+test canvas-1.13 {configuration options: good value for "cursor"} -body {
+ .c configure -cursor arrow
+ .c cget -cursor
+} -result {arrow}
+test canvas-1.14 {configuration options: bad value for "cursor"} -body {
+ .c configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test canvas-1.15 {configuration options: good value for "height"} -body {
+ .c configure -height 2.1
+ .c cget -height
+} -result {2}
+test canvas-1.16 {configuration options: bad value for "height"} -body {
+ .c configure -height x42
+} -returnCodes error -result {bad screen distance "x42"}
+test canvas-1.17 {configuration options: good value for "highlightbackground"} -body {
+ .c configure -highlightbackground #112233
+ .c cget -highlightbackground
+} -result {#112233}
+test canvas-1.18 {configuration options: bad value for "highlightbackground"} -body {
+ .c configure -highlightbackground ugly
+} -returnCodes error -result {unknown color name "ugly"}
+test canvas-1.19 {configuration options: good value for "highlightcolor"} -body {
+ .c configure -highlightcolor #110022
+ .c cget -highlightcolor
+} -result {#110022}
+test canvas-1.20 {configuration options: bad value for "highlightcolor"} -body {
+ .c configure -highlightcolor bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test canvas-1.21 {configuration options: good value for "highlightthickness"} -body {
+ .c configure -highlightthickness 18
+ .c cget -highlightthickness
+} -result {18}
+test canvas-1.22 {configuration options: bad value for "highlightthickness"} -body {
+ .c configure -highlightthickness badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test canvas-1.23 {configuration options: good value for "insertbackground"} -body {
+ .c configure -insertbackground #110022
+ .c cget -insertbackground
+} -result {#110022}
+test canvas-1.24 {configuration options: bad value for "insertbackground"} -body {
+ .c configure -insertbackground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test canvas-1.25 {configuration options: good value for "insertborderwidth"} -body {
+ .c configure -insertborderwidth 1.3
+ .c cget -insertborderwidth
+} -result {1}
+test canvas-1.26 {configuration options: bad value for "insertborderwidth"} -body {
+ .c configure -insertborderwidth 2.6x
+} -returnCodes error -result {bad screen distance "2.6x"}
+test canvas-1.27 {configuration options: good value for "insertofftime"} -body {
+ .c configure -insertofftime 100
+ .c cget -insertofftime
+} -result {100}
+test canvas-1.28 {configuration options: bad value for "insertofftime"} -body {
+ .c configure -insertofftime 3.2
+} -returnCodes error -result {expected integer but got "3.2"}
+test canvas-1.29 {configuration options: good value for "insertontime"} -body {
+ .c configure -insertontime 100
+ .c cget -insertontime
+} -result {100}
+test canvas-1.30 {configuration options: bad value for "insertontime"} -body {
+ .c configure -insertontime 3.2
+} -returnCodes error -result {expected integer but got "3.2"}
+test canvas-1.31 {configuration options: good value for "insertwidth"} -body {
+ .c configure -insertwidth 1.3
+ .c cget -insertwidth
+} -result {1}
+test canvas-1.32 {configuration options: bad value for "insertwidth"} -body {
+ .c configure -insertwidth 6x
+} -returnCodes error -result {bad screen distance "6x"}
+test canvas-1.33 {configuration options: good value for "relief"} -body {
+ .c configure -relief groove
+ .c cget -relief
+} -result {groove}
+test canvas-1.34 {configuration options: bad value for "relief"} -body {
+ .c configure -relief 1.5
+} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test canvas-1.35 {configuration options: good value for "selectbackground"} -body {
+ .c configure -selectbackground #110022
+ .c cget -selectbackground
+} -result {#110022}
+test canvas-1.36 {configuration options: bad value for "selectbackground"} -body {
+ .c configure -selectbackground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test canvas-1.37 {configuration options: good value for "selectborderwidth"} -body {
+ .c configure -selectborderwidth 1.3
+ .c cget -selectborderwidth
+} -result {1}
+test canvas-1.38 {configuration options: bad value for "selectborderwidth"} -body {
+ .c configure -selectborderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test canvas-1.39 {configuration options: good value for "selectforeground"} -body {
+ .c configure -selectforeground #654321
+ .c cget -selectforeground
+} -result {#654321}
+test canvas-1.40 {configuration options: bad value for "selectforeground"} -body {
+ .c configure -selectforeground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test canvas-1.41 {configuration options: good value for "takefocus"} -body {
+ .c configure -takefocus "any string"
+ .c cget -takefocus
+} -result {any string}
+test canvas-1.42 {configuration options: good value for "width"} -body {
+ .c configure -width 402
+ .c cget -width
+} -result {402}
+test canvas-1.43 {configuration options: bad value for "width"} -body {
+ .c configure -width xyz
+} -returnCodes error -result {bad screen distance "xyz"}
+test canvas-1.44 {configuration options: good value for "xscrollcommand"} -body {
+ .c configure -xscrollcommand {Some command}
+ .c cget -xscrollcommand
+} -result {Some command}
+test canvas-1.45 {configuration options: good value for "yscrollcommand"} -body {
+ .c configure -yscrollcommand {Another command}
+ .c cget -yscrollcommand
+} -result {Another command}
+test canvas-1.46 {configure throws error on bad option} -body {
+ .c configure -gorp foo
+} -returnCodes error -match glob -result {*}
+test canvas-1.47 {configure throws error on bad option} -body {
+ catch {.c configure -gorp foo}
+ .c create rect 10 10 100 100
+ .c configure -gorp foo
+} -returnCodes error -match glob -result {*}
+catch {destroy .c}
+
+# Canvas used in 2.* test cases
+canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \
+ -highlightthickness 0
+pack .c
+update
+
+test canvas-2.1 {CanvasWidgetCmd, bind option} -body {
+ set i [.c create rect 10 10 100 100]
+ .c bind $i <a>
+} -cleanup {
+ .c delete $i
+} -returnCodes ok
+test canvas-2.2 {CanvasWidgetCmd, bind option} -body {
+ set i [.c create rect 10 10 100 100]
+ .c bind $i <
+} -cleanup {
+ .c delete $i
+} -returnCodes error -result {no event type or button # or keysym}
+test canvas-2.3 {CanvasWidgetCmd, xview option} -body {
+ .c configure -xscrollincrement 40 -yscrollincrement 5
+ .c xview moveto 0
+ update
+ set x [list [.c xview]]
+ .c xview scroll 2 units
+ update
+ lappend x [.c xview]
+} -result {{0.0 0.3} {0.4 0.7}}
+test canvas-2.4 {CanvasWidgetCmd, xview option} -constraints nonPortable -body {
+ # This test gives slightly different results on platforms such as NetBSD.
+ # I don't know why...
+ .c configure -xscrollincrement 0 -yscrollincrement 5
+ .c xview moveto 0.6
+ update
+ set x [list [.c xview]]
+ .c xview scroll 2 units
+ update
+ lappend x [.c xview]
+} -result {{0.6 0.9} {0.66 0.96}}
+catch {destroy .c}
+
+# Canvas used in 3.* test cases
+canvas .c -width 60 -height 40 -scrollregion {0 0 200 80} \
+ -borderwidth 0 -highlightthickness 0
+pack .c
+update
+
+test canvas-3.1 {CanvasWidgetCmd, yview option} -body {
+ .c configure -xscrollincrement 40 -yscrollincrement 5
+ .c yview moveto 0
+ update
+ set x [list [.c yview]]
+ .c yview scroll 3 units
+ update
+ lappend x [.c yview]
+} -result {{0.0 0.5} {0.1875 0.6875}}
+test canvas-3.2 {CanvasWidgetCmd, yview option} -body {
+ .c configure -xscrollincrement 40 -yscrollincrement 0
+ .c yview moveto 0
+ update
+ set x [list [.c yview]]
+ .c yview scroll 2 units
+ update
+ lappend x [.c yview]
+} -result {{0.0 0.5} {0.1 0.6}}
+destroy .c
+
+test canvas-4.1 {ButtonEventProc procedure} -setup {
+ deleteWindows
+ set x {}
+} -body {
+ canvas .c1 -bg #543210
+ rename .c1 .c2
+ lappend x [winfo children .]
+ lappend x [.c2 cget -bg]
+ destroy .c1
+ lappend x [info command .c*] [winfo children .]
+} -result {.c1 #543210 {} {}}
+
+test canvas-5.1 {ButtonCmdDeletedProc procedure} -body {
+ canvas .c1
+ rename .c1 {}
+ list [info command .c*] [winfo children .]
+} -cleanup {
+ destroy .c1
+} -result {{} {}}
+
+# Canvas used in 6.* test cases
+canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \
+ -borderwidth 2 -highlightthickness 3
+pack .c
+update
+
+test canvas-6.1 {CanvasSetOrigin procedure} -body {
+ .c configure -xscrollincrement 0 -yscrollincrement 0
+ .c xview moveto 0
+ .c yview moveto 0
+ update
+ list [.c canvasx 0] [.c canvasy 0]
+} -result {-205.0 -105.0}
+test canvas-6.2 {CanvasSetOrigin procedure} -body {
+ .c configure -xscrollincrement 20 -yscrollincrement 10
+ set x ""
+ foreach i {.08 .10 .48 .50} {
+ .c xview moveto $i
+ update
+ lappend x [.c canvasx 0]
+ }
+ return $x
+} -result {-165.0 -145.0 35.0 55.0}
+test canvas-6.3 {CanvasSetOrigin procedure} -body {
+ .c configure -xscrollincrement 20 -yscrollincrement 10
+ set x ""
+ foreach i {.06 .08 .70 .72} {
+ .c yview moveto $i
+ update
+ lappend x [.c canvasy 0]
+ }
+ return $x
+} -result {-95.0 -85.0 35.0 45.0}
+test canvas-6.4 {CanvasSetOrigin procedure} -body {
+ .c configure -xscrollincrement 20 -yscrollincrement 10
+ .c xview moveto 1.0
+ .c canvasx 0
+} -result {215.0}
+test canvas-6.5 {CanvasSetOrigin procedure} -body {
+ .c configure -xscrollincrement 20 -yscrollincrement 10
+ .c yview moveto 1.0
+ .c canvasy 0
+} -result {55.0}
+deleteWindows
+
+test canvas-7.1 {canvas widget vs hidden commands} -setup {
+ canvas .c
+} -body {
+ interp hide {} .c
+ destroy .c
+ list [winfo children .] [lsort [interp hidden]]
+} -cleanup {
+ destroy .c
+} -result [list {} [lsort [interp hidden]]]
+
+test canvas-8.1 {canvas arc bbox} -setup {
+ catch {destroy .c}
+ canvas .c
+} -body {
+ .c create arc -100 10 100 210 -start 10 -extent 50 -style arc -tags arc1
+ set arcBox [.c bbox arc1]
+ .c create arc 100 10 300 210 -start 10 -extent 50 -style chord -tags arc2
+ set coordBox [.c bbox arc2]
+ .c create arc 300 10 500 210 -start 10 -extent 50 -style pieslice -tags arc3
+ set pieBox [.c bbox arc3]
+ list $arcBox $coordBox $pieBox
+} -result {{48 21 100 94} {248 21 300 94} {398 21 500 112}}
+
+test canvas-9.1 {canvas id creation and deletion} -setup {
+ catch {destroy .c}
+ canvas .c
+} -body {
+ # With Tk 8.0.4 the ids are now stored in a hash table. You can use this
+ # test as a performance test with older versions by changing the value of
+ # size.
+ set size 15
+ for {set i 0} {$i < $size} {incr i} {
+ set x [expr {-10 + 3*$i}]
+ for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} {
+ .c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \
+ -outline black -fill blue -tags rect
+ .c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \
+ -anchor center -tags text
+ }
+ }
+ # The actual bench mark - this code also exercises all the hash table
+ # changes.
+ set time [lindex [time {
+ foreach id [.c find withtag all] {
+ .c lower $id
+ .c raise $id
+ .c find withtag $id
+ .c bind <Return> $id {}
+ .c delete $id
+ }
+ }] 0]
+ set x ""
+} -result {}
+
+test canvas-10.1 {find items using tag expressions} -setup {
+ catch {destroy .c}
+ canvas .c
+ set res {}
+} -body {
+ .c create oval 20 20 40 40 -fill red -tag [list a b c d]
+ .c create oval 20 60 40 80 -fill yellow -tag [list b a]
+ .c create oval 20 100 40 120 -fill green -tag [list c b]
+ .c create oval 20 140 40 160 -fill blue -tag [list b]
+ .c create oval 20 180 40 200 -fill bisque -tag [list a d e]
+ .c create oval 20 220 40 240 -fill bisque -tag b
+ .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
+ lappend res [.c find withtag {!a}]
+ lappend res [.c find withtag {b&&c}]
+ lappend res [.c find withtag {b||c}]
+ lappend res [.c find withtag {a&&!b}]
+ lappend res [.c find withtag {!b&&!c}]
+ lappend res [.c find withtag {d&&a&&c&&b}]
+ lappend res [.c find withtag {b^a}]
+ lappend res [.c find withtag {(a&&!b)||(!a&&b)}]
+ lappend res [.c find withtag { ( a && ! b ) || ( ! a && b ) }]
+ lappend res [.c find withtag {a&&!(c||d)}]
+ lappend res [.c find withtag {d&&"tag with spaces"}]
+ lappend res [.c find withtag "tag with spaces"]
+} -result {{3 4 6 7} {1 3} {1 2 3 4 6} 5 {5 7} 1 {3 4 5 6} {3 4 5 6} {3 4 5 6} 2 7 7}
+test canvas-10.2 {check errors from tag expressions} -setup {
+ catch {destroy .c}
+ canvas .c
+ .c create oval 20 20 40 40 -fill red -tag [list a b c d]
+ .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
+} -body {
+ .c find withtag {&&c}
+} -returnCodes error -result {unexpected operator in tag search expression}
+test canvas-10.3 {check errors from tag expressions} -setup {
+ catch {destroy .c}
+ canvas .c
+ .c create oval 20 20 40 40 -fill red -tag [list a b c d]
+ .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
+} -body {
+ .c find withtag {!!c}
+} -returnCodes error -result {too many '!' in tag search expression}
+test canvas-10.4 {check errors from tag expressions} -setup {
+ catch {destroy .c}
+ canvas .c
+ .c create oval 20 20 40 40 -fill red -tag [list a b c d]
+ .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
+} -body {
+ .c find withtag {b||}
+} -returnCodes error -result {missing tag in tag search expression}
+test canvas-10.5 {check errors from tag expressions} -setup {
+ catch {destroy .c}
+ canvas .c
+ .c create oval 20 20 40 40 -fill red -tag [list a b c d]
+ .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
+} -body {
+ .c find withtag {b&&(c||)}
+} -returnCodes error -result {unexpected operator in tag search expression}
+test canvas-10.6 {check errors from tag expressions} -setup {
+ catch {destroy .c}
+ canvas .c
+ .c create oval 20 20 40 40 -fill red -tag [list a b c d]
+ .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
+} -body {
+ .c find withtag {d&&""}
+} -returnCodes error -result {null quoted tag string in tag search expression}
+test canvas-10.7 {check errors from tag expressions} -setup {
+ catch {destroy .c}
+ canvas .c
+ .c create oval 20 20 40 40 -fill red -tag [list a b c d]
+ .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
+} -body {
+ .c find withtag "d&&\"tag with spaces"
+} -returnCodes error -result {missing endquote in tag search expression}
+test canvas-10.8 {check errors from tag expressions} -setup {
+ catch {destroy .c}
+ canvas .c
+ .c create oval 20 20 40 40 -fill red -tag [list a b c d]
+ .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
+} -returnCodes error -body {
+ .c find withtag {a&&"tag with spaces"z}
+} -result {invalid boolean operator in tag search expression}
+test canvas-10.9 {check errors from tag expressions} -setup {
+ catch {destroy .c}
+ canvas .c
+ .c create oval 20 20 40 40 -fill red -tag [list a b c d]
+ .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
+} -body {
+ .c find withtag {a&&b&c}
+} -returnCodes error -result {singleton '&' in tag search expression}
+test canvas-10.10 {check errors from tag expressions} -setup {
+ catch {destroy .c}
+ canvas .c
+ .c create oval 20 20 40 40 -fill red -tag [list a b c d]
+ .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
+} -body {
+ .c find withtag {a||b|c}
+} -returnCodes error -result {singleton '|' in tag search expression}
+test canvas-10.11 {backward compatility - strange tags that are not expressions} -setup {
+ catch {destroy .c}
+ canvas .c
+ .c create oval 20 20 40 40 -fill red \
+ -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }]
+} -body {
+ .c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }
+} -result 1
+test canvas-10.12 {multple events bound to same tag expr} -setup {
+ catch {destroy .c}
+ canvas .c
+} -body {
+ .c bind {a && b} <Enter> {puts Enter}
+ .c bind {a && b} <Leave> {puts Leave}
+} -result {}
+test canvas-10.13 {more long tag searches; Bug 2931374} -setup {
+ catch {destroy .c}
+ canvas .c
+} -body {
+ .c find withtag {(A&&B&&C&&D)&&area&&!text}
+ # memory errors on failure
+} -cleanup {
+ destroy .c
+} -result {}
+
+test canvas-11.1 {canvas poly fill check, bug 5783} -setup {
+ destroy .c
+ pack [canvas .c]
+} -body {
+ # This would crash in 8.3.0 and 8.3.1
+ .c create polygon 0 0 100 100 200 50 \
+ -fill {} -stipple gray50 -outline black
+} -result 1
+test canvas-11.2 {canvas poly overlap fill check, bug 226357} -setup {
+ destroy .c
+ pack [canvas .c]
+ set result {}
+} -body {
+ .c create poly 30 30 90 90 30 90 90 30
+ lappend result [.c find over 40 40 45 45]; # rect region inc. edge
+ lappend result [.c find over 60 40 60 40]; # top-center point
+ lappend result [.c find over 0 0 0 0]; # not on poly
+ lappend result [.c find over 60 60 60 60]; # center-point
+ lappend result [.c find over 45 50 45 50]; # outside poly
+ .c itemconfig 1 -fill "" -outline black
+ lappend result [.c find over 40 40 45 45]; # rect region inc. edge
+ lappend result [.c find over 60 40 60 40]; # top-center point
+ lappend result [.c find over 0 0 0 0]; # not on poly
+ lappend result [.c find over 60 60 60 60]; # center-point
+ lappend result [.c find over 45 50 45 50]; # outside poly
+ .c itemconfig 1 -width 8
+ lappend result [.c find over 45 50 45 50]; # outside poly
+} -result {1 1 {} 1 {} 1 1 {} 1 {} 1}
+test canvas-11.3 {canvas poly dchars, bug 3291543} {
+ # This would crash
+ destroy .c
+ pack [canvas .c]
+ .c create polygon 0 0 0 10 10 0
+ .c dchars 1 2 end
+ .c coords 1
+} {}
+
+test canvas-12.1 {canvas mm obj, patch SF-403327, 102471} -setup {
+ destroy .c
+ pack [canvas .c]
+} -body {
+ set qx [expr {1.+1.}]
+ # qx has type double and no string representation
+ .c scale all $qx 0 1. 1.
+ # qx has now type MMRep and no string representation
+ list $qx [string length $qx]
+} -result {2.0 3}
+test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} -setup {
+ destroy .c
+ pack [canvas .c]
+} -body {
+ set val 10
+ incr val
+ # qx has type double and no string representation
+ .c scale all $val 0 1 1
+ # qx has now type MMRep and no string representation
+ incr val
+} -result 12
+
+# procedure used in 13.1 test case
+proc kill_canvas {w} {
+ destroy $w
+ pack [canvas $w -height 200 -width 200] -fill both -expand yes
+ update idle
+ $w create rectangle 80 80 120 120 -fill blue -tags blue
+ # bind a button press to re-build the canvas
+ $w bind blue <ButtonRelease-1> [subst {
+ [lindex [info level 0] 0] $w
+ append ::x ok
+ }]
+}
+test canvas-13.1 {canvas delete during event, SF bug-228024} -body {
+ kill_canvas .c
+ set ::x {}
+ # do this many times to improve chances of triggering the crash
+ for {set i 0} {$i < 30} {incr i} {
+ event generate .c <1> -x 100 -y 100
+ event generate .c <ButtonRelease-1> -x 100 -y 100
+ }
+ return $::x
+} -result {okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok}
+
+test canvas-14.1 {canvas scan SF bug 581560} -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c scan
+} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}
+test canvas-14.2 {canvas scan} -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c scan bogus
+} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}
+test canvas-14.3 {canvas scan} -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c scan mark
+} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}
+test canvas-14.4 {canvas scan} -setup {
+ destroy .c
+ canvas .c
+} -body {
+ .c scan mark 10 10
+} -result {}
+test canvas-14.5 {canvas scan} -setup {
+ destroy .c
+ canvas .c
+} -body {
+ .c scan mark 10 10 5
+} -returnCodes error -result {wrong # args: should be ".c scan mark x y"}
+test canvas-14.6 {canvas scan} -setup {
+ destroy .c
+ canvas .c
+} -body {
+ .c scan dragto 10 10 5
+} -result {}
+
+test canvas-15.1 {basic types check: arc requires coords} -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create arc
+} -result {wrong # args: should be ".c create arc coords ?arg ...?"}
+test canvas-15.2 "basic coords check: arc coords are paired" -setup {
+ destroy .c
+ canvas .c
+} -body {
+ .c create arc 0
+} -returnCodes error -result {wrong # coordinates: expected 4, got 1}
+test canvas-15.3 {basic types check: bitmap requires coords} -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create bitmap
+} -result {wrong # args: should be ".c create bitmap coords ?arg ...?"}
+test canvas-15.4 "basic coords check: bitmap coords are paired" -setup {
+ destroy .c
+ canvas .c
+} -body {
+ .c create bitmap 0
+} -returnCodes error -result {wrong # coordinates: expected 2, got 1}
+test canvas-15.5 {basic types check: image requires coords} -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create image
+} -result {wrong # args: should be ".c create image coords ?arg ...?"}
+test canvas-15.6 "basic coords check: image coords are paired" -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create image 0
+} -result {wrong # coordinates: expected 2, got 1}
+test canvas-15.7 {basic types check: line requires coords} -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create line
+} -result {wrong # args: should be ".c create line coords ?arg ...?"}
+test canvas-15.8 "basic coords check: line coords are paired" -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create line 0
+} -result {wrong # coordinates: expected an even number, got 1}
+test canvas-15.9 {basic types check: oval requires coords} -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create oval
+} -result {wrong # args: should be ".c create oval coords ?arg ...?"}
+test canvas-15.10 "basic coords check: oval coords are paired" -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create oval 0
+} -result {wrong # coordinates: expected 0 or 4, got 1}
+test canvas-15.11 {basic types check: polygon requires coords} -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create polygon
+} -result {wrong # args: should be ".c create polygon coords ?arg ...?"}
+test canvas-15.12 "basic coords check: polygon coords are paired" -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create polygon 0
+} -result {wrong # coordinates: expected an even number, got 1}
+test canvas-15.13 {basic types check: rect requires coords} -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create rect
+} -result {wrong # args: should be ".c create rect coords ?arg ...?"}
+test canvas-15.14 "basic coords check: rect coords are paired" -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create rect 0
+} -result {wrong # coordinates: expected 0 or 4, got 1}
+test canvas-15.15 {basic types check: text requires coords} -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create text
+} -result {wrong # args: should be ".c create text coords ?arg ...?"}
+test canvas-15.16 "basic coords check: text coords are paired" -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create text 0
+} -result {wrong # coordinates: expected 2, got 1}
+test canvas-15.17 {basic types check: window requires coords} -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create window
+} -result {wrong # args: should be ".c create window coords ?arg ...?"}
+test canvas-15.18 "basic coords check: window coords are paired" -setup {
+ destroy .c
+ canvas .c
+} -returnCodes error -body {
+ .c create window 0
+} -result {wrong # coordinates: expected 2, got 1}
+test canvas-15.19 "basic coords check: centimeters are larger than pixels" -setup {
+ destroy .c
+ canvas .c
+} -body {
+ set id [.c create rect 0 0 1cm 1cm]
+ expr {[lindex [.c coords $id] 2]>1}
+} -result {1}
+destroy .c
+
+test canvas-16.1 {arc coords check} -setup {
+ canvas .c
+} -body {
+ set id [.c create arc {0 10 20 30} -start 33]
+ .c itemcget $id -start
+} -cleanup {
+ destroy .c
+} -result {33.0}
+
+test canvas-17.1 {default smooth method handling} -setup {
+ canvas .c
+} -body {
+ set id [.c create line {0 0 1 1 2 2 3 3 4 4 5 5 6 6}]
+ set result [.c itemcget $id -smooth]
+ foreach smoother {yes 1 bezier raw r b} {
+ .c itemconfigure $id -smooth $smoother
+ lappend result [.c itemcget $id -smooth]
+ }
+ return $result
+} -cleanup {
+ destroy .c
+} -result {0 true true true raw raw true}
+
+test canvas-18.1 {imove method - lines} -setup {
+ canvas .c
+} -body {
+ set id [.c create line 0 0 1 1 2 2 3 3]
+ .c imove $id 0 4 4
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {4.0 4.0 1.0 1.0 2.0 2.0 3.0 3.0}
+test canvas-18.2 {imove method - lines} -setup {
+ canvas .c
+} -body {
+ set id [.c create line 0 0 1 1]
+ .c imove $id 0 4 4
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {4.0 4.0 1.0 1.0}
+test canvas-18.3 {imove method - lines} -setup {
+ canvas .c
+} -body {
+ set id [.c create line 0 0 1 1 2 2 3 3]
+ .c imove $id @1,1 4 4
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {0.0 0.0 4.0 4.0 2.0 2.0 3.0 3.0}
+test canvas-18.4 {imove method - lines} -constraints knownBug -setup {
+ canvas .c
+} -body {
+ set id [.c create line 0 0 1 1 2 2 3 3]
+ .c imove $id end 4 4
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {0.0 0.0 1.0 1.0 2.0 2.0 4.0 4.0}
+test canvas-18.5 {imove method - polygon} -setup {
+ canvas .c
+} -body {
+ set id [.c create polygon 0 0 1 1 2 2 3 3]
+ .c imove $id 0 4 4
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {4.0 4.0 1.0 1.0 2.0 2.0 3.0 3.0}
+test canvas-18.6 {imove method - polygon} -setup {
+ canvas .c
+} -body {
+ set id [.c create polygon 0 0 1 1]
+ .c imove $id 0 4 4
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {4.0 4.0 1.0 1.0}
+test canvas-18.7 {imove method - polygon} -setup {
+ canvas .c
+} -body {
+ set id [.c create polygon 0 0 1 1 2 2 3 3]
+ .c imove $id @1,1 4 4
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {0.0 0.0 4.0 4.0 2.0 2.0 3.0 3.0}
+test canvas-18.8 {imove method - polygon} -constraints knownBug -setup {
+ canvas .c
+} -body {
+ set id [.c create polygon 0 0 1 1 2 2 3 3]
+ .c imove $id end 4 4
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {0.0 0.0 1.0 1.0 2.0 2.0 4.0 4.0}
+test canvas-18.9 {imove method - errors} -setup {
+ canvas .c
+} -body {
+ set id [.c create line 0 0 1 1 2 2 3 3]
+ .c imove $id foobar 4 4
+} -cleanup {
+ destroy .c
+} -returnCodes error -result {bad index "foobar"}
+test canvas-18.10 {imove method - errors} -setup {
+ canvas .c
+} -body {
+ set id [.c create line 0 0 1 1 2 2 3 3]
+ .c imove $id 0 foobar 4
+} -cleanup {
+ destroy .c
+} -returnCodes error -result {bad screen distance "foobar"}
+test canvas-18.11 {imove method - errors} -setup {
+ canvas .c
+} -body {
+ set id [.c create line 0 0 1 1 2 2 3 3]
+ .c imove $id 0 4 foobar
+} -cleanup {
+ destroy .c
+} -returnCodes error -result {bad screen distance "foobar"}
+
+test canvas-19.1 {rchars method - lines} -setup {
+ canvas .c
+} -body {
+ set id [.c create line 0 0 1 1 2 2 3 3]
+ .c rchars $id 2 4 {4 4}
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {0.0 0.0 4.0 4.0 3.0 3.0}
+test canvas-19.2 {rchars method - lines} -setup {
+ canvas .c
+} -body {
+ set id [.c create line 0 0 1 1 2 2 3 3]
+ .c rchars $id 2 4 {}
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {0.0 0.0 3.0 3.0}
+test canvas-19.3 {rchars method - lines} -setup {
+ canvas .c
+} -body {
+ set id [.c create line 0 0 1 1 2 2 3 3]
+ .c rchars $id 2 4 {10 11 12 13 14 15}
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {0.0 0.0 10.0 11.0 12.0 13.0 14.0 15.0 3.0 3.0}
+test canvas-19.4 {rchars method - polygon} -setup {
+ canvas .c
+} -body {
+ set id [.c create polygon 0 0 1 1 2 2 3 3]
+ .c rchars $id 2 4 {4 4}
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {0.0 0.0 4.0 4.0 3.0 3.0}
+test canvas-19.5 {rchars method - polygon} -setup {
+ canvas .c
+} -body {
+ set id [.c create polygon 0 0 1 1 2 2 3 3]
+ .c rchars $id 2 4 {}
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {0.0 0.0 3.0 3.0}
+test canvas-19.6 {rchars method - polygon} -setup {
+ canvas .c
+} -body {
+ set id [.c create polygon 0 0 1 1 2 2 3 3]
+ .c rchars $id 2 4 {10 11 12 13 14 15}
+ .c coords $id
+} -cleanup {
+ destroy .c
+} -result {0.0 0.0 10.0 11.0 12.0 13.0 14.0 15.0 3.0 3.0}
+test canvas-19.7 {rchars method - text} -setup {
+ canvas .c
+} -body {
+ set id [.c create text 0 0 -text abcde]
+ .c rchars $id 1 3 XYZ
+ .c itemcget $id -text
+} -cleanup {
+ destroy .c
+} -result aXYZe
+test canvas-19.8 {rchars method - text} -setup {
+ canvas .c
+} -body {
+ set id [.c create text 0 0 -text abcde]
+ .c rchars $id 1 3 {}
+ .c itemcget $id -text
+} -cleanup {
+ destroy .c
+} -result ae
+test canvas-19.9 {rchars method - text} -setup {
+ canvas .c
+} -body {
+ set id [.c create text 0 0 -text abcde]
+ .c rchars $id 1 3 FOOBAR
+ .c itemcget $id -text
+} -cleanup {
+ destroy .c
+} -result aFOOBARe
+test canvas-19.10 {rchars method - errors} -setup {
+ canvas .c
+} -body {
+ set id [.c create line 0 0 1 1]
+ .c rchars $id foo 1 {2 2}
+} -cleanup {
+ destroy .c
+} -returnCodes error -result {bad index "foo"}
+test canvas-19.11 {rchars method - errors} -setup {
+ canvas .c
+} -body {
+ set id [.c create line 0 0 1 1]
+ .c rchars $id 1 foo {2 2}
+} -cleanup {
+ destroy .c
+} -returnCodes error -result {bad index "foo"}
+
+# cleanup
+imageCleanup
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/choosedir.test b/tk8.6/tests/choosedir.test
new file mode 100644
index 0000000..fb6e62d
--- /dev/null
+++ b/tk8.6/tests/choosedir.test
@@ -0,0 +1,172 @@
+# This file is a Tcl script to test out Tk's "tk_chooseDir" and
+# It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+#----------------------------------------------------------------------
+#
+# Procedures needed by this test file
+#
+#----------------------------------------------------------------------
+
+proc ToPressButton {parent btn} {
+ after 100 SendButtonPress $parent $btn mouse
+}
+
+proc ToEnterDirsByKey {parent dirs} {
+ after 100 [list EnterDirsByKey $parent $dirs]
+}
+
+proc PressButton {btn} {
+ event generate $btn <Enter>
+ event generate $btn <1> -x 5 -y 5
+ event generate $btn <ButtonRelease-1> -x 5 -y 5
+}
+
+proc EnterDirsByKey {parent dirs} {
+ global tk_strictMotif
+ if {$parent == "."} {
+ set w .__tk_choosedir
+ } else {
+ set w $parent.__tk_choosedir
+ }
+ upvar ::tk::dialog::file::__tk_choosedir data
+
+ foreach dir $dirs {
+ $data(ent) delete 0 end
+ $data(ent) insert 0 $dir
+ update
+ SendButtonPress $parent ok mouse
+ after 50
+ }
+}
+
+proc SendButtonPress {parent btn type} {
+ global tk_strictMotif
+ if {$parent == "."} {
+ set w .__tk_choosedir
+ } else {
+ set w $parent.__tk_choosedir
+ }
+ upvar ::tk::dialog::file::__tk_choosedir data
+
+ set button $data($btn\Btn)
+ if ![winfo ismapped $button] {
+ update
+ }
+
+ if {$type == "mouse"} {
+ PressButton $button
+ } else {
+ event generate $w <Enter>
+ focus $w
+ event generate $button <Enter>
+ event generate $w <KeyPress> -keysym Return
+ }
+}
+
+
+#----------------------------------------------------------------------
+#
+# The test suite proper
+#
+#----------------------------------------------------------------------
+# Make a dir for us to rely on for tests
+set real [makeDirectory choosedirTest]
+set dir [file dirname $real]
+set fake [file join $dir non-existant]
+
+set parent .
+
+test choosedir-1.1 {tk_chooseDirectory command} -constraints unix -body {
+ tk_chooseDirectory -initialdir
+} -returnCodes error -result {value for "-initialdir" missing}
+test choosedir-1.2 {tk_chooseDirectory command} -constraints unix -body {
+ tk_chooseDirectory -mustexist
+} -returnCodes error -result {value for "-mustexist" missing}
+test choosedir-1.3 {tk_chooseDirectory command} -constraints unix -body {
+ tk_chooseDirectory -parent
+} -returnCodes error -result {value for "-parent" missing}
+test choosedir-1.4 {tk_chooseDirectory command} -constraints unix -body {
+ tk_chooseDirectory -title
+} -returnCodes error -result {value for "-title" missing}
+
+test choosedir-1.5 {tk_chooseDirectory command} -constraints unix -body {
+ tk_chooseDirectory -foo bar
+} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}
+test choosedir-1.6 {tk_chooseDirectory command} -constraints unix -body {
+ tk_chooseDirectory -parent foo.bar
+} -returnCodes error -result {bad window path name "foo.bar"}
+
+
+test choosedir-2.1 {tk_chooseDirectory command, cancel gives null} -constraints {
+ unix notAqua
+} -body {
+ ToPressButton $parent cancel
+ tk_chooseDirectory -title "Press Cancel" -parent $parent
+} -result {}
+
+
+test choosedir-3.1 {tk_chooseDirectory -mustexist 1} -constraints {
+ unix notAqua
+} -body {
+ # first enter a bogus dirname, then enter a real one.
+ ToEnterDirsByKey $parent [list $fake $real $real]
+ set result [tk_chooseDirectory \
+ -title "Enter \"$fake\", press OK, enter \"$real\", press OK" \
+ -parent $parent -mustexist 1]
+ set result
+} -result $real
+test choosedir-3.2 {tk_chooseDirectory -mustexist 0} -constraints {
+ unix notAqua
+} -body {
+ ToEnterDirsByKey $parent [list $fake $fake]
+ tk_chooseDirectory -title "Enter \"$fake\", press OK" \
+ -parent $parent -mustexist 0
+} -result $fake
+
+
+test choosedir-4.1 {tk_chooseDirectory command, initialdir} -constraints {
+ unix notAqua
+} -body {
+ ToPressButton $parent ok
+ tk_chooseDirectory -title "Press Ok" -parent $parent -initialdir $real
+} -result $real
+test choosedir-4.2 {tk_chooseDirectory command, initialdir} -constraints {
+ unix notAqua
+} -body {
+ ToEnterDirsByKey $parent [list $fake $fake]
+ tk_chooseDirectory \
+ -title "Enter \"$fake\" and press Ok" \
+ -parent $parent -initialdir $real
+} -result $fake
+test choosedir-4.3 {tk_chooseDirectory command, {} initialdir} -constraints {
+ unix notAqua
+} -body {
+ catch {unset ::tk::dialog::file::__tk_choosedir}
+ ToPressButton $parent ok
+ tk_chooseDirectory \
+ -title "Press OK" \
+ -parent $parent -initialdir ""
+} -result [pwd]
+
+
+test choosedir-5.1 {tk_chooseDirectory, handles {} entry text} -constraints {
+ unix notAqua
+} -body {
+ ToEnterDirsByKey $parent [list "" $real $real]
+ tk_chooseDirectory -title "Clear entry, Press OK; Enter $real, press OK" \
+ -parent $parent
+} -result $real
+
+# cleanup
+removeDirectory choosedirTest
+cleanupTests
+return
diff --git a/tk8.6/tests/clipboard.test b/tk8.6/tests/clipboard.test
new file mode 100644
index 0000000..6077940
--- /dev/null
+++ b/tk8.6/tests/clipboard.test
@@ -0,0 +1,361 @@
+# This file is a Tcl script to test out Tk's clipboard management code,
+# especially the "clipboard" command. It is organized in the standard
+# fashion for Tcl tests.
+#
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+#
+# Note: Multiple display clipboard handling will only be tested if the
+# environment variable TK_ALT_DISPLAY is set to an alternate display.
+#
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# set up a very large buffer to test INCR retrievals
+set longValue ""
+foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} {
+ set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14
+ append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j
+}
+
+# Now we start the main body of the test code
+
+test clipboard-1.1 {ClipboardHandler procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append "test"
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -result {test}
+test clipboard-1.2 {ClipboardHandler procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append "test"
+ clipboard append "ing"
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -result {testing}
+test clipboard-1.3 {ClipboardHandler procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append "t"
+ clipboard append "e"
+ clipboard append "s"
+ clipboard append "t"
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -result {test}
+test clipboard-1.4 {ClipboardHandler procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append $longValue
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -result "$longValue"
+test clipboard-1.5 {ClipboardHandler procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append $longValue
+ clipboard append "test"
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -result "${longValue}test"
+test clipboard-1.6 {ClipboardHandler procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -t TEST $longValue
+ clipboard append -t STRING "test"
+ list [clipboard get -t STRING] [clipboard get -t TEST]
+} -cleanup {
+ clipboard clear
+} -result [list test $longValue]
+test clipboard-1.7 {ClipboardHandler procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -t TEST [string range $longValue 1 4000]
+ clipboard append -t STRING "test"
+ list [clipboard get -t STRING] [clipboard get -t TEST]
+} -cleanup {
+ clipboard clear
+} -result [list test [string range $longValue 1 4000]]
+test clipboard-1.8 {ClipboardHandler procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append ""
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -result {}
+test clipboard-1.9 {ClipboardHandler procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append ""
+ clipboard append "Test"
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -result {Test}
+
+##############################################################################
+
+test clipboard-2.1 {ClipboardAppHandler procedure} -setup {
+ set oldAppName [tk appname]
+ clipboard clear
+} -body {
+ tk appname UnexpectedName
+ clipboard append -type NEW_TYPE Data
+ selection get -selection CLIPBOARD -type TK_APPLICATION
+} -cleanup {
+ tk appname $oldAppName
+ clipboard clear
+} -result {UnexpectedName}
+
+##############################################################################
+
+test clipboard-3.1 {ClipboardWindowHandler procedure} -setup {
+ set oldAppName [tk appname]
+ clipboard clear
+} -body {
+ tk appname UnexpectedName
+ clipboard append -type NEW_TYPE Data
+ selection get -selection CLIPBOARD -type TK_WINDOW
+} -cleanup {
+ tk appname $oldAppName
+ clipboard clear
+} -result {.}
+
+##############################################################################
+
+test clipboard-4.1 {ClipboardLostSel procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append "Test"
+ selection clear -s CLIPBOARD
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined}
+test clipboard-4.2 {ClipboardLostSel procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append "Test"
+ clipboard append -t TEST "Test2"
+ selection clear -s CLIPBOARD
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined}
+test clipboard-4.3 {ClipboardLostSel procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append "Test"
+ clipboard append -t TEST "Test2"
+ selection clear -s CLIPBOARD
+ catch {clipboard get}
+ clipboard get -t TEST
+} -cleanup {
+ clipboard clear
+} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "TEST" not defined}
+test clipboard-4.4 {ClipboardLostSel procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append "Test"
+ clipboard append -t TEST "Test2"
+ clipboard append "Test3"
+ selection clear -s CLIPBOARD
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined}
+test clipboard-4.5 {ClipboardLostSel procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append "Test"
+ clipboard append -t TEST "Test2"
+ clipboard append "Test3"
+ selection clear -s CLIPBOARD
+ catch {clipboard get}
+ clipboard get -t TEST
+} -cleanup {
+ clipboard clear
+} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "TEST" not defined}
+
+
+
+##############################################################################
+
+test clipboard-5.1 {Tk_ClipboardClear procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -t TEST "test"
+ set result [lsort [clipboard get TARGETS]]
+ clipboard clear
+ list $result [lsort [clipboard get TARGETS]]
+} -cleanup {
+ clipboard clear
+} -result {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test clipboard-5.2 {Tk_ClipboardClear procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -t TEST "test"
+ set result [lsort [clipboard get TARGETS]]
+ selection own -s CLIPBOARD .
+ lappend result [lsort [clipboard get TARGETS]]
+ clipboard clear
+ clipboard append -t TEST "test"
+ lappend result [lsort [clipboard get TARGETS]]
+} -cleanup {
+ clipboard clear
+} -result {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
+
+##############################################################################
+
+test clipboard-6.1 {Tk_ClipboardAppend procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append "first chunk"
+ selection own -s CLIPBOARD .
+ clipboard append " second chunk"
+ clipboard get
+} -cleanup {
+ clipboard clear
+} -returnCodes ok -result {first chunk second chunk}
+test clipboard-6.2 {Tk_ClipboardAppend procedure} -constraints unix -setup {
+ clipboard clear
+} -body {
+ setupbg
+ clipboard append -f INTEGER -t TEST "16"
+ set result [dobg {clipboard get TEST}]
+ return $result
+} -cleanup {
+ clipboard clear
+ cleanupbg
+} -result {0x10 }
+test clipboard-6.3 {Tk_ClipboardAppend procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -f INTEGER -t TEST "16"
+ clipboard append -t TEST "test"
+} -cleanup {
+ clipboard clear
+} -returnCodes error -result {format "STRING" does not match current format "INTEGER" for TEST}
+
+##############################################################################
+
+test clipboard-7.1 {Tk_ClipboardCmd procedure} -body {
+ clipboard
+} -returnCodes error -result {wrong # args: should be "clipboard option ?arg ...?"}
+test clipboard-7.2 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append --
+} -cleanup {
+ clipboard clear
+} -returnCodes ok -result {}
+test clipboard-7.3 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append --
+ selection get -selection CLIPBOARD
+} -cleanup {
+ clipboard clear
+} -result {--}
+test clipboard-7.4 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -- information
+ selection get -selection CLIPBOARD
+} -cleanup {
+ clipboard clear
+} -result {information}
+test clipboard-7.5 {Tk_ClipboardCmd procedure} -body {
+ clipboard append --x a b
+} -returnCodes error -result {bad option "--x": must be -displayof, -format, or -type}
+test clipboard-7.6 {Tk_ClipboardCmd procedure} -body {
+ clipboard append -- a b
+} -returnCodes error -result {wrong # args: should be "clipboard append ?-option value ...? data"}
+test clipboard-7.7 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -format
+} -returnCodes ok -result {}
+test clipboard-7.8 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -format
+ selection get -selection CLIPBOARD
+} -cleanup {
+ clipboard clear
+} -result {-format}
+test clipboard-7.9 {Tk_ClipboardCmd procedure} -body {
+ clipboard append -displayofoo f
+} -returnCodes error -result {bad option "-displayofoo": must be -displayof, -format, or -type}
+test clipboard-7.10 {Tk_ClipboardCmd procedure} -body {
+ clipboard append -type TEST
+} -returnCodes error -result {wrong # args: should be "clipboard append ?-option value ...? data"}
+test clipboard-7.11 {Tk_ClipboardCmd procedure} -body {
+ clipboard append -displayof foo "test"
+} -returnCodes error -result {bad window path name "foo"}
+test clipboard-7.12 {Tk_ClipboardCmd procedure} -body {
+ clipboard clear -displayof
+} -returnCodes error -result {wrong # args: should be "clipboard clear ?-displayof window?"}
+test clipboard-7.13 {Tk_ClipboardCmd procedure} -body {
+ clipboard clear -displayofoo f
+} -returnCodes error -result {bad option "-displayofoo": must be -displayof}
+test clipboard-7.14 {Tk_ClipboardCmd procedure} -body {
+ clipboard clear foo
+} -returnCodes error -result {wrong # args: should be "clipboard clear ?-displayof window?"}
+test clipboard-7.15 {Tk_ClipboardCmd procedure} -body {
+ clipboard clear -displayof foo
+} -returnCodes error -result {bad window path name "foo"}
+test clipboard-7.16 {Tk_ClipboardCmd procedure} -body {
+ clipboard error
+} -returnCodes error -result {bad option "error": must be append, clear, or get}
+test clipboard-7.17 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -displayof
+} -cleanup {
+ clipboard clear
+} -returnCodes ok -result {}
+test clipboard-7.18 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -displayof
+ selection get -selection CLIPBOARD
+} -cleanup {
+ clipboard clear
+} -result {-displayof}
+test clipboard-7.19 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -type
+} -cleanup {
+ clipboard clear
+} -returnCodes ok -result {}
+test clipboard-7.20 {Tk_ClipboardCmd procedure} -setup {
+ clipboard clear
+} -body {
+ clipboard append -type
+ selection get -selection CLIPBOARD
+} -cleanup {
+ clipboard clear
+} -result {-type}
+
+# cleanup
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/clrpick.test b/tk8.6/tests/clrpick.test
new file mode 100644
index 0000000..5f1b8b5
--- /dev/null
+++ b/tk8.6/tests/clrpick.test
@@ -0,0 +1,216 @@
+# This file is a Tcl script to test out Tk's "tk_chooseColor" command.
+# It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+if {[testConstraint defaultPseudocolor8]} {
+ # let's soak up a bunch of colors...so that
+ # machines with small color palettes still fail.
+ # some tests will be skipped if there are no more colors
+ set numcolors 32
+ testConstraint colorsLeftover 1
+ set i 0
+ canvas .c
+ pack .c -expand 1 -fill both
+ while {$i<$numcolors} {
+ set color \#[format "%02x%02x%02x" $i [expr $i+1] [expr $i+3]]
+ .c create rectangle [expr 10+$i] [expr 10+$i] [expr 50+$i] [expr 50+$i] -fill $color -outline $color
+ incr i
+ }
+ set i 0
+ while {$i<$numcolors} {
+ set color [.c itemcget $i -fill]
+ if {$color != ""} {
+ foreach {r g b} [winfo rgb . $color] {}
+ set r [expr $r/256]
+ set g [expr $g/256]
+ set b [expr $b/256]
+ if {"$color" != "#[format %02x%02x%02x $r $g $b]"} {
+ testConstraint colorsLeftover 0
+ }
+ }
+ .c delete $i
+ incr i
+ }
+ destroy .c
+} else {
+ testConstraint colorsLeftover 0
+}
+
+test clrpick-1.1 {tk_chooseColor command} -body {
+ tk_chooseColor -foo
+} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title}
+
+test clrpick-1.2 {tk_chooseColor command } -body {
+ tk_chooseColor -initialcolor
+} -returnCodes error -result {value for "-initialcolor" missing}
+test clrpick-1.2.1 {tk_chooseColor command } -body {
+ tk_chooseColor -parent
+} -returnCodes error -result {value for "-parent" missing}
+test clrpick-1.2.2 {tk_chooseColor command } -body {
+ tk_chooseColor -title
+} -returnCodes error -result {value for "-title" missing}
+
+test clrpick-1.3 {tk_chooseColor command} -body {
+ tk_chooseColor -foo bar
+} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title}
+test clrpick-1.4 {tk_chooseColor command} -body {
+ tk_chooseColor -initialcolor
+} -returnCodes error -result {value for "-initialcolor" missing}
+test clrpick-1.5 {tk_chooseColor command} -body {
+ tk_chooseColor -parent foo.bar
+} -returnCodes error -result {bad window path name "foo.bar"}
+test clrpick-1.6 {tk_chooseColor command} -body {
+ tk_chooseColor -initialcolor badbadbaadcolor
+} -returnCodes error -result {unknown color name "badbadbaadcolor"}
+test clrpick-1.7 {tk_chooseColor command} -body {
+ tk_chooseColor -initialcolor ##badbadbaadcolor
+} -returnCodes error -result {invalid color name "##badbadbaadcolor"}
+
+
+# tests 3.1 and 3.2 fail when individually run
+# if there is no catch {tk_chooseColor -foo 1} msg
+# before settin isNative
+catch {tk_chooseColor -foo 1} msg
+set isNative [expr {[info commands tk::dialog::color::] eq ""}]
+
+proc ToPressButton {parent btn} {
+ global isNative
+ if {!$isNative} {
+ after 200 "SendButtonPress . $btn mouse"
+ }
+}
+
+proc ToChooseColorByKey {parent r g b} {
+ global isNative
+ if {!$isNative} {
+ after 200 ChooseColorByKey . $r $g $b
+ }
+}
+
+proc PressButton {btn} {
+ event generate $btn <Enter>
+ event generate $btn <1> -x 5 -y 5
+ event generate $btn <ButtonRelease-1> -x 5 -y 5
+}
+
+proc ChooseColorByKey {parent r g b} {
+ set w .__tk__color
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ update
+ $data(red,entry) delete 0 end
+ $data(green,entry) delete 0 end
+ $data(blue,entry) delete 0 end
+
+ $data(red,entry) insert 0 $r
+ $data(green,entry) insert 0 $g
+ $data(blue,entry) insert 0 $b
+
+ # Manually force the refresh of the color values instead
+ # of counting on the timing of the event stream to change
+ # the values for us.
+ tk::dialog::color::HandleRGBEntry $w
+
+ SendButtonPress . ok mouse
+}
+
+proc SendButtonPress {parent btn type} {
+ set w .__tk__color
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ set button $data($btn\Btn)
+ if ![winfo ismapped $button] {
+ update
+ }
+
+ if {$type == "mouse"} {
+ PressButton $button
+ } else {
+ event generate $w <Enter>
+ focus $w
+ event generate $button <Enter>
+ event generate $w <KeyPress> -keysym Return
+ }
+}
+
+
+
+test clrpick-2.1 {tk_chooseColor command} -constraints {
+ nonUnixUserInteraction colorsLeftover
+} -setup {
+ set verylongstring longstring:
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ #set verylongstring $verylongstring$verylongstring
+ # Interesting thing...when this is too long, the
+ # delay caused in processing it kills the automated testing,
+ # and makes a lot of the test cases fail.
+ #set verylongstring $verylongstring$verylongstring
+ #set verylongstring $verylongstring$verylongstring
+ #set verylongstring $verylongstring$verylongstring
+ #set verylongstring $verylongstring$verylongstring
+} -body {
+ ToPressButton . ok
+ tk_chooseColor -title "Press Ok $verylongstring" -initialcolor #404040 \
+ -parent .
+} -result {#404040}
+test clrpick-2.2 {tk_chooseColor command} -constraints {
+ nonUnixUserInteraction colorsLeftover
+} -body {
+ set colors "128 128 64"
+ ToChooseColorByKey . 128 128 64
+ tk_chooseColor -parent . -title "choose #808040"
+} -result {#808040}
+test clrpick-2.3 {tk_chooseColor command} -constraints {
+ nonUnixUserInteraction colorsLeftover
+} -body {
+ ToPressButton . ok
+ tk_chooseColor -parent . -title "Press OK"
+} -result {#808040}
+test clrpick-2.4 {tk_chooseColor command} -constraints {
+ nonUnixUserInteraction colorsLeftover
+} -body {
+ ToPressButton . cancel
+ tk_chooseColor -parent . -title "Press Cancel"
+} -result {}
+
+
+test clrpick-3.1 {tk_chooseColor: background events} -constraints {
+ nonUnixUserInteraction
+} -body {
+ after 1 {set x 53}
+ ToPressButton . ok
+ tk_chooseColor -parent . -title "Press OK" -initialcolor #000000
+} -result {#000000}
+test clrpick-3.2 {tk_chooseColor: background events} -constraints {
+ nonUnixUserInteraction
+} -body {
+ after 1 {set x 53}
+ ToPressButton . cancel
+ tk_chooseColor -parent . -title "Press Cancel"
+} -result {}
+
+
+test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} -constraints {
+ unix notAqua
+} -body {
+ after 50 {set ::scr [winfo screen .__tk__color]}
+ ToPressButton . cancel
+ tk_chooseColor -parent .
+ set ::scr
+} -result [winfo screen .]
+
+# cleanup
+cleanupTests
+return
+
diff --git a/tk8.6/tests/cmap.tcl b/tk8.6/tests/cmap.tcl
new file mode 100644
index 0000000..cca4c24
--- /dev/null
+++ b/tk8.6/tests/cmap.tcl
@@ -0,0 +1,72 @@
+# This file creates a visual test for colormaps and the WM_COLORMAP_WINDOWS
+# property. It is part of the Tk visual test suite, which is invoked
+# via the "visual" script.
+
+catch {destroy .t}
+toplevel .t -colormap new
+wm title .t "Visual Test for Colormaps"
+wm iconname .t "Colormaps"
+wm geom .t +0+0
+
+# The following procedure creates a whole bunch of frames within a
+# window, in order to eat up all the colors in a colormap.
+
+proc colors {w redInc greenInc blueInc} {
+ set red 0
+ set green 0
+ set blue 0
+ for {set y 0} {$y < 8} {incr y} {
+ for {set x 0} {$x < 8} {incr x} {
+ frame $w.f$x,$y -width 40 -height 40 -bd 2 -relief raised \
+ -bg [format #%02x%02x%02x $red $green $blue]
+ place $w.f$x,$y -x [expr 40*$x] -y [expr 40*$y]
+ incr red $redInc
+ incr green $greenInc
+ incr blue $blueInc
+ }
+ }
+}
+
+message .t.m -width 6i -text {This window displays two nested frames, each with a whole bunch of subwindows that eat up a lot of colors. The toplevel window has its own colormap, which is inherited by the outer frame. The inner frame has its own colormap. As you move the mouse around, the colors in the frames should change back and forth.}
+pack .t.m -side top -fill x
+
+button .t.quit -text Quit -command {destroy .t}
+pack .t.quit -side bottom -pady 3 -ipadx 4 -ipady 2
+
+frame .t.f -width 700 -height 450 -relief raised -bd 2
+pack .t.f -side top -padx 1c -pady 1c
+colors .t.f 4 0 0
+frame .t.f.f -width 350 -height 350 -colormap new -bd 2 -relief raised
+place .t.f.f -relx 1.0 -rely 0 -anchor ne
+colors .t.f.f 0 4 0
+bind .t.f.f <Enter> {wm colormapwindows .t {.t.f.f .t}}
+bind .t.f.f <Leave> {wm colormapwindows .t {.t .t.f.f}}
+
+catch {destroy .t2}
+toplevel .t2
+wm title .t2 "Visual Test for Colormaps"
+wm iconname .t2 "Colormaps"
+wm geom .t2 +0-0
+
+message .t2.m -width 6i -text {This window just eats up most of the colors in the default colormap.}
+pack .t2.m -side top -fill x
+
+button .t2.quit -text Quit -command {destroy .t2}
+pack .t2.quit -side bottom -pady 3 -ipadx 4 -ipady 2
+
+frame .t2.f -height 320 -width 320
+pack .t2.f -side bottom
+colors .t2.f 0 0 4
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tk8.6/tests/cmds.test b/tk8.6/tests/cmds.test
new file mode 100644
index 0000000..fa7e788
--- /dev/null
+++ b/tk8.6/tests/cmds.test
@@ -0,0 +1,60 @@
+# This file is a Tcl script to test the procedures in the file
+# tkCmds.c. It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+update
+
+test cmds-1.1 {tkwait visibility, argument errors} -body {
+ tkwait visibility
+} -returnCodes {error} -result {wrong # args: should be "tkwait variable|visibility|window name"}
+test cmds-1.2 {tkwait visibility, argument errors} -body {
+ tkwait visibility foo bar
+} -returnCodes {error} -result {wrong # args: should be "tkwait variable|visibility|window name"}
+test cmds-1.3 {tkwait visibility, argument errors} -body {
+ tkwait visibility bad_window
+} -returnCodes {error} -result {bad window path name "bad_window"}
+test cmds-1.4 {tkwait visibility, waiting for window to be mapped} -setup {
+ button .b -text "Test"
+ set x init
+} -body {
+ after 100 {set x delay; place .b -x 0 -y 0}
+ tkwait visibility .b
+ return $x
+} -cleanup {
+ destroy .b
+} -result {delay}
+test cmds-1.5 {tkwait visibility, window gets deleted} -setup {
+ frame .f
+ button .f.b -text "Test"
+ pack .f.b
+ set x init
+} -body {
+ after 100 {set x deleted; destroy .f}
+ tkwait visibility .f.b
+} -returnCodes {error} -result {window ".f.b" was deleted before its visibility changed}
+test cmds-1.6 {tkwait visibility, window gets deleted} -setup {
+ frame .f
+ button .f.b -text "Test"
+ pack .f.b
+ set x init
+} -body {
+ after 100 {set x deleted; destroy .f}
+ catch {tkwait visibility .f.b}
+ return $x
+} -cleanup {
+ destroy .f
+} -result {deleted}
+
+
+# cleanup
+cleanupTests
+return
+
diff --git a/tk8.6/tests/color.test b/tk8.6/tests/color.test
new file mode 100644
index 0000000..a7ed1f8
--- /dev/null
+++ b/tk8.6/tests/color.test
@@ -0,0 +1,282 @@
+# This file is a Tcl script to test out the procedures in the file
+# tkColor.c. It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1995-1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# cname --
+# Returns a proper name for a color, given its intensities.
+#
+# Arguments:
+# r, g, b - Intensities on a 0-255 scale.
+
+proc cname {r g b} {
+ format #%02x%02x%02x $r $g $b
+}
+proc cname4 {r g b} {
+ format #%04x%04x%04x $r $g $b
+}
+
+# mkColors --
+# Creates a canvas and fills it with a 2-D array of squares, each of a
+# different color.
+#
+# Arguments:
+# c - Name of canvas window to create.
+# width - Number of squares in each row.
+# height - Number of squares in each column.
+# r, g, b - Initial value for red, green, and blue intensities.
+# rx, gx, bx - Change in intensities between adjacent elements in row.
+# ry, gy, by - Change in intensities between adjacent elements in column.
+
+proc mkColors {c width height r g b rx gx bx ry gy by} {
+ catch {destroy $c}
+ canvas $c -width 400 -height 200 -bd 0
+ for {set y 0} {$y < $height} {incr y} {
+ for {set x 0} {$x < $width} {incr x} {
+ set color [format #%02x%02x%02x [expr $r + $y*$ry + $x*$rx] \
+ [expr $g + $y*$gy + $x*$gx] [expr $b + $y*$by + $x*$bx]]
+ $c create rectangle [expr 10*$x] [expr 20*$y] \
+ [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
+ -fill $color
+ }
+ }
+}
+
+# closest -
+# Given intensities between 0 and 255, return the closest intensities
+# that the server can provide.
+#
+# Arguments:
+# w - Window in which to lookup color
+# r, g, b - Desired intensities, between 0 and 255.
+
+proc closest {w r g b} {
+ set vals [winfo rgb $w [cname $r $g $b]]
+ list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \
+ [expr [lindex $vals 2]/256]
+}
+
+# c255 -
+# Given a list of red, green, and blue intensities, scale them
+# down to a 0-255 range.
+#
+# Arguments:
+# vals - List of intensities.
+
+proc c255 {vals} {
+ list [expr {[lindex $vals 0]/256}] [expr {[lindex $vals 1]/256}] \
+ [expr {[lindex $vals 2]/256}]
+}
+
+# colorsFree --
+#
+# Returns 1 if there appear to be free colormap entries in a window,
+# 0 otherwise.
+#
+# Arguments:
+# w - Name of window in which to check.
+# red, green, blue - Intensities to use in a trial color allocation
+# to see if there are colormap entries free.
+
+proc colorsFree {w {red 31} {green 245} {blue 192}} {
+ set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
+ expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
+ && ([lindex $vals 2]/256 == $blue)
+}
+
+if {[testConstraint psuedocolor8]} {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ wm geom .t +0+0
+ mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40
+ pack .t.c
+ update
+
+ testConstraint colorsFree [colorsFree .t.c 101 233 17]
+
+ if {[testConstraint colorsFree]} {
+ mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
+ pack .t.c2
+ testConstraint colorsFree [expr {![colorsFree .t.c]}]
+ }
+ destroy .t.c .t.c2
+}
+
+test color-1.1 {Tk_AllocColorFromObj - converting internal reps} colorsFree {
+ set x green
+ lindex $x 0
+ destroy .b1
+ button .b1 -foreground $x -text .b1
+ lindex $x 0
+ testcolor green
+} {{1 0}}
+test color-1.2 {Tk_AllocColorFromObj - discard stale color} colorsFree {
+ set x green
+ destroy .b1 .b2
+ button .b1 -foreground $x -text First
+ destroy .b1
+ set result {}
+ lappend result [testcolor green]
+ button .b2 -foreground $x -text Second
+ lappend result [testcolor green]
+} {{} {{1 1}}}
+test color-1.3 {Tk_AllocColorFromObj - reuse existing color} colorsFree {
+ set x green
+ destroy .b1 .b2
+ button .b1 -foreground $x -text First
+ set result {}
+ lappend result [testcolor green]
+ button .b2 -foreground $x -text Second
+ pack .b1 .b2 -side top
+ lappend result [testcolor green]
+} {{{1 1}} {{2 1}}}
+test color-1.4 {Tk_AllocColorFromObj - try other colors in list} colorsFree {
+ set x purple
+ destroy .b1 .b2 .t.b
+ button .b1 -foreground $x -text First
+ pack .b1 -side top
+ set result {}
+ lappend result [testcolor purple]
+ button .t.b -foreground $x -text Second
+ pack .t.b -side top
+ lappend result [testcolor purple]
+ button .b2 -foreground $x -text Third
+ pack .b2 -side top
+ lappend result [testcolor purple]
+} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
+test color-1.5 {Color table} nonPortable {
+ set fd [open ../xlib/rgb.txt]
+ set result {}
+ while {[gets $fd line] != -1} {
+ if {[string index $line 0] == "!"} continue
+ set rgb [c255 [winfo rgb . [lrange $line 3 end]]]
+ if {$rgb != [lrange $line 0 2] } {
+ append result $line\n
+ }
+
+ }
+ return $result
+} {}
+
+test color-2.1 {Tk_GetColor procedure} colorsFree {
+ c255 [winfo rgb .t #FF0000]
+} {255 0 0}
+test color-2.2 {Tk_GetColor procedure} colorsFree {
+ list [catch {winfo rgb .t noname} msg] $msg
+} {1 {unknown color name "noname"}}
+test color-2.3 {Tk_GetColor procedure} colorsFree {
+ c255 [winfo rgb .t #123456]
+} {18 52 86}
+test color-2.4 {Tk_GetColor procedure} colorsFree {
+ list [catch {winfo rgb .t #xyz} msg] $msg
+} {1 {invalid color name "#xyz"}}
+test color-2.5 {Tk_GetColor procedure} colorsFree {
+ winfo rgb .t #00FF00
+} {0 65535 0}
+test color-2.6 {Tk_GetColor procedure} {colorsFree nonPortable} {
+ # Red doesn't always map to *pure* red
+ winfo rgb .t red
+} {65535 0 0}
+test color-2.7 {Tk_GetColor procedure} colorsFree {
+ winfo rgb .t #ff0000
+} {65535 0 0}
+
+test color-3.1 {Tk_FreeColor procedure, reference counting} colorsFree {
+ eval destroy [winfo child .t]
+ mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40
+ pack .t.c
+ mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
+ pack .t.c2
+ update
+ set last [.t.c2 create rectangle 50 50 70 60 -outline {} \
+ -fill [cname 0 240 240]]
+ .t.c delete 1
+ set result [colorsFree .t]
+ .t.c2 delete $last
+ lappend result [colorsFree .t]
+} {0 1}
+test color-3.2 {Tk_FreeColor procedure, flushing stressed cmap information} colorsFree {
+ eval destroy [winfo child .t]
+ mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40
+ pack .t.c
+ mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
+ mkColors .t.c2 20 1 250 250 0 -10 -10 0 0 0 0
+ pack .t.c2
+ update
+ closest .t 241 241 1
+} {240 240 0}
+test color-3.3 {Tk_FreeColorFromObj - reference counts} colorsFree {
+ set x purple
+ destroy .b1 .b2 .t.b
+ button .b1 -foreground $x -text First
+ pack .b1 -side top
+ button .t.b -foreground $x -text Second
+ pack .t.b -side top
+ button .b2 -foreground $x -text Third
+ pack .b2 -side top
+ set result {}
+ lappend result [testcolor purple]
+ destroy .b1
+ lappend result [testcolor purple]
+ destroy .b2
+ lappend result [testcolor purple]
+ destroy .t.b
+ lappend result [testcolor purple]
+} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
+test color-3.4 {Tk_FreeColorFromObj - unlinking from list} colorsFree {
+ destroy .b .t.b .t2 .t3
+ toplevel .t2 -visual {pseudocolor 8} -colormap new
+ toplevel .t3 -visual {pseudocolor 8} -colormap new
+ set x purple
+ button .b -foreground $x -text .b1
+ button .t.b1 -foreground $x -text .t.b1
+ button .t.b2 -foreground $x -text .t.b2
+ button .t2.b1 -foreground $x -text .t2.b1
+ button .t2.b2 -foreground $x -text .t2.b2
+ button .t2.b3 -foreground $x -text .t2.b3
+ button .t3.b1 -foreground $x -text .t3.b1
+ button .t3.b2 -foreground $x -text .t3.b2
+ button .t3.b3 -foreground $x -text .t3.b3
+ button .t3.b4 -foreground $x -text .t3.b4
+ set result {}
+ lappend result [testcolor purple]
+ destroy .t2
+ lappend result [testcolor purple]
+ destroy .b
+ lappend result [testcolor purple]
+ destroy .t3
+ lappend result [testcolor purple]
+ destroy .t
+ lappend result [testcolor purple]
+} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
+
+test color-4.1 {FreeColorObjProc} colorsFree {
+ destroy .b
+ set x [format purple]
+ button .b -foreground $x -text .b1
+ set y [format purple]
+ .b configure -foreground $y
+ set z [format purple]
+ .b configure -foreground $z
+ set result {}
+ lappend result [testcolor purple]
+ set x red
+ lappend result [testcolor purple]
+ set z 32
+ lappend result [testcolor purple]
+ destroy .b
+ lappend result [testcolor purple]
+ set y bogus
+ set result
+} {{{1 3}} {{1 2}} {{1 1}} {}}
+
+destroy .t
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/config.test b/tk8.6/tests/config.test
new file mode 100644
index 0000000..a0c1921
--- /dev/null
+++ b/tk8.6/tests/config.test
@@ -0,0 +1,1929 @@
+# This file is a Tcl script to test the procedures in tkConfig.c,
+# which comprise the new new option configuration system. It is
+# organized in the standard "white-box" fashion for Tcl tests.
+#
+# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+proc killTables {} {
+ # Note: it's important to delete chain2 before chain1, because
+ # chain2 depends on chain1. If chain1 is deleted first, the
+ # delete of chain2 will crash.
+ deleteWindows
+ foreach t {alltypes chain3 chain2 chain1 configerror internal
+ new notenoughparams twowindows} {
+ while {[testobjconfig info $t] != ""} {
+ testobjconfig delete $t
+ }
+ }
+}
+
+
+option clear
+deleteWindows
+if {[testConstraint testobjconfig]} {
+ killTables
+}
+
+test config-1.1 {Tk_CreateOptionTable - reference counts} -constraints {
+ testobjconfig
+} -body {
+ set x {}
+ testobjconfig alltypes .a
+ lappend x [testobjconfig info alltypes]
+ testobjconfig alltypes .b
+ lappend x [testobjconfig info alltypes]
+ set x
+} -cleanup {
+ killTables
+} -result {{1 16 -boolean} {2 16 -boolean}}
+test config-1.2 {Tk_CreateOptionTable - synonym initialization} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .a -synonym green
+ .a cget -color
+} -cleanup {
+ killTables
+} -result {green}
+test config-1.3 {Tk_CreateOptionTable - option database initialization} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .a
+ option add *b.string different
+ testobjconfig alltypes .b
+ list [.a cget -string] [.b cget -string]
+} -cleanup {
+ killTables
+ option clear
+} -result {foo different}
+test config-1.4 {Tk_CreateOptionTable - option database initialization} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .a
+ option add *b.String bar
+ testobjconfig alltypes .b
+ list [.a cget -string] [.b cget -string]
+} -cleanup {
+ killTables
+ option clear
+} -result {foo bar}
+test config-1.5 {Tk_CreateOptionTable - default initialization} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .a
+ .a cget -relief
+} -cleanup {
+ killTables
+} -result {raised}
+test config-1.6 {Tk_CreateOptionTable - chained tables} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain1 .a
+ testobjconfig chain2 .b
+ testobjconfig info chain2
+} -cleanup {
+ killTables
+} -result {1 4 -three 2 2 -one}
+test config-1.7 {Tk_CreateOptionTable - chained tables} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain2 .b
+ testobjconfig chain1 .a
+ testobjconfig info chain2
+} -cleanup {
+ killTables
+} -result {1 4 -three 2 2 -one}
+test config-1.8 {Tk_CreateOptionTable - chained tables} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain1 .a
+ testobjconfig chain2 .b
+ .a cget -four
+} -cleanup {
+ killTables
+} -returnCodes error -result {unknown option "-four"}
+test config-1.9 {Tk_CreateOptionTable - chained tables} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain1 .a
+ testobjconfig chain2 .b
+ catch {.a cget -four}
+ list [.a cget -one] [.b cget -four] [.b cget -one]
+} -cleanup {
+ killTables
+} -result {one four one}
+
+
+test config-2.1 {Tk_DeleteOptionTable - reference counts} -constraints {
+ testobjconfig
+} -body {
+ set x {}
+ testobjconfig chain1 .a
+ testobjconfig chain2 .b
+ testobjconfig chain3 .c
+ deleteWindows
+ testobjconfig delete chain3
+ lappend x [testobjconfig info chain2] [testobjconfig info chain1]
+ testobjconfig delete chain2
+ lappend x [testobjconfig info chain2] [testobjconfig info chain1]
+} -cleanup {
+ killTables
+} -result {{3 4 -three 2 2 -one} {2 2 -one} {} {2 2 -one}}
+
+# No tests for DestroyOptionHashTable; couldn't figure out how to test.
+
+test config-3.1 {Tk_InitOptions - priority of chained tables} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain1 .a
+ testobjconfig chain2 .b
+ list [.a cget -two] [.b cget -two]
+} -cleanup {
+ killTables
+} -result {two {two and a half}}
+test config-3.2 {Tk_InitOptions - initialize from database} -constraints {
+ testobjconfig
+} -body {
+ option add *a.color blue
+ testobjconfig alltypes .a
+ list [.a cget -color]
+} -cleanup {
+ killTables
+ option clear
+} -result {blue}
+test config-3.3 {Tk_InitOptions - initialize from database} -constraints {
+ testobjconfig
+} -body {
+ option add *a.justify bogus
+ testobjconfig alltypes .a
+ list [.a cget -justify]
+} -cleanup {
+ killTables
+ option clear
+} -result {left}
+test config-3.4 {Tk_InitOptions - initialize from widget class} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .a
+ list [.a cget -color]
+} -cleanup {
+ killTables
+} -result {red}
+test config-3.5 {Tk_InitOptions - no initial value} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .a
+ .a cget -anchor
+} -cleanup {
+ killTables
+} -result {}
+test config-3.6 {Tk_InitOptions - bad initial value} -constraints {
+ testobjconfig
+} -body {
+ option add *a.color non-existent
+ testobjconfig alltypes .a
+} -cleanup {
+ killTables
+ option clear
+} -returnCodes error -result {unknown color name "non-existent"}
+test config-3.7 {Tk_InitOptions - bad initial value} -constraints {
+ testobjconfig
+} -body {
+ option add *a.color non-existent
+ catch {testobjconfig alltypes .a}
+ return $errorInfo
+} -cleanup {
+ killTables
+ option clear
+} -result {unknown color name "non-existent"
+ (database entry for "-color" in widget ".a")
+ invoked from within
+"testobjconfig alltypes .a"}
+
+test config-3.8 {Tk_InitOptions - bad initial value} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig configerror
+} -returnCodes error -result {expected integer but got "bogus"}
+test config-3.9 {Tk_InitOptions - bad initial value} -constraints {
+ testobjconfig
+} -body {
+ catch {testobjconfig configerror}
+ return $errorInfo
+} -result {expected integer but got "bogus"
+ (default value for "-int")
+ invoked from within
+"testobjconfig configerror"}
+
+test config-4.1 {DoObjConfig - boolean} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -boolean 0
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.2 {DoObjConfig - boolean} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -boolean 0
+ .foo cget -boolean
+} -cleanup {
+ killTables
+} -returnCodes ok -result {0}
+test config-4.3 {DoObjConfig - boolean} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -boolean 0
+ .foo cget -boolean
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.4 {DoObjConfig - boolean} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -boolean 1
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.5 {DoObjConfig - boolean} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -boolean 1
+ .foo cget -boolean
+} -cleanup {
+ killTables
+} -returnCodes ok -result {1}
+test config-4.6 {DoObjConfig - boolean} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -boolean 1
+ .foo cget -boolean
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.7 {DoObjConfig - invalid boolean} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -boolean {}
+} -cleanup {
+ killTables
+} -returnCodes error -result {expected boolean value but got ""}
+test config-4.8 {DoObjConfig - boolean internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -boolean 0
+ .foo cget -boolean
+} -cleanup {
+ killTables
+} -result {0}
+
+test config-4.9 {DoObjConfig - integer} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -integer 3
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.10 {DoObjConfig - integer} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -integer 3
+ .foo cget -integer
+} -cleanup {
+ killTables
+} -returnCodes ok -result {3}
+test config-4.11 {DoObjConfig - integer} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -integer 3
+ .foo cget -integer
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.12 {DoObjConfig - invalid integer} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -integer bar
+} -cleanup {
+ killTables
+} -cleanup {
+ killTables
+} -returnCodes error -result {expected integer but got "bar"}
+test config-4.13 {DoObjConfig - integer internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -integer 421
+ .foo cget -integer
+} -cleanup {
+ killTables
+} -result {421}
+
+test config-4.14 {DoObjConfig - double} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -double 3.14
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.15 {DoObjConfig - double} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -double 3.14
+ .foo cget -double
+} -cleanup {
+ killTables
+} -returnCodes ok -result {3.14}
+test config-4.16 {DoObjConfig - double} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -double 3.14
+ .foo cget -double
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.17 {DoObjConfig - invalid double} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -double bar
+} -cleanup {
+ killTables
+} -returnCodes error -result {expected floating-point number but got "bar"}
+test config-4.18 {DoObjConfig - double internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -double 62.75
+ .foo cget -double
+} -cleanup {
+ killTables
+} -result {62.75}
+
+test config-4.19 {DoObjConfig - string} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -string test
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.20 {DoObjConfig - string} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -string test
+ .foo cget -string
+} -cleanup {
+ killTables
+} -returnCodes ok -result {test}
+test config-4.21 {DoObjConfig - string} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -string test
+ .foo cget -string
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.22 {DoObjConfig - null string} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -string {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.23 {DoObjConfig - null string} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -string {}
+ .foo cget -string
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.24 {DoObjConfig - null string} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -string {}
+ .foo cget -string
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+
+test config-4.25 {DoObjConfig - string internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -string "this is a test"
+ .foo cget -string
+} -cleanup {
+ killTables
+} -result {this is a test}
+
+test config-4.26 {DoObjConfig - string table} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -stringtable two
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.27 {DoObjConfig - string table} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -stringtable two
+ .foo cget -stringtable
+} -cleanup {
+ killTables
+} -returnCodes ok -result {two}
+test config-4.28 {DoObjConfig - string table} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -stringtable two
+ .foo cget -stringtable
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.29 {DoObjConfig - invalid string table} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -stringtable foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad stringtable "foo": must be one, two, three, or four}
+
+test config-4.30 {DoObjConfig - new string table} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -stringtable two
+ .foo configure -stringtable three
+} -cleanup {
+ killTables
+} -returnCodes ok -result {16}
+test config-4.31 {DoObjConfig - new string table} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -stringtable two
+ .foo configure -stringtable three
+ .foo cget -stringtable
+} -cleanup {
+ killTables
+} -returnCodes ok -result {three}
+test config-4.32 {DoObjConfig - new string table} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -stringtable two
+ .foo configure -stringtable three
+ .foo cget -stringtable
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.33 {DoObjConfig - stringtable internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -stringtable "four"
+ .foo cget -stringtable
+} -cleanup {
+ killTables
+} -result {four}
+
+test config-4.34 {DoObjConfig - color} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -color blue
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.35 {DoObjConfig - color} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -color blue
+ .foo cget -color
+} -cleanup {
+ killTables
+} -returnCodes ok -result {blue}
+test config-4.36 {DoObjConfig - color} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -color blue
+ .foo cget -color
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.37 {DoObjConfig - invalid color} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -color xxx
+} -cleanup {
+ killTables
+} -returnCodes error -result {unknown color name "xxx"}
+test config-4.38 {DoObjConfig - color internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -color purple
+ .foo cget -color
+} -cleanup {
+ killTables
+} -result {purple}
+
+test config-4.39 {DoObjConfig - null color} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -color {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.40 {DoObjConfig - null color} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -color {}
+ .foo cget -color
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.41 {DoObjConfig - null color} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -color {}
+ .foo cget -color
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.42 {DoObjConfig - getting rid of old color} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -color #333333
+ .foo configure -color #444444
+} -cleanup {
+ killTables
+} -returnCodes ok -result {32}
+test config-4.43 {DoObjConfig - getting rid of old color} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -color #333333
+ .foo configure -color #444444
+ .foo cget -color
+} -cleanup {
+ killTables
+} -returnCodes ok -result {#444444}
+test config-4.44 {DoObjConfig - getting rid of old color} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -color #333333
+ .foo configure -color #444444
+ .foo cget -color
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+
+test config-4.45 {DoObjConfig - font} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -font {Helvetica 72}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.46 {DoObjConfig - font} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -font {Helvetica 72}
+ .foo cget -font
+} -cleanup {
+ killTables
+} -returnCodes ok -result {Helvetica 72}
+test config-4.47 {DoObjConfig - new font} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -font {Courier 12}
+ .foo configure -font {Helvetica 72}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {64}
+test config-4.48 {DoObjConfig - new font} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -font {Courier 12}
+ .foo configure -font {Helvetica 72}
+ .foo cget -font
+} -cleanup {
+ killTables
+} -returnCodes ok -result {Helvetica 72}
+test config-4.49 {DoObjConfig - invalid font} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -font {Helvetica 12 foo}
+} -cleanup {
+ killTables
+} -returnCodes error -result {unknown font style "foo"}
+test config-4.50 {DoObjConfig - null font} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -font {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.51 {DoObjConfig - null font} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -font {}
+ .foo cget -font
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.52 {DoObjConfig - font internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -font {Times 16}
+ .foo cget -font
+} -cleanup {
+ killTables
+} -result {Times 16}
+
+test config-4.53 {DoObjConfig - bitmap} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -bitmap gray75
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.54 {DoObjConfig - bitmap} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -bitmap gray75
+ .foo cget -bitmap
+} -cleanup {
+ killTables
+} -returnCodes ok -result {gray75}
+test config-4.55 {DoObjConfig - new bitmap} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -bitmap gray75
+ .foo configure -bitmap gray50
+} -cleanup {
+ killTables
+} -returnCodes ok -result {128}
+test config-4.56 {DoObjConfig - new bitmap} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -bitmap gray75
+ .foo configure -bitmap gray50
+ .foo cget -bitmap
+} -cleanup {
+ killTables
+} -returnCodes ok -result {gray50}
+test config-4.57 {DoObjConfig - invalid bitmap} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -bitmap foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bitmap "foo" not defined}
+test config-4.58 {DoObjConfig - null bitmap} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -bitmap {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.59 {DoObjConfig - null bitmap} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -bitmap {}
+ .foo cget -bitmap
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.60 {DoObjConfig - bitmap internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -bitmap gray25
+ .foo cget -bitmap
+} -cleanup {
+ killTables
+} -result {gray25}
+
+test config-4.61 {DoObjConfig - border} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -border green
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.62 {DoObjConfig - border} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -border green
+ .foo cget -border
+} -cleanup {
+ killTables
+} -returnCodes ok -result {green}
+test config-4.63 {DoObjConfig - invalid border} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -border xxx
+} -cleanup {
+ killTables
+} -returnCodes error -result {unknown color name "xxx"}
+test config-4.64 {DoObjConfig - null border} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -border {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.65 {DoObjConfig - null border} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -border {}
+ .foo cget -border
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.66 {DoObjConfig - border internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -border #123456
+ .foo cget -border
+} -cleanup {
+ killTables
+} -result {#123456}
+test config-4.67 {DoObjConfig - getting rid of old border} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -border #333333
+ .foo configure -border #444444
+} -cleanup {
+ killTables
+} -returnCodes ok -result {256}
+test config-4.68 {DoObjConfig - getting rid of old border} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -border #333333
+ .foo configure -border #444444
+ .foo cget -border
+} -cleanup {
+ killTables
+} -returnCodes ok -result {#444444}
+
+test config-4.69 {DoObjConfig - relief} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -relief flat
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.70 {DoObjConfig - relief} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -relief flat
+ .foo cget -relief
+} -cleanup {
+ killTables
+} -returnCodes ok -result {flat}
+test config-4.71 {DoObjConfig - invalid relief} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -relief foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken}
+test config-4.72 {DoObjConfig - relief internal value} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -relief ridge
+ .foo cget -relief
+} -cleanup {
+ killTables
+} -result {ridge}
+test config-4.73 {DoObjConfig - new relief} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -relief raised
+ .foo configure -relief flat
+} -cleanup {
+ killTables
+} -returnCodes ok -result {512}
+test config-4.74 {DoObjConfig - new relief} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -relief raised
+ .foo configure -relief flat
+ .foo cget -relief
+} -cleanup {
+ killTables
+} -returnCodes ok -result {flat}
+
+test config-4.75 {DoObjConfig - cursor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -cursor arrow
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.76 {DoObjConfig - cursor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -cursor arrow
+ .foo cget -cursor
+} -cleanup {
+ killTables
+} -returnCodes ok -result {arrow}
+test config-4.77 {DoObjConfig - invalid cursor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -cursor foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad cursor spec "foo"}
+test config-4.78 {DoObjConfig - null cursor} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -cursor {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.79 {DoObjConfig - null cursor} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -cursor {}
+ .foo cget -cursor
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.80 {DoObjConfig - new cursor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -cursor xterm
+ .foo configure -cursor arrow
+} -cleanup {
+ killTables
+} -returnCodes ok -result {1024}
+test config-4.81 {DoObjConfig - new cursor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -cursor xterm
+ .foo configure -cursor arrow
+ .foo cget -cursor
+} -cleanup {
+ killTables
+} -returnCodes ok -result {arrow}
+test config-4.82 {DoObjConfig - cursor internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -cursor watch
+ .foo cget -cursor
+} -cleanup {
+ killTables
+} -result {watch}
+
+test config-4.83 {DoObjConfig - justify} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -justify center
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.84 {DoObjConfig - justify} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -justify center
+ .foo cget -justify
+} -cleanup {
+ killTables
+} -returnCodes ok -result {center}
+test config-4.85 {DoObjConfig - invalid justify} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -justify foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad justification "foo": must be left, right, or center}
+test config-4.86 {DoObjConfig - new justify} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -justify left
+ .foo configure -justify right
+} -cleanup {
+ killTables
+} -returnCodes ok -result {2048}
+test config-4.87 {DoObjConfig - new justify} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -justify left
+ .foo configure -justify right
+ .foo cget -justify
+} -cleanup {
+ killTables
+} -returnCodes ok -result {right}
+test config-4.88 {DoObjConfig - justify internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -justify center
+ .foo cget -justify
+} -cleanup {
+ killTables
+} -result {center}
+
+test config-4.89 {DoObjConfig - anchor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -anchor center
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.90 {DoObjConfig - anchor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -anchor center
+ .foo cget -anchor
+} -cleanup {
+ killTables
+} -returnCodes ok -result {center}
+test config-4.91 {DoObjConfig - invalid anchor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -anchor foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center}
+test config-4.92 {DoObjConfig - new anchor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -anchor e
+ .foo configure -anchor n
+} -cleanup {
+ killTables
+} -returnCodes ok -result {4096}
+test config-4.93 {DoObjConfig - new anchor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -anchor e
+ .foo configure -anchor n
+ .foo cget -anchor
+} -cleanup {
+ killTables
+} -returnCodes ok -result {n}
+test config-4.94 {DoObjConfig - anchor internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -anchor sw
+ .foo cget -anchor
+} -cleanup {
+ killTables
+} -result {sw}
+test config-4.95 {DoObjConfig - pixel} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -pixel 42
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.96 {DoObjConfig - pixel} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -pixel 42
+ .foo cget -pixel
+} -cleanup {
+ killTables
+} -returnCodes ok -result {42}
+test config-4.97 {DoObjConfig - invalid pixel} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -pixel foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad screen distance "foo"}
+test config-4.98 {DoObjConfig - new pixel} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -pixel 42m
+ .foo configure -pixel 3c
+} -cleanup {
+ killTables
+} -returnCodes ok -result {8192}
+test config-4.99 {DoObjConfig - new pixel} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -pixel 42m
+ .foo configure -pixel 3c
+ .foo cget -pixel
+} -cleanup {
+ killTables
+} -returnCodes ok -result {3c}
+test config-4.100 {DoObjConfig - pixel internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -pixel [winfo screenmmwidth .]m
+ set screenW [winfo screenwidth .]
+ set result [.foo cget -pixel]
+ expr {$screenW eq $result}
+} -cleanup {
+ killTables
+} -result {1}
+
+test config-4.101 {DoObjConfig - window} -constraints testobjconfig -body {
+ toplevel .bar
+ testobjconfig twowindows .foo -window .bar
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.102 {DoObjConfig - window} -constraints testobjconfig -body {
+ toplevel .bar
+ testobjconfig twowindows .foo -window .bar
+ .foo cget -window
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.bar}
+test config-4.103 {DoObjConfig - invalid window} -constraints testobjconfig -body {
+ toplevel .bar
+ testobjconfig twowindows .foo -window foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad window path name "foo"}
+test config-4.104 {DoObjConfig - null window} -constraints testobjconfig -body {
+ toplevel .bar
+ testobjconfig twowindows .foo -window {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.105 {DoObjConfig - null window} -constraints testobjconfig -body {
+ toplevel .bar
+ testobjconfig twowindows .foo -window {}
+ .foo cget -window
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.106 {DoObjConfig - new window} -constraints testobjconfig -body {
+ toplevel .bar
+ toplevel .blamph
+ testobjconfig twowindows .foo -window .bar
+ .foo configure -window .blamph
+} -cleanup {
+ killTables
+} -returnCodes ok -result {0}
+test config-4.107 {DoObjConfig - new window} -constraints testobjconfig -body {
+ toplevel .bar
+ toplevel .blamph
+ testobjconfig twowindows .foo -window .bar
+ .foo configure -window .blamph
+ .foo cget -window
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.blamph}
+test config-4.108 {DoObjConfig - window internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -window .
+ .foo cget -window
+} -cleanup {
+ killTables
+} -result {.}
+
+test config-4.109 {DoObjConfig - releasing old values} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ # This test doesn't generate a useful value to check; if an
+ # error occurs, it will be detected only by memory checking software
+ # such as Purify or Tcl's built-in checker.
+
+ testobjconfig alltypes .foo -string {Test string} -color yellow \
+ -font {Courier 18} -bitmap questhead -border green -cursor cross \
+ -custom foobar
+ .foo configure -string {new string} -color brown \
+ -font {Times 8} -bitmap gray75 -border pink -cursor watch \
+ -custom barbaz
+ concat {}
+} -cleanup {
+ killTables
+} -result {}
+test config-4.110 {DoObjConfig - releasing old values} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ # This test doesn't generate a useful value to check; if an
+ # error occurs, it will be detected only by memory checking software
+ # such as Purify or Tcl's built-in checker.
+
+ testobjconfig internal .foo -string {Test string} -color yellow \
+ -font {Courier 18} -bitmap questhead -border green -cursor cross \
+ -custom foobar
+ .foo configure -string {new string} -color brown \
+ -font {Times 8} -bitmap gray75 -border pink -cursor watch \
+ -custom barbaz
+ concat {}
+} -cleanup {
+ killTables
+} -result {}
+
+test config-4.111 {DoObjConfig - custom} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -custom test
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.112 {DoObjConfig - custom} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -custom test
+ .foo cget -custom
+} -cleanup {
+ killTables
+} -returnCodes ok -result {TEST}
+test config-4.113 {DoObjConfig - null custom} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -custom {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.114 {DoObjConfig - null custom} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -custom {}
+ .foo cget -custom
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.115 {DoObjConfig - custom internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig internal .foo -custom "this is a test"
+ .foo cget -custom
+} -cleanup {
+ killTables
+} -result {THIS IS A TEST}
+
+
+test config-5.1 {ObjectIsEmpty - object is already string} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -color [format ""]
+ .foo cget -color
+} -cleanup {
+ killTables
+} -result {}
+test config-5.2 {ObjectIsEmpty - object is already string} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -color [format " "]
+} -cleanup {
+ killTables
+} -returnCodes error -result {unknown color name " "}
+test config-5.3 {ObjectIsEmpty - must convert back to string} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -color [list]
+ .foo cget -color
+} -cleanup {
+ killTables
+} -result {}
+
+
+test config-6.1 {GetOptionFromObj - cached answer} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain2 .a
+ list [.a cget -three] [.a cget -three]
+} -cleanup {
+ killTables
+} -result {three three}
+test config-6.2 {GetOptionFromObj - exact match} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain2 .a
+ .a cget -one
+} -cleanup {
+ killTables
+} -result {one}
+test config-6.3 {GetOptionFromObj - abbreviation} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain2 .a
+ .a cget -fo
+} -cleanup {
+ killTables
+} -result {four}
+test config-6.4 {GetOptionFromObj - ambiguous abbreviation} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain2 .a
+ .a cget -on
+} -cleanup {
+ killTables
+} -cleanup {
+ killTables
+} -returnCodes error -result {unknown option "-on"}
+test config-6.5 {GetOptionFromObj - duplicate options in different tables} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain2 .a
+ .a cget -tw
+} -cleanup {
+ killTables
+} -result {two and a half}
+test config-6.6 {GetOptionFromObj - synonym} -constraints testobjconfig -body {
+ testobjconfig alltypes .b
+ .b cget -synonym
+} -cleanup {
+ killTables
+} -result {red}
+
+
+if {[testConstraint testobjconfig]} {
+ testobjconfig alltypes .a
+}
+test config-7.1 {Tk_SetOptions - basics} -constraints testobjconfig -body {
+ .a configure -color green -rel sunken
+ list [.a cget -color] [.a cget -relief]
+} -result {green sunken}
+test config-7.2 {Tk_SetOptions - bogus option name} -constraints {
+ testobjconfig
+} -body {
+ .a configure -bogus
+} -returnCodes error -result {unknown option "-bogus"}
+test config-7.3 {Tk_SetOptions - synonym} -constraints testobjconfig -body {
+ .a configure -synonym blue
+ .a cget -color
+} -result {blue}
+test config-7.4 {Tk_SetOptions - missing value} -constraints {
+ testobjconfig
+} -body {
+ .a configure -color green -relief
+} -returnCodes error -result {value for "-relief" missing}
+test config-7.5 {Tk_SetOptions - missing value} -constraints {
+ testobjconfig
+} -body {
+ catch {.a configure -color green -relief}
+ .a cget -color
+} -result {green}
+test config-7.6 {Tk_SetOptions - saving old values} -constraints {
+ testobjconfig
+} -body {
+ .a configure -color red -int 7 -relief raised -double 3.14159
+ .a csave -color green -int 432 -relief sunken -double 2.0 -color bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test config-7.7 {Tk_SetOptions - saving old values} -constraints {
+ testobjconfig
+} -body {
+ .a configure -color red -int 7 -relief raised -double 3.14159
+ catch {.a csave -color green -int 432 -relief sunken -double 2.0 -color bogus}
+ list [.a cget -color] [.a cget -int] [.a cget -relief] [.a cget -double]
+} -result {red 7 raised 3.14159}
+
+test config-7.8 {Tk_SetOptions - error in DoObjConfig call} -constraints {
+ testobjconfig
+} -body {
+ .a configure -color bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test config-7.9 {Tk_SetOptions - error in DoObjConfig call} -constraints {
+ testobjconfig
+} -body {
+ catch {.a configure -color bogus}
+ return $errorInfo
+} -result {unknown color name "bogus"
+ (processing "-color" option)
+ invoked from within
+".a configure -color bogus"}
+
+test config-7.10 {Tk_SetOptions - synonym name in error message} -constraints {
+ testobjconfig
+} -body {
+ .a configure -synonym bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test config-7.11 {Tk_SetOptions - synonym name in error message} -constraints {
+ testobjconfig
+} -body {
+ catch {.a configure -synonym bogus}
+ return $errorInfo
+} -result {unknown color name "bogus"
+ (processing "-synonym" option)
+ invoked from within
+".a configure -synonym bogus"}
+test config-7.12 {Tk_SetOptions - returning mask} -constraints testobjconfig -body {
+ format %x [.a configure -color red -int 7 -relief raised -double 3.14159]
+} -result {226}
+test config-7.13 {Tk_SetOptions - error in DoObjConfig with custom option} -constraints {
+ testobjconfig
+} -body {
+ .a configure -custom bad
+} -returnCodes error -result {expected good value, got "BAD"}
+test config-7.14 {Tk_SetOptions - error in DoObjConfig with custom option} -constraints {
+ testobjconfig
+} -body {
+ catch {.a configure -custom bad}
+ return $errorInfo
+} -result {expected good value, got "BAD"
+ (processing "-custom" option)
+ invoked from within
+".a configure -custom bad"}
+if {[testConstraint testobjconfig]} {
+ killTables
+}
+
+
+test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .a
+ .a csave -color green -color black -color blue \
+ -color #ffff00 -color #ff00ff -color bogus \
+} -cleanup {
+ killTables
+} -returnCodes error -result {unknown color name "bogus"}
+test config-8.2 {Tk_RestoreSavedOptions - restore in proper order} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .a
+ catch {.a csave -color green -color black -color blue \
+ -color #ffff00 -color #ff00ff -color bogus}
+ .a cget -color
+} -cleanup {
+ killTables
+} -result {red}
+test config-8.3 {Tk_RestoreSavedOptions - freeing object memory} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .a
+ .a csave -color green -color black -color blue -color #ffff00 -color #ff00ff
+} -cleanup {
+ killTables
+} -result {32}
+test config-8.4 {Tk_RestoreSavedOptions - boolean internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ .a csave -boolean 0 -color bogus
+} -cleanup {
+ killTables
+} -returnCodes error -match glob -result *
+test config-8.5 {Tk_RestoreSavedOptions - boolean internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -boolean 0 -color bogus}
+ .a cget -boolean
+} -cleanup {
+ killTables
+} -result {1}
+test config-8.6 {Tk_RestoreSavedOptions - integer internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ .a csave -integer 24 -color bogus
+} -cleanup {
+ killTables
+} -returnCodes error -match glob -result *
+test config-8.7 {Tk_RestoreSavedOptions - integer internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -integer 24 -color bogus}
+ .a cget -integer
+} -cleanup {
+ killTables
+} -result {148962237}
+test config-8.8 {Tk_RestoreSavedOptions - double internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -double 62.4 -color bogus}
+ .a cget -double
+} -cleanup {
+ killTables
+} -result {3.14159}
+test config-8.9 {Tk_RestoreSavedOptions - string internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -string "A long string" -color bogus}
+ .a cget -string
+} -cleanup {
+ killTables
+} -result {foo}
+test config-8.10 {Tk_RestoreSavedOptions - string table internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -stringtable three -color bogus}
+ .a cget -stringtable
+} -cleanup {
+ killTables
+} -result {one}
+test config-8.11 {Tk_RestoreSavedOptions - color internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -color green -color bogus}
+ .a cget -color
+} -cleanup {
+ killTables
+} -result {red}
+test config-8.12 {Tk_RestoreSavedOptions - font internal form} -constraints {
+ testobjconfig nonPortable
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -font {Times 12} -color bogus}
+ .a cget -font
+} -cleanup {
+ killTables
+} -result {Helvetica 12}
+test config-8.13 {Tk_RestoreSavedOptions - bitmap internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -bitmap questhead -color bogus}
+ .a cget -bitmap
+} -cleanup {
+ killTables
+} -result {gray50}
+test config-8.14 {Tk_RestoreSavedOptions - border internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -border brown -color bogus}
+ .a cget -border
+} -cleanup {
+ killTables
+} -result {blue}
+test config-8.15 {Tk_RestoreSavedOptions - relief internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -relief sunken -color bogus}
+ .a cget -relief
+} -cleanup {
+ killTables
+} -result {raised}
+test config-8.16 {Tk_RestoreSavedOptions - cursor internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -cursor watch -color bogus}
+ .a cget -cursor
+} -cleanup {
+ killTables
+} -result {xterm}
+test config-8.17 {Tk_RestoreSavedOptions - justify internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -justify right -color bogus}
+ .a cget -justify
+} -cleanup {
+ killTables
+} -result {left}
+test config-8.18 {Tk_RestoreSavedOptions - anchor internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -anchor center -color bogus}
+ .a cget -anchor
+} -cleanup {
+ killTables
+} -result {n}
+test config-8.19 {Tk_RestoreSavedOptions - window internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a -window .a
+ catch {.a csave -window .a -color bogus}
+ .a cget -window
+} -cleanup {
+ killTables
+} -result {.a}
+test config-8.20 {Tk_RestoreSavedOptions - custom internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a -custom "foobar"
+ catch {.a csave -custom "barbaz" -color bogus}
+ .a cget -custom
+} -cleanup {
+ killTables
+} -result {FOOBAR}
+
+# Most of the tests below will cause memory leakage if there is a
+# problem. This may not be evident unless the tests are run in
+# conjunction with a memory usage analyzer such as Purify.
+
+test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .foo
+ .foo configure -string "two words"
+ destroy .foo
+} -result {}
+test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .foo
+ .foo configure -color yellow
+ destroy .foo
+} -result {}
+test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo
+ .foo configure -color [format blue]
+ destroy .foo
+} -result {}
+test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .foo
+ .foo configure -font {Courier 20}
+ destroy .foo
+} -result {}
+test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo
+ .foo configure -font [format {Courier 24}]
+ destroy .foo
+} -result {}
+test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .foo
+ .foo configure -bitmap gray75
+ destroy .foo
+} -result {}
+test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo
+ .foo configure -bitmap [format gray75]
+ destroy .foo
+} -result {}
+test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .foo
+ .foo configure -border orange
+ destroy .foo
+} -result {}
+test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo
+ .foo configure -border [format blue]
+ destroy .foo
+} -result {}
+test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .foo
+ .foo configure -cursor cross
+ destroy .foo
+} -result {}
+test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo
+ .foo configure -cursor [format watch]
+ destroy .foo
+} -result {}
+test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo
+ .foo configure -integer [format 27]
+ destroy .foo
+} -result {}
+test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} -constraints {
+ testobjconfig
+} -body {
+ catch {destroy .fpp}
+ testobjconfig internal .foo
+ .foo configure -custom "foobar"
+ destroy .foo
+} -result {}
+if {[testConstraint testobjconfig]} {
+ killTables
+}
+
+
+test config-10.1 {Tk_GetOptionInfo - one item} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo
+ .foo configure -relief groove
+ .foo configure -relief
+} -cleanup {
+ destroy .foo
+} -result {-relief relief Relief raised groove}
+test config-10.2 {Tk_GetOptionInfo - one item, synonym} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo
+ .foo configure -color black
+ .foo configure -synonym
+} -cleanup {
+ destroy .foo
+} -result {-color color Color red black}
+test config-10.3 {Tk_GetOptionInfo - all items} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -font {Helvetica 18} -integer 13563
+ .foo configure
+} -cleanup {
+ destroy .foo
+} -result {{-boolean boolean Boolean 1 1} {-integer integer Integer 7 13563} {-double double Double 3.14159 3.14159} {-string string String foo foo} {-stringtable StringTable stringTable one one} {-color color Color red red} {-font font Font {Helvetica 12} {Helvetica 18}} {-bitmap bitmap Bitmap gray50 gray50} {-border border Border blue blue} {-relief relief Relief raised raised} {-cursor cursor Cursor xterm xterm} {-justify {} {} left left} {-anchor anchor Anchor {} {}} {-pixel pixel Pixel 1 1} {-custom {} {} {} {}} {-synonym -color}}
+test config-10.4 {Tk_GetOptionInfo - chaining through tables} -constraints testobjconfig -body {
+ testobjconfig chain2 .foo -one asdf -three xyzzy
+ .foo configure
+} -cleanup {
+ destroy .foo
+} -result {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}}
+if {[testConstraint testobjconfig]} {
+ killTables
+}
+
+
+if {[testConstraint testobjconfig]} {
+ testobjconfig alltypes .a
+}
+test config-11.1 {GetConfigList - synonym} -constraints testobjconfig -body {
+ lindex [.a configure] end
+} -result {-synonym -color}
+test config-11.2 {GetConfigList - null database names} -constraints {
+ testobjconfig
+} -body {
+ .a configure -justify
+} -result {-justify {} {} left left}
+test config-11.3 {GetConfigList - null default and current value} -constraints {
+ testobjconfig
+} -body {
+ .a configure -anchor
+} -result {-anchor anchor Anchor {} {}}
+if {[testConstraint testobjconfig]} {
+ killTables
+}
+
+
+if {[testConstraint testobjconfig]} {
+ testobjconfig internal .a
+}
+test config-12.1 {GetObjectForOption - boolean} -constraints testobjconfig -body {
+ .a configure -boolean 0
+ .a cget -boolean
+} -result {0}
+test config-12.2 {GetObjectForOption - integer} -constraints testobjconfig -body {
+ .a configure -integer 1247
+ .a cget -integer
+} -result {1247}
+test config-12.3 {GetObjectForOption - double} -constraints testobjconfig -body {
+ .a configure -double -88.82
+ .a cget -double
+} -result {-88.82}
+test config-12.4 {GetObjectForOption - string} -constraints testobjconfig -body {
+ .a configure -string "test value"
+ .a cget -string
+} -result {test value}
+test config-12.5 {GetObjectForOption - stringTable} -constraints {
+ testobjconfig
+} -body {
+ .a configure -stringtable "two"
+ .a cget -stringtable
+} -result {two}
+test config-12.6 {GetObjectForOption - color} -constraints testobjconfig -body {
+ .a configure -color "green"
+ .a cget -color
+} -result {green}
+test config-12.7 {GetObjectForOption - font} -constraints testobjconfig -body {
+ .a configure -font {Times 36}
+ .a cget -font
+} -result {Times 36}
+test config-12.8 {GetObjectForOption - bitmap} -constraints testobjconfig -body {
+ .a configure -bitmap "questhead"
+ .a cget -bitmap
+} -result {questhead}
+test config-12.9 {GetObjectForOption - border} -constraints testobjconfig -body {
+ .a configure -border #33217c
+ .a cget -border
+} -result {#33217c}
+test config-12.10 {GetObjectForOption - relief} -constraints {
+ testobjconfig
+} -body {
+ .a configure -relief groove
+ .a cget -relief
+} -result {groove}
+test config-12.11 {GetObjectForOption - cursor} -constraints {
+ testobjconfig
+} -body {
+ .a configure -cursor watch
+ .a cget -cursor
+} -result {watch}
+test config-12.12 {GetObjectForOption - justify} -constraints {
+ testobjconfig
+} -body {
+ .a configure -justify right
+ .a cget -justify
+} -result {right}
+test config-12.13 {GetObjectForOption - anchor} -constraints testobjconfig -body {
+ .a configure -anchor e
+ .a cget -anchor
+} -result {e}
+test config-12.14 {GetObjectForOption - pixels} -constraints testobjconfig -body {
+ .a configure -pixel 193.2
+ .a cget -pixel
+} -result {193}
+test config-12.15 {GetObjectForOption - window} -constraints testobjconfig -body {
+ .a configure -window .a
+ .a cget -window
+} -result {.a}
+test config-12.16 {GetObjectForOption -custom} -constraints testobjconfig -body {
+ .a configure -custom foobar
+ .a cget -custom
+} -result {FOOBAR}
+test config-12.17 {GetObjectForOption - null values} -constraints {
+ testobjconfig
+} -body {
+ .a configure -string {} -color {} -font {} -bitmap {} -border {} \
+ -cursor {} -window {} -custom {}
+ list [.a cget -string] [.a cget -color] [.a cget -font] \
+ [.a cget -bitmap] [.a cget -border] [.a cget -cursor] \
+ [.a cget -window] [.a cget -custom]
+} -result {{} {} {} {} {} {} {} {}}
+if {[testConstraint testobjconfig]} {
+ killTables
+}
+
+
+test config-13.1 {proper cleanup of options with widget destroy} -body {
+ button .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.2 {proper cleanup of options with widget destroy} -body {
+ canvas .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.3 {proper cleanup of options with widget destroy} -body {
+ entry .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.4 {proper cleanup of options with widget destroy} -body {
+ frame .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.5 {proper cleanup of options with widget destroy} -body {
+ listbox .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.6 {proper cleanup of options with widget destroy} -body {
+ menu .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.7 {proper cleanup of options with widget destroy} -body {
+ menubutton .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.8 {proper cleanup of options with widget destroy} -body {
+ message .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.9 {proper cleanup of options with widget destroy} -body {
+ scale .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.10 {proper cleanup of options with widget destroy} -body {
+ scrollbar .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.11 {proper cleanup of options with widget destroy} -body {
+ text .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.12 {proper cleanup of options with widget destroy} -body {
+ radiobutton .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.13 {proper cleanup of options with widget destroy} -body {
+ checkbutton .w -cursor crosshair
+ destroy .w
+} -result {}
+
+test config-14.1 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::button
+ ::foo::button .a
+ ::foo::button .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.2 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::canvas
+ ::foo::canvas .a
+ ::foo::canvas .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.3 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::entry
+ ::foo::entry .a
+ ::foo::entry .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.4 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::frame
+ ::foo::frame .a
+ ::foo::frame .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.5 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::listbox
+ ::foo::listbox .a
+ ::foo::listbox .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.6 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::menu
+ ::foo::menu .a
+ ::foo::menu .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.7 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::menubutton
+ ::foo::menubutton .a
+ ::foo::menubutton .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.8 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::message
+ ::foo::message .a
+ ::foo::message .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.9 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::scale
+ ::foo::scale .a
+ ::foo::scale .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.10 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::scrollbar
+ ::foo::scrollbar .a
+ ::foo::scrollbar .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.11 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::spinbox
+ ::foo::spinbox .a
+ ::foo::spinbox .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.12 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::text
+ ::foo::text .a
+ ::foo::text .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.13 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::radiobutton
+ ::foo::radiobutton .a
+ ::foo::radiobutton .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.14 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::checkbutton
+ ::foo::checkbutton .a
+ ::foo::checkbutton .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+
+
+# cleanup
+deleteWindows
+if {[testConstraint testobjconfig]} {
+ killTables
+}
+cleanupTests
+return
+
+
+
+
+
+
+
+
diff --git a/tk8.6/tests/constraints.tcl b/tk8.6/tests/constraints.tcl
new file mode 100644
index 0000000..e0486ff
--- /dev/null
+++ b/tk8.6/tests/constraints.tcl
@@ -0,0 +1,282 @@
+if {[namespace exists tk::test]} {
+ deleteWindows
+ wm geometry . {}
+ raise .
+ return
+}
+
+package require Tk 8.4
+tk appname tktest
+wm title . tktest
+# If the main window isn't already mapped (e.g. because the tests are
+# being run automatically) , specify a precise size for it so that the
+# user won't have to position it manually.
+
+if {![winfo ismapped .]} {
+ wm geometry . +0+0
+ update
+}
+
+package require tcltest 2.1
+
+namespace eval tk {
+ namespace eval test {
+
+ namespace export loadTkCommand
+ proc loadTkCommand {} {
+ set tklib {}
+ foreach pair [info loaded {}] {
+ foreach {lib pfx} $pair break
+ if {$pfx eq "Tk"} {
+ set tklib $lib
+ break
+ }
+ }
+ return [list load $tklib Tk]
+ }
+
+ namespace eval bg {
+ # Manage a background process.
+ # Replace with slave interp or thread?
+ namespace import ::tcltest::interpreter
+ namespace import ::tk::test::loadTkCommand
+ namespace export setup cleanup do
+
+ proc cleanup {} {
+ variable fd
+ # catch in case the background process has closed $fd
+ catch {puts $fd exit}
+ catch {close $fd}
+ set fd ""
+ }
+ proc setup args {
+ variable fd
+ if {[info exists fd] && [string length $fd]} {
+ cleanup
+ }
+ set fd [open "|[list [interpreter] \
+ -geometry +0+0 -name tktest] $args" r+]
+ puts $fd "puts foo; flush stdout"
+ flush $fd
+ if {[gets $fd data] < 0} {
+ error "unexpected EOF from \"[interpreter]\""
+ }
+ if {$data ne "foo"} {
+ error "unexpected output from\
+ background process: \"$data\""
+ }
+ puts $fd [loadTkCommand]
+ flush $fd
+ fileevent $fd readable [namespace code Ready]
+ }
+ proc Ready {} {
+ variable fd
+ variable Data
+ variable Done
+ set x [gets $fd]
+ if {[eof $fd]} {
+ fileevent $fd readable {}
+ set Done 1
+ } elseif {$x eq "**DONE**"} {
+ set Done 1
+ } else {
+ append Data $x
+ }
+ }
+ proc do {cmd {block 0}} {
+ variable fd
+ variable Data
+ variable Done
+ if {$block} {
+ fileevent $fd readable {}
+ }
+ puts $fd "[list catch $cmd msg]; update; puts \$msg;\
+ puts **DONE**; flush stdout"
+ flush $fd
+ set Data {}
+ if {$block} {
+ while {![eof $fd]} {
+ set line [gets $fd]
+ if {$line eq "**DONE**"} {
+ break
+ }
+ append Data $line
+ }
+ } else {
+ set Done 0
+ vwait [namespace which -variable Done]
+ }
+ return $Data
+ }
+ }
+
+ proc Export {internal as external} {
+ uplevel 1 [list namespace import $internal]
+ uplevel 1 [list rename [namespace tail $internal] $external]
+ uplevel 1 [list namespace export $external]
+ }
+ Export bg::setup as setupbg
+ Export bg::cleanup as cleanupbg
+ Export bg::do as dobg
+
+ namespace export deleteWindows
+ proc deleteWindows {} {
+ eval destroy [winfo children .]
+ }
+
+ namespace export fixfocus
+ proc fixfocus {} {
+ catch {destroy .focus}
+ toplevel .focus
+ wm geometry .focus +0+0
+ entry .focus.e
+ .focus.e insert 0 "fixfocus"
+ pack .focus.e
+ update
+ focus -force .focus.e
+ destroy .focus
+ }
+
+
+ namespace export imageInit imageFinish imageCleanup imageNames
+ variable ImageNames
+ proc imageInit {} {
+ variable ImageNames
+ if {![info exists ImageNames]} {
+ set ImageNames [lsort [image names]]
+ }
+ imageCleanup
+ if {[lsort [image names]] ne $ImageNames} {
+ return -code error "IMAGE NAMES mismatch: [image names] != $ImageNames"
+ }
+ }
+ proc imageFinish {} {
+ variable ImageNames
+ if {[lsort [image names]] ne $ImageNames} {
+ return -code error "images remaining: [image names] != $ImageNames"
+ }
+ imageCleanup
+ }
+ proc imageCleanup {} {
+ variable ImageNames
+ foreach img [image names] {
+ if {$img ni $ImageNames} {image delete $img}
+ }
+ }
+ proc imageNames {} {
+ variable ImageNames
+ set r {}
+ foreach img [image names] {
+ if {$img ni $ImageNames} {lappend r $img}
+ }
+ return $r
+ }
+
+ }
+}
+
+namespace import -force tk::test::*
+
+namespace import -force tcltest::testConstraint
+testConstraint notAqua [expr {[tk windowingsystem] ne "aqua"}]
+testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}]
+testConstraint nonwin [expr {[tk windowingsystem] ne "win32"}]
+testConstraint userInteraction 0
+testConstraint nonUnixUserInteraction [expr {
+ [testConstraint userInteraction] ||
+ ([testConstraint unix] && [testConstraint notAqua])
+}]
+testConstraint haveDISPLAY [info exists env(DISPLAY)]
+testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)]
+testConstraint noExceed [expr {
+ ![testConstraint unix] || [catch {font actual "\{xyz"}]
+}]
+
+# constraints for testing facilities defined in the tktest executable...
+testConstraint testImageType [expr {[lsearch [image types] test] >= 0}]
+testConstraint testOldImageType [expr {[lsearch [image types] oldtest] >= 0}]
+testConstraint testbitmap [llength [info commands testbitmap]]
+testConstraint testborder [llength [info commands testborder]]
+testConstraint testcbind [llength [info commands testcbind]]
+testConstraint testclipboard [llength [info commands testclipboard]]
+testConstraint testcolor [llength [info commands testcolor]]
+testConstraint testcursor [llength [info commands testcursor]]
+testConstraint testembed [llength [info commands testembed]]
+testConstraint testfont [llength [info commands testfont]]
+testConstraint testmakeexist [llength [info commands testmakeexist]]
+testConstraint testmenubar [llength [info commands testmenubar]]
+testConstraint testmetrics [llength [info commands testmetrics]]
+testConstraint testobjconfig [llength [info commands testobjconfig]]
+testConstraint testsend [llength [info commands testsend]]
+testConstraint testtext [llength [info commands testtext]]
+testConstraint testwinevent [llength [info commands testwinevent]]
+testConstraint testwrapper [llength [info commands testwrapper]]
+
+# constraint to see what sort of fonts are available
+testConstraint fonts 1
+destroy .e
+entry .e -width 0 -font {Helvetica -12} -bd 1 -highlightthickness 1
+.e insert end a.bcd
+if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
+ testConstraint fonts 0
+}
+destroy .e
+destroy .t
+text .t -width 80 -height 20 -font {Times -14} -bd 1
+pack .t
+.t insert end "This is\na dot."
+update
+set x [list [.t bbox 1.3] [.t bbox 2.5]]
+destroy .t
+if {![string match {{22 3 6 15} {31 18 [34] 15}} $x]} {
+ testConstraint fonts 0
+}
+testConstraint textfonts [expr {
+ [testConstraint fonts] || [tk windowingsystem] eq "win32"
+}]
+
+# constraints for the visuals available..
+testConstraint pseudocolor8 [expr {
+ ([catch {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ }] == 0) && ([winfo depth .t] == 8)
+}]
+destroy .t
+testConstraint haveTruecolor24 [expr {
+ [lsearch -exact [winfo visualsavailable .] {truecolor 24}] >= 0
+}]
+testConstraint haveGrayscale8 [expr {
+ [lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0
+}]
+testConstraint defaultPseudocolor8 [expr {
+ ([winfo visual .] eq "pseudocolor") && ([winfo depth .] == 8)
+}]
+
+# constraint based on whether our display is secure
+setupbg
+set app [dobg {tk appname}]
+testConstraint secureserver 0
+if {[llength [info commands send]]} {
+ testConstraint secureserver 1
+ if {[catch {send $app set a 0} msg] == 1} {
+ if {[string match "X server insecure *" $msg]} {
+ testConstraint secureserver 0
+ }
+ }
+}
+cleanupbg
+
+eval tcltest::configure $argv
+namespace import -force tcltest::test
+namespace import -force tcltest::makeFile
+namespace import -force tcltest::removeFile
+namespace import -force tcltest::makeDirectory
+namespace import -force tcltest::removeDirectory
+namespace import -force tcltest::interpreter
+namespace import -force tcltest::testsDirectory
+namespace import -force tcltest::cleanupTests
+
+deleteWindows
+wm geometry . {}
+raise .
+
diff --git a/tk8.6/tests/cursor.test b/tk8.6/tests/cursor.test
new file mode 100644
index 0000000..ab7949e
--- /dev/null
+++ b/tk8.6/tests/cursor.test
@@ -0,0 +1,843 @@
+# This file is a Tcl script to test out the procedures in the file
+# tkCursor.c. It is organized in the standard white-box fashion for
+# Tcl tests.
+#
+# Copyright (c) 1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+
+# Tests 2.3 and 2.4 need a helper file with a very specific name and
+# controlled format.
+proc setWincur {wincurName} {
+ upvar $wincurName wincur
+ set wincur(data_octal) {
+ 000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001
+ 000 000 026 000 000 000 050 000 000 000 040 000 000 000 100 000
+ 000 000 001 000 001 000 000 000 000 000 000 000 000 000 000 000
+ 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
+ 000 000 377 377 377 000 000 000 000 000 000 000 000 000 000 000
+ 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
+ 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
+ 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
+ 000 000 000 000 000 000 000 000 000 000 160 016 000 000 170 036
+ 000 000 174 076 000 000 076 174 000 000 037 370 000 000 017 360
+ 000 000 007 340 000 000 007 340 000 000 017 360 000 000 037 370
+ 000 000 076 174 000 000 174 076 000 000 170 036 000 000 160 016
+ 000 000 000 000 000 000 377 377 377 377 377 377 377 377 377 377
+ 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
+ 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
+ 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
+ 377 377 377 377 377 377 017 360 377 377 007 340 377 377 003 300
+ 377 377 001 200 377 377 200 001 377 377 300 003 377 377 340 007
+ 377 377 360 017 377 377 360 017 377 377 340 007 377 377 300 003
+ 377 377 200 001 377 377 001 200 377 377 003 300 377 377 007 340
+ 377 377 017 360 377 377
+ }
+ set wincur(data_binary) {}
+ foreach wincur(num) $wincur(data_octal) {
+ append wincur(data_binary) [binary format c [scan $wincur(num) %o]]
+ }
+ set wincur(dir) [makeDirectory {dir with spaces}]
+ set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)]
+}
+
+
+test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} -constraints {
+ testcursor
+} -body {
+ set x watch
+ lindex $x 0
+ button .b -cursor $x
+ lindex $x 0
+ testcursor watch
+} -cleanup {
+ destroy .b
+} -result {{1 0}}
+test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} -constraints {
+ testcursor
+} -body {
+ set x watch
+ set result {}
+ button .b1 -cursor $x
+ destroy .b1
+ lappend result [testcursor watch]
+ button .b2 -cursor $x
+ lappend result [testcursor watch]
+} -cleanup {
+ destroy .b2
+} -result {{} {{1 1}}}
+test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} -constraints {
+ testcursor
+} -body {
+ set x watch
+ set result {}
+ button .b1 -cursor $x
+ lappend result [testcursor watch]
+ button .b2 -cursor $x
+ pack .b1 .b2 -side top
+ lappend result [testcursor watch]
+} -cleanup {
+ destroy .b1 .b2
+} -result {{{1 1}} {{2 1}}}
+
+test cursor-2.1 {Tk_GetCursor procedure} -body {
+ button .b -cursor bad_name
+} -cleanup {
+ destroy .b
+} -returnCodes error -result {bad cursor spec "bad_name"}
+test cursor-2.2 {Tk_GetCursor procedure} -body {
+ button .b -cursor @xyzzy
+} -cleanup {
+ destroy .b
+} -returnCodes error -result {bad cursor spec "@xyzzy"}
+
+test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} -constraints {
+ win
+} -setup {
+ unset -nocomplain wincur
+ set wincur(file) ""
+} -body {
+ setWincur wincur
+ button .b -cursor [list @$wincur(file)]
+} -cleanup {
+ destroy .b
+ removeDirectory $wincur(dir)
+ unset wincur
+} -result {.b}
+test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} -constraints {
+ win
+} -setup {
+ unset -nocomplain wincur
+ set wincur(file) ""
+} -body {
+ setWincur wincur
+ button .b -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}]
+} -cleanup {
+ destroy .b
+ removeDirectory $wincur(dir)
+ unset wincur
+} -result {.b}
+
+test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} -constraints {
+ testcursor
+} -setup {
+ set x heart
+ set result {}
+} -body {
+ button .b1 -cursor $x
+ button .b3 -cursor $x
+ button .b2 -cursor $x
+ lappend result [testcursor heart]
+ destroy .b1
+ lappend result [testcursor heart]
+ destroy .b2
+ lappend result [testcursor heart]
+ destroy .b3
+ lappend result [testcursor heart]
+} -result {{{3 1}} {{2 1}} {{1 1}} {}}
+
+test cursor-4.1 {FreeCursorObjProc} -constraints {
+ testcursor
+} -body {
+ set x [join heart]
+ button .b -cursor $x
+ set y [join heart]
+ .b configure -cursor $y
+ set z [join heart]
+ .b configure -cursor $z
+ set result {}
+ lappend result [testcursor heart]
+ set x red
+ lappend result [testcursor heart]
+ set z 32
+ lappend result [testcursor heart]
+ destroy .b
+ lappend result [testcursor heart]
+ set y bogus
+ set result
+} -cleanup {
+ destroy .b
+} -result {{{1 3}} {{1 2}} {{1 1}} {}}
+
+# -------------------------------------------------------------------------
+test cursor-5.1 {assert consistent cursor configuration command} -setup {
+ button .b
+} -body {
+ .b configure -cursor {watch red black}
+} -cleanup {
+ destroy .b
+} -result {}
+
+# -------------------------------------------------------------------------
+# Check for the standard set of cursors.
+test cursor-6.1 {check cursor-font cursor X_cursor} -setup {
+ button .b -text X_cursor
+} -body {
+ .b configure -cursor X_cursor
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.2 {check cursor-font cursor arrow} -setup {
+ button .b -text arrow
+} -body {
+ .b configure -cursor arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.3 {check cursor-font cursor based_arrow_down} -setup {
+ button .b -text based_arrow_down
+} -body {
+ .b configure -cursor based_arrow_down
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.4 {check cursor-font cursor based_arrow_up} -setup {
+ button .b -text based_arrow_up
+} -body {
+ .b configure -cursor based_arrow_up
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.5 {check cursor-font cursor boat} -setup {
+ button .b -text boat
+} -body {
+ .b configure -cursor boat
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.6 {check cursor-font cursor bogosity} -setup {
+ button .b -text bogosity
+} -body {
+ .b configure -cursor bogosity
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.7 {check cursor-font cursor bottom_left_corner} -setup {
+ button .b -text bottom_left_corner
+} -body {
+ .b configure -cursor bottom_left_corner
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.8 {check cursor-font cursor bottom_right_corner} -setup {
+ button .b -text bottom_right_corner
+} -body {
+ .b configure -cursor bottom_right_corner
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.9 {check cursor-font cursor bottom_side} -setup {
+ button .b -text bottom_side
+} -body {
+ .b configure -cursor bottom_side
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.10 {check cursor-font cursor bottom_tee} -setup {
+ button .b -text bottom_tee
+} -body {
+ .b configure -cursor bottom_tee
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.11 {check cursor-font cursor box_spiral} -setup {
+ button .b -text box_spiral
+} -body {
+ .b configure -cursor box_spiral
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.12 {check cursor-font cursor center_ptr} -setup {
+ button .b -text center_ptr
+} -body {
+ .b configure -cursor center_ptr
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.13 {check cursor-font cursor circle} -setup {
+ button .b -text circle
+} -body {
+ .b configure -cursor circle
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.14 {check cursor-font cursor clock} -setup {
+ button .b -text clock
+} -body {
+ .b configure -cursor clock
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.15 {check cursor-font cursor coffee_mug} -setup {
+ button .b -text coffee_mug
+} -body {
+ .b configure -cursor coffee_mug
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.16 {check cursor-font cursor cross} -setup {
+ button .b -text cross
+} -body {
+ .b configure -cursor cross
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.17 {check cursor-font cursor cross_reverse} -setup {
+ button .b -text cross_reverse
+} -body {
+ .b configure -cursor cross_reverse
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.18 {check cursor-font cursor crosshair} -setup {
+ button .b -text crosshair
+} -body {
+ .b configure -cursor crosshair
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.19 {check cursor-font cursor diamond_cross} -setup {
+ button .b -text diamond_cross
+} -body {
+ .b configure -cursor diamond_cross
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.20 {check cursor-font cursor dot} -setup {
+ button .b -text dot
+} -body {
+ .b configure -cursor dot
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.21 {check cursor-font cursor dotbox} -setup {
+ button .b -text dotbox
+} -body {
+ .b configure -cursor dotbox
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.22 {check cursor-font cursor double_arrow} -setup {
+ button .b -text double_arrow
+} -body {
+ .b configure -cursor double_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.23 {check cursor-font cursor draft_large} -setup {
+ button .b -text draft_large
+} -body {
+ .b configure -cursor draft_large
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.24 {check cursor-font cursor draft_small} -setup {
+ button .b -text draft_small
+} -body {
+ .b configure -cursor draft_small
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.25 {check cursor-font cursor draped_box} -setup {
+ button .b -text draped_box
+} -body {
+ .b configure -cursor draped_box
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.26 {check cursor-font cursor exchange} -setup {
+ button .b -text exchange
+} -body {
+ .b configure -cursor exchange
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.27 {check cursor-font cursor fleur} -setup {
+ button .b -text fleur
+} -body {
+ .b configure -cursor fleur
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.28 {check cursor-font cursor gobbler} -setup {
+ button .b -text gobbler
+} -body {
+ .b configure -cursor gobbler
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.29 {check cursor-font cursor gumby} -setup {
+ button .b -text gumby
+} -body {
+ .b configure -cursor gumby
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.30 {check cursor-font cursor hand1} -setup {
+ button .b -text hand1
+} -body {
+ .b configure -cursor hand1
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.31 {check cursor-font cursor hand2} -setup {
+ button .b -text hand2
+} -body {
+ .b configure -cursor hand2
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.32 {check cursor-font cursor heart} -setup {
+ button .b -text heart
+} -body {
+ .b configure -cursor heart
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.33 {check cursor-font cursor icon} -setup {
+ button .b -text icon
+} -body {
+ .b configure -cursor icon
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.34 {check cursor-font cursor iron_cross} -setup {
+ button .b -text iron_cross
+} -body {
+ .b configure -cursor iron_cross
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.35 {check cursor-font cursor left_ptr} -setup {
+ button .b -text left_ptr
+} -body {
+ .b configure -cursor left_ptr
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.36 {check cursor-font cursor left_side} -setup {
+ button .b -text left_side
+} -body {
+ .b configure -cursor left_side
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.37 {check cursor-font cursor left_tee} -setup {
+ button .b -text left_tee
+} -body {
+ .b configure -cursor left_tee
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.38 {check cursor-font cursor leftbutton} -setup {
+ button .b -text leftbutton
+} -body {
+ .b configure -cursor leftbutton
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.39 {check cursor-font cursor ll_angle} -setup {
+ button .b -text ll_angle
+} -body {
+ .b configure -cursor ll_angle
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.40 {check cursor-font cursor lr_angle} -setup {
+ button .b -text lr_angle
+} -body {
+ .b configure -cursor lr_angle
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.41 {check cursor-font cursor man} -setup {
+ button .b -text man
+} -body {
+ .b configure -cursor man
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.42 {check cursor-font cursor middlebutton} -setup {
+ button .b -text middlebutton
+} -body {
+ .b configure -cursor middlebutton
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.43 {check cursor-font cursor mouse} -setup {
+ button .b -text mouse
+} -body {
+ .b configure -cursor mouse
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.44 {check cursor-font cursor pencil} -setup {
+ button .b -text pencil
+} -body {
+ .b configure -cursor pencil
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.45 {check cursor-font cursor pirate} -setup {
+ button .b -text pirate
+} -body {
+ .b configure -cursor pirate
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.46 {check cursor-font cursor plus} -setup {
+ button .b -text plus
+} -body {
+ .b configure -cursor plus
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.47 {check cursor-font cursor question_arrow} -setup {
+ button .b -text question_arrow
+} -body {
+ .b configure -cursor question_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.48 {check cursor-font cursor right_ptr} -setup {
+ button .b -text right_ptr
+} -body {
+ .b configure -cursor right_ptr
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.49 {check cursor-font cursor right_side} -setup {
+ button .b -text right_side
+} -body {
+ .b configure -cursor right_side
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.50 {check cursor-font cursor right_tee} -setup {
+ button .b -text right_tee
+} -body {
+ .b configure -cursor right_tee
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.51 {check cursor-font cursor rightbutton} -setup {
+ button .b -text rightbutton
+} -body {
+ .b configure -cursor rightbutton
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.52 {check cursor-font cursor rtl_logo} -setup {
+ button .b -text rtl_logo
+} -body {
+ .b configure -cursor rtl_logo
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.53 {check cursor-font cursor sailboat} -setup {
+ button .b -text sailboat
+} -body {
+ .b configure -cursor sailboat
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.54 {check cursor-font cursor sb_down_arrow} -setup {
+ button .b -text sb_down_arrow
+} -body {
+ .b configure -cursor sb_down_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.55 {check cursor-font cursor sb_h_double_arrow} -setup {
+ button .b -text sb_h_double_arrow
+} -body {
+ .b configure -cursor sb_h_double_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.56 {check cursor-font cursor sb_left_arrow} -setup {
+ button .b -text sb_left_arrow
+} -body {
+ .b configure -cursor sb_left_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.57 {check cursor-font cursor sb_right_arrow} -setup {
+ button .b -text sb_right_arrow
+} -body {
+ .b configure -cursor sb_right_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.58 {check cursor-font cursor sb_up_arrow} -setup {
+ button .b -text sb_up_arrow
+} -body {
+ .b configure -cursor sb_up_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.59 {check cursor-font cursor sb_v_double_arrow} -setup {
+ button .b -text sb_v_double_arrow
+} -body {
+ .b configure -cursor sb_v_double_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.60 {check cursor-font cursor shuttle} -setup {
+ button .b -text shuttle
+} -body {
+ .b configure -cursor shuttle
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.61 {check cursor-font cursor sizing} -setup {
+ button .b -text sizing
+} -body {
+ .b configure -cursor sizing
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.62 {check cursor-font cursor spider} -setup {
+ button .b -text spider
+} -body {
+ .b configure -cursor spider
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.63 {check cursor-font cursor spraycan} -setup {
+ button .b -text spraycan
+} -body {
+ .b configure -cursor spraycan
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.64 {check cursor-font cursor star} -setup {
+ button .b -text star
+} -body {
+ .b configure -cursor star
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.65 {check cursor-font cursor target} -setup {
+ button .b -text target
+} -body {
+ .b configure -cursor target
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.66 {check cursor-font cursor tcross} -setup {
+ button .b -text tcross
+} -body {
+ .b configure -cursor tcross
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.67 {check cursor-font cursor top_left_arrow} -setup {
+ button .b -text top_left_arrow
+} -body {
+ .b configure -cursor top_left_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.68 {check cursor-font cursor top_left_corner} -setup {
+ button .b -text top_left_corner
+} -body {
+ .b configure -cursor top_left_corner
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.69 {check cursor-font cursor top_right_corner} -setup {
+ button .b -text top_right_corner
+} -body {
+ .b configure -cursor top_right_corner
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.70 {check cursor-font cursor top_side} -setup {
+ button .b -text top_side
+} -body {
+ .b configure -cursor top_side
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.71 {check cursor-font cursor top_tee} -setup {
+ button .b -text top_tee
+} -body {
+ .b configure -cursor top_tee
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.72 {check cursor-font cursor trek} -setup {
+ button .b -text trek
+} -body {
+ .b configure -cursor trek
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.73 {check cursor-font cursor ul_angle} -setup {
+ button .b -text ul_angle
+} -body {
+ .b configure -cursor ul_angle
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.74 {check cursor-font cursor umbrella} -setup {
+ button .b -text umbrella
+} -body {
+ .b configure -cursor umbrella
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.75 {check cursor-font cursor ur_angle} -setup {
+ button .b -text ur_angle
+} -body {
+ .b configure -cursor ur_angle
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.76 {check cursor-font cursor watch} -setup {
+ button .b -text watch
+} -body {
+ .b configure -cursor watch
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.77 {check cursor-font cursor xterm} -setup {
+ button .b -text xterm
+} -body {
+ .b configure -cursor xterm
+} -cleanup {
+ destroy .b
+} -result {}
+
+# Test cursor named "none", it is not defined in
+# the X cursor table. It is defined in a Tk specific
+# table of named cursors and should be available on
+# all platforms.
+test cursor-6.78 {test cursor named "none"} -setup {
+ button .b -text CButton
+} -body {
+ .b configure -cursor none
+ .b cget -cursor
+} -cleanup {
+ destroy .b
+} -result none
+
+test cursor-6.79 {test cursor named "none"} -setup {
+ button .b -text CButton
+} -body {
+ .b configure -cursor none
+ .b configure -cursor {}
+ .b cget -cursor
+} -cleanup {
+ destroy .b
+} -result {}
+
+test cursor-6.80 {test cursor named "none"} -setup {
+ button .b -text CButton
+} -body {
+ .b configure -cursor none
+ .b configure -cursor {}
+ .b configure -cursor none
+ .b cget -cursor
+} -cleanup {
+ destroy .b
+} -result none
+
+test cursor-6.81 {test cursor named "none"} -setup {
+ button .b -text CButton
+} -body {
+ # Setting fg and bg does nothing for the none cursor
+ # because it displays no fg or bg pixels.
+ set results [list]
+ .b configure -cursor none
+ lappend results [.b cget -cursor]
+ .b configure -cursor {none blue}
+ lappend results [.b cget -cursor]
+ .b configure -cursor {none blue green}
+ lappend results [.b cget -cursor]
+ .b configure -cursor {}
+ lappend results [.b cget -cursor]
+ set results
+} -cleanup {
+ destroy .b
+ unset results
+} -result {none {none blue} {none blue green} {}}
+
+# -------------------------------------------------------------------------
+# Check the Windows specific cursors
+test cursor-7.1 {check Windows cursor no} -constraints win -setup {
+ button .b -text no
+} -body {
+ .b configure -cursor no
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.2 {check Windows cursor starting} -constraints win -setup {
+ button .b -text starting
+} -body {
+ .b configure -cursor starting
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.3 {check Windows cursor size} -constraints win -setup {
+ button .b -text size
+} -body {
+ .b configure -cursor size
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.4 {check Windows cursor size_ne_sw} -constraints win -setup {
+ button .b -text size_ne_sw
+} -body {
+ .b configure -cursor size_ne_sw
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.5 {check Windows cursor size_ns} -constraints win -setup {
+ button .b -text size_ns
+} -body {
+ .b configure -cursor size_ns
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.6 {check Windows cursor size_nw_se} -constraints win -setup {
+ button .b -text size_nw_se
+} -body {
+ .b configure -cursor size_nw_se
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.7 {check Windows cursor size_we} -constraints win -setup {
+ button .b -text size_we
+} -body {
+ .b configure -cursor size_we
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.8 {check Windows cursor uparrow} -constraints win -setup {
+ button .b -text uparrow
+} -body {
+ .b configure -cursor uparrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.9 {check Windows cursor wait} -constraints win -setup {
+ button .b -text wait
+} -body {
+ .b configure -cursor wait
+} -cleanup {
+ destroy .b
+} -result {}
+
+# -------------------------------------------------------------------------
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/dialog.test b/tk8.6/tests/dialog.test
new file mode 100644
index 0000000..78b6620
--- /dev/null
+++ b/tk8.6/tests/dialog.test
@@ -0,0 +1,67 @@
+# This file is a Tcl script to test out Tk's "tk_dialog" command.
+# It is organized in the standard fashion for Tcl tests.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+test dialog-1.1 {tk_dialog command} -body {
+ tk_dialog
+} -match glob -returnCodes error -result {wrong # args: should be "tk_dialog w title text bitmap default *"}
+test dialog-1.2 {tk_dialog command} -body {
+ tk_dialog foo foo foo foo foo
+} -returnCodes error -result {bad window path name "foo"}
+test dialog-1.3 {tk_dialog command} -body {
+ tk_dialog .d foo foo fooBitmap foo
+} -cleanup {
+ destroy .d
+} -returnCodes error -result {bitmap "fooBitmap" not defined}
+
+
+test dialog-2.1 {tk_dialog operation} -setup {
+ proc PressButton {btn} {
+ if {![winfo ismapped $btn]} {
+ update
+ }
+ event generate $btn <Enter>
+ event generate $btn <1> -x 5 -y 5
+ event generate $btn <ButtonRelease-1> -x 5 -y 5
+ }
+} -body {
+ set x [after 5000 [list set tk::Priv(button) "no response"]]
+ after 100 PressButton .d.button0
+ set res [tk_dialog .d foo foo info 0 click]
+ after cancel $x
+ return $res
+} -cleanup {
+ destroy .d
+} -result {0}
+test dialog-2.2 {tk_dialog operation} -setup {
+ proc HitReturn {w} {
+ event generate $w <Enter>
+ focus -force $w
+ event generate $w <KeyPress> -keysym Return
+ }
+} -body {
+ set x [after 5000 [list set tk::Priv(button) "no response"]]
+ after 100 HitReturn .d
+ set res [tk_dialog .d foo foo info 1 click default]
+ after cancel $x
+ return $res
+} -cleanup {
+ destroy .d
+} -result {1}
+test dialog-2.3 {tk_dialog operation} -body {
+ set x [after 5000 [list set tk::Priv(button) "no response"]]
+ after 100 destroy .d
+ set res [tk_dialog .d foo foo info 0 click]
+ after cancel $x
+ return $res
+} -cleanup {
+ destroy .b
+} -result {-1}
+
+cleanupTests
+return
+
diff --git a/tk8.6/tests/earth.gif b/tk8.6/tests/earth.gif
new file mode 100644
index 0000000..2c229eb
--- /dev/null
+++ b/tk8.6/tests/earth.gif
Binary files differ
diff --git a/tk8.6/tests/embed.test b/tk8.6/tests/embed.test
new file mode 100644
index 0000000..1fe73ef
--- /dev/null
+++ b/tk8.6/tests/embed.test
@@ -0,0 +1,88 @@
+# This file is a Tcl script to test out embedded Windows.
+#
+# Copyright (c) 1996-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+
+test embed-1.1 {TkpUseWindow procedure, bad window identifier} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -use xyz
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "xyz"}
+
+test embed-1.2 {CreateFrame procedure, bad window identifier} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -container xyz
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected boolean value but got "xyz"}
+
+test embed-1.3 {CreateFrame procedure, both -use and -container is invalid} -setup {
+ deleteWindows
+} -body {
+ toplevel .container -container 1
+ toplevel .t -use [winfo id .container] -container 1
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {windows cannot have both the -use and the -container option set}
+
+# testing window embedding for win platforms
+test embed-1.4.win {TkpUseWindow procedure, -container must be set} -constraints {
+ win
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .container
+ toplevel .embd -use [winfo id .container]
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {the window to use is not a Tk container}
+# testing window embedding for win platforms
+test embed-1.5.win {TkpUseWindow procedure, -container must be set} -constraints {
+ win
+} -setup {
+ deleteWindows
+} -body {
+ frame .container
+ toplevel .embd -use [winfo id .container]
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {the window to use is not a Tk container}
+
+# testing window embedding for other than win platforms
+test embed-1.4.nonwin {TkpUseWindow procedure, -container must be set} -constraints {
+ nonwin
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .container
+ toplevel .embd -use [winfo id .container]
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {window ".container" doesn't have -container option set}
+# testing window embedding for other than win platforms
+test embed-1.5.nonwin {TkpUseWindow procedure, -container must be set} -constraints {
+ nonwin
+} -setup {
+ deleteWindows
+} -body {
+ frame .container
+ toplevel .embd -use [winfo id .container]
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {window ".container" doesn't have -container option set}
+
+
+cleanupTests
+return
+
+
diff --git a/tk8.6/tests/entry.test b/tk8.6/tests/entry.test
new file mode 100644
index 0000000..d27ffb5
--- /dev/null
+++ b/tk8.6/tests/entry.test
@@ -0,0 +1,3518 @@
+# This file is a Tcl script to test entry widgets in Tk. It is
+# organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# For xscrollcommand
+proc scroll args {
+ global scrollInfo
+ set scrollInfo $args
+}
+# For trace variable
+proc override args {
+ global x
+ set x 12345
+}
+
+# Procedures used in widget VALIDATION tests
+proc doval {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ return 1
+}
+proc doval2 {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ set ::e mydata
+ return 1
+}
+proc doval3 {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ return 0
+}
+
+set cy [font metrics {Courier -12} -linespace]
+
+
+test entry-1.1 {configuration option: "background" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -background #ff0000
+ .e cget -background
+} -cleanup {
+ destroy .e
+} -result {#ff0000}
+test entry-1.2 {configuration option: "background" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -background non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.3 {configuration option: "bd" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -bd 4
+ .e cget -bd
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-1.4 {configuration option: "bd" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -bd badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test entry-1.5 {configuration option: "bg" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -bg #ff0000
+ .e cget -bg
+} -cleanup {
+ destroy .e
+} -result {#ff0000}
+test entry-1.6 {configuration option: "bg" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -bg non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.7 {configuration option: "borderwidth" for entry} -setup {
+ entry .e -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -borderwidth 1.3
+ .e cget -borderwidth
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-1.8 {configuration option: "borderwidth" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -borderwidth badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test entry-1.9 {configuration option: "cursor" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -cursor arrow
+ .e cget -cursor
+} -cleanup {
+ destroy .e
+} -result {arrow}
+test entry-1.10 {configuration option: "cursor" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -cursor badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+
+test entry-1.11 {configuration option: "disabledbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -disabledbackground green
+ .e cget -disabledbackground
+} -cleanup {
+ destroy .e
+} -result {green}
+test entry-1.12 {configuration option: "disabledbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -disabledbackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.13 {configuration option: "disabledforeground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -disabledforeground blue
+ .e cget -disabledforeground
+} -cleanup {
+ destroy .e
+} -result {blue}
+test entry-1.14 {configuration option: "disabledforeground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -disabledforeground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.15 {configuration option: "exportselection" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -exportselection yes
+ .e cget -exportselection
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-1.16 {configuration option: "exportselection" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -exportselection xyzzy
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected boolean value but got "xyzzy"}
+
+test entry-1.17 {configuration option: "fg" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -fg #110022
+ .e cget -fg
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.18 {configuration option: "fg" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -fg non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.19 {configuration option: "font" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e configure -font {Helvetica -12}
+ .e cget -font
+} -cleanup {
+ destroy .e
+} -result {Helvetica -12}
+test entry-1.20 {configuration option: "font" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e configure -font {}
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {font "" doesn't exist}
+
+test entry-1.21 {configuration option: "foreground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -foreground #110022
+ .e cget -foreground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.22 {configuration option: "foreground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -foreground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.23 {configuration option: "highlightbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightbackground #110022
+ .e cget -highlightbackground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.24 {configuration option: "highlightbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightbackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.25 {configuration option: "highlightcolor" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightcolor #110022
+ .e cget -highlightcolor
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.26 {configuration option: "highlightcolor" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightcolor non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.27 {configuration option: "highlightthickness" for entry} -setup {
+ entry .e -borderwidth 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightthickness 6
+ .e cget -highlightthickness
+} -cleanup {
+ destroy .e
+} -result {6}
+test entry-1.28 {configuration option: "highlightthickness" for entry} -setup {
+ entry .e -borderwidth 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightthickness -2
+ .e cget -highlightthickness
+} -cleanup {
+ destroy .e
+} -result {0}
+test entry-1.29 {configuration option: "highlightthickness" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightthickness badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test entry-1.30 {configuration option: "insertbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertbackground #110022
+ .e cget -insertbackground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.31 {configuration option: "insertbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertbackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.32 {configuration option: "insertborderwidth" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertborderwidth 1.3
+ .e cget -insertborderwidth
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-1.33 {configuration option: "insertborderwidth" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertborderwidth 2.6x
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "2.6x"}
+
+test entry-1.34 {configuration option: "insertofftime" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertofftime 100
+ .e cget -insertofftime
+} -cleanup {
+ destroy .e
+} -result {100}
+test entry-1.35 {configuration option: "insertofftime" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertofftime 3.2
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3.2"}
+
+test entry-1.36 {configuration option: "insertontime" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertontime 100
+ .e cget -insertontime
+} -cleanup {
+ destroy .e
+} -result {100}
+test entry-1.37 {configuration option: "insertontime" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertontime 3.2
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3.2"}
+
+test entry-1.38 {configuration option: "invalidcommand" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -invalidcommand "any string"
+ .e cget -invalidcommand
+} -cleanup {
+ destroy .e
+} -result {any string}
+
+test entry-1.39 {configuration option: "invcmd" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -invcmd "any string"
+ .e cget -invcmd
+} -cleanup {
+ destroy .e
+} -result {any string}
+
+test entry-1.40 {configuration option: "justify" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -justify right
+ .e cget -justify
+} -cleanup {
+ destroy .e
+} -result {right}
+test entry-1.41 {configuration option: "justify" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -justify bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+
+test entry-1.42 {configuration option: "readonlybackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -readonlybackground green
+ .e cget -readonlybackground
+} -cleanup {
+ destroy .e
+} -result {green}
+test entry-1.43 {configuration option: "readonlybackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -readonlybackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.44 {configuration option: "relief" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -relief flat
+ .e cget -relief
+} -cleanup {
+ destroy .e
+} -result {flat}
+
+test entry-1.45 {configuration option: "selectbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -selectbackground #110022
+ .e cget -selectbackground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.46 {configuration option: "selectbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -selectbackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.47 {configuration option: "selectborderwidth" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -selectborderwidth 1.3
+ .e cget -selectborderwidth
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-1.48 {configuration option: "selectborderwidth" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -selectborderwidth badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test entry-1.49 {configuration option: "selectforeground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -selectforeground #110022
+ .e cget -selectforeground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.50 {configuration option: "selectforeground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -selectforeground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.51 {configuration option: "show" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -show *
+ .e cget -show
+} -cleanup {
+ destroy .e
+} -result {*}
+
+test entry-1.52 {configuration option: "state" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -state n
+ .e cget -state
+} -cleanup {
+ destroy .e
+} -result {normal}
+test entry-1.53 {configuration option: "state" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -state bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad state "bogus": must be disabled, normal, or readonly}
+
+test entry-1.54 {configuration option: "takefocus" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -takefocus "any string"
+ .e cget -takefocus
+} -cleanup {
+ destroy .e
+} -result {any string}
+
+test entry-1.55 {configuration option: "textvariable" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -textvariable i
+ .e cget -textvariable
+} -cleanup {
+ destroy .e
+} -result {i}
+
+test entry-1.56 {configuration option: "width" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -width 402
+ .e cget -width
+} -cleanup {
+ destroy .e
+} -result {402}
+test entry-1.57 {configuration option: "width" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -width 3p
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3p"}
+
+test entry-1.58 {configuration option: "xscrollcommand" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -xscrollcommand {Some command}
+ .e cget -xscrollcommand
+} -cleanup {
+ destroy .e
+} -result {Some command}
+
+
+
+test entry-2.1 {Tk_EntryCmd procedure} -body {
+ entry
+} -returnCodes error -result {wrong # args: should be "entry pathName ?-option value ...?"}
+test entry-2.2 {Tk_EntryCmd procedure} -body {
+ entry gorp
+} -returnCodes error -result {bad window path name "gorp"}
+test entry-2.3 {Tk_EntryCmd procedure} -body {
+ entry .e
+ pack .e
+ update
+ list [winfo exists .e] [winfo class .e] [info commands .e]
+} -cleanup {
+ destroy .e
+} -result {1 Entry .e}
+test entry-2.4 {Tk_EntryCmd procedure} -body {
+ entry .e -gorp foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "-gorp"}
+test entry-2.4.1 {Tk_EntryCmd procedure} -body {
+ catch {entry .e -gorp foo}
+ list [winfo exists .e] [info commands .e]
+} -cleanup {
+ destroy .e
+} -result {0 {}}
+test entry-2.5 {Tk_EntryCmd procedure} -body {
+ entry .e
+} -cleanup {
+ destroy .e
+} -result {.e}
+
+
+test entry-3.1 {EntryWidgetCmd procedure} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e option ?arg ...?"}
+test entry-3.2 {EntryWidgetCmd procedure, "bbox" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e bbox
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e bbox index"}
+test entry-3.3 {EntryWidgetCmd procedure, "bbox" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e bbox a b
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e bbox index"}
+test entry-3.4 {EntryWidgetCmd procedure, "bbox" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e bbox bogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "bogus"}
+test entry-3.5 {EntryWidgetCmd procedure, "bbox" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e bbox 0
+} -cleanup {
+ destroy .e
+} -result [list 5 5 0 $cy]
+
+# Previously the result was count using previousli counted font measurements
+# and metrics. It was changed to less verbose solution - the result is the one
+# that passes fonts constraint (this concerns tests 3.6, 3.7, 3.8, 3.10)
+test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): no utf chars
+ .e insert 0 "abc"
+ list [.e bbox 3] [.e bbox end]
+} -cleanup {
+ destroy .e
+} -result {{19 5 7 13} {19 5 7 13}}
+test entry-3.7 {EntryWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): utf at end
+ .e insert 0 "ab\u4e4e"
+ .e bbox end
+} -cleanup {
+ destroy .e
+} -result {19 5 12 13}
+test entry-3.8 {EntryWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): utf before index
+ .e insert 0 "ab\u4e4ec"
+ .e bbox 3
+} -cleanup {
+ destroy .e
+} -result {31 5 7 13}
+test entry-3.9 {EntryWidgetCmd procedure, "bbox" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): no chars
+ .e bbox end
+} -cleanup {
+ destroy .e
+} -result "5 5 0 $cy"
+test entry-3.10 {EntryWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e insert 0 "abcdefghij\u4e4eklmnop"
+ list [.e bbox 0] [.e bbox 1] [.e bbox 10] [.e bbox end]
+} -cleanup {
+ destroy .e
+} -result {{5 5 7 13} {12 5 7 13} {75 5 12 13} {122 5 7 13}}
+test entry-3.11 {EntryWidgetCmd procedure, "cget" widget command} -setup {
+ entry .e
+} -body {
+ .e cget
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e cget option"}
+test entry-3.12 {EntryWidgetCmd procedure, "cget" widget command} -setup {
+ entry .e
+} -body {
+ .e cget a b
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e cget option"}
+test entry-3.13 {EntryWidgetCmd procedure, "cget" widget command} -setup {
+ entry .e
+} -body {
+ .e cget -gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "-gorp"}
+test entry-3.14 {EntryWidgetCmd procedure, "cget" widget command} -setup {
+ entry .e
+} -body {
+ .e configure -bd 4
+ .e cget -bd
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-3.15 {EntryWidgetCmd procedure, "configure" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ llength [.e configure]
+} -cleanup {
+ destroy .e
+} -result {36}
+test entry-3.16 {EntryWidgetCmd procedure, "configure" widget command} -setup {
+ entry .e
+} -body {
+ .e configure -foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "-foo"}
+test entry-3.17 {EntryWidgetCmd procedure, "configure" widget command} -setup {
+ entry .e
+} -body {
+ .e configure -bd 4
+ .e configure -bg #ffffff
+ lindex [.e configure -bd] 4
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-3.18 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+} -body {
+ .e delete
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"}
+test entry-3.19 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+} -body {
+ .e delete a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"}
+test entry-3.20 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+} -body {
+ .e delete foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "foo"}
+test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+} -body {
+ .e delete 0 bar
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "bar"}
+test entry-3.22 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e delete 2 4
+ .e get
+} -cleanup {
+ destroy .e
+} -result {014567890}
+test entry-3.23 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+} -body {
+ .e insert end "01234567890"
+ .e delete 6
+ .e get
+} -cleanup {
+ destroy .e
+} -result {0123457890}
+test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+ pack .e
+ update
+ set x {}
+} -body {
+# UTF
+ .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]
+} -cleanup {
+ destroy .e
+} -result [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"]
+test entry-3.25 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e delete 6 5
+ .e get
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test entry-3.26 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e configure -state disabled
+ .e delete 2 8
+ .e configure -state normal
+ .e get
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test entry-3.26a {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e configure -state readonly
+ .e delete 2 8
+ .e configure -state normal
+ .e get
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test entry-3.27 {EntryWidgetCmd procedure, "get" widget command} -setup {
+ entry .e
+} -body {
+ .e get foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e get"}
+test entry-3.28 {EntryWidgetCmd procedure, "icursor" widget command} -setup {
+ entry .e
+} -body {
+ .e icursor
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e icursor pos"}
+test entry-3.29 {EntryWidgetCmd procedure, "icursor" widget command} -setup {
+ entry .e
+} -body {
+ .e icursor foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "foo"}
+test entry-3.30 {EntryWidgetCmd procedure, "icursor" widget command} -setup {
+ entry .e
+} -body {
+ .e insert end "01234567890"
+ .e icursor 4
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-3.31 {EntryWidgetCmd procedure, "index" widget command} -setup {
+ entry .e
+} -body {
+ .e in
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {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} -setup {
+ entry .e
+} -body {
+ .e index
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e index string"}
+test entry-3.33 {EntryWidgetCmd procedure, "index" widget command} -setup {
+ entry .e
+} -body {
+ .e index foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "foo"}
+test entry-3.34 {EntryWidgetCmd procedure, "index" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e index 0
+} -cleanup {
+ destroy .e
+} -returnCodes {ok} -match glob -result {*}
+test entry-3.35 {EntryWidgetCmd procedure, "index" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+# UTF
+ .e insert 0 abc\u4e4e\u0153def
+ list [.e index 3] [.e index 4] [.e index end]
+} -cleanup {
+ destroy .e
+} -result {3 4 8}
+test entry-3.36 {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+} -body {
+ .e insert a
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e insert index text"}
+test entry-3.37 {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+} -body {
+ .e insert a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e insert index text"}
+test entry-3.38 {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+} -body {
+ .e insert foo Text
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "foo"}
+test entry-3.39 {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e insert 3 xxx
+ .e get
+} -cleanup {
+ destroy .e
+} -result {012xxx34567890}
+test entry-3.40 {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e configure -state disabled
+ .e insert 3 xxx
+ .e configure -state normal
+ .e get
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test entry-3.40a {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e configure -state readonly
+ .e insert 3 xxx
+ .e configure -state normal
+ .e get
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test entry-3.41 {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+} -body {
+ .e insert a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e insert index text"}
+test entry-3.42 {EntryWidgetCmd procedure, "scan" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e scan a
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e scan mark|dragto x"}
+test entry-3.43 {EntryWidgetCmd procedure, "scan" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e scan a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e scan mark|dragto x"}
+test entry-3.44 {EntryWidgetCmd procedure, "scan" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e scan foobar 20
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad scan option "foobar": must be mark or dragto}
+test entry-3.45 {EntryWidgetCmd procedure, "scan" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e scan mark 20.1
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {expected integer but got "20.1"}
+
+# This test is non-portable because character sizes vary.
+test entry-3.46 {EntryWidgetCmd procedure, "scan" widget command} -constraints {
+ fonts
+} -setup {
+ entry .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e insert end "This is quite a long string, in fact a "
+ .e insert end "very very long string"
+ .e scan mark 30
+ .e scan dragto 28
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {2}
+test entry-3.47 {EntryWidgetCmd procedure, "select" widget command} -setup {
+ entry .e
+} -body {
+ .e select
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection option ?index?"}
+test entry-3.48 {EntryWidgetCmd procedure, "select" widget command} -setup {
+ entry .e
+} -body {
+ .e select foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad selection option "foo": must be adjust, clear, from, present, range, or to}
+
+test entry-3.49 {EntryWidgetCmd procedure, "select clear" widget command} -setup {
+ entry .e
+} -body {
+ .e select clear gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection clear"}
+test entry-3.50 {EntryWidgetCmd procedure, "select clear" widget command} -setup {
+ entry .e
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 4
+ update
+ .e select clear
+ selection get
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined}
+test entry-3.50.1 {EntryWidgetCmd procedure, "select clear" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 4
+ update
+ .e select clear
+ catch {selection get}
+ selection own
+} -cleanup {
+ destroy .e
+} -result {.e}
+
+test entry-3.51 {EntryWidgetCmd procedure, "selection present" widget command} -setup {
+ entry .e
+} -body {
+ .e selection present foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection present"}
+test entry-3.52 {EntryWidgetCmd procedure, "selection present" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end 0123456789
+ .e select from 3
+ .e select to 6
+ .e selection present
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-3.53 {EntryWidgetCmd procedure, "selection present" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end 0123456789
+ .e select from 3
+ .e select to 6
+ .e configure -exportselection false
+ .e selection present
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-3.54 {EntryWidgetCmd procedure, "selection present" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end 0123456789
+ .e select from 3
+ .e select to 6
+ .e delete 0 end
+ .e selection present
+} -cleanup {
+ destroy .e
+} -result {0}
+test entry-3.55 {EntryWidgetCmd procedure, "selection adjust" widget command} -setup {
+ entry .e
+} -body {
+ .e select adjust x
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "x"}
+test entry-3.56 {EntryWidgetCmd procedure, "selection adjust" widget command} -setup {
+ entry .e
+} -body {
+ .e select adjust 2 3
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection adjust index"}
+test entry-3.57 {EntryWidgetCmd procedure, "selection adjust" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 5
+ update
+ .e select adjust 4
+ selection get
+} -cleanup {
+ destroy .e
+} -result {123}
+test entry-3.58 {EntryWidgetCmd procedure, "selection adjust" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 5
+ update
+ .e select adjust 2
+ selection get
+} -cleanup {
+ destroy .e
+} -result {234}
+test entry-3.59 {EntryWidgetCmd procedure, "selection from" widget command} -setup {
+ entry .e
+} -body {
+ .e select from 2 3
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection from index"}
+
+test entry-3.60 {EntryWidgetCmd procedure, "selection range" widget command} -setup {
+ entry .e
+} -body {
+ .e select range 2
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection range start end"}
+test entry-3.61 {EntryWidgetCmd procedure, "selection range" widget command} -setup {
+ entry .e
+} -body {
+ .e selection range 2 3 4
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection range start end"}
+test entry-3.62 {EntryWidgetCmd procedure, "selection range" widget command} -setup {
+ entry .e
+} -body {
+ .e insert end 0123456789
+ .e select from 1
+ .e select to 5
+ .e select range 4 4
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+test entry-3.63 {EntryWidgetCmd procedure, "selection range" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end 0123456789
+ .e select from 3
+ .e select to 7
+ .e select range 2 9
+ list [.e index sel.first] [.e index sel.last] [.e index anchor]
+} -cleanup {
+ destroy .e
+} -result {2 9 3}
+test entry-3.64 {EntryWidgetCmd procedure, "selection" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .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]
+} -cleanup {
+ destroy .e
+} -result {0 10}
+test entry-3.64a {EntryWidgetCmd procedure, "selection" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .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]
+} -cleanup {
+ destroy .e
+} -result {2 4}
+test entry-3.64b {EntryWidgetCmd procedure, "selection to" widget command} -setup {
+ entry .e
+ pack .e
+ update
+ .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."
+} -body {
+ .e select to 2 3
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection to index"}
+
+test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .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 xview 5
+ format {%.7f %.7f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.0537634 0.2688172}
+test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e xview gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "gorp"}
+test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .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 xview 0
+ .e icursor 10
+ .e xview insert
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.107527 0.322581}
+test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e xview moveto foo bar
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e xview moveto fraction"}
+test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e xview moveto foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {expected floating-point number but got "foo"}
+test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .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 xview moveto 0.5
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.505376 0.720430}
+test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .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 xview scroll 24
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e xview scroll number units|pages"}
+test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview scroll gorp units
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {expected integer but got "gorp"}
+test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview moveto 0
+ .e xview scroll 1 pages
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.193548 0.408602}
+test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .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 xview moveto .9
+ update
+ .e xview scroll -2 p
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.397849 0.612903}
+test entry-3.75 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview 30
+ update
+ .e xview scroll 2 units
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {32}
+test entry-3.76 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview 30
+ update
+ .e xview scroll -1 units
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {29}
+test entry-3.77 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview scroll 23 foobars
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad argument "foobars": must be units or pages}
+test entry-3.78 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview eat 23 hamburgers
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "eat": must be moveto or scroll}
+test entry-3.79 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .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 xview 0
+ update
+ .e xview -4
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {0}
+test entry-3.80 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview 300
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {73}
+test entry-3.86 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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 insert 10 \u4e4e
+ update
+# 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 [format {%.6f} [lindex [.e xview] 0]]
+ .e xview moveto .11
+ lappend x [format {%.6f} [lindex [.e xview] 0]]
+ .e xview moveto .12
+ lappend x [format {%.6f} [lindex [.e xview] 0]]
+} -cleanup {
+ destroy .e
+} -result {0.095745 0.106383 0.117021}
+
+test entry-3.82 {EntryWidgetCmd procedure} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {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
+# ensure that resources get properly freed.
+
+test entry-4.1 {DestroyEntry procedure} -body {
+ entry .e -textvariable x -show *
+ pack .e
+ .e insert end "Sample text"
+ update
+ destroy .e
+} -result {}
+
+test entry-5.1 {ConfigureEntry procedure, -textvariable} -body {
+ set x 12345
+ entry .e -textvariable x
+ .e get
+} -cleanup {
+ destroy .e
+} -result {12345}
+test entry-5.2 {ConfigureEntry procedure, -textvariable} -body {
+ set x 12345
+ entry .e -textvariable x
+ set y abcde
+ .e configure -textvariable y
+ set x 54321
+ .e get
+} -cleanup {
+ destroy .e
+} -result {abcde}
+test entry-5.3 {ConfigureEntry procedure, -textvariable} -setup {
+ unset -nocomplain x
+ entry .e
+} -body {
+ .e insert 0 "Some text"
+ .e configure -textvariable x
+ return $x
+} -cleanup {
+ destroy .e
+} -result {Some text}
+test entry-5.4 {ConfigureEntry procedure, -textvariable} -setup {
+ unset -nocomplain x
+ entry .e
+} -body {
+ trace variable x w override
+ .e insert 0 "Some text"
+ .e configure -textvariable x
+ list $x [.e get]
+} -cleanup {
+ destroy .e
+ trace vdelete x w override
+ unset x;
+} -result {12345 12345}
+
+test entry-5.5 {ConfigureEntry procedure} -setup {
+ set x {}
+ entry .e1
+ entry .e2
+} -body {
+ .e2 insert end "This is some sample text"
+ .e1 configure -exportselection false
+ .e1 insert end "0123456789"
+ pack .e1 .e2
+ .e2 select from 0
+ .e2 select to 10
+ lappend x [selection get]
+ .e1 select from 1
+ .e1 select to 5
+ lappend x [selection get]
+ .e1 configure -exportselection 1
+ lappend x [selection get]
+ return $x
+} -cleanup {
+ destroy .e1 .e2
+} -result {{This is so} {This is so} 1234}
+test entry-5.6 {ConfigureEntry procedure} -setup {
+ entry .e
+ pack .e
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 5
+ .e configure -exportselection 0
+ selection get
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined}
+test entry-5.6.1 {ConfigureEntry procedure} -setup {
+ entry .e
+ pack .e
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 5
+ .e configure -exportselection 0
+ catch {selection get}
+ list [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {1 5}
+
+test entry-5.7 {ConfigureEntry procedure} -setup {
+ entry .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -width 4 -xscrollcommand scroll
+ .e insert end "01234567890"
+ update
+ .e configure -width 5
+ format {%.6f %.6f} {*}$scrollInfo
+} -cleanup {
+ destroy .e
+} -result {0.000000 0.363636}
+
+
+test entry-5.8 {ConfigureEntry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -width 0 -font {Helvetica -12}
+ .e insert end "0123"
+ update
+ .e configure -font {Helvetica -24}
+ update
+ winfo geom .e
+} -cleanup {
+ destroy .e
+} -result {62x37+0+0}
+test entry-5.9 {ConfigureEntry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised
+ .e insert end "0123"
+ update
+ list [.e index @10] [.e index @11] [.e index @12] [.e index @13]
+} -cleanup {
+ destroy .e
+} -result {0 0 1 1}
+test entry-5.10 {ConfigureEntry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief flat
+ .e insert end "0123"
+ update
+ list [.e index @10] [.e index @11] [.e index @12] [.e index @13]
+} -cleanup {
+ destroy .e
+} -result {0 0 1 1}
+test entry-5.11 {ConfigureEntry procedure} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+# If "0" in selected font had 0 width, caused divide-by-zero error.
+ .e configure -font {{open look glyph}}
+ .e scan dragto 30
+ update
+} -cleanup {
+ destroy .e
+} -result {}
+
+# No tests for DisplayEntry.
+
+test entry-6.1 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 20 \
+ -highlightthickness 3
+ .e insert end 012\t45
+ update
+ list [.e index @61] [.e index @62]
+} -cleanup {
+ destroy .e
+} -result {3 4}
+test entry-6.2 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 20 \
+ -justify center -highlightthickness 3
+ .e insert end 012\t45
+ update
+ list [.e index @96] [.e index @97]
+} -cleanup {
+ destroy .e
+} -result {3 4}
+test entry-6.3 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 20 \
+ -justify right -highlightthickness 3
+ .e insert end 012\t45
+ update
+ list [.e index @131] [.e index @132]
+} -cleanup {
+ destroy .e
+} -result {3 4}
+test entry-6.4 {EntryComputeGeometry procedure} -setup {
+ entry .e
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 5
+ .e insert end "01234567890"
+ update
+ .e xview 6
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {6}
+test entry-6.5 {EntryComputeGeometry procedure} -setup {
+ entry .e -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 5
+ .e insert end "01234567890"
+ update
+ .e xview 7
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {6}
+test entry-6.6 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 10
+ .e insert end "01234\t67890"
+ update
+ .e xview 3
+ list [.e index @39] [.e index @40]
+} -cleanup {
+ destroy .e
+} -result {5 6}
+test entry-6.7 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Helvetica -24} -bd 3 -relief raised -width 5
+ .e insert end "01234567"
+ update
+ list [winfo reqwidth .e] [winfo reqheight .e]
+} -cleanup {
+ destroy .e
+} -result {77 39}
+test entry-6.8 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0
+ .e insert end "01234567"
+ update
+ list [winfo reqwidth .e] [winfo reqheight .e]
+} -cleanup {
+ destroy .e
+} -result {116 39}
+test entry-6.9 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0
+ update
+ list [winfo reqwidth .e] [winfo reqheight .e]
+} -cleanup {
+ destroy .e
+} -result {25 39}
+test entry-6.10 {EntryComputeGeometry procedure} -constraints {
+ unix fonts
+} -setup {
+ entry .e -highlightthickness 2 -font {Helvetica -12}
+ pack .e
+} -body {
+ .e configure -bd 1 -relief raised -width 0 -show .
+ .e insert 0 12345
+ update
+ set x [winfo reqwidth .e]
+ .e configure -show X
+ lappend x [winfo reqwidth .e]
+ .e configure -show ""
+ lappend x [winfo reqwidth .e]
+} -cleanup {
+ destroy .e
+} -result {23 53 43}
+test entry-6.11 {EntryComputeGeometry procedure} -constraints {
+ win
+} -setup {
+ entry .e -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -bd 1 -relief raised -width 0 -show . -font {helvetica 12}
+ .e insert 0 12345
+ update
+ set x1 [winfo reqwidth .e]
+ set x2 [expr {8+5*[font measure {helvetica 12} .]}]
+ set x [expr {$x1 eq $x2}]
+ .e configure -show X
+ set x1 [winfo reqwidth .e]
+ set x2 [expr {8+5*[font measure {helvetica 12} X]}]
+ lappend x [expr {$x1 eq $x2}]
+ .e configure -show ""
+ set x1 [winfo reqwidth .e]
+ set x2 [expr {8+[font measure {helvetica 12} 12345]}]
+ lappend x [expr {$x1 eq $x2}]
+} -cleanup {
+ destroy .e
+} -result {1 1 1}
+test entry-6.12 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ catch {destroy .e}
+ entry .e -font {Courier -12} -bd 2 -relief raised -width 20
+ pack .e
+} -body {
+ .e insert end "012\t456\t"
+ update
+ list [.e index @80] [.e index @81] [.e index @115] [.e index @116]
+} -cleanup {
+ destroy .e
+} -result {6 7 7 8}
+
+
+test entry-7.1 {InsertChars procedure} -setup {
+ unset -nocomplain contents
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
+ .e insert 0 abcde
+ .e insert 2 XXX
+ update
+ list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
+} -cleanup {
+ destroy .e
+} -result {abXXXcde abXXXcde {0.000000 1.000000}}
+
+test entry-7.2 {InsertChars procedure} -setup {
+ unset -nocomplain contents
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
+ .e insert 0 abcde
+ .e insert 500 XXX
+ update
+ list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
+} -cleanup {
+ destroy .e
+} -result {abcdeXXX abcdeXXX {0.000000 1.000000}}
+test entry-7.3 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 0123456789
+ .e select from 2
+ .e select to 6
+ .e insert 2 XXX
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 8
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {5 9 5 8}
+test entry-7.4 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 0123456789
+ .e select from 2
+ .e select to 6
+ .e insert 3 XXX
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 8
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {2 9 2 8}
+test entry-7.5 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 0123456789
+ .e select from 2
+ .e select to 6
+ .e insert 5 XXX
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 8
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {2 9 2 8}
+test entry-7.6 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 0123456789
+ .e select from 2
+ .e select to 6
+ .e insert 6 XXX
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 5
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {2 6 2 5}
+test entry-7.7 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -xscrollcommand scroll
+ .e insert 0 0123456789
+ .e icursor 4
+ .e insert 4 XXX
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {7}
+test entry-7.8 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 0123456789
+ .e icursor 4
+ .e insert 5 XXX
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-7.9 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 "This is a very long string"
+ update
+ .e xview 4
+ .e insert 3 XXX
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {7}
+test entry-7.10 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 "This is a very long string"
+ update
+ .e xview 4
+ .e insert 4 XXX
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {4}
+
+test entry-7.11 {InsertChars procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 "xyzzy"
+ update
+ .e insert 2 00
+ winfo reqwidth .e
+} -cleanup {
+ destroy .e
+} -result {59}
+
+test entry-8.1 {DeleteChars procedure} -setup {
+ unset -nocomplain contents
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
+ .e insert 0 abcde
+ .e delete 2 4
+ update
+ list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
+} -cleanup {
+ destroy .e
+} -result {abe abe {0.000000 1.000000}}
+test entry-8.2 {DeleteChars procedure} -setup {
+ unset -nocomplain contents
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
+ .e insert 0 abcde
+ .e delete -2 2
+ update
+ list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
+} -cleanup {
+ destroy .e
+} -result {cde cde {0.000000 1.000000}}
+test entry-8.3 {DeleteChars procedure} -setup {
+ unset -nocomplain contents
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
+ .e insert 0 abcde
+ .e delete 3 1000
+ update
+ list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
+} -cleanup {
+ destroy .e
+} -result {abc abc {0.000000 1.000000}}
+test entry-8.4 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 3
+ .e select to 8
+ .e delete 1 3
+ update
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 5
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {1 6 1 5}
+test entry-8.5 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 3
+ .e select to 8
+ .e delete 1 4
+ update
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 4
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {1 5 1 4}
+test entry-8.6 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 3
+ .e select to 8
+ .e delete 1 7
+ update
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 5
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {1 2 1 5}
+test entry-8.7 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 3
+ .e select to 8
+ .e delete 1 8
+ update
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+test entry-8.8 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 3
+ .e select to 8
+ .e delete 3 7
+ update
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 8
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {3 4 3 8}
+test entry-8.9 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 3
+ .e select to 8
+ .e delete 3 8
+ update
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+test entry-8.10 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 8
+ .e select to 3
+ .e delete 5 8
+ update
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 8
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {3 5 5 8}
+test entry-8.11 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 8
+ .e select to 3
+ .e delete 8 10
+ update
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 4
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {3 8 4 8}
+test entry-8.12 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e icursor 4
+ .e delete 1 4
+ update
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-8.13 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e icursor 4
+ .e delete 1 5
+ update
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-8.14 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e icursor 4
+ .e delete 4 6
+ update
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-8.15 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 "This is a very long string"
+ .e xview 4
+ .e delete 1 4
+ update
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-8.16 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 "This is a very long string"
+ .e xview 4
+ .e delete 1 5
+ update
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-8.17 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 "This is a very long string"
+ .e xview 4
+ .e delete 4 6
+ update
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-8.18 {DeleteChars procedure} -setup {
+ entry .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 "xyzzy"
+ update
+ .e delete 2 4
+ winfo reqwidth .e
+} -cleanup {
+ destroy .e
+} -result {31}
+
+test entry-9.1 {EntryValueChanged procedure} -setup {
+ unset -nocomplain x
+} -body {
+ trace variable x w override
+ entry .e -textvariable x -width 0
+ .e insert 0 foo
+ list $x [.e get]
+} -cleanup {
+ destroy .e
+ trace vdelete x w override
+ unset x
+} -result {12345 12345}
+
+
+test entry-10.1 {EntrySetValue procedure} -constraints fonts -body {
+ set x abcde
+ set y ab
+ entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 -width 0
+ pack .e
+ .e configure -textvariable x
+ .e configure -textvariable y
+ update
+ list [.e get] [winfo reqwidth .e]
+} -cleanup {
+ destroy .e
+} -result {ab 24}
+test entry-10.2 {EntrySetValue procedure, updating selection} -setup {
+ unset -nocomplain x
+ entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -textvariable x
+ .e insert 0 "abcdefghjklmnopqrstu"
+ .e selection range 4 10
+ set x "a"
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+test entry-10.3 {EntrySetValue procedure, updating selection} -setup {
+ unset -nocomplain x
+ entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -textvariable x
+ .e insert 0 "abcdefghjklmnopqrstu"
+ .e selection range 4 10
+ set x "abcdefg"
+ list [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {4 7}
+test entry-10.4 {EntrySetValue procedure, updating selection} -setup {
+ unset -nocomplain x
+ entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -textvariable x
+ .e insert 0 "abcdefghjklmnopqrstu"
+ .e selection range 4 10
+ set x "abcdefghijklmn"
+ list [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {4 10}
+test entry-10.5 {EntrySetValue procedure, updating display position} -setup {
+ unset -nocomplain x
+ entry .e -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -width 10 -font {Courier -12} -textvariable x
+ .e insert 0 "abcdefghjklmnopqrstuvwxyz"
+ .e xview 10
+ update
+ set x "abcdefg"
+ update
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {0}
+test entry-10.6 {EntrySetValue procedure, updating display position} -setup {
+ unset -nocomplain x
+ entry .e -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -width 10 -font {Courier -12} -textvariable x
+ pack .e
+ .e insert 0 "abcdefghjklmnopqrstuvwxyz"
+ .e xview 10
+ update
+ set x "1234567890123456789012"
+ update
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {10}
+test entry-10.7 {EntrySetValue procedure, updating insertion cursor} -setup {
+ unset -nocomplain x
+ entry .e -highlightthickness 2 -bd 2
+ pack .e
+ update
+} -body {
+ .e configure -width 10 -font {Courier -12} -textvariable x
+ pack .e
+ .e insert 0 "abcdefghjklmnopqrstuvwxyz"
+ .e icursor 5
+ set x "123"
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {3}
+test entry-10.8 {EntrySetValue procedure, updating insertion cursor} -setup {
+ unset -nocomplain x
+ entry .e -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -width 10 -font {Courier -12} -textvariable x
+ pack .e
+ .e insert 0 "abcdefghjklmnopqrstuvwxyz"
+ .e icursor 5
+ set x "123456"
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {5}
+
+test entry-11.1 {EntryEventProc procedure} -setup {
+ entry .e -highlightthickness 2 -bd 2 -font {Helvetica -12}
+ pack .e
+} -body {
+ .e insert 0 abcdefg
+ destroy .e
+ update
+} -cleanup {
+ destroy .e
+} -result {}
+test entry-11.2 {EntryEventProc procedure} -setup {
+ set x {}
+} -body {
+ entry .e1 -fg #112233
+ rename .e1 .e2
+ lappend x [winfo children .]
+ lappend x [.e2 cget -fg]
+ destroy .e1
+ lappend x [info command .e*] [winfo children .]
+} -cleanup {
+ destroy .e1
+} -result {.e1 #112233 {} {}}
+
+test entry-12.1 {EntryCmdDeletedProc procedure} -body {
+ button .b -text "xyz_123"
+ rename .b {}
+ list [info command .b*] [winfo children .]
+} -cleanup {
+ destroy .b
+} -result {{} {}}
+
+
+test entry-13.1 {GetEntryIndex procedure} -setup {
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index end
+} -cleanup {
+ destroy .e
+} -result {21}
+test entry-13.2 {GetEntryIndex procedure} -body {
+ entry .e
+ .e index abogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "abogus"}
+test entry-13.3 {GetEntryIndex procedure} -setup {
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ .e index anchor
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-13.4 {GetEntryIndex procedure} -setup {
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 4
+ .e select to 1
+ .e index anchor
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-13.5 {GetEntryIndex procedure} -setup {
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 3
+ .e select to 15
+ .e select adjust 4
+ .e index anchor
+} -cleanup {
+ destroy .e
+} -result {15}
+test entry-13.6 {GetEntryIndex procedure} -setup {
+ entry .e
+} -body {
+ .e index ebogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "ebogus"}
+test entry-13.7 {GetEntryIndex procedure} -setup {
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e icursor 2
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {2}
+test entry-13.8 {GetEntryIndex procedure} -setup {
+ entry .e
+} -body {
+ .e index ibogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "ibogus"}
+test entry-13.9 {GetEntryIndex procedure} -setup {
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {1 6}
+
+
+
+
+
+
+test entry-13.10 {GetEntryIndex procedure} -constraints unix -body {
+# On unix, when selection is cleared, entry widget's internal
+# selection range is reset.
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+
+test entry-13.11 {GetEntryIndex procedure} -constraints win -body {
+# 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.
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ catch {selection get}
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -result {1}
+
+test entry-13.12 {GetEntryIndex procedure} -constraints unix -body {
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index sbogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+
+# why when string in .e index changed to not beginning with s,
+# it behaves differently?
+test entry-13.12.1 {GetEntryIndex procedure} -constraints unix -body {
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index bogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "bogus"}
+
+test entry-13.13 {GetEntryIndex procedure} -constraints win -body {
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index sbogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "sbogus"}
+
+test entry-13.14 {GetEntryIndex procedure} -constraints win -body {
+# 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.
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ selection get
+} -cleanup {
+ destroy .e
+} -returnCodes error -match glob -result {*}
+
+test entry-13.14.1 {GetEntryIndex procedure} -constraints win -body {
+# 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.
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ catch {selection get}
+ .e index sbogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -match glob -result {*}
+
+test entry-13.15 {GetEntryIndex procedure} -body {
+ entry .e
+ selection clear .e
+ .e index @xyz
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "@xyz"}
+
+test entry-13.16 {GetEntryIndex procedure} -constraints fonts -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @4
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-13.17 {GetEntryIndex procedure} -constraints fonts -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @11
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-13.18 {GetEntryIndex procedure} -constraints fonts -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @12
+} -cleanup {
+ destroy .e
+} -result {5}
+test entry-13.19 {GetEntryIndex procedure} -constraints fonts -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @[expr {[winfo width .e] - 6}]
+} -cleanup {
+ destroy .e
+} -result {8}
+test entry-13.20 {GetEntryIndex procedure} -constraints fonts -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @[expr {[winfo width .e] - 5}]
+} -cleanup {
+ destroy .e
+} -result {9}
+test entry-13.21 {GetEntryIndex procedure} -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @1000
+} -cleanup {
+ destroy .e
+} -result {9}
+test entry-13.22 {GetEntryIndex procedure} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e index 1xyz
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "1xyz"}
+test entry-13.23 {GetEntryIndex procedure} -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index -10
+} -cleanup {
+ destroy .e
+} -result {0}
+test entry-13.24 {GetEntryIndex procedure} -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index 12
+} -cleanup {
+ destroy .e
+} -result {12}
+test entry-13.25 {GetEntryIndex procedure} -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index 49
+} -cleanup {
+ destroy .e
+} -result {21}
+test entry-13.26 {GetEntryIndex procedure} -constraints fonts -body {
+ entry .e -highlightthickness 2 -bd 2 -font {Helvetica -12}
+ selection clear .e
+ .e configure -show .
+ .e insert 0 XXXYZZY
+ pack .e
+ update
+ list [.e index @7] [.e index @8]
+} -cleanup {
+ destroy .e
+} -result {0 1}
+
+# XXX Still need to write tests for EntryScanTo and EntrySelectTo.
+
+
+test entry-14.1 {EntryFetchSelection procedure} -body {
+ entry .e
+ .e insert end "This is a test string"
+ .e select from 1
+ .e select to 18
+ selection get
+} -cleanup {
+ destroy .e
+} -result {his is a test str}
+test entry-14.2 {EntryFetchSelection procedure} -body {
+ entry .e -show *
+ .e insert end "This is a test string"
+ .e select from 1
+ .e select to 18
+ selection get
+} -cleanup {
+ destroy .e
+} -result {*****************}
+test entry-14.3 {EntryFetchSelection procedure} -setup {
+ set x {}
+ for {set i 1} {$i <= 500} {incr i} {
+ append x "This is line $i, out of 500\n"
+}
+} -body {
+ entry .e
+ .e insert end $x
+ .e select from 0
+ .e select to end
+ string compare [selection get] $x
+} -cleanup {
+ destroy .e
+} -result {0}
+
+test entry-15.1 {EntryLostSelection} -body {
+ entry .e
+ .e insert 0 "Text"
+ .e select from 0
+ .e select to 4
+ set result [selection get]
+ selection clear
+ .e select from 0
+ .e select to 4
+ lappend result [selection get]
+} -cleanup {
+ destroy .e
+} -result {Text Text}
+
+# is scrollcommand needed here??
+test entry-16.1 {EntryVisibleRange procedure} -constraints fonts -body {
+ entry .e -width 10 -font {Helvetica -12}
+ pack .e
+ update
+ .e insert 0 "............................."
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.000000 0.827586}
+test entry-16.2 {EntryVisibleRange procedure} -constraints {
+ unix fonts
+} -body {
+ entry .e -show X -width 10 -font {Helvetica -12}
+ pack .e
+ update
+ .e insert 0 "............................."
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.000000 0.275862}
+test entry-16.3 {EntryVisibleRange procedure} -constraints {
+ win
+} -body {
+ entry .e -show . -width 10 -font {Helvetica -12}
+ pack .e
+ update
+ .e insert 0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.000000 0.827586}
+test entry-16.4 {EntryVisibleRange procedure} -body {
+ entry .e -show ""
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.000000 1.000000}
+
+
+test entry-17.1 {EntryUpdateScrollbar procedure} -body {
+ entry .e -width 10 -xscrollcommand scroll -font {Courier -12}
+ pack .e
+ .e delete 0 end
+ .e insert 0 123
+ update
+ format {%.6f %.6f} {*}$scrollInfo
+} -cleanup {
+ destroy .e
+} -result {0.000000 1.000000}
+test entry-17.2 {EntryUpdateScrollbar procedure} -body {
+ entry .e -width 10 -xscrollcommand scroll -font {Courier -12}
+ pack .e
+ .e insert 0 0123456789abcdef
+ .e xview 3
+ update
+ format {%.6f %.6f} {*}$scrollInfo
+} -cleanup {
+ destroy .e
+} -result {0.187500 0.812500}
+test entry-17.3 {EntryUpdateScrollbar procedure} -body {
+ entry .e -width 10 -xscrollcommand scroll -font {Courier -12}
+ pack .e
+ .e insert 0 abcdefghijklmnopqrs
+ .e xview 6
+ update
+ format {%.6f %.6f} {*}$scrollInfo
+} -cleanup {
+ destroy .e
+} -result {0.315789 0.842105}
+test entry-17.4 {EntryUpdateScrollbar procedure} -setup {
+ proc bgerror msg {
+ global x
+ set x $msg
+}
+} -body {
+ entry .e -width 5 -xscrollcommand thisisnotacommand
+ pack .e
+ update
+ list $x $errorInfo
+} -cleanup {
+ destroy .e
+ rename bgerror {}
+} -result {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand"
+ while executing
+"thisisnotacommand 0.0 1.0"
+ (horizontal scrolling command executed by .e)}}
+
+
+test entry-18.1 {Entry widget vs hiding} -setup {
+ entry .e
+} -body {
+ set l [interp hidden]
+ interp hide {} .e
+ destroy .e
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 == $res2}
+} -result {1}
+
+##
+## Entry widget VALIDATION tests
+##
+# The validation tests build each one upon the previous, so cascading
+# failures aren't good
+#
+
+# 19.* test cases in previous version highly depended on the previous
+# test cases. This was replaced by inserting recently set configurations
+# that matters for the test case
+test entry-19.1 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ 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
+ .e insert 0 a
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 1 0 a {} a all key}
+
+test entry-19.2 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ 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
+ .e insert 0 a ;# previous settings
+ .e insert 1 b
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 1 1 ab a b all key}
+
+test entry-19.3 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ 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
+ .e insert 0 ab ;# previous settings
+ .e insert end c
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 1 2 abc ab c all key}
+
+test entry-19.4 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ 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
+ .e insert 0 abc ;# previous settings
+ .e insert 1 123
+ list $::vVals $::e
+} -cleanup {
+ destroy .e
+} -result {{.e 1 1 a123bc abc 123 all key} a123bc}
+
+test entry-19.5 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ 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
+ .e insert 0 a123bc ;# previous settings
+ .e delete 2
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 0 2 a13bc a123bc 2 all key}
+
+test entry-19.6 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ 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
+ .e insert 0 a13bc ;# previous settings
+ .e configure -validate key
+ .e delete 1 3
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 0 1 abc a13bc 13 key key}
+
+test entry-19.7 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focus \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abc ;# previous settings
+ set ::vVals {}
+ .e insert end d
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {}
+
+test entry-19.8 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ 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
+ .e configure -validate focus ;# previous settings
+ .e insert end abcd ;# previous settings
+ focus -force .e
+# update necessary to process FocusIn event
+ update
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focus focusin}
+
+test entry-19.9 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focus \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ focus -force .e ;# previous settings
+ update ;# previous settings
+# update necessary to process FocusIn event
+ focus -force .
+# update necessary to process FocusOut event
+ update
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focus focusout}
+
+test entry-19.10 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ 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
+ .e insert end abcd ;# previous settings
+ focus -force .e
+# update necessary to process FocusIn event
+ update
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} all focusin}
+
+test entry-19.11 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ 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
+ .e insert end abcd ;# previous settings
+ focus -force .e ;# previous settings
+# update necessary to process FocusIn event
+ update ;# previous settings
+ focus -force .
+# update necessary to process FocusOut event
+ update
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} all focusout}
+
+test entry-19.12 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focusin \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 abcd ;# previous settings
+ focus -force .e
+# update necessary to process FocusIn event
+ update
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focusin focusin}
+
+test entry-19.13 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focusin \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {}
+ focus -force .
+# update necessary to process FocusOut event
+ update
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {}
+
+test entry-19.14 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {} ;# previous settings
+ focus -force .e
+# update necessary to process FocusIn event
+ update
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {}
+
+test entry-19.15 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {} ;# previous settings
+ focus -force .e ;# previous settings
+# update necessary to process FocusIn event
+ update ;# previous settings
+ focus -force .
+# update necessary to process FocusOut event
+ update
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focusout focusout}
+
+# the same as 19.16 but added [.e validate] to returned list
+test entry-19.16 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {} ;# previous settings
+ focus -force .e ;# previous settings
+# update necessary to process FocusIn event
+ update ;# previous settings
+ focus -force .
+# update necessary to process FocusOut event
+ update
+ list [.e validate] $::vVals
+} -cleanup {
+ destroy .e
+} -result {1 {.e -1 -1 abcd abcd {} all forced}}
+
+
+test entry-19.17 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::e newdata
+ list [.e cget -validate] $::vVals
+} -cleanup {
+ destroy .e
+} -result {focusout {.e -1 -1 newdata abcd {} focusout forced}}
+
+
+# proc doval changed - returns 0
+test entry-19.18 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ set ::e newdata ;# previous settings
+ .e configure -validate all
+ set ::e nextdata
+ list [.e cget -validate] $::vVals
+} -cleanup {
+ destroy .e
+} -result {none {.e -1 -1 nextdata newdata {} all forced}}
+
+## 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
+# proc doval2 used
+test entry-19.19 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ set ::e nextdata ;# previous settings
+
+ .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V]
+ .e validate
+ list [.e cget -validate] [.e get] $::vVals
+} -cleanup {
+ destroy .e
+} -result {none mydata {.e -1 -1 nextdata nextdata {} all forced}}
+
+## 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} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ 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
+ set ::e nextdata ;# previous settings
+ .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] ;# prev
+ .e validate ;# previous settings
+
+ .e configure -validate all
+ set ::e testdata
+ list [.e cget -validate] [.e get] $::e $::vVals
+} -cleanup {
+ destroy .e
+} -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}}
+##
+## End validation tests
+##
+
+test entry-20.1 {widget deletion while active} -body {
+ entry .e -validate all \
+ -validatecommand { destroy %W ; return 1 } \
+ -invalidcommand bell
+ update
+ .e insert 0 abc
+ winfo exists .e
+} -cleanup {
+ destroy .e
+} -result {0}
+
+test entry-20.2 {widget deletion while active} -body {
+ entry .e -validate all \
+ -validatecommand { return 0 } \
+ -invalidcommand { destroy %W }
+ .e insert 0 abc
+ winfo exists .e
+} -cleanup {
+ destroy .e
+} -result {0}
+
+test entry-20.3 {widget deletion while active} -body {
+ entry .e -validate all \
+ -validatecommand { rename .e {} ; return 1 }
+ .e insert 0 abc
+ winfo exists .e
+} -cleanup {
+ destroy .e
+} -result {0}
+
+test entry-20.4 {widget deletion while active} -body {
+ entry .e -validate all \
+ -validatecommand { return 0 } \
+ -invalidcommand { rename .e {} }
+ .e insert 0 abc
+ winfo exists .e
+} -cleanup {
+ destroy .e
+} -result {0}
+
+test entry-20.5 {widget deletion while active} -body {
+ entry .e -validatecommand { destroy .e ; return 0 }
+ .e validate
+ winfo exists .e
+} -cleanup {
+ destroy .e
+} -result {0}
+
+test entry-20.6 {widget deletion while active} -body {
+ pack [entry .e]
+ update
+ .e config -xscrollcommand { destroy .e }
+ update idle
+ winfo exists .e
+} -cleanup {
+ destroy .e
+} -result {0}
+
+test entry-20.7 {widget deletion with textvariable active} -body {
+# SF bugs 607390 and 617446
+ 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
+} -cleanup {
+ destroy .e
+} -result {0}
+
+
+test entry-21.1 {selection present while disabled, bug 637828} -body {
+ entry .e
+ .e insert end 0123456789
+ .e select from 3
+ .e select to 6
+ set out [.e selection present]
+ .e configure -state disabled
+# still return 1 when disabled, because 'selection get' will work,
+# but selection cannot be changed (new behavior since 8.4)
+ .e select to 9
+ lappend out [.e selection present] [selection get]
+} -cleanup {
+ destroy .e
+} -result {1 1 345}
+
+test entry-22.1 {lost namespaced textvar} -body {
+ namespace eval test { variable foo {a b} }
+ entry .e -textvariable ::test::foo
+ namespace delete test
+ set ::test::foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {can't read "::test::foo": no such variable}
+test entry-22.2 {lost namespaced textvar} -body {
+ namespace eval test { variable foo {a b} }
+ entry .e -textvariable ::test::foo
+ namespace delete test
+ catch {.e insert end "more stuff"} result1
+ catch {.e delete 5 end } result2
+ catch {set ::test::foo} result3
+ list [.e get] [.e cget -textvar] $result1 $result2 $result3
+} -cleanup {
+ destroy .e
+} -result [list "a bmo" ::test::foo \
+ {can't set "::test::foo": parent namespace doesn't exist} \
+ {can't set "::test::foo": parent namespace doesn't exist} \
+ {can't read "::test::foo": no such variable}]
+
+test entry-23.1 {error in trace proc attached to the textvariable} -setup {
+ destroy .e
+} -body {
+ trace variable myvar w traceit
+ proc traceit args {error "Intentional error here!"}
+ entry .e -textvariable myvar
+ catch {.e insert end mystring} result1
+ catch {.e delete 0} result2
+ list $result1 $result2
+} -cleanup {
+ destroy .e
+} -result [list {can't set "myvar": Intentional error here!} \
+ {can't set "myvar": Intentional error here!}]
+
+test entry-24.1 {textvariable lives in a non-existing namespace} -setup {
+ destroy .e
+} -body {
+ catch {entry .e -textvariable thisnsdoesntexist::myvar} result1
+ set result1
+} -cleanup {
+ destroy .e
+} -result {can't trace "thisnsdoesntexist::myvar": parent namespace doesn't exist}
+
+# Gathered comments about lacks
+# XXX Still need to write tests for EntryBlinkProc, EntryFocusProc,
+# and EntryTextVarProc.
+# No tests for DisplayEntry.
+# XXX Still need to write tests for EntryScanTo and EntrySelectTo.
+# No tests for EventuallyRedraw
+
+# option clear
+# cleanup
+cleanupTests
+return
+
+
+
diff --git a/tk8.6/tests/event.test b/tk8.6/tests/event.test
new file mode 100644
index 0000000..756dbe5
--- /dev/null
+++ b/tk8.6/tests/event.test
@@ -0,0 +1,837 @@
+# This file is a Tcl script to test the code in tkEvent.c. It is
+# organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+# XXX This test file is woefully incomplete. Right now it only tests
+# a few of the procedures in tkEvent.c. Please add more tests whenever
+# possible.
+
+# Setup table used to query key events.
+
+proc _init_keypress_lookup {} {
+ global keypress_lookup
+
+ scan A %c start
+ scan Z %c finish
+
+ for {set i $start} {$i <= $finish} {incr i} {
+ set l [format %c $i]
+ set keypress_lookup($l) $l
+ }
+
+ scan a %c start
+ scan z %c finish
+
+ for {set i $start} {$i <= $finish} {incr i} {
+ set l [format %c $i]
+ set keypress_lookup($l) $l
+ }
+
+ scan 0 %c start
+ scan 9 %c finish
+
+ for {set i $start} {$i <= $finish} {incr i} {
+ set l [format %c $i]
+ set keypress_lookup($l) $l
+ }
+
+ # Most punctuation
+ array set keypress_lookup {
+ ! exclam
+ % percent
+ & ampersand
+ ( parenleft
+ ) parenright
+ * asterisk
+ + plus
+ , comma
+ - minus
+ . period
+ / slash
+ : colon
+ < less
+ = equal
+ > greater
+ ? question
+ @ at
+ ^ asciicircum
+ _ underscore
+ | bar
+ ~ asciitilde
+ ' apostrophe
+ }
+ # Characters with meaning to Tcl...
+ array set keypress_lookup [list \
+ \" quotedbl \
+ \# numbersign \
+ \$ dollar \
+ \; semicolon \
+ \[ bracketleft \
+ \\ backslash \
+ \] bracketright \
+ \{ braceleft \
+ \} braceright \
+ " " space \
+ "\n" Return \
+ "\t" Tab]
+}
+
+# Lookup an event in the keypress table.
+# For example:
+# Q -> Q
+# . -> period
+# / -> slash
+# Delete -> Delete
+# Escape -> Escape
+
+proc _keypress_lookup {char} {
+ global keypress_lookup
+
+ if {! [info exists keypress_lookup]} {
+ _init_keypress_lookup
+ }
+
+ if {$char == ""} {
+ error "empty char"
+ }
+
+ if {[info exists keypress_lookup($char)]} {
+ return $keypress_lookup($char)
+ } else {
+ return $char
+ }
+}
+
+# Lookup and generate a pair of KeyPress and KeyRelease events
+
+proc _keypress {win key} {
+ set keysym [_keypress_lookup $key]
+
+ # Force focus to the window before delivering
+ # each event so that a window manager using
+ # a focus follows mouse will not steal away
+ # the focus if the mouse is moved around.
+
+ if {[focus] != $win} {
+ focus -force $win
+ }
+ event generate $win <KeyPress-$keysym>
+ _pause 50
+ if {[focus] != $win} {
+ focus -force $win
+ }
+ event generate $win <KeyRelease-$keysym>
+ _pause 50
+}
+
+# Call _keypress for each character in the given string
+
+proc _keypress_string {win string} {
+ foreach letter [split $string ""] {
+ _keypress $win $letter
+ }
+}
+
+# Delay script execution for a given amount of time
+
+proc _pause {{msecs 1000}} {
+ global _pause
+
+ if {! [info exists _pause(number)]} {
+ set _pause(number) 0
+ }
+
+ set num [incr _pause(number)]
+ set _pause($num) 0
+
+ after $msecs "set _pause($num) 1"
+ vwait _pause($num)
+ unset _pause($num)
+}
+
+# Helper proc to convert index to x y position
+
+proc _text_ind_to_x_y {text ind} {
+ set bbox [$text bbox $ind]
+ if {[llength $bbox] != 4} {
+ error "got bbox \{$bbox\} from $text, index $ind"
+ }
+ foreach {x1 y1 width height} $bbox break
+ set middle_y [expr {$y1 + ($height / 2)}]
+ return [list $x1 $middle_y]
+}
+
+# Return selection only if owned by the given widget
+
+proc _get_selection {widget} {
+ if {[string compare $widget [selection own]] != 0} {
+ return ""
+ }
+ if {[catch {selection get} sel]} {
+ return ""
+ }
+ return $sel
+}
+
+# Begining of the actual tests
+
+test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} -setup {
+ deleteWindows
+ set x {}
+} -body {
+ button .b -text Test
+ pack .b
+ bindtags .b .b
+ update
+ bind .b <Destroy> {
+ lappend x destroy
+ event generate .b <1>
+ event generate .b <ButtonRelease-1>
+ }
+ bind .b <1> {
+ lappend x button
+ }
+
+ destroy .b
+ return $x
+} -cleanup {
+ deleteWindows
+} -result {destroy}
+test event-1.2 {event generate <Alt-z>} -setup {
+ deleteWindows
+ catch {unset ::event12result}
+} -body {
+ set ::event12result 0
+ pack [entry .e]
+ update
+ bind .e <Alt-z> {set ::event12result "1"}
+
+ focus -force .e
+ event generate .e <Alt-z>
+ destroy .e
+ set ::event12result
+} -cleanup {
+ deleteWindows
+} -result 1
+
+
+test event-2.1(keypress) {type into entry widget and hit Return} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+ set e [entry $t.e]
+ pack $e
+ set return_binding 0
+ bind $e <Return> {set return_binding 1}
+ tkwait visibility $e
+ _keypress_string $e HELLO\n
+ list [$e get] $return_binding
+} -cleanup {
+ deleteWindows
+} -result {HELLO 1}
+test event-2.2(keypress) {type into entry widget and then delete some text} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+ set e [entry $t.e]
+ pack $e
+ tkwait visibility $e
+ _keypress_string $e MELLO
+ _keypress $e BackSpace
+ _keypress $e BackSpace
+ $e get
+} -cleanup {
+ deleteWindows
+} -result {MEL}
+test event-2.3(keypress) {type into entry widget, triple click, hit Delete key,
+ and then type some more} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+ set e [entry $t.e]
+ pack $e
+ tkwait visibility $e
+ _keypress_string $e JUMP
+
+ set result [$e get]
+
+ event generate $e <Enter>
+ for {set i 0} {$i < 3} {incr i} {
+ _pause 100
+ event generate $e <ButtonPress-1>
+ _pause 100
+ event generate $e <ButtonRelease-1>
+ }
+
+ _keypress $e Delete
+ _keypress_string $e UP
+ lappend result [$e get]
+} -cleanup {
+ deleteWindows
+} -result {JUMP UP}
+test event-2.4(keypress) {type into text widget and hit Return} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+ set e [text $t.e]
+ pack $e
+ set return_binding 0
+ bind $e <Return> {set return_binding 1}
+ tkwait visibility $e
+ _keypress_string $e HELLO\n
+ list [$e get 1.0 end] $return_binding
+} -cleanup {
+ deleteWindows
+} -result [list "HELLO\n\n" 1]
+test event-2.5(keypress) {type into text widget and then delete some text} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+ set e [text $t.e]
+ pack $e
+ tkwait visibility $e
+ _keypress_string $e MELLO
+ _keypress $e BackSpace
+ _keypress $e BackSpace
+ $e get 1.0 1.end
+} -cleanup {
+ deleteWindows
+} -result {MEL}
+test event-2.6(keypress) {type into text widget, triple click,
+ hit Delete key, and then type some more} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+ set e [text $t.e]
+ pack $e
+ tkwait visibility $e
+ _keypress_string $e JUMP
+
+ set result [$e get 1.0 1.end]
+
+ event generate $e <Enter>
+ for {set i 0} {$i < 3} {incr i} {
+ _pause 100
+ event generate $e <ButtonPress-1>
+ _pause 100
+ event generate $e <ButtonRelease-1>
+ }
+
+ _keypress $e Delete
+ _keypress_string $e UP
+ lappend result [$e get 1.0 1.end]
+} -cleanup {
+ deleteWindows
+} -result {JUMP UP}
+
+test event-3.1(click-drag) {click and drag in a text widget, this tests
+ tkTextSelectTo in text.tcl} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+ set e [text $t.e]
+ pack $e
+ tkwait visibility $e
+ _keypress_string $e "A Tcl/Tk selection test!"
+ set anchor 1.6
+ set selend 1.18
+
+ set result [list]
+ lappend result [$e get 1.0 1.end]
+
+ # Get the x,y coords of the second T in "Tcl/Tk"
+ foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break
+
+ # Click down to set the insert cursor position
+ event generate $e <Enter>
+ event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
+
+ # Save the position of the insert cursor
+ lappend result [$e index insert]
+
+ # Now drag until selend is highlighted, then click up
+
+ set current $anchor
+ while {[$e compare $current <= $selend]} {
+ foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+ event generate $e <B1-Motion> -x $current_x -y $current_y
+ set current [$e index [list $current + 1 char]]
+ _pause 50
+ }
+
+ event generate $e <ButtonRelease-1> -x $current_x -y $current_y
+ _pause 200
+
+ # Save the position of the insert cursor
+ lappend result [$e index insert]
+
+ # Save the highlighted text
+ lappend result [_get_selection $e]
+
+ # Now click and click and drag to the left, over "Tcl/Tk selection"
+
+ event generate $e <ButtonPress-1> -x $current_x -y $current_y
+
+ while {[$e compare $current >= [list $anchor - 4 char]]} {
+ foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+ event generate $e <B1-Motion> -x $current_x -y $current_y
+ set current [$e index [list $current - 1 char]]
+ _pause 50
+ }
+
+ event generate $e <ButtonRelease-1> -x $current_x -y $current_y
+ _pause 200
+
+ # Save the position of the insert cursor
+ lappend result [$e index insert]
+
+ # Save the highlighted text
+ lappend result [_get_selection $e]
+
+} -cleanup {
+ deleteWindows
+} -result {{A Tcl/Tk selection test!} 1.6 1.18 {Tk selection} 1.2 {Tcl/Tk selection}}
+ test event-3.2(click-drag) {click and drag in an entry widget, this
+ tests tkEntryMouseSelect in entry.tcl} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+ set e [entry $t.e]
+ pack $e
+ tkwait visibility $e
+ _keypress_string $e "A Tcl/Tk selection!"
+ set anchor 6
+ set selend 18
+
+ set result [list]
+ lappend result [$e get]
+
+ # Get the x,y coords of the second T in "Tcl/Tk"
+ foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break
+
+ # Click down to set the insert cursor position
+ event generate $e <Enter>
+ event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
+
+ # Save the position of the insert cursor
+ lappend result [$e index insert]
+
+ # Now drag until selend is highlighted, then click up
+
+ set current $anchor
+ while {$current <= $selend} {
+ foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+ event generate $e <B1-Motion> -x $current_x -y $current_y
+ incr current
+ _pause 50
+ }
+
+ event generate $e <ButtonRelease-1> -x $current_x -y $current_y
+ _pause 200
+
+ # Save the position of the insert cursor
+ lappend result [$e index insert]
+
+ # Save the highlighted text
+ lappend result [_get_selection $e]
+
+ # Now click and click and drag to the left, over "Tcl/Tk selection"
+
+ event generate $e <ButtonPress-1> -x $current_x -y $current_y
+
+ while {$current >= ($anchor - 4)} {
+ foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+ event generate $e <B1-Motion> -x $current_x -y $current_y
+ incr current -1
+ _pause 50
+ }
+
+ event generate $e <ButtonRelease-1> -x $current_x -y $current_y
+ _pause 200
+
+ # Save the position of the insert cursor
+ lappend result [$e index insert]
+
+ # Save the highlighted text
+ lappend result [_get_selection $e]
+
+} -cleanup {
+ deleteWindows
+} -result {{A Tcl/Tk selection!} 6 18 {Tk selection} 2 {Tcl/Tk selection}}
+
+
+test event-4.1(double-click-drag) {click down, click up, click down again,
+ then drag in a text widget} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+ set e [text $t.e]
+ pack $e
+ tkwait visibility $e
+ _keypress_string $e "Word select test"
+ set anchor 1.8
+
+ # Get the x,y coords of the second e in "select"
+ foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break
+
+ # Click down, release, then click down again
+ event generate $e <Enter>
+ event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
+ _pause 50
+ event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y
+ _pause 50
+ event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
+ _pause 50
+
+ # Save the highlighted text
+ set result [list]
+ lappend result [_get_selection $e]
+
+ # Insert cursor should be at beginning of "select"
+ lappend result [$e index insert]
+
+ # Move mouse one character to the left
+ set current [$e index [list $anchor - 1 char]]
+ foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+
+ event generate $e <B1-Motion> -x $current_x -y $current_y
+ _pause 50
+
+ # Insert cursor should be before the l in "select"
+ lappend result [$e index insert]
+
+ # Selection should still be the word "select"
+ lappend result [_get_selection $e]
+
+ # Move mouse to the space before the word "select"
+ set current [$e index [list $current - 3 char]]
+
+ foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+ event generate $e <B1-Motion> -x $current_x -y $current_y
+ _pause 200
+
+ lappend result [$e index insert]
+ lappend result [_get_selection $e]
+
+ # Move mouse to the r in "Word"
+ set current 1.2
+ foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+
+ event generate $e <B1-Motion> -x $current_x -y $current_y
+ _pause 50
+
+ # Selection should now be "Word select"
+ lappend result [_get_selection $e]
+
+ # Insert cursor should be before the r in "Word"
+ lappend result [$e index insert]
+
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {select 1.5 1.7 select 1.4 { select} {Word select} 1.2}
+test event-4.2(double-click-drag) {click down, click up, click down again,
+ then drag in an entry widget} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+ set e [entry $t.e]
+ pack $e
+ tkwait visibility $e
+ _keypress_string $e "Word select test"
+
+ set anchor 8
+
+ # Get the x,y coords of the second e in "select"
+ foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break
+
+ # Click down, release, then click down again
+ event generate $e <Enter>
+ event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
+ _pause 50
+ event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y
+ _pause 50
+ event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
+ _pause 50
+
+ set result [list]
+ lappend result [_get_selection $e]
+
+ # Insert cursor should be at the end of "select"
+ lappend result [$e index insert]
+
+ # Move mouse one character to the left
+ set current [expr {$anchor - 1}]
+ foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+
+ event generate $e <B1-Motion> -x $current_x -y $current_y
+ _pause 50
+
+ # Insert cursor should be before the l in "select"
+ lappend result [$e index insert]
+
+ # Selection should still be the word "select"
+ lappend result [_get_selection $e]
+
+ # Move mouse to the space before the word "select"
+ set current [expr {$current - 3}]
+ foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+
+ event generate $e <B1-Motion> -x $current_x -y $current_y
+ _pause 50
+
+ lappend result [$e index insert]
+ lappend result [_get_selection $e]
+
+ # Move mouse to the r in "Word"
+ set current [expr {$current - 2}]
+ foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+
+ event generate $e <B1-Motion> -x $current_x -y $current_y
+ _pause 50
+
+ # Selection should now be "Word select"
+ lappend result [_get_selection $e]
+
+ # Insert cursor should be before the r in "Word"
+ lappend result [$e index insert]
+
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {select 11 7 select 4 { select} {Word select} 2}
+
+test event-5.1(triple-click-drag) {Triple click and drag across lines in a
+ text widget, this should extend the selection to the new line} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+ set e [text $t.e]
+ pack $e
+ tkwait visibility $e
+ _keypress_string $e "LINE ONE\nLINE TWO\nLINE THREE"
+
+ set anchor 3.2
+
+ # Triple click one third line leaving mouse down
+
+ foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break
+
+ event generate $e <Enter>
+
+ event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
+ _pause 50
+ event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y
+ _pause 50
+
+ event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
+ _pause 50
+ event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y
+ _pause 50
+
+ event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y
+ _pause 50
+
+ set result [list]
+ lappend result [_get_selection $e]
+
+ # Drag up to second line
+
+ set current [$e index [list $anchor - 1 line]]
+ foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+
+ event generate $e <B1-Motion> -x $current_x -y $current_y
+ _pause 50
+
+ lappend result [_get_selection $e]
+
+ # Drag up to first line
+
+ set current [$e index [list $current - 1 line]]
+ foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+
+ event generate $e <B1-Motion> -x $current_x -y $current_y
+ _pause 50
+
+ lappend result [_get_selection $e]
+
+ return $result
+} -cleanup {
+ deleteWindows
+} -result [list "LINE THREE\n" "LINE TWO\nLINE THREE\n" \
+ "LINE ONE\nLINE TWO\nLINE THREE\n"]
+
+test event-6.1(button-state) {button press in a window that is then
+ destroyed, when the mouse is moved into another window it
+ should not generate a <B1-motion> event since the mouse
+ was not pressed down in that window} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+
+ event generate $t <ButtonPress-1>
+ destroy $t
+ set t [toplevel .t]
+ set motion nomotion
+ bind $t <B1-Motion> {set motion inmotion}
+ event generate $t <Motion>
+ return $motion
+} -cleanup {
+ deleteWindows
+} -result {nomotion}
+
+test event-7.1(double-click) {A double click on a lone character
+ in a text widget should select that character} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+ set e [text $t.e]
+ pack $e
+ tkwait visibility $e
+ focus -force $e
+ _keypress_string $e "On A letter"
+
+ set anchor 1.3
+
+ # Get x,y coords just inside the left
+ # and right hand side of the letter A
+ foreach {x1 y1 width height} [$e bbox $anchor] break
+
+ set middle_y [expr {$y1 + ($height / 2)}]
+
+ set left_x [expr {$x1 + 2}]
+ set left_y $middle_y
+
+ set right_x [expr {($x1 + $width) - 2}]
+ set right_y $middle_y
+
+ # Double click near left hand egde of the letter A
+
+ event generate $e <Enter>
+ event generate $e <ButtonPress-1> -x $left_x -y $left_y
+ _pause 50
+ event generate $e <ButtonRelease-1> -x $left_x -y $left_y
+ _pause 50
+ event generate $e <ButtonPress-1> -x $left_x -y $left_y
+ _pause 50
+ event generate $e <ButtonRelease-1> -x $left_x -y $left_y
+ _pause 50
+
+ set result [list]
+ lappend result [$e index insert]
+ lappend result [_get_selection $e]
+
+ # Clear selection by clicking at 0,0
+
+ event generate $e <ButtonPress-1> -x 0 -y 0
+ _pause 50
+ event generate $e <ButtonRelease-1> -x 0 -y 0
+ _pause 50
+
+ # Double click near right hand edge of the letter A
+
+ event generate $e <ButtonPress-1> -x $right_x -y $right_y
+ _pause 50
+ event generate $e <ButtonRelease-1> -x $right_x -y $right_y
+ _pause 50
+ event generate $e <ButtonPress-1> -x $right_x -y $right_y
+ _pause 50
+ event generate $e <ButtonRelease-1> -x $right_x -y $right_y
+ _pause 50
+
+ lappend result [$e index insert]
+ lappend result [_get_selection $e]
+
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {1.3 A 1.3 A}
+test event-7.2(double-click) {A double click on a lone character
+ in an entry widget should select that character} -setup {
+ deleteWindows
+} -body {
+ set t [toplevel .t]
+ set e [entry $t.e]
+ pack $e
+ tkwait visibility $e
+ focus -force $e
+ _keypress_string $e "On A letter"
+
+ set anchor 3
+
+ # Get x,y coords just inside the left
+ # and right hand side of the letter A
+ foreach {x1 y1 width height} [$e bbox $anchor] break
+
+ set middle_y [expr {$y1 + ($height / 2)}]
+
+ set left_x [expr {$x1 + 2}]
+ set left_y $middle_y
+
+ set right_x [expr {($x1 + $width) - 2}]
+ set right_y $middle_y
+
+ # Double click near left hand egde of the letter A
+
+ event generate $e <Enter>
+ event generate $e <ButtonPress-1> -x $left_x -y $left_y
+ _pause 50
+ event generate $e <ButtonRelease-1> -x $left_x -y $left_y
+ _pause 50
+ event generate $e <ButtonPress-1> -x $left_x -y $left_y
+ _pause 50
+ event generate $e <ButtonRelease-1> -x $left_x -y $left_y
+ _pause 50
+
+ set result [list]
+ lappend result [$e index insert]
+ lappend result [_get_selection $e]
+
+ # Clear selection by clicking at 0,0
+
+ event generate $e <ButtonPress-1> -x 0 -y 0
+ _pause 50
+ event generate $e <ButtonRelease-1> -x 0 -y 0
+ _pause 50
+
+ # Double click near right hand edge of the letter A
+
+ event generate $e <ButtonPress-1> -x $right_x -y $right_y
+ _pause 50
+ event generate $e <ButtonRelease-1> -x $right_x -y $right_y
+ _pause 50
+ event generate $e <ButtonPress-1> -x $right_x -y $right_y
+ _pause 50
+ event generate $e <ButtonRelease-1> -x $right_x -y $right_y
+ _pause 50
+
+ lappend result [$e index insert]
+ lappend result [_get_selection $e]
+
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {4 A 4 A}
+
+# cleanup
+unset -nocomplain keypress_lookup
+rename _init_keypress_lookup {}
+rename _keypress_lookup {}
+rename _keypress {}
+rename _pause {}
+rename _text_ind_to_x_y {}
+rename _get_selection {}
+
+cleanupTests
+return
+
+
diff --git a/tk8.6/tests/face.xbm b/tk8.6/tests/face.xbm
new file mode 100644
index 0000000..03d829f
--- /dev/null
+++ b/tk8.6/tests/face.xbm
@@ -0,0 +1,173 @@
+#define face_width 108
+#define face_height 144
+#define face_x_hot 48
+#define face_y_hot 80
+static char face_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x20, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x08, 0x09,
+ 0x20, 0x80, 0x24, 0x05, 0x00, 0x80, 0x08, 0x00, 0x00, 0x00, 0x00, 0x88,
+ 0x24, 0x20, 0x80, 0x24, 0x00, 0x00, 0x00, 0x10, 0x80, 0x04, 0x00, 0x01,
+ 0x00, 0x01, 0x40, 0x0a, 0x09, 0x00, 0x92, 0x04, 0x80, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x10, 0x40, 0x12, 0x00, 0x00, 0x10, 0x40, 0x00, 0x00, 0x84,
+ 0x24, 0x40, 0x22, 0xa8, 0x02, 0x14, 0x84, 0x92, 0x40, 0x42, 0x12, 0x04,
+ 0x10, 0x00, 0x00, 0x00, 0x00, 0x52, 0x00, 0x52, 0x11, 0x00, 0x12, 0x00,
+ 0x40, 0x02, 0x00, 0x20, 0x00, 0x08, 0x00, 0xaa, 0x02, 0x54, 0x85, 0x24,
+ 0x00, 0x10, 0x12, 0x00, 0x00, 0x81, 0x44, 0x00, 0x90, 0x5a, 0x00, 0xea,
+ 0x1b, 0x00, 0x80, 0x40, 0x40, 0x02, 0x00, 0x08, 0x00, 0x20, 0xa2, 0x05,
+ 0x8a, 0xb4, 0x6e, 0x45, 0x12, 0x04, 0x08, 0x00, 0x00, 0x00, 0x10, 0x02,
+ 0xa8, 0x92, 0x00, 0xda, 0x5f, 0x10, 0x00, 0x10, 0xa1, 0x04, 0x20, 0x41,
+ 0x02, 0x00, 0x5a, 0x25, 0xa0, 0xff, 0xfb, 0x05, 0x41, 0x02, 0x04, 0x00,
+ 0x00, 0x08, 0x40, 0x80, 0xec, 0x9b, 0xec, 0xfe, 0x7f, 0x01, 0x04, 0x20,
+ 0x90, 0x02, 0x04, 0x00, 0x08, 0x20, 0xfb, 0x2e, 0xf5, 0xff, 0xff, 0x57,
+ 0x00, 0x04, 0x02, 0x00, 0x00, 0x20, 0x01, 0xc1, 0x6e, 0xab, 0xfa, 0xff,
+ 0xff, 0x05, 0x90, 0x20, 0x48, 0x02, 0x00, 0x04, 0x20, 0xa8, 0xdf, 0xb5,
+ 0xfe, 0xff, 0xff, 0x0b, 0x01, 0x00, 0x01, 0x00, 0x80, 0x80, 0x04, 0xe0,
+ 0xbb, 0xef, 0xff, 0xff, 0x7f, 0x01, 0x00, 0x04, 0x48, 0x02, 0x00, 0x20,
+ 0x80, 0xf4, 0x6f, 0xfb, 0xff, 0xff, 0xff, 0x20, 0x90, 0x40, 0x02, 0x00,
+ 0x00, 0x04, 0x08, 0xb8, 0xf6, 0xff, 0xff, 0xdf, 0xbe, 0x12, 0x45, 0x10,
+ 0x90, 0x04, 0x90, 0x00, 0x22, 0xfa, 0xff, 0xff, 0xff, 0xbb, 0xd7, 0xe9,
+ 0x3a, 0x02, 0x02, 0x00, 0x04, 0x90, 0x80, 0xfe, 0xdf, 0xf6, 0xb7, 0xef,
+ 0xbe, 0x56, 0x57, 0x40, 0x48, 0x09, 0x00, 0x04, 0x00, 0xfa, 0xf5, 0xdf,
+ 0xed, 0x5a, 0xd5, 0xea, 0xbd, 0x09, 0x00, 0x00, 0x40, 0x00, 0x92, 0xfe,
+ 0xbf, 0x7d, 0xb7, 0x6a, 0x55, 0xbf, 0xf7, 0x02, 0x11, 0x01, 0x00, 0x91,
+ 0x00, 0xff, 0xff, 0xaf, 0x55, 0x55, 0x5b, 0xeb, 0xef, 0x22, 0x04, 0x04,
+ 0x04, 0x00, 0xa4, 0xff, 0xf7, 0xad, 0xaa, 0xaa, 0xaa, 0xbe, 0xfe, 0x03,
+ 0x20, 0x00, 0x10, 0x44, 0x80, 0xff, 0x7f, 0x55, 0x12, 0x91, 0x2a, 0xeb,
+ 0xbf, 0x0b, 0x82, 0x02, 0x00, 0x00, 0xd1, 0x7f, 0xdf, 0xa2, 0xa4, 0x54,
+ 0x55, 0xfd, 0xfd, 0x47, 0x08, 0x08, 0x00, 0x21, 0xe4, 0xff, 0x37, 0x11,
+ 0x09, 0xa5, 0xaa, 0xb6, 0xff, 0x0d, 0x80, 0x00, 0x00, 0x04, 0xd0, 0xff,
+ 0x4f, 0x44, 0x20, 0x48, 0x55, 0xfb, 0xff, 0x27, 0x11, 0x02, 0x40, 0x40,
+ 0xe2, 0xfb, 0x15, 0x11, 0x4a, 0x55, 0x4a, 0x7d, 0xf7, 0x0f, 0x00, 0x00,
+ 0x04, 0x08, 0xf8, 0xdf, 0x52, 0x44, 0x01, 0x52, 0xb5, 0xfa, 0xff, 0x0f,
+ 0x49, 0x02, 0x00, 0x02, 0xe9, 0xf6, 0x0a, 0x11, 0xa4, 0x88, 0x4a, 0x6d,
+ 0xff, 0x5f, 0x00, 0x00, 0x10, 0x20, 0xf0, 0x2f, 0x21, 0x44, 0x10, 0x52,
+ 0xb5, 0xfa, 0xff, 0x0f, 0x44, 0x04, 0x80, 0x08, 0xf8, 0xab, 0x8a, 0x00,
+ 0x81, 0xa4, 0xd4, 0xd6, 0xfe, 0x2f, 0x00, 0x00, 0x04, 0x40, 0xb5, 0x2d,
+ 0x21, 0x08, 0x04, 0x90, 0xaa, 0xfa, 0xff, 0x1f, 0x11, 0x01, 0x00, 0x04,
+ 0xf0, 0x57, 0x0a, 0x22, 0x40, 0x4a, 0xda, 0x5e, 0xfb, 0x1f, 0x40, 0x00,
+ 0x40, 0x20, 0xba, 0x95, 0x90, 0x00, 0x01, 0xa0, 0xaa, 0xea, 0xff, 0x5f,
+ 0x02, 0x02, 0x00, 0x01, 0xe8, 0x57, 0x05, 0x00, 0x00, 0x12, 0xd5, 0xfe,
+ 0xfd, 0x1f, 0x48, 0x00, 0x04, 0x48, 0x7a, 0x95, 0x08, 0x02, 0x10, 0x40,
+ 0xaa, 0x55, 0xf7, 0x1f, 0x00, 0x09, 0x20, 0x00, 0xf8, 0x57, 0x22, 0x10,
+ 0x00, 0x28, 0xa9, 0xfa, 0xff, 0x5f, 0x02, 0x00, 0x00, 0x49, 0xdd, 0x29,
+ 0x01, 0x00, 0x80, 0x80, 0xaa, 0xd7, 0xff, 0x0f, 0x10, 0x00, 0x08, 0x00,
+ 0xf8, 0x96, 0x08, 0x00, 0x00, 0x20, 0x54, 0xfa, 0xee, 0x3f, 0x81, 0x04,
+ 0x40, 0x24, 0xfe, 0x55, 0x82, 0x00, 0x00, 0x82, 0xd2, 0xad, 0xff, 0x0f,
+ 0x08, 0x00, 0x04, 0x80, 0x6c, 0x97, 0x00, 0x00, 0x02, 0x20, 0xa9, 0xf6,
+ 0xdf, 0x5f, 0x00, 0x02, 0x20, 0x09, 0xfa, 0x49, 0x12, 0x00, 0x20, 0x84,
+ 0x54, 0xdb, 0xfe, 0x1f, 0x91, 0x00, 0x00, 0x00, 0xf8, 0x2b, 0x00, 0x20,
+ 0x00, 0x40, 0xa4, 0xf6, 0xbb, 0x1f, 0x04, 0x00, 0x44, 0x92, 0x7e, 0x95,
+ 0x02, 0x00, 0x00, 0x89, 0xaa, 0xdd, 0xff, 0x1f, 0x20, 0x09, 0x10, 0x00,
+ 0xf4, 0x57, 0x20, 0x01, 0x08, 0x20, 0xa9, 0x76, 0xff, 0x5f, 0x02, 0x00,
+ 0x00, 0x21, 0xfc, 0x4a, 0x05, 0x00, 0x01, 0x80, 0x54, 0xdb, 0xff, 0x1e,
+ 0x08, 0x02, 0x04, 0x08, 0xf9, 0x2b, 0x00, 0x00, 0x40, 0x28, 0xd2, 0xf6,
+ 0xff, 0xbf, 0x80, 0x00, 0x90, 0x00, 0xbc, 0x92, 0x08, 0x10, 0x00, 0x82,
+ 0x54, 0xdb, 0xff, 0x1f, 0x20, 0x00, 0x00, 0x44, 0xf9, 0x55, 0x02, 0x01,
+ 0x00, 0x20, 0xaa, 0xbd, 0xfd, 0x3f, 0x08, 0x04, 0x04, 0x10, 0xf4, 0x2a,
+ 0x01, 0x00, 0x22, 0x80, 0xd4, 0xf6, 0xff, 0x5f, 0x82, 0x00, 0x40, 0x02,
+ 0xf8, 0x55, 0x20, 0x00, 0x00, 0x50, 0x6a, 0xdf, 0xfe, 0x3f, 0x00, 0x00,
+ 0x00, 0x48, 0xe9, 0x4a, 0x05, 0x08, 0x00, 0xa5, 0xd5, 0xf5, 0xff, 0x3f,
+ 0x10, 0x01, 0x10, 0x01, 0xb0, 0xab, 0x92, 0x02, 0x40, 0xf8, 0xbf, 0xde,
+ 0xfe, 0x5f, 0x02, 0x04, 0x04, 0x48, 0xfa, 0xd4, 0x6f, 0x20, 0x84, 0xef,
+ 0xff, 0xfb, 0xff, 0x1f, 0x20, 0x00, 0x00, 0x00, 0xe0, 0xed, 0xbf, 0x0b,
+ 0xa1, 0x7e, 0xff, 0xbf, 0xfd, 0x5f, 0x04, 0x01, 0x20, 0x49, 0xd2, 0xfb,
+ 0xfe, 0x55, 0xd4, 0xff, 0xff, 0xf6, 0xff, 0x07, 0x00, 0x04, 0x00, 0x00,
+ 0xc0, 0xaa, 0xfb, 0x2b, 0xa2, 0xfe, 0xff, 0xdf, 0xee, 0x1f, 0x91, 0x00,
+ 0x82, 0xa4, 0xa4, 0xf5, 0xff, 0x57, 0xd5, 0xff, 0xbf, 0xfd, 0xff, 0x4d,
+ 0x00, 0x00, 0x20, 0x00, 0x88, 0x5b, 0xff, 0x2f, 0x69, 0xff, 0xff, 0xdb,
+ 0xfe, 0x1f, 0x24, 0x02, 0x00, 0x49, 0xa2, 0xd6, 0xff, 0x5f, 0xea, 0xff,
+ 0x7f, 0x7f, 0x7f, 0x0d, 0x00, 0x00, 0x10, 0x00, 0x40, 0xab, 0xf7, 0xbb,
+ 0xf0, 0xdf, 0xff, 0xd5, 0xff, 0xbf, 0x82, 0x04, 0x42, 0x24, 0x91, 0xd5,
+ 0xaa, 0xae, 0xd4, 0xaa, 0x52, 0x7b, 0xff, 0x15, 0x08, 0x00, 0x00, 0x01,
+ 0x04, 0x55, 0xd5, 0x55, 0x70, 0x5b, 0x75, 0xdd, 0xdf, 0x1f, 0x40, 0x00,
+ 0x08, 0x48, 0xa0, 0x4a, 0xa9, 0x56, 0xea, 0x56, 0xad, 0x6a, 0x7d, 0x9b,
+ 0x04, 0x01, 0x00, 0x02, 0x42, 0x2a, 0xd5, 0xaa, 0xa8, 0xaa, 0xaa, 0xfa,
+ 0xdf, 0x2f, 0x10, 0x04, 0x22, 0x48, 0x08, 0x45, 0x2a, 0x15, 0x68, 0x55,
+ 0x55, 0xd7, 0x76, 0x1b, 0x00, 0x00, 0x00, 0x01, 0x40, 0x2a, 0x80, 0xa0,
+ 0xb2, 0x09, 0x48, 0xb9, 0xdf, 0x17, 0x22, 0x01, 0x00, 0x24, 0x45, 0x8a,
+ 0x24, 0x4a, 0x54, 0x51, 0x91, 0xf6, 0x6e, 0x4b, 0x00, 0x04, 0x90, 0x00,
+ 0x80, 0x52, 0x00, 0x20, 0x69, 0x05, 0xa4, 0xaa, 0xff, 0x1e, 0x48, 0x00,
+ 0x02, 0x92, 0x08, 0x05, 0x81, 0x94, 0xd4, 0x92, 0x40, 0xfd, 0xb6, 0x8b,
+ 0x00, 0x01, 0x40, 0x00, 0x82, 0x54, 0x00, 0x48, 0x68, 0x05, 0x90, 0xa4,
+ 0xef, 0x06, 0x24, 0x00, 0x08, 0x12, 0x10, 0x05, 0x00, 0x10, 0xb5, 0x01,
+ 0x42, 0xfb, 0xbf, 0x43, 0x00, 0x09, 0x00, 0x40, 0x81, 0xa8, 0x08, 0x4a,
+ 0xaa, 0x96, 0x90, 0xac, 0x6d, 0x15, 0x22, 0x00, 0x20, 0x09, 0x04, 0x15,
+ 0x80, 0x28, 0xdc, 0x01, 0x24, 0xfb, 0xbf, 0x01, 0x80, 0x04, 0x09, 0x00,
+ 0x40, 0x48, 0x02, 0x45, 0xb2, 0x2e, 0x41, 0x6d, 0xef, 0x05, 0x11, 0x00,
+ 0x40, 0x52, 0x02, 0x15, 0x29, 0x2a, 0xac, 0x42, 0x54, 0xfb, 0x3b, 0x51,
+ 0x84, 0x00, 0x08, 0x00, 0x20, 0x54, 0x80, 0x05, 0xb5, 0x3d, 0xa2, 0xb6,
+ 0xdf, 0x00, 0x20, 0x04, 0x20, 0x49, 0x89, 0xa8, 0x6a, 0x29, 0xac, 0xd6,
+ 0x54, 0xff, 0x3f, 0x84, 0x00, 0x01, 0x04, 0x10, 0x00, 0x94, 0xa8, 0x56,
+ 0xda, 0x5f, 0xab, 0xd5, 0x1e, 0x10, 0x48, 0x00, 0x90, 0x82, 0x48, 0xa8,
+ 0xb2, 0xac, 0xfd, 0x55, 0xd5, 0xfe, 0x9f, 0x80, 0x00, 0x0a, 0x02, 0x08,
+ 0x02, 0x55, 0x5a, 0x75, 0xff, 0xaf, 0xb6, 0xf7, 0x2d, 0x12, 0x92, 0x00,
+ 0x10, 0x20, 0x10, 0xa8, 0x54, 0xd5, 0xbf, 0x5d, 0xad, 0xdd, 0x0f, 0x00,
+ 0x00, 0x04, 0x40, 0x09, 0x84, 0xa8, 0xaa, 0x5a, 0xed, 0xeb, 0x6a, 0xff,
+ 0x9f, 0xa4, 0x24, 0x01, 0x02, 0xa0, 0x20, 0x50, 0x55, 0xd5, 0xbe, 0xae,
+ 0xad, 0xfd, 0x16, 0x00, 0x10, 0x04, 0x20, 0x0a, 0x08, 0xb4, 0xaa, 0x95,
+ 0xaa, 0x7b, 0xb7, 0xdb, 0x5f, 0x92, 0x04, 0x01, 0x84, 0x20, 0x21, 0x51,
+ 0xd5, 0x2a, 0xa9, 0xee, 0xd5, 0xfe, 0x0d, 0x00, 0x20, 0x04, 0x10, 0x00,
+ 0x08, 0x50, 0xe9, 0xd7, 0xd4, 0xfb, 0xb5, 0xff, 0x9f, 0x24, 0x09, 0x01,
+ 0x42, 0x4a, 0xa2, 0x64, 0xd5, 0x55, 0x7b, 0x7f, 0xda, 0x7d, 0x4f, 0x00,
+ 0x20, 0x04, 0x00, 0x80, 0x00, 0xa0, 0x2a, 0x13, 0x84, 0x6a, 0x55, 0xff,
+ 0x1d, 0x48, 0x8a, 0x00, 0x94, 0x24, 0x8a, 0xc8, 0xaa, 0x42, 0x20, 0x5d,
+ 0xf5, 0xff, 0x5f, 0x01, 0x00, 0x02, 0x01, 0x00, 0x20, 0xa2, 0x4a, 0x1a,
+ 0x82, 0x56, 0xda, 0xbd, 0x3f, 0x92, 0x92, 0x00, 0x90, 0x92, 0x00, 0x40,
+ 0x95, 0x6a, 0xf4, 0x55, 0x6d, 0xff, 0xd6, 0x00, 0x00, 0x0a, 0x04, 0x20,
+ 0x14, 0x49, 0x4b, 0xaa, 0xaa, 0x56, 0xf5, 0xff, 0xbf, 0xab, 0xa4, 0x00,
+ 0x20, 0x89, 0x40, 0x80, 0xaa, 0xaa, 0xaa, 0xaa, 0xde, 0xbf, 0xeb, 0x03,
+ 0x00, 0x02, 0x04, 0x02, 0x0a, 0x10, 0x2b, 0x2a, 0x55, 0x5b, 0xf5, 0xff,
+ 0xd7, 0x2f, 0x92, 0x00, 0x10, 0x28, 0x21, 0x01, 0x56, 0x95, 0xa0, 0x56,
+ 0xdf, 0xef, 0xea, 0x87, 0x40, 0x0a, 0x42, 0x41, 0x00, 0x90, 0xaa, 0x52,
+ 0xb6, 0xad, 0xfa, 0xff, 0xd5, 0x2f, 0x14, 0x00, 0x00, 0x04, 0x95, 0x04,
+ 0xaa, 0xac, 0x55, 0x6b, 0xff, 0xb7, 0xea, 0x9f, 0x40, 0x02, 0x28, 0x51,
+ 0x00, 0x40, 0x58, 0xd5, 0xda, 0xd6, 0x6e, 0x7f, 0xf9, 0x3f, 0x12, 0x04,
+ 0x02, 0x04, 0x49, 0x25, 0x55, 0xaa, 0x77, 0xab, 0xff, 0x2b, 0xfd, 0x3f,
+ 0x48, 0x01, 0x20, 0x41, 0x00, 0x00, 0x58, 0xa9, 0xda, 0xea, 0xfd, 0xaf,
+ 0xfa, 0xff, 0x02, 0x04, 0x08, 0x14, 0x29, 0x49, 0x52, 0x55, 0x55, 0x55,
+ 0xff, 0x8d, 0xfe, 0x3f, 0xa8, 0x00, 0x02, 0x41, 0x00, 0x02, 0xa0, 0xa2,
+ 0xaa, 0xea, 0xff, 0x53, 0xfd, 0xff, 0x02, 0x04, 0x50, 0x04, 0x25, 0xa8,
+ 0x54, 0x49, 0x52, 0xb5, 0xbf, 0x8a, 0xfe, 0xff, 0xa9, 0x08, 0x04, 0x50,
+ 0x80, 0x02, 0xa1, 0x2a, 0x95, 0xea, 0xff, 0xa1, 0xff, 0xff, 0x03, 0x02,
+ 0x90, 0x02, 0x09, 0x08, 0x44, 0x49, 0x52, 0xbd, 0x7f, 0xca, 0xff, 0xff,
+ 0x2b, 0x09, 0x04, 0x48, 0x40, 0x82, 0x90, 0x56, 0xa9, 0xf6, 0xbf, 0xd0,
+ 0xff, 0xff, 0x47, 0x00, 0x50, 0x02, 0x15, 0x11, 0x40, 0x95, 0xaa, 0xfd,
+ 0x2f, 0xe9, 0xff, 0xff, 0x8f, 0x0a, 0x84, 0x50, 0x40, 0x84, 0x14, 0xaa,
+ 0x6a, 0xff, 0x5f, 0xf2, 0xff, 0xff, 0x7f, 0x00, 0x10, 0x02, 0x09, 0x10,
+ 0x40, 0x7d, 0xf7, 0xff, 0x0b, 0xfc, 0xff, 0xff, 0xaf, 0x02, 0x84, 0x50,
+ 0x42, 0x85, 0x12, 0xd0, 0xdd, 0xff, 0xa7, 0xf2, 0xff, 0xff, 0xff, 0x04,
+ 0x00, 0x0a, 0x08, 0x10, 0x48, 0xf8, 0xff, 0xff, 0x0a, 0xfe, 0xff, 0xff,
+ 0x7f, 0x03, 0xa4, 0x80, 0xa2, 0x8a, 0x02, 0x68, 0xff, 0xff, 0x52, 0xfd,
+ 0xff, 0xff, 0xff, 0x07, 0x00, 0x2a, 0x08, 0x20, 0x28, 0xdc, 0xff, 0x5f,
+ 0x05, 0xff, 0xff, 0xff, 0xff, 0x0d, 0x92, 0x40, 0x22, 0x09, 0x02, 0xea,
+ 0xfb, 0xaf, 0x48, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x12, 0x81, 0xa0,
+ 0x48, 0x9c, 0x6e, 0x93, 0xa2, 0xff, 0xff, 0xff, 0xff, 0x07, 0xa8, 0x40,
+ 0x28, 0x0a, 0x02, 0x74, 0xb5, 0x45, 0x81, 0xff, 0xff, 0xff, 0xff, 0x0f,
+ 0x02, 0x0a, 0x81, 0x20, 0x08, 0xae, 0xaa, 0x90, 0xe8, 0xff, 0xff, 0xff,
+ 0xff, 0x0f, 0x90, 0x40, 0x28, 0x88, 0x12, 0x58, 0x15, 0x50, 0xd0, 0xff,
+ 0xff, 0xff, 0xff, 0x0f, 0x44, 0x0a, 0x41, 0x21, 0x08, 0xae, 0x04, 0x14,
+ 0xf0, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x40, 0x14, 0x88, 0x04, 0xba,
+ 0x02, 0x28, 0xe8, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x42, 0x15, 0x41, 0x21,
+ 0x05, 0xad, 0x00, 0x05, 0xf8, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x40,
+ 0x24, 0x8a, 0x0e, 0x36, 0x00, 0x0a, 0xf4, 0xff, 0xff, 0xff, 0xff, 0x0f,
+ 0x42, 0x25, 0x90, 0xd0, 0x8b, 0xc2, 0x41, 0x05, 0xfc, 0xff, 0xff, 0xff,
+ 0xff, 0x0f, 0x10, 0x08, 0x05, 0xe8, 0x8e, 0x58, 0x80, 0x02, 0xfa, 0xff,
+ 0xff, 0xff, 0xff, 0x0f, 0x4a, 0x20, 0xa8, 0xba, 0x0b, 0x2b, 0x51, 0x01,
+ 0xfe, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x8a, 0x02, 0xe8, 0xaf, 0x84,
+ 0x90, 0x04, 0xfd, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x52, 0x21, 0x54, 0xbf,
+ 0x1f, 0x15, 0xa5, 0x02, 0xfe, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x08,
+ 0x01, 0xfa, 0xb6, 0xa4, 0x52, 0x40, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f,
+ 0x4a, 0xa2, 0x54, 0xef, 0x5f, 0x4b, 0xa4, 0x80, 0xff, 0xff, 0xff, 0xff,
+ 0xff, 0x0f, 0x80, 0x10, 0x82, 0xfe, 0xbf, 0x92, 0x52, 0x42, 0xff, 0xff,
+ 0xff, 0xff, 0xff, 0x0f, 0x12, 0x42, 0xa8, 0xbf, 0x1f, 0x24, 0x80, 0xa0,
+ 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x84, 0x28, 0x8a, 0xf7, 0x37, 0x80,
+ 0x52, 0x80, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x10, 0x82, 0xe0, 0xff,
+ 0x1f, 0x00, 0x20, 0xe1, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x84, 0x28,
+ 0xca, 0xff, 0x1f, 0x00, 0x00, 0xc0, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f,
+ 0x10, 0x42, 0xf0, 0xfd, 0x1b, 0x00, 0x50, 0xf0, 0xff, 0xff, 0xff, 0xff,
+ 0xff, 0x0f, 0xa4, 0x10, 0xc5, 0xff, 0x1f, 0x00, 0x00, 0xe0, 0xff, 0xff,
+ 0xff, 0xff, 0xff, 0x0f, 0x00, 0x22, 0xf8, 0xff, 0x0e, 0x00, 0x00, 0xf0,
+ 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0xaa, 0x88, 0xe2, 0xff, 0x0f, 0x10,
+ 0x00, 0xf0, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x25, 0xfa, 0xff,
+ 0x0f, 0x01, 0x11, 0xfd, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0xff, 0xfb,
+ 0xfb, 0xff, 0x7f, 0x5d, 0xd5, 0xfa, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f};
diff --git a/tk8.6/tests/filebox.test b/tk8.6/tests/filebox.test
new file mode 100644
index 0000000..7b9fa2c
--- /dev/null
+++ b/tk8.6/tests/filebox.test
@@ -0,0 +1,476 @@
+# This file is a Tcl script to test out Tk's "tk_getOpenFile" and
+# "tk_getSaveFile" commands. It is organized in the standard fashion
+# for Tcl tests.
+#
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test fileDialog-0.1 {GetFileName: file types: MakeFilter() fails} {
+ # MacOS type that is too long
+
+ set res [list [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0\0}}}} msg] $msg]
+ regsub -all "\0" $res {\\0}
+} {1 {bad Macintosh file type "\0\0\0\0\0"}}
+test fileDialog-0.2 {GetFileName: file types: MakeFilter() fails} {
+ # MacOS type that is too short, but looks ok in utf (4 bytes).
+
+ set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0}}}} msg]
+ regsub -all "\0" $msg {\\0} msg
+ list $x $msg
+} {1 {bad Macintosh file type "\0\0"}}
+
+set tk_strictMotif_old $tk_strictMotif
+
+#----------------------------------------------------------------------
+#
+# Procedures needed by this test file
+#
+#----------------------------------------------------------------------
+
+proc ToPressButton {parent btn} {
+ global isNative
+ if {!$isNative} {
+ after 100 SendButtonPress $parent $btn mouse
+ }
+}
+
+proc ToEnterFileByKey {parent fileName fileDir} {
+ global isNative
+ if {!$isNative} {
+ after 100 EnterFileByKey $parent [list $fileName] [list $fileDir]
+ }
+}
+
+proc PressButton {btn} {
+ event generate $btn <Enter>
+ event generate $btn <1> -x 5 -y 5
+ event generate $btn <ButtonRelease-1> -x 5 -y 5
+}
+
+proc EnterFileByKey {parent fileName fileDir} {
+ global tk_strictMotif
+ if {$parent == "."} {
+ set w .__tk_filedialog
+ } else {
+ set w $parent.__tk_filedialog
+ }
+ upvar ::tk::dialog::file::__tk_filedialog data
+
+ if {$tk_strictMotif} {
+ $data(sEnt) delete 0 end
+ $data(sEnt) insert 0 [file join $fileDir $fileName]
+ } else {
+ $data(ent) delete 0 end
+ $data(ent) insert 0 $fileName
+ }
+
+ update
+ SendButtonPress $parent ok mouse
+}
+
+proc SendButtonPress {parent btn type} {
+ global tk_strictMotif
+ if {$parent == "."} {
+ set w .__tk_filedialog
+ } else {
+ set w $parent.__tk_filedialog
+ }
+ upvar ::tk::dialog::file::__tk_filedialog data
+
+ set button $data($btn\Btn)
+ if ![winfo ismapped $button] {
+ update
+ }
+
+ if {$type == "mouse"} {
+ PressButton $button
+ } else {
+ event generate $w <Enter>
+ focus $w
+ event generate $button <Enter>
+ event generate $w <KeyPress> -keysym Return
+ }
+}
+
+
+#----------------------------------------------------------------------
+#
+# The test suite proper
+#
+#----------------------------------------------------------------------
+
+if {$tcl_platform(platform) == "unix"} {
+ set modes "0 1"
+} else {
+ set modes 1
+}
+
+set unknownOptionsMsg(tk_getOpenFile) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
+set unknownOptionsMsg(tk_getSaveFile) {bad option "-foo": must be -confirmoverwrite, -defaultextension, -filetypes, -initialdir, -initialfile, -parent, -title, or -typevariable}
+
+set tmpFile "filebox.tmp"
+makeFile {
+ # this file can be empty!
+} $tmpFile
+
+array set filters {
+ 1 {}
+ 2 {
+ {"Text files" {.txt .doc} }
+ {"Text files" {} TEXT}
+ {"Tcl Scripts" {.tcl} TEXT}
+ {"C Source Files" {.c .h} }
+ {"All Source Files" {.tcl .c .h} }
+ {"Image Files" {.gif} }
+ {"Image Files" {.jpeg .jpg} }
+ {"Image Files" "" {GIFF JPEG}}
+ {"All files" *}
+ }
+ 3 {
+ {"Text files" {.txt .doc} TEXT}
+ {"Foo" {""} TEXT}
+ }
+}
+
+foreach mode $modes {
+ #
+ # Test both the motif version and the "tk" version of the file dialog
+ # box on Unix.
+ #
+ # Note that this means that test names are unusually complex.
+ #
+
+ set addedExtensions {}
+ if {$tcl_platform(platform) == "unix"} {
+ set tk_strictMotif $mode
+ # Extension adding is only done when using the non-motif file
+ # box with an extension-less filename
+ if {!$mode} {
+ set addedExtensions {NONE {} .txt .txt}
+ }
+ }
+
+ test filebox-1.1-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -foo
+ } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile)
+
+ catch {tk_getOpenFile -foo 1} msg
+ regsub -all , $msg "" options
+ regsub \"-foo\" $options "" options
+
+ foreach option $options {
+ if {[string index $option 0] eq "-"} {
+ test filebox-1.2-$mode$option "tk_getOpenFile command" -body {
+ tk_getOpenFile $option
+ } -returnCodes error -result "value for \"$option\" missing"
+ }
+ }
+
+ test filebox-1.3-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -foo bar
+ } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile)
+ test filebox-1.4-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -initialdir
+ } -returnCodes error -result {value for "-initialdir" missing}
+ test filebox-1.5-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -parent foo.bar
+ } -returnCodes error -result {bad window path name "foo.bar"}
+ test filebox-1.6-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -filetypes {Foo}
+ } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}
+
+ set isNative [expr {
+ [info commands ::tk::MotifFDialog] eq "" &&
+ [info commands ::tk::dialog::file::] eq ""
+ }]
+
+ set parent .
+
+ set verylongstring longstring:
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ # set verylongstring $verylongstring$verylongstring
+ # set verylongstring $verylongstring$verylongstring
+ # set verylongstring $verylongstring$verylongstring
+ # set verylongstring $verylongstring$verylongstring
+ # set verylongstring $verylongstring$verylongstring
+
+ set color #404040
+ test filebox-2.1-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ ToPressButton $parent cancel
+ tk_getOpenFile -title "Press Cancel ($verylongstring)" -parent $parent
+ } ""
+
+ set fileName $tmpFile
+ set fileDir [tcltest::temporaryDirectory]
+ set pathName [file join $fileDir $fileName]
+
+ test filebox-2.2-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getOpenFile -title "Press Ok" \
+ -parent $parent -initialfile $fileName -initialdir $fileDir]
+ } $pathName
+ test filebox-2.3-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ ToEnterFileByKey $parent $fileName $fileDir
+ set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \
+ -parent $parent -initialdir $fileDir]
+ } $pathName
+ test filebox-2.4-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ cd $fileDir
+ ToPressButton $parent ok
+ set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \
+ -parent $parent -initialdir . -initialfile $fileName]
+ } $pathName
+ test filebox-2.5-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \
+ -parent $parent -initialdir /badpath -initialfile $fileName]
+ } $pathName
+ test filebox-2.6-$mode "tk_getOpenFile command" -setup {
+ toplevel .t1; toplevel .t2
+ wm geometry .t1 +0+0
+ wm geometry .t2 +0+0
+ } -constraints nonUnixUserInteraction -body {
+ set choice {}
+ ToPressButton .t1 ok
+ lappend choice [tk_getOpenFile \
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t1 -initialdir $fileDir \
+ -initialfile $fileName]
+ ToPressButton .t2 ok
+ lappend choice [tk_getOpenFile \
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t2 -initialdir $fileDir \
+ -initialfile $fileName]
+ ToPressButton .t1 ok
+ lappend choice [tk_getOpenFile \
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t1 -initialdir $fileDir \
+ -initialfile $fileName]
+ } -result [list $pathName $pathName $pathName] -cleanup {
+ destroy .t1
+ destroy .t2
+ }
+
+ foreach x [lsort -integer [array names filters]] {
+ test filebox-3.$x-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getOpenFile -title "Press Ok" \
+ -filetypes $filters($x) -parent $parent \
+ -initialfile $fileName -initialdir $fileDir]
+ } $pathName
+ }
+ foreach {x res} [list 1 "-unset-" 2 "Text files"] {
+ set t [expr {$x + [llength [array names filters]]}]
+ test filebox-3.$t-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ catch {unset tv}
+ catch {unset typeName}
+ ToPressButton $parent ok
+ if {[info exists tv]} {
+ } else {
+ }
+ set choice [tk_getOpenFile -title "Press Ok" \
+ -filetypes $filters($x) -parent $parent \
+ -initialfile $fileName -initialdir $fileDir \
+ -typevariable tv]
+ if {[info exists tv]} {
+ regexp {^(.*) \(.*\)$} $tv dummy typeName
+ } else {
+ set typeName "-unset-"
+ }
+ set typeName
+ } $res
+ }
+
+ test filebox-4.1-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -foo
+ } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile)
+
+ catch {tk_getSaveFile -foo 1} msg
+ regsub -all , $msg "" options
+ regsub \"-foo\" $options "" options
+
+ foreach option $options {
+ if {[string index $option 0] eq "-"} {
+ test filebox-4.2-$mode$option "tk_getSaveFile command" -body {
+ tk_getSaveFile $option
+ } -returnCodes error -result "value for \"$option\" missing"
+ }
+ }
+
+ test filebox-4.3-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -foo bar
+ } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile)
+ test filebox-4.4-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -initialdir
+ } -returnCodes error -result {value for "-initialdir" missing}
+ test filebox-4.5-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -parent foo.bar
+ } -returnCodes error -result {bad window path name "foo.bar"}
+ test filebox-4.6-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -filetypes {Foo}
+ } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}
+
+ set isNative [expr {
+ [info commands ::tk::MotifFDialog] eq "" &&
+ [info commands ::tk::dialog::file::] eq ""
+ }]
+
+ set parent .
+
+ set verylongstring longstring:
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ # set verylongstring $verylongstring$verylongstring
+ # set verylongstring $verylongstring$verylongstring
+ # set verylongstring $verylongstring$verylongstring
+ # set verylongstring $verylongstring$verylongstring
+ # set verylongstring $verylongstring$verylongstring
+
+ set color #404040
+ test filebox-5.1-$mode "tk_getSaveFile command" nonUnixUserInteraction {
+ ToPressButton $parent cancel
+ tk_getSaveFile -title "Press Cancel ($verylongstring)" -parent $parent
+ } ""
+
+ set fileName "12x 455"
+ set fileDir [pwd]
+ set pathName [file join [pwd] $fileName]
+
+ test filebox-5.2-$mode "tk_getSaveFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getSaveFile -title "Press Ok" \
+ -parent $parent -initialfile $fileName -initialdir $fileDir]
+ } $pathName
+ test filebox-5.3-$mode "tk_getSaveFile command" nonUnixUserInteraction {
+ ToEnterFileByKey $parent $fileName $fileDir
+ set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \
+ -parent $parent -initialdir $fileDir]
+ } $pathName
+ test filebox-5.4-$mode "tk_getSaveFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \
+ -parent $parent -initialdir . -initialfile $fileName]
+ } $pathName
+ test filebox-5.5-$mode "tk_getSaveFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \
+ -parent $parent -initialdir /badpath -initialfile $fileName]
+ } $pathName
+
+ test filebox-5.6-$mode "tk_getSaveFile command" -setup {
+ toplevel .t1; toplevel .t2
+ wm geometry .t1 +0+0
+ wm geometry .t2 +0+0
+ } -constraints nonUnixUserInteraction -body {
+ set choice {}
+ ToPressButton .t1 ok
+ lappend choice [tk_getSaveFile \
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t1 -initialdir $fileDir -initialfile $fileName]
+ ToPressButton .t2 ok
+ lappend choice [tk_getSaveFile \
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t2 -initialdir $fileDir -initialfile $fileName]
+ ToPressButton .t1 ok
+ lappend choice [tk_getSaveFile \
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t1 -initialdir $fileDir -initialfile $fileName]
+ } -result [list $pathName $pathName $pathName] -cleanup {
+ destroy .t1
+ destroy .t2
+ }
+
+ foreach x [lsort -integer [array names filters]] {
+ test filebox-6.$x-$mode "tk_getSaveFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getSaveFile -title "Press Ok" \
+ -filetypes $filters($x) -parent $parent \
+ -initialfile $fileName -initialdir $fileDir]
+ } $pathName[lindex $addedExtensions $x]
+ }
+
+ if {!$mode} {
+
+ test filebox-7.1-$mode "tk_getOpenFile - directory not readable" \
+ -constraints nonUnixUserInteraction \
+ -setup {
+ rename ::tk_messageBox ::saved_messageBox
+ set ::gotmessage {}
+ proc tk_messageBox args {
+ set ::gotmessage $args
+ }
+ toplevel .t1
+ file mkdir [file join $fileDir NOTREADABLE]
+ file attributes [file join $fileDir NOTREADABLE] \
+ -permissions 300
+ } \
+ -cleanup {
+ rename ::tk_messageBox {}
+ rename ::saved_messageBox ::tk_messageBox
+ unset ::gotmessage
+ destroy .t1
+ file delete -force [file join $fileDir NOTREADABLE]
+ } \
+ -body {
+ ToEnterFileByKey .t1 NOTREADABLE $fileDir
+ ToPressButton .t1 ok
+ ToPressButton .t1 cancel
+ tk_getOpenFile -parent .t1 \
+ -title "Please select the NOTREADABLE directory" \
+ -initialdir $fileDir
+ set gotmessage
+ } \
+ -match glob \
+ -result "*NOTREADABLE*"
+
+ test filebox-7.2-$mode "tk_getOpenFile - bad file name" \
+ -constraints nonUnixUserInteraction \
+ -setup {
+ rename ::tk_messageBox ::saved_messageBox
+ set ::gotmessage {}
+ proc tk_messageBox args {
+ set ::gotmessage $args
+ }
+ toplevel .t1
+ } \
+ -cleanup {
+ rename ::tk_messageBox {}
+ rename ::saved_messageBox ::tk_messageBox
+ unset ::gotmessage
+ destroy .t1
+ } \
+ -body {
+ ToEnterFileByKey .t1 RUBBISH $fileDir
+ ToPressButton .t1 ok
+ ToPressButton .t1 cancel
+ tk_getOpenFile -parent .t1 \
+ -title "Please enter RUBBISH as a file name" \
+ -initialdir $fileDir
+ set gotmessage
+ } \
+ -match glob \
+ -result "*RUBBISH*"
+ }
+
+ # The rest of the tests need to be executed on Unix only.
+ # The test whether the dialog box widgets were implemented correctly.
+ # These tests are not
+ # needed on the other platforms because they use native file dialogs.
+}
+
+set tk_strictMotif $tk_strictMotif_old
+
+# cleanup
+removeFile filebox.tmp
+cleanupTests
+return
diff --git a/tk8.6/tests/flagdown.xbm b/tk8.6/tests/flagdown.xbm
new file mode 100644
index 0000000..55abc51
--- /dev/null
+++ b/tk8.6/tests/flagdown.xbm
@@ -0,0 +1,27 @@
+#define flagdown_width 48
+#define flagdown_height 48
+static char flagdown_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00,
+ 0x00, 0x00, 0x80, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xe0, 0xe1, 0x00, 0x00,
+ 0x00, 0x00, 0x70, 0x80, 0x01, 0x00, 0x00, 0x00, 0x18, 0x00, 0x03, 0x00,
+ 0x00, 0x00, 0x0c, 0x00, 0x03, 0x00, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04,
+ 0x00, 0x00, 0x03, 0x00, 0x06, 0x06, 0x00, 0x80, 0x01, 0x00, 0x06, 0x07,
+ 0x00, 0xc0, 0x1f, 0x00, 0x87, 0x07, 0x00, 0xe0, 0x7f, 0x80, 0xc7, 0x07,
+ 0x00, 0x70, 0xe0, 0xc0, 0xe5, 0x07, 0x00, 0x38, 0x80, 0xe1, 0x74, 0x07,
+ 0x00, 0x18, 0x80, 0x71, 0x3c, 0x07, 0x00, 0x0c, 0x00, 0x3b, 0x1e, 0x03,
+ 0x00, 0x0c, 0x00, 0x1f, 0x0f, 0x00, 0x00, 0x86, 0x1f, 0x8e, 0x07, 0x00,
+ 0x00, 0x06, 0x06, 0xc6, 0x05, 0x00, 0x00, 0x06, 0x00, 0xc6, 0x05, 0x00,
+ 0x00, 0x06, 0x00, 0xc6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00,
+ 0x7f, 0x06, 0x00, 0x06, 0xe4, 0xff, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00,
+ 0x00, 0x06, 0x00, 0x06, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x06, 0x00,
+ 0x00, 0x06, 0x00, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00,
+ 0x00, 0x06, 0x00, 0xc6, 0x00, 0x00, 0x00, 0x06, 0x00, 0x66, 0x00, 0x00,
+ 0x00, 0x06, 0x00, 0x36, 0x00, 0x00, 0x00, 0x06, 0x00, 0x3e, 0x00, 0x00,
+ 0x00, 0xfe, 0xff, 0x2f, 0x00, 0x00, 0x00, 0xfc, 0xff, 0x27, 0x00, 0x00,
+ 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
+ 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
+ 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
+ 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
+ 0xf7, 0xbf, 0x8e, 0xfc, 0xdf, 0xf8, 0x9d, 0xeb, 0x9b, 0x76, 0xd2, 0x7a,
+ 0x46, 0x30, 0xe2, 0x0f, 0xe1, 0x47, 0x55, 0x84, 0x48, 0x11, 0x84, 0x19};
diff --git a/tk8.6/tests/flagup.xbm b/tk8.6/tests/flagup.xbm
new file mode 100644
index 0000000..6eb0d84
--- /dev/null
+++ b/tk8.6/tests/flagup.xbm
@@ -0,0 +1,27 @@
+#define flagup_width 48
+#define flagup_height 48
+static char flagup_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00,
+ 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xef, 0x6a, 0x00,
+ 0x00, 0x00, 0xc0, 0x7b, 0x75, 0x00, 0x00, 0x00, 0xe0, 0xe0, 0x6a, 0x00,
+ 0x00, 0x00, 0x30, 0x60, 0x75, 0x00, 0x00, 0x00, 0x18, 0xe0, 0x7f, 0x00,
+ 0x00, 0x00, 0x0c, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x06, 0xe0, 0x04, 0x00,
+ 0x00, 0x00, 0x03, 0xe0, 0x04, 0x00, 0x00, 0x80, 0x01, 0xe0, 0x06, 0x00,
+ 0x00, 0xc0, 0x1f, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x7f, 0xe0, 0x07, 0x00,
+ 0x00, 0x70, 0xe0, 0xe0, 0x05, 0x00, 0x00, 0x38, 0x80, 0xe1, 0x04, 0x00,
+ 0x00, 0x18, 0x80, 0xf1, 0x04, 0x00, 0x00, 0x0c, 0x00, 0xfb, 0x04, 0x00,
+ 0x00, 0x0c, 0x00, 0xff, 0x04, 0x00, 0x00, 0x86, 0x1f, 0xee, 0x04, 0x00,
+ 0x00, 0x06, 0x06, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00,
+ 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x66, 0x04, 0x00,
+ 0x7f, 0x56, 0x52, 0x06, 0xe4, 0xff, 0x00, 0x76, 0x55, 0x06, 0x04, 0x00,
+ 0x00, 0x56, 0x57, 0x06, 0x04, 0x00, 0x00, 0x56, 0x55, 0x06, 0x06, 0x00,
+ 0x00, 0x56, 0xd5, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00,
+ 0x54, 0x06, 0x00, 0xc6, 0x54, 0x55, 0xaa, 0x06, 0x00, 0x66, 0xaa, 0x2a,
+ 0x54, 0x06, 0x00, 0x36, 0x55, 0x55, 0xaa, 0x06, 0x00, 0xbe, 0xaa, 0x2a,
+ 0x54, 0xfe, 0xff, 0x6f, 0x55, 0x55, 0xaa, 0xfc, 0xff, 0xa7, 0xaa, 0x2a,
+ 0x54, 0x01, 0x88, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
+ 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
+ 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
+ 0x54, 0x55, 0x8d, 0x50, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa8, 0xaa, 0x2a,
+ 0x54, 0x55, 0x95, 0x54, 0x55, 0x55, 0xaa, 0xaa, 0xaa, 0xaa, 0xaa, 0x2a,
+ 0x54, 0x55, 0x55, 0x55, 0x55, 0x15, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
diff --git a/tk8.6/tests/focus.test b/tk8.6/tests/focus.test
new file mode 100644
index 0000000..45cf73b
--- /dev/null
+++ b/tk8.6/tests/focus.test
@@ -0,0 +1,739 @@
+# This file is a Tcl script to test out the "focus" command and the
+# other procedures in the file tkFocus.c. It is organized in the
+# standard fashion for Tcl tests.
+#
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+proc focusSetup {} {
+ destroy .t
+ toplevel .t
+ wm geom .t +0+0
+ foreach i {b1 b2 b3 b4} {
+ button .t.$i -text .t.$i -relief raised -bd 2
+ pack .t.$i
+ }
+ tkwait visibility .t.b4
+}
+proc focusSetupAlt {} {
+ global env
+ destroy .alt
+ toplevel .alt -screen $env(TK_ALT_DISPLAY)
+ foreach i {a b c d} {
+ button .alt.$i -text .alt.$i -relief raised -bd 2
+ pack .alt.$i
+ }
+ tkwait visibility .alt.d
+}
+
+
+# The following procedure ensures that there is no input focus
+# in this application. It does it by arranging for another
+# application to grab the focus. The "after" and "update" stuff
+# is needed to wait long enough for pending actions to get through
+# the X server and possibly also the window manager.
+
+proc focusClear {} {
+ global x;
+ after 200 {set x 1}
+ tkwait variable x
+ dobg {focus -force .; update}
+ update
+}
+
+
+# Button used in some tests in the whole test file
+button .b -text .b -relief raised -bd 2
+pack .b
+
+# Make sure the window manager knows who has focus
+catch {fixfocus}
+
+# cleanupbg will be after 4.3 test
+setupbg
+update
+bind all <FocusIn> {
+ append focusInfo "in %W %d\n"
+}
+bind all <FocusOut> {
+ append focusInfo "out %W %d\n"
+}
+bind all <KeyPress> {
+ append focusInfo "press %W %K"
+}
+focusSetup
+if {[testConstraint altDisplay]} {
+ focusSetupAlt
+}
+
+
+test focus-1.1 {Tk_FocusCmd procedure} -constraints unix -body {
+ focusClear
+ focus
+} -result {}
+test focus-1.2 {Tk_FocusCmd procedure} -constraints {
+ unix altDisplay
+} -body {
+ focus .alt.b
+ focus
+} -result {}
+test focus-1.3 {Tk_FocusCmd procedure} -constraints unix -body {
+ focusClear
+ focus .t.b3
+ focus
+} -result {}
+test focus-1.4 {Tk_FocusCmd procedure} -constraints unix -body {
+ focus ""
+} -returnCodes ok -result {}
+test focus-1.5 {Tk_FocusCmd procedure} -constraints unix -body {
+ focusClear
+ focus -force .t
+ focus .t.b3
+ focus
+} -result {.t.b3}
+test focus-1.6 {Tk_FocusCmd procedure} -constraints unix -body {
+ focus .gorp
+} -returnCodes error -result {bad window path name ".gorp"}
+test focus-1.7 {Tk_FocusCmd procedure} -constraints unix -body {
+ focus .gorp a
+} -returnCodes error -result {bad option ".gorp": must be -displayof, -force, or -lastfor}
+test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} -constraints {
+ unix
+} -setup {
+ destroy .t2
+} -body {
+ focusClear
+ toplevel .t2
+ wm geom .t2 +10+10
+ frame .t2.f -width 200 -height 100 -bd 2 -relief raised
+ frame .t2.f2 -width 200 -height 100 -bd 2 -relief raised
+ pack .t2.f .t2.f2
+ bind .t2.f <Destroy> {focus .t2.f}
+ bind .t2.f2 <Destroy> {focus .t2}
+ focus -force .t2.f2
+ tkwait visibility .t2.f2
+ update
+ set x [focus]
+ destroy .t2.f2
+ lappend x [focus]
+ destroy .t2.f
+ lappend x [focus]
+ destroy .t2
+ return $x
+} -cleanup {
+ destroy .t2
+} -result {.t2.f2 .t2 .t2}
+test focus-1.9 {Tk_FocusCmd procedure, -displayof option} -constraints {
+ unix
+} -body {
+ focus -displayof
+} -returnCodes error -result {wrong # args: should be "focus -displayof window"}
+test focus-1.10 {Tk_FocusCmd procedure, -displayof option} -constraints {
+ unix
+} -body {
+ focus -displayof a b
+} -returnCodes error -result {wrong # args: should be "focus -displayof window"}
+test focus-1.11 {Tk_FocusCmd procedure, -displayof option} -constraints {
+ unix
+} -body {
+ focus -displayof .lousy
+} -returnCodes error -result {bad window path name ".lousy"}
+test focus-1.12 {Tk_FocusCmd procedure, -displayof option} -constraints {
+ unix
+} -body {
+ focusClear
+ focus .t
+ focus -displayof .t.b3
+} -result {}
+test focus-1.13 {Tk_FocusCmd procedure, -displayof option} -constraints {
+ unix
+} -body {
+ focusClear
+ focus -force .t
+ focus -displayof .t.b3
+} -result {.t}
+test focus-1.14 {Tk_FocusCmd procedure, -displayof option} -constraints {
+ unix altDisplay
+} -body {
+ focusClear
+ focus -force .alt.c
+ focus -displayof .alt
+} -result {.alt.c}
+test focus-1.15 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
+ focus -force
+} -returnCodes error -result {wrong # args: should be "focus -force window"}
+test focus-1.16 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
+ focus -force a b
+} -returnCodes error -result {wrong # args: should be "focus -force window"}
+test focus-1.17 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
+ focus -force foo
+} -returnCodes error -result {bad window path name "foo"}
+test focus-1.18 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
+ focus -force ""
+} -returnCodes ok -result {}
+test focus-1.19 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
+ focusClear
+ focus .t.b1
+ set x [list [focus]]
+ focus -force .t.b1
+ lappend x [focus]
+} -result {{} .t.b1}
+test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} -constraints {
+ unix
+} -body {
+ focus -lastfor
+} -returnCodes error -result {wrong # args: should be "focus -lastfor window"}
+test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} -constraints {
+ unix
+} -body {
+ focus -lastfor 1 2
+} -returnCodes error -result {wrong # args: should be "focus -lastfor window"}
+test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} -constraints {
+ unix
+} -body {
+ focus -lastfor who_knows?
+} -returnCodes error -result {bad window path name "who_knows?"}
+test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} -constraints {
+ unix
+} -body {
+ focusClear
+ focusSetup
+ focus .b
+ focus .t.b1
+ list [focus -lastfor .] [focus -lastfor .t.b3]
+} -result {.b .t.b1}
+test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} -constraints {
+ unix
+} -body {
+ focusClear
+ focusSetup
+ update
+ focus -lastfor .t.b2
+} -result {.t}
+test focus-1.25 {Tk_FocusCmd procedure} -constraints unix -body {
+ focus -unknown
+} -returnCodes error -result {bad option "-unknown": must be -displayof, -force, or -lastfor}
+
+
+focusSetup
+test focus-2.1 {TkFocusFilterEvent procedure} -constraints {
+ unix nonPortable testwrapper
+} -body {
+ focusClear
+ focus -force .b
+ focusSetup
+ update
+ set focusInfo {}
+ event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor \
+ -sendevent 0x54217567
+ return $focusInfo
+} -result {}
+test focus-2.2 {TkFocusFilterEvent procedure} -constraints {
+ unix nonPortable testwrapper
+} -body {
+ focusClear
+ focus -force .b
+ focusSetup
+ update
+ set focusInfo {}
+ event gen .t <FocusIn> -detail NotifyAncestor -sendevent 0x547321ac
+ list $focusInfo [focus]
+} -result {{in .t NotifyAncestor
+} .b}
+test focus-2.3 {TkFocusFilterEvent procedure} -constraints {
+ unix nonPortable testwrapper
+} -body {
+ focusClear
+ focus -force .b
+ focusSetup
+ update
+ set focusInfo {}
+ event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
+ update
+ list $focusInfo [focus -lastfor .t]
+} -result {{out .b NotifyNonlinear
+out . NotifyNonlinearVirtual
+in .t NotifyNonlinear
+} .t}
+test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} -constraints {
+ unix nonPortable testwrapper
+} -body {
+ focusClear
+ set result {}
+ focus .t.b1
+ # Important to end with NotifyAncestor, which is an
+ # event that is processed normally. This has a side
+ # effect on text 2.5
+ foreach detail {NotifyAncestor NotifyNonlinear
+ NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot
+ NotifyVirtual NotifyAncestor} {
+ focus -force .
+ update
+ event gen [testwrapper .t] <FocusIn> -detail $detail
+ set focusInfo {}
+ update
+ lappend result $focusInfo
+ }
+ return $result
+} -result {{out . NotifyNonlinear
+in .t NotifyNonlinearVirtual
+in .t.b1 NotifyNonlinear
+} {out . NotifyNonlinear
+in .t NotifyNonlinearVirtual
+in .t.b1 NotifyNonlinear
+} {} {out . NotifyNonlinear
+in .t NotifyNonlinearVirtual
+in .t.b1 NotifyNonlinear
+} {} {} {out . NotifyNonlinear
+in .t NotifyNonlinearVirtual
+in .t.b1 NotifyNonlinear
+}}
+test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} -constraints {
+ unix nonPortable testwrapper
+} -body {
+ focusSetup
+ focus .t.b1
+ update
+ event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
+ list $focusInfo [focus]
+} -result {{out . NotifyNonlinear
+in .t NotifyNonlinearVirtual
+in .t.b1 NotifyNonlinear
+} .t.b1}
+
+test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} -constraints {
+ unix testwrapper
+} -body {
+ focus .t.b1
+ focus .
+ update
+ event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
+ set focusInfo {}
+ set x [focus]
+ event gen . <KeyPress-x>
+ list $x $focusInfo
+} -result {.t.b1 {press .t.b1 x}}
+test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
+ unix testwrapper
+} -body {
+ set result {}
+ foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear
+ NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot
+ NotifyVirtual} {
+ focus -force .t.b1
+ event gen [testwrapper .t] <FocusOut> -detail $detail
+ update
+ lappend result [focus]
+ }
+ return $result
+} -result {{} .t.b1 {} {} .t.b1 .t.b1 {}}
+test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
+ unix testwrapper
+} -body {
+ focus -force .t.b1
+ event gen .t.b1 <FocusOut> -detail NotifyAncestor
+ focus
+} -result {.t.b1}
+test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
+ unix testwrapper
+} -body {
+ focus .t.b1
+ event gen [testwrapper .] <FocusOut> -detail NotifyAncestor
+ focus
+} -result {}
+test focus-2.10 {TkFocusFilterEvent procedure, Enter events} -constraints {
+ unix testwrapper
+} -body {
+ set result {}
+ focus .t.b1
+ focusClear
+ foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear
+ NotifyNonlinearVirtual NotifyVirtual} {
+ event gen [testwrapper .t] <Enter> -detail $detail -focus 1
+ update
+ lappend result [focus]
+ event gen [testwrapper .t] <Leave> -detail NotifyAncestor
+ update
+ }
+ return $result
+} -result {.t.b1 {} .t.b1 .t.b1 .t.b1}
+test focus-2.11 {TkFocusFilterEvent procedure, Enter events} -constraints {
+ unix testwrapper
+} -body {
+ focusClear
+ set focusInfo {}
+ event gen [testwrapper .t] <Enter> -detail NotifyAncestor
+ update
+ return $focusInfo
+} -result {}
+test focus-2.12 {TkFocusFilterEvent procedure, Enter events} -constraints {
+ unix testwrapper
+} -body {
+ focus -force .b
+ update
+ set focusInfo {}
+ event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
+ update
+ return $focusInfo
+} -result {}
+test focus-2.13 {TkFocusFilterEvent procedure, Enter events} -constraints {
+ unix testwrapper
+} -body {
+ focus .t.b1
+ focusClear
+ event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
+ set focusInfo {}
+ update
+ return $focusInfo
+} -result {in .t NotifyVirtual
+in .t.b1 NotifyAncestor
+}
+test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} -constraints {
+ unix testwrapper
+} -setup {
+ destroy .t2
+ set focusInfo {}
+} -body {
+ focusClear
+ toplevel .t2
+ wm withdraw .t2
+ update
+ event gen [testwrapper .t2] <Enter> -detail NotifyAncestor -focus 1
+ update
+} -cleanup {
+ destroy .t2
+} -result {}
+test focus-2.15 {TkFocusFilterEvent procedure, Leave events} -constraints {
+ unix testwrapper
+} -body {
+ set result {}
+ focus .t.b1
+ foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear
+ NotifyNonlinearVirtual NotifyVirtual} {
+ focusClear
+ event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
+ update
+ event gen [testwrapper .t] <Leave> -detail $detail
+ update
+ lappend result [focus]
+ }
+ return $result
+} -result {{} .t.b1 {} {} {}}
+test focus-2.16 {TkFocusFilterEvent procedure, Leave events} -constraints {
+ unix testwrapper
+} -body {
+ focusClear
+ focus .t.b1
+ event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
+ update
+ set focusInfo {}
+ event gen [testwrapper .t] <Leave> -detail NotifyAncestor
+ update
+ return $focusInfo
+} -result {out .t.b1 NotifyAncestor
+out .t NotifyVirtual
+}
+test focus-2.17 {TkFocusFilterEvent procedure, Leave events} -constraints {
+ unix testwrapper
+} -body {
+ focusClear
+ focus .t.b1
+ event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
+ update
+ set focusInfo {}
+ event gen .t.b1 <Leave> -detail NotifyAncestor
+ event gen [testwrapper .] <Leave> -detail NotifyAncestor
+ update
+ list $focusInfo [focus]
+} -result {{out .t.b1 NotifyAncestor
+out .t NotifyVirtual
+} {}}
+
+
+test focus-3.1 {SetFocus procedure, create record on focus} -constraints {
+ unix testwrapper
+} -body {
+ toplevel .t2 -width 250 -height 100
+ wm geometry .t2 +0+0
+ update
+ focus -force .t2
+ update
+ focus
+} -cleanup {
+ destroy .t2
+} -result {.t2}
+# This test produces no result, but it will generate a protocol
+# error if Tk forgets to make the window exist before focussing
+# on it.
+test focus-3.2 {SetFocus procedure, making window exist} -constraints {
+ unix testwrapper
+} -body {
+ update
+ button .b2 -text "Another button"
+ focus .b2
+ update
+} -cleanup {
+ destroy .b2
+ update
+} -result {}
+# The following test doesn't produce a check-able result, but if
+# there are bugs it may generate an X protocol error.
+test focus-3.3 {SetFocus procedure, delaying claim of X focus} -constraints {
+ unix testwrapper
+} -body {
+ focusSetup
+ focus -force .t.b2
+ update
+} -result {}
+test focus-3.4 {SetFocus procedure, delaying claim of X focus} -constraints {
+ unix testwrapper
+} -body {
+ focusSetup
+ wm withdraw .t
+ focus -force .t.b2
+ toplevel .t2 -width 250 -height 100
+ wm geometry .t2 +10+10
+ focus -force .t2
+ wm withdraw .t2
+ update
+ wm deiconify .t2
+ wm deiconify .t
+} -cleanup {
+ destroy .t2
+} -result {}
+test focus-3.5 {SetFocus procedure, generating events} -constraints {
+ unix testwrapper
+} -body {
+ focusSetup
+ focusClear
+ set focusInfo {}
+ focus -force .t.b2
+ update
+ return $focusInfo
+} -result {in .t NotifyVirtual
+in .t.b2 NotifyAncestor
+}
+test focus-3.6 {SetFocus procedure, generating events} -constraints {
+ unix testwrapper
+} -body {
+ focusSetup
+ focus -force .b
+ update
+ set focusInfo {}
+ focus .t.b2
+ update
+ return $focusInfo
+} -result {out .b NotifyNonlinear
+out . NotifyNonlinearVirtual
+in .t NotifyNonlinearVirtual
+in .t.b2 NotifyNonlinear
+}
+test focus-3.7 {SetFocus procedure, generating events} -constraints {
+unix nonPortable testwrapper
+} -body {
+ # Non-portable because some platforms generate extra events.
+ focusSetup
+ focusClear
+ set focusInfo {}
+ focus .t.b2
+ update
+ return $focusInfo
+} -result {}
+
+
+test focus-4.1 {TkFocusDeadWindow procedure} -constraints {
+ unix testwrapper
+} -body {
+ focusSetup
+ update
+ focus -force .b
+ update
+ destroy .t
+ focus
+} -result {.b}
+test focus-4.2 {TkFocusDeadWindow procedure} -constraints {
+ unix testwrapper
+} -body {
+ focusSetup
+ update
+ focus -force .t.b2
+ focus .b
+ update
+ destroy .t.b2
+ update
+ focus
+} -result {.b}
+# Non-portable due to wm-specific redirection of input focus when
+# windows are deleted:
+test focus-4.3 {TkFocusDeadWindow procedure} -constraints {
+ unix nonPortable testwrapper
+} -body {
+ focusSetup
+ update
+ focus .t
+ update
+ destroy .t
+ update
+ focus
+} -result {}
+test focus-4.4 {TkFocusDeadWindow procedure} -constraints {
+ unix testwrapper
+} -body {
+ focusSetup
+ focus -force .t.b2
+ update
+ destroy .t.b2
+ focus
+} -result {.t}
+cleanupbg
+
+
+# I don't know how to test most of the remaining procedures of this file
+# explicitly; they've already been exercised by the preceding tests.
+
+# Test 5.1 fails (before and after update)
+test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} -constraints {
+ unix testwrapper secureserver
+} -body {
+ setupbg
+ focusSetup
+ focus -force .t
+ update
+ set result [focus]
+ send [dobg {tk appname}] {focus -force .; update}
+ lappend result [focus]
+ focus .t.b2
+ update
+ lappend result [focus]
+} -cleanup {
+ cleanupbg
+} -result {.t {} {}}
+destroy .t
+bind all <FocusIn> {}
+bind all <FocusOut> {}
+bind all <KeyPress> {}
+
+
+fixfocus
+test focus-6.1 {miscellaneous - embedded application in same process} -constraints {
+ unix testwrapper
+} -setup {
+ eval interp delete [interp slaves]
+} -body {
+ toplevel .t
+ wm geometry .t +0+0
+ frame .t.f1 -container 1
+ frame .t.f2
+ pack .t.f1 .t.f2
+ entry .t.f2.e1 -bg red
+ pack .t.f2.e1
+ bind all <FocusIn> {lappend x "focus in %W %d"}
+ bind all <FocusOut> {lappend x "focus out %W %d"}
+ interp create child
+ child eval "set argv {-use [winfo id .t.f1]}"
+ load {} Tk child
+ child eval {
+ entry .e1 -bg lightBlue
+ pack .e1
+ bind all <FocusIn> {lappend x "focus in %W %d"}
+ bind all <FocusOut> {lappend x "focus out %W %d"}
+ set x {}
+ }
+
+ # Claim the focus and wait long enough for it to really arrive.
+
+ focus -force .t.f2.e1
+ after 300 {set timer 1}
+ vwait timer
+ set x {}
+ lappend x [focus] [child eval focus]
+
+ # See if a "focus" command will move the focus to the embedded
+ # application.
+
+ child eval {focus .e1}
+ after 300 {set timer 1}
+ vwait timer
+ lappend x |
+ child eval {lappend x |}
+
+ # Bring the focus back to the main application.
+
+ focus .t.f2.e1
+ after 300 {set timer 1}
+ vwait timer
+ set result [list $x [child eval {set x}]]
+ return $result
+} -cleanup {
+ interp delete child
+ destroy .t
+ bind all <FocusIn> {}
+ bind all <FocusOut> {}
+} -result {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}}
+
+test focus-6.2 {miscellaneous - embedded application in different process} -constraints {
+ unix testwrapper
+} -body {
+ setupbg
+ toplevel .t
+ wm geometry .t +0+0
+ frame .t.f1 -container 1
+ frame .t.f2
+ pack .t.f1 .t.f2
+ entry .t.f2.e1 -bg red
+ pack .t.f2.e1
+ bind all <FocusIn> {lappend x "focus in %W %d"}
+ bind all <FocusOut> {lappend x "focus out %W %d"}
+ setupbg -use [winfo id .t.f1]
+ dobg {
+ entry .e1 -bg lightBlue
+ pack .e1
+ bind all <FocusIn> {lappend x "focus in %W %d"}
+ bind all <FocusOut> {lappend x "focus out %W %d"}
+ set x {}
+ }
+
+ # Claim the focus and wait long enough for it to really arrive.
+
+ focus -force .t.f2.e1
+ after 300 {set timer 1}
+ vwait timer
+ set x {}
+ lappend x [focus] [dobg focus]
+
+ # See if a "focus" command will move the focus to the embedded
+ # application.
+
+ dobg {focus .e1}
+ after 300 {set timer 1}
+ vwait timer
+ lappend x |
+ dobg {lappend x |}
+
+ # Bring the focus back to the main application.
+
+ focus .t.f2.e1
+ after 300 {set timer 1}
+ vwait timer
+ set result [list $x [dobg {set x}]]
+ return $result
+} -cleanup {
+ destroy .t
+ cleanupbg
+ bind all <FocusIn> {}
+ bind all <FocusOut> {}
+} -result {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}}
+
+
+
+deleteWindows
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/focusTcl.test b/tk8.6/tests/focusTcl.test
new file mode 100644
index 0000000..ef848bb
--- /dev/null
+++ b/tk8.6/tests/focusTcl.test
@@ -0,0 +1,485 @@
+# This file is a Tcl script to test out the features of the script
+# file focus.tcl, which includes the procedures tk_focusNext and
+# tk_focusPrev, among other things. This file is organized in the
+# standard fashion for Tcl tests.
+#
+# Copyright (c) 1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+option add *takeFocus 1
+option add *highlightThickness 2
+. configure -takefocus 1 -highlightthickness 2
+
+proc setup1 w {
+ if {$w == "."} {
+ set w ""
+ }
+ foreach i {a b c d} {
+ destroy $w.$i
+ frame $w.$i -width 200 -height 50 -bd 2 -relief raised
+ pack $w.$i
+ }
+ .b configure -width 0 -height 0
+ foreach i {x y z} {
+ destroy $w.b.$i
+ button $w.b.$i -text "Button $w.b.$i"
+ pack $w.b.$i -side left
+ }
+ if {![winfo ismapped $w.b.z]} {
+ tkwait visibility $w.b.z
+ }
+}
+
+proc cleanup1 w {
+ if {$w == "."} {
+ set w ""
+ }
+ foreach i {a b c d} {
+ destroy $w.$i
+ }
+ foreach i {x y z} {
+ destroy $w.b.$i
+ }
+}
+
+
+test focusTcl-1.1 {tk_focusNext procedure, no children} -body {
+ tk_focusNext .
+} -result {.}
+
+test focusTcl-1.2 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusNext .
+} -cleanup {
+ cleanup1 .
+} -result {.a}
+test focusTcl-1.3 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusNext .a
+} -cleanup {
+ cleanup1 .
+} -result {.b}
+test focusTcl-1.4 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusNext .b
+} -cleanup {
+ cleanup1 .
+} -result {.b.x}
+test focusTcl-1.5 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusNext .b.x
+} -cleanup {
+ cleanup1 .
+} -result {.b.y}
+test focusTcl-1.6 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusNext .b.y
+} -cleanup {
+ cleanup1 .
+} -result {.b.z}
+test focusTcl-1.7 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusNext .b.z
+} -cleanup {
+ cleanup1 .
+} -result {.c}
+test focusTcl-1.8 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusNext .c
+} -cleanup {
+ cleanup1 .
+} -result {.d}
+test focusTcl-1.9 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusNext .d
+} -cleanup {
+ cleanup1 .
+} -result {.}
+
+test focusTcl-1.10 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
+ foreach w {.b .b.x .b.y .c .d} {
+ $w configure -takefocus 0
+ }
+ tk_focusNext .a
+} -cleanup {
+ cleanup1 .
+} -result {.b.z}
+test focusTcl-1.11 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
+ foreach w {.b .b.x .b.y .c .d} {
+ $w configure -takefocus 0
+ }
+ tk_focusNext .b.z
+} -cleanup {
+ cleanup1 .
+} -result {.}
+
+test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
+ deleteWindows
+ setup1 .
+ update
+ . configure -takefocus 0
+ tk_focusNext .d
+} -cleanup {
+ . configure -takefocus 1
+ cleanup1 .
+} -result {.a}
+
+
+test focusTcl-2.1 {tk_focusNext procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+
+ tk_focusNext .a
+} -cleanup {
+ deleteWindows
+} -result {.b}
+test focusTcl-2.2 {tk_focusNext procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+
+ tk_focusNext .d
+} -cleanup {
+ deleteWindows
+} -result {.}
+test focusTcl-2.3 {tk_focusNext procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+
+ tk_focusNext .t
+} -cleanup {
+ deleteWindows
+} -result {.t}
+test focusTcl-2.4 {tk_focusNext procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+ setup1 .t
+ raise .t.b
+
+ tk_focusNext .t
+} -cleanup {
+ deleteWindows
+} -result {.t.a}
+test focusTcl-2.5 {tk_focusNext procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+ setup1 .t
+ raise .t.b
+
+ tk_focusNext .t.b.z
+} -cleanup {
+ deleteWindows
+} -result {.t}
+
+
+test focusTcl-3.1 {tk_focusPrev procedure, no children} -body {
+ tk_focusPrev .
+} -result {.}
+
+test focusTcl-3.2 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusPrev .
+} -cleanup {
+ cleanup1 .
+} -result {.d}
+test focusTcl-3.3 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusPrev .d
+} -cleanup {
+ cleanup1 .
+} -result {.c}
+test focusTcl-3.4 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusPrev .c
+} -cleanup {
+ cleanup1 .
+} -result {.b.z}
+test focusTcl-3.5 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusPrev .b.z
+} -cleanup {
+ cleanup1 .
+} -result {.b.y}
+test focusTcl-3.6 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusPrev .b.y
+} -cleanup {
+ cleanup1 .
+} -result {.b.x}
+test focusTcl-3.7 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusPrev .b.x
+} -cleanup {
+ cleanup1 .
+} -result {.b}
+test focusTcl-3.8 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusPrev .b
+} -cleanup {
+ cleanup1 .
+} -result {.a}
+test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
+ tk_focusPrev .a
+} -cleanup {
+ cleanup1 .
+} -result {.}
+
+
+deleteWindows
+setup1 .
+toplevel .t
+wm geom .t +0+0
+toplevel .t2
+wm geom .t2 -0+0
+raise .t .a
+test focusTcl-4.1 {tk_focusPrev procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+
+ tk_focusPrev .
+} -cleanup {
+ deleteWindows
+} -result {.d}
+test focusTcl-4.2 {tk_focusPrev procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+
+ tk_focusPrev .b
+} -cleanup {
+ deleteWindows
+} -result {.a}
+test focusTcl-4.3 {tk_focusPrev procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+
+ tk_focusPrev .t
+} -cleanup {
+ deleteWindows
+} -result {.t}
+
+test focusTcl-4.4 {tk_focusPrev procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+ setup1 .t
+ update
+ .t configure -takefocus 0
+ raise .t.b
+
+ tk_focusPrev .t
+} -cleanup {
+ deleteWindows
+} -result {.t.b.z}
+test focusTcl-4.5 {tk_focusPrev procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+ setup1 .t
+ update
+ .t configure -takefocus 0
+ raise .t.b
+
+ tk_focusPrev .t.a
+} -cleanup {
+ deleteWindows
+} -result {.t.b.z}
+
+
+test focusTcl-5.1 {tkFocusOK procedure, -takefocus 0} -body {
+ setup1 .
+ .b.x configure -takefocus 0
+ tk_focusNext .b
+} -cleanup {
+ cleanup1 .
+} -result {.b.y}
+test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} -body {
+ setup1 .
+ pack forget .b
+ update
+ .b configure -takefocus ""
+ .b.y configure -takefocus ""
+ .b.z configure -takefocus ""
+ list [tk_focusNext .a] [tk_focusNext .b.x]
+} -cleanup {
+ cleanup1 .
+} -result {.c .c}
+test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} -body {
+ proc t w {
+ if {$w == ".b.x"} {
+ return 1
+ } elseif {$w == ".b.y"} {
+ return ""
+ }
+ return 0
+ }
+
+ setup1 .
+ pack forget .b.y
+ update
+ .b configure -takefocus ""
+ foreach w {.b.x .b.y .b.z .c} {
+ $w configure -takefocus t
+ }
+ list [tk_focusNext .a] [tk_focusNext .b.x]
+} -cleanup {
+ cleanup1 .
+} -result {.b.x .d}
+test focusTcl-5.4 {tkFocusOK procedure, -takefocus ""} -body {
+ setup1 .
+ .b.x configure -takefocus ""
+ update
+ tk_focusNext .b
+} -cleanup {
+ cleanup1 .
+} -result {.b.x}
+test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} -body {
+ setup1 .
+ .b.x configure -takefocus ""
+ pack unpack .b.x
+ update
+ tk_focusNext .b
+} -cleanup {
+ cleanup1 .
+} -result {.b.y}
+test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} -body {
+ setup1 .
+ foreach w {.b.x .b.y .b.z} {
+ $w configure -takefocus ""
+ }
+ pack unpack .b
+ update
+ tk_focusNext .b
+} -cleanup {
+ cleanup1 .
+} -result {.c}
+test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} -body {
+ setup1 .
+ .b.y configure -takefocus 1
+ pack unpack .b.y
+ update
+ tk_focusNext .b.x
+} -cleanup {
+ cleanup1 .
+} -result {.b.z}
+test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} -body {
+ proc always args {return 1}
+ setup1 .
+ .b.y configure -takefocus always
+ pack unpack .b.y
+ update
+ tk_focusNext .b.x
+} -cleanup {
+ cleanup1 .
+} -result {.b.y}
+test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} -body {
+ setup1 .
+ foreach w {.b.x .b.y .b.z} {
+ $w configure -takefocus ""
+ }
+ update
+ .b.x configure -state disabled
+ tk_focusNext .b
+} -cleanup {
+ cleanup1 .
+} -result {.b.y}
+test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} -body {
+ setup1 .
+ foreach w {.a .b .c .d} {
+ $w configure -takefocus ""
+ }
+ update
+ bind .a <Key> {foo}
+ list [tk_focusNext .] [tk_focusNext .a]
+} -cleanup {
+ cleanup1 .
+} -result {.a .b.x}
+test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} -body {
+ setup1 .
+ foreach w {.a .b .c .d} {
+ $w configure -takefocus ""
+ }
+ update
+ bind Frame <Key> {foo}
+ list [tk_focusNext .] [tk_focusNext .a]
+} -cleanup {
+ cleanup1 .
+ bind Frame <Key> {}
+} -result {.a .b}
+
+
+. configure -takefocus 0 -highlightthickness 0
+option clear
+
+# cleanup
+cleanupTests
+return
+
+
+
diff --git a/tk8.6/tests/font.test b/tk8.6/tests/font.test
new file mode 100644
index 0000000..9e44a93
--- /dev/null
+++ b/tk8.6/tests/font.test
@@ -0,0 +1,2382 @@
+# This file is a Tcl script to test out Tk's "font" command
+# plus the procedures in tkFont.c. It is organized in the
+# standard white-box fashion for Tcl tests.
+#
+# Copyright (c) 1996-1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+
+set defaultfontlist [font names]
+
+proc getnondefaultfonts {} {
+ global defaultfontlist
+ set nondeffonts [list ]
+ foreach afont [font names] {
+ if {$afont ni $defaultfontlist} {
+ lappend nondeffonts $afont
+ }
+ }
+ set nondeffonts
+}
+
+proc clearnondefaultfonts {} {
+ foreach afont [getnondefaultfonts] {
+ font delete $afont
+ }
+}
+
+deleteWindows
+# Toplevel used (in some tests) of the whole file
+toplevel .t
+wm geom .t +0+0
+update idletasks
+
+switch [tk windowingsystem] {
+ x11 {set fixed "fixed"}
+ win32 {set fixed "courier 12"}
+ aqua {set fixed "monaco 9"}
+}
+
+
+# Procedure used in tests: 24.15, 26.*, 28.*, 30.*, 31.*, 32.1
+proc csetup {{str ""}} {
+ focus -force .t.c
+ .t.c dchars text 0 end
+ .t.c insert text 0 $str
+ .t.c focus text
+}
+
+
+test font-1.1 {TkFontPkgInit} -setup {
+ catch {interp delete foo}
+} -body {
+ interp create foo
+ foo eval {
+ load {} Tk
+ wm geometry . +0+0
+ update
+ }
+ interp delete foo
+} -result {}
+
+
+test font-2.1 {TkFontPkgFree} -setup {
+ catch {interp delete foo}
+ set x {}
+} -body {
+ interp create foo
+
+ # Makes sure that named font was visible only to child interp.
+ foo eval {
+ load {} Tk
+ wm geometry . +0+0
+ button .b -font {times 16} -text "hi"
+ pack .b
+ font create wiggles -family courier -underline 1
+ update
+ }
+ lappend x [catch {font configure wiggles} msg; set msg]
+
+ # Tests cancelling the idle handler for TheWorldHasChanged,
+ # because app goes away before idle serviced.
+ foo eval {
+ .b config -font wiggles
+ font config wiggles -size 24
+ destroy .
+ }
+ lappend x [foo eval {catch {font families} msg; set msg}]
+} -cleanup {
+ interp delete foo
+} -result {{named font "wiggles" doesn't exist} {can't invoke "font" command: application has been destroyed}}
+
+
+test font-3.1 {font command: general} -body {
+ font
+} -returnCodes error -result {wrong # args: should be "font option ?arg?"}
+test font-3.2 {font command: general} -body {
+ font xyz
+} -returnCodes error -result {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names}
+
+
+test font-4.1 {font command: actual: arguments} -body {
+ # (skip < 0)
+ font actual xyz -displayof
+} -returnCodes error -result {value for "-displayof" missing}
+test font-4.2 {font command: actual: arguments} -body {
+ # (objc < 3)
+ font actual
+} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}
+test font-4.3 {font command: actual: arguments} -body {
+ # (objc - skip > 4) when skip == 0
+ font actual xyz abc def
+} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}
+test font-4.4 {font command: actual: displayof specified, so skip to next} -body {
+ catch {font actual xyz -displayof . -size}
+} -result {0}
+test font-4.5 {font command: actual: displayof specified, so skip to next} -body {
+ lindex [font actual xyz -displayof .] 0
+} -result {-family}
+test font-4.6 {font command: actual: arguments} -body {
+ # (objc - skip > 4) when skip == 2
+ font actual xyz -displayof . abc def
+} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}
+test font-4.7 {font command: actual: arguments} -constraints noExceed -body {
+ # (tkfont == NULL)
+ font actual "\{xyz"
+} -returnCodes error -result "font \"{xyz\" doesn't exist"
+test font-4.8 {font command: actual: all attributes} -body {
+ # not (objc > 3) so objPtr = NULL
+ lindex [font actual {-family times}] 0
+} -result {-family}
+test font-4.9 {font command: actual} -constraints {unix noExceed} -body {
+ # (objc > 3) so objPtr = objv[3 + skip]
+ string tolower [font actual {-family times} -family]
+} -result {times}
+test font-4.10 {font command: actual} -constraints win -body {
+ # (objc > 3) so objPtr = objv[3 + skip]
+ font actual {-family times} -family
+} -result {Times New Roman}
+test font-4.11 {font command: bad option} -body {
+ font actual xyz -style
+} -returnCodes error -result {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}
+
+
+test font-5.1 {font command: configure} -body {
+ # (objc < 3)
+ font configure
+} -returnCodes error -result {wrong # args: should be "font configure fontname ?-option value ...?"}
+test font-5.2 {font command: configure: non-existent font} -body {
+ # (namedHashPtr == NULL)
+ font configure xyz
+} -returnCodes error -result {named font "xyz" doesn't exist}
+test font-5.3 {font command: configure: "deleted" font} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
+ # (nfPtr->deletePending != 0)
+ font create xyz
+ .t.f configure -font xyz
+ font delete xyz
+ font configure xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {named font "xyz" doesn't exist}
+test font-5.4 {font command: configure: get all options} -setup {
+ catch {font delete xyz}
+} -body {
+ # (objc == 3) so objPtr = NULL
+ font create xyz -family xyz
+ lindex [font configure xyz] 1
+} -cleanup {
+ font delete xyz
+} -result xyz
+test font-5.5 {font command: configure: get one option} -setup {
+ clearnondefaultfonts
+} -body {
+ # (objc == 4) so objPtr = objv[3]
+ font create xyz -family xyz
+ font configure xyz -family
+ getnondefaultfonts
+} -cleanup {
+ font delete xyz
+} -result xyz
+test font-5.6 {font command: configure: update existing font} -setup {
+ catch {font delete xyz}
+} -body {
+ # else result = ConfigAttributesObj()
+ font create xyz
+ font configure xyz -family xyz
+ update
+ font configure xyz -family
+} -cleanup {
+ font delete xyz
+} -result xyz
+test font-5.7 {font command: configure: bad option} -setup {
+ catch {font delete xyz}
+} -body {
+ font create xyz
+ font configure xyz -style
+} -cleanup {
+ font delete xyz
+} -returnCodes error -result {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}
+
+
+test font-6.1 {font command: create: make up name} -setup {
+ clearnondefaultfonts
+} -body {
+ # (objc < 3) so name = NULL
+ font create
+ getnondefaultfonts
+} -cleanup {
+ font delete font1
+} -result {font1}
+test font-6.2 {font command: create: name specified} -setup {
+ clearnondefaultfonts
+} -body {
+ # not (objc < 3)
+ font create xyz
+ getnondefaultfonts
+} -cleanup {
+ font delete xyz
+} -result {xyz}
+test font-6.3 {font command: create: name not really specified} -setup {
+ clearnondefaultfonts
+} -body {
+ # (name[0] == '-') so name = NULL
+ font create -family xyz
+ getnondefaultfonts
+} -cleanup {
+ font delete font1
+} -result {font1}
+test font-6.4 {font command: create: generate name} -setup {
+} -body {
+ # (name == NULL)
+ font create -family one
+ font create -family two
+ font create -family three
+ font delete font2
+ font create -family four
+ font configure font2 -family
+} -cleanup {
+ font delete font1 font2 font3
+} -result {four}
+test font-6.5 {font command: create: bad option creating new font} -setup {
+ catch {font delete xyz}
+} -body {
+ # name was specified so skip = 3
+ font create xyz -xyz times
+} -returnCodes error -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}
+test font-6.6 {font command: create: bad option creating new font} -setup {
+ clearnondefaultfonts
+} -body {
+ # name was not specified so skip = 2
+ font create -xyz times
+} -returnCodes error -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}
+test font-6.7 {font command: create: already exists} -setup {
+ catch {font delete xyz}
+} -body {
+ # (CreateNamedFont() != TCL_OK)
+ font create xyz
+ font create xyz
+} -cleanup {
+ font delete xyz
+} -returnCodes error -result {named font "xyz" already exists}
+
+test font-7.1 {font command: delete: arguments} -body {
+ # (objc < 3)
+ font delete
+} -returnCodes error -result {wrong # args: should be "font delete fontname ?fontname ...?"}
+test font-7.2 {font command: delete: loop test} -setup {
+ clearnondefaultfonts
+ set x {}
+} -body {
+ # for (i = 2; i < objc; i++)
+ font create a -underline 1
+ font create b -underline 1
+ font create c -underline 1
+ font create d -underline 1
+ font create e -underline 1
+ lappend x [lsort [getnondefaultfonts]]
+ font delete a e c b
+ lappend x [lsort [getnondefaultfonts]]
+} -cleanup {
+ getnondefaultfonts
+} -result {{a b c d e} d}
+test font-7.3 {font command: delete: loop test} -setup {
+ clearnondefaultfonts
+ set x {}
+} -body {
+ # (namedHashPtr == NULL) in middle of loop
+ font create a -underline 1
+ font create b -underline 1
+ font create c -underline 1
+ font create d -underline 1
+ font create e -underline 1
+ lappend x [lsort [getnondefaultfonts]]
+ catch {font delete a d q c e b}
+ lappend x [lsort [getnondefaultfonts]]
+} -cleanup {
+ clearnondefaultfonts
+} -result {{a b c d e} {b c e}}
+test font-7.4 {font command: delete: non-existent} -setup {
+ catch {font delete xyz}
+} -body {
+ # (namedHashPtr == NULL)
+ font delete xyz
+} -returnCodes error -result {named font "xyz" doesn't exist}
+test font-7.5 {font command: delete: mark for later deletion} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
+ # (nfPtr->refCount != 0)
+ font create xyz
+ .t.f configure -font xyz
+ font delete xyz
+ font actual xyz
+ font configure xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {named font "xyz" doesn't exist}
+test font-7.6 {font command: delete: mark for later deletion} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
+ # (nfPtr->refCount != 0)
+ font create xyz
+ .t.f configure -font xyz
+ font delete xyz
+ font actual xyz
+ catch {font configure xyz}
+ .t.f cget -font
+} -cleanup {
+ destroy .t.f
+} -result xyz
+test font-7.7 {font command: delete: actually delete} -setup {
+ catch {font delete xyz}
+} -body {
+ # not (nfPtr->refCount != 0)
+ font create xyz -underline 1
+ font delete xyz
+ font config xyz
+} -returnCodes error -match glob -result {*}
+
+
+test font-8.1 {font command: families: arguments} -body {
+ # (skip < 0)
+ font families -displayof
+} -returnCodes error -result {value for "-displayof" missing}
+test font-8.2 {font command: families: arguments} -body {
+ # (objc - skip != 2) when skip == 0
+ font families xyz
+} -returnCodes error -result {wrong # args: should be "font families ?-displayof window?"}
+test font-8.3 {font command: families: arguments} -body {
+ # (objc - skip != 2) when skip == 2
+ font families -displayof . xyz
+} -returnCodes error -result {wrong # args: should be "font families ?-displayof window?"}
+test font-8.4 {font command: families} -body {
+ # TkpGetFontFamilies()
+ regexp -nocase times [font families]
+} -result 1
+
+
+test font-9.1 {font command: measure: arguments} -body {
+ # (skip < 0)
+ expr {[font measure xyz -displayof] > 0}
+} -returnCodes ok -result 1
+test font-9.2 {font command: measure: arguments} -body {
+ # (objc - skip != 4)
+ font measure
+} -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"}
+test font-9.3 {font command: measure: arguments} -body {
+ # (objc - skip != 4)
+ font measure xyz abc def
+} -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"}
+test font-9.4 {font command: measure: arguments} -constraints noExceed -body {
+ # (tkfont == NULL)
+ font measure "\{xyz" abc
+} -returnCodes error -result "font \"{xyz\" doesn't exist"
+test font-9.5 {font command: measure} -body {
+ # Tk_TextWidth()
+ expr {[font measure $fixed "abcdefg"] == [font measure $fixed "a"]*7 }
+} -result 1
+test font-9.6 {font command: measure -d} -body {
+ expr {[font measure $fixed -d] > 0}
+} -returnCodes ok -result 1
+test font-9.7 {font command: measure -d with -displayof} -body {
+ expr {[font measure $fixed -displayof . -d] > 0}
+} -returnCodes ok -result 1
+test font-9.8 {font command: measure: arguments} -body {
+ font measure $fixed -displayof .
+} -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"}
+
+
+test font-10.1 {font command: metrics: arguments} -body {
+ font metrics xyz -displayof
+} -returnCodes error -result {value for "-displayof" missing}
+test font-10.2 {font command: metrics: arguments} -body {
+ # (skip < 0)
+ font metrics xyz -displayof
+} -returnCodes error -result {value for "-displayof" missing}
+test font-10.3 {font command: metrics: arguments} -body {
+ # (objc < 3)
+ font metrics
+} -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?option?"}
+test font-10.4 {font command: metrics: arguments} -body {
+ # (objc - skip) > 4) when skip == 0
+ font metrics xyz abc def
+} -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?option?"}
+test font-10.5 {font command: metrics: arguments} -body {
+ # (objc - skip) > 4) when skip == 2
+ font metrics xyz -displayof . abc
+} -returnCodes error -result {bad metric "abc": must be -ascent, -descent, -linespace, or -fixed}
+test font-10.6 {font command: metrics: bad font} -constraints noExceed -body {
+ # (tkfont == NULL)
+ font metrics "\{xyz"
+} -returnCodes error -result "font \"{xyz\" doesn't exist"
+test font-10.7 {font command: metrics: get all metrics} -setup {
+ catch {unset a}
+} -body {
+ # (objc == 3)
+ array set a [font metrics {-family xyz}]
+ lsort [array names a]
+} -cleanup {
+ unset a
+} -result {-ascent -descent -fixed -linespace}
+test font-10.8 {font command: metrics: bad metric} -body {
+ # (Tcl_GetIndexFromObj() != TCL_OK)
+ font metrics $fixed -xyz
+} -returnCodes error -result {bad metric "-xyz": must be -ascent, -descent, -linespace, or -fixed}
+test font-10.9 {font command: metrics: get individual metrics} -body {
+ font metrics $fixed -ascent
+ font metrics $fixed -descent
+ font metrics $fixed -linespace
+ font metrics $fixed -fixed
+} -result 1
+
+
+test font-11.1 {font command: names: arguments} -body {
+ # (objc != 2)
+ font names xyz
+} -returnCodes error -result {wrong # args: should be "font names"}
+test font-11.2 {font command: names: loop test: no passes} -setup {
+ clearnondefaultfonts
+} -body {
+ getnondefaultfonts
+} -result {}
+test font-11.3 {font command: names: loop test: one pass} -setup {
+ clearnondefaultfonts
+} -body {
+ font create
+ getnondefaultfonts
+} -result {font1}
+test font-11.4 {font command: names: loop test: multiple passes} -setup {
+ clearnondefaultfonts
+} -body {
+ font create xyz
+ font create abc
+ font create def
+ lsort [getnondefaultfonts]
+} -cleanup {
+ clearnondefaultfonts
+} -result {abc def xyz}
+test font-11.5 {font command: names: skip deletePending fonts} -setup {
+ destroy .t.f
+ clearnondefaultfonts
+ pack [label .t.f]
+ update
+ set x {}
+} -body {
+ # (nfPtr->deletePending == 0)
+ font create xyz
+ font create abc
+ lappend x [lsort [getnondefaultfonts]]
+ .t.f config -font xyz
+ font delete xyz
+ lappend x [getnondefaultfonts]
+} -cleanup {
+ clearnondefaultfonts
+} -result {{abc xyz} abc}
+
+
+test font-12.1 {UpdateDependantFonts procedure: no users} -setup {
+ catch {font delete xyz}
+} -body {
+ # (nfPtr->refCount == 0)
+ font create xyz
+ font configure xyz -family times
+} -cleanup {
+ font delete xyz
+} -result {}
+test font-12.2 {UpdateDependantFonts procedure: pings the widgets} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
+ font create xyz -family times -size 20
+ .t.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0
+ set a1 [font measure xyz "abcd"]
+ update
+ set b1 [winfo reqwidth .t.f]
+ font configure xyz -family helvetica -size 20
+ set a2 [font measure xyz "abcd"]
+ update
+ set b2 [winfo reqwidth .t.f]
+ expr {$a1==$b1 && $a2==$b2}
+} -cleanup {
+ destroy .t.f
+ font delete xyz
+} -result {1}
+
+
+test font-13.1 {CreateNamedFont: new named font} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ # not (new == 0)
+ lappend x [getnondefaultfonts]
+ font create xyz
+ lappend x [getnondefaultfonts]
+} -cleanup {
+ font delete xyz
+} -result {{} xyz}
+test font-13.2 {CreateNamedFont: named font already exists} -setup {
+ catch {font delete xyz}
+} -body {
+ # (new == 0)
+ font create xyz
+ font create xyz
+} -cleanup {
+ font delete xyz
+} -returnCodes error -result {named font "xyz" already exists}
+test font-13.3 {CreateNamedFont: named font already exists} -setup {
+ catch {font delete xyz}
+} -body {
+ # (nfPtr->deletePending == 0)
+ font create xyz
+ font create xyz
+} -cleanup {
+ font delete xyz
+} -returnCodes error -result {named font "xyz" already exists}
+test font-13.4 {CreateNamedFont: recreate "deleted" font} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
+ # not (nfPtr->deletePending == 0)
+ font create xyz -family times
+ .t.f configure -font xyz
+ font delete xyz
+ font create xyz -family courier
+ font configure xyz -family
+} -cleanup {
+ font delete xyz
+ destroy .t.f
+} -result {courier}
+
+
+test font-14.1 {Tk_GetFont procedure} -body {
+} -result {}
+
+
+test font-15.1 {Tk_AllocFontFromObj - converting internal reps} -constraints {
+ testfont
+} -setup {
+ destroy .b1 .b2
+} -body {
+ set x {Times 16}
+ lindex $x 0
+ button .b1 -font $x
+ lindex $x 0
+ testfont counts {Times 16}
+} -cleanup {
+ destroy .b1 .b2
+} -result {{1 0}}
+test font-15.2 {Tk_AllocFontFromObj - discard stale font} -constraints {
+ testfont
+} -setup {
+ destroy .b1 .b2
+ set result {}
+} -body {
+ set x {Times 16}
+ button .b1 -font $x
+ destroy .b1
+ lappend result [testfont counts {Times 16}]
+ button .b2 -font $x
+ lappend result [testfont counts {Times 16}]
+} -cleanup {
+ destroy .b2
+} -result {{} {{1 1}}}
+test font-15.3 {Tk_AllocFontFromObj - reuse existing font} -constraints {
+ testfont
+} -setup {
+ destroy .b1 .b2
+ set result {}
+} -body {
+ set x {Times 16}
+ button .b1 -font $x
+ lappend result [testfont counts {Times 16}]
+ button .b2 -font $x
+ pack .b1 .b2 -side top
+ lappend result [testfont counts {Times 16}]
+} -cleanup {
+ destroy .b1 .b2
+} -result {{{1 1}} {{2 1}}}
+test font-15.4 {Tk_AllocFontFromObj procedure: bump ref count} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ # (new == 0)
+ .t.f config -font {-family fixed}
+ lindex [font actual {-family fixed}] 0
+} -cleanup {
+ destroy .t.f
+} -result {-family}
+test font-15.5 {Tk_AllocFontFromObj procedure: get named font} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
+ # (namedHashPtr != NULL)
+ font create xyz
+ .t.f config -font xyz
+} -cleanup {
+ destroy .t.f
+ font delete xyz
+} -result {}
+test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ # not (namedHashPtr != NULL)
+ .t.f config -font {times 20}
+} -cleanup {
+ destroy .t.f
+} -result {-family} -result {}
+test font-15.7 {Tk_AllocFontFromObj procedure: get native font} -constraints {
+ unix
+} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ # not (fontPtr == NULL)
+ .t.f config -font fixed
+} -result {}
+test font-15.8 {Tk_AllocFontFromObj procedure: get native font} -constraints {
+ win
+} -setup {
+ destroy .t.f
+ clearnondefaultfonts
+ pack [label .t.f]
+ update
+} -body {
+ # not (fontPtr == NULL)
+ .t.f config -font oemfixed
+} -cleanup {
+ destroy .t.f
+} -result {}
+test font-15.9 {Tk_AllocFontFromObj procedure: get attribute font} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ # (fontPtr == NULL)
+ .t.f config -font {xxx yyy zzz}
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {expected integer but got "yyy"}
+test font-15.10 {Tk_AllocFontFromObj procedure: no match} -constraints noExceed -body {
+ # (ParseFontNameObj() != TCL_OK)
+ font actual "\{xyz"
+} -returnCodes error -result "font \"{xyz\" doesn't exist"
+test font-15.11 {Tk_AllocFontFromObj procedure: get attribute font} -body {
+ # not (ParseFontNameObj() != TCL_OK)
+ lindex [font actual {plan 9}] 0
+} -result {-family}
+test font-15.12 {Tk_AllocFontFromObj procedure: setup tab width} -setup {
+ destroy .l
+} -body {
+ # Tk_MeasureChars(fontPtr, "0", ...)
+ label .l -bd 0 -padx 0 -highlightthickness 0 -font $fixed -text "a\tb"
+ update
+ set res1 [winfo reqwidth .l]
+ set res2 [expr [font measure $fixed "0"]*9]
+ expr {$res1 eq $res2}
+} -cleanup {
+ destroy .l
+} -result 1
+test font-15.13 {Tk_AllocFontFromObj procedure: underline position} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ # (fontPtr->underlineHeight == 0) because size was < 10
+ .t.f config -text "underline" -font "times -8 underline"
+ update
+} -cleanup {
+ destroy .t.f
+} -result {}
+
+
+test font-16.1 {Tk_NameOfFont procedure} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ .t.f config -font -family\ fixed
+ .t.f cget -font
+} -cleanup {
+ destroy .t.f
+} -result {-family fixed}
+
+
+test font-17.1 {Tk_FreeFontFromObj - reference counts} -constraints {
+ testfont
+} -setup {
+ destroy .b1 .b2 .b3
+ set result {}
+} -body {
+ set x {Courier 12}
+ button .b1 -font $x
+ button .b3 -font $x
+ button .b2 -font $x
+ lappend result [testfont counts {Courier 12}]
+ destroy .b1
+ lappend result [testfont counts {Courier 12}]
+ destroy .b2
+ lappend result [testfont counts {Courier 12}]
+ destroy .b3
+ lappend result [testfont counts {Courier 12}]
+} -result {{{3 1}} {{2 1}} {{1 1}} {}}
+test font-17.2 {Tk_FreeFont procedure: one ref} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ # (fontPtr->refCount == 0)
+ .t.f config -font {-family fixed}
+ destroy .t.f
+} -result {}
+test font-17.3 {Tk_FreeFont procedure: multiple ref} -setup {
+ destroy .t.f .t.b
+ pack [label .t.f]
+ update
+} -body {
+ # not (fontPtr->refCount == 0)
+ .t.f config -font {-family fixed}
+ button .t.b -font {-family fixed}
+ destroy .t.f
+ .t.b cget -font
+} -cleanup {
+ destroy .t.b
+} -result {-family fixed}
+test font-17.4 {Tk_FreeFont procedure: named font} -setup {
+ destroy .t.f
+ clearnondefaultfonts
+ pack [label .t.f]
+ update
+} -body {
+ # (fontPtr->namedHashPtr != NULL)
+ font create xyz
+ .t.f config -font xyz
+ destroy .t.f
+ getnondefaultfonts
+} -result {xyz}
+test font-17.5 {Tk_FreeFont procedure: named font} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
+ # not (fontPtr->refCount == 0)
+ font create xyz -underline 1
+ .t.f config -font xyz
+ font delete xyz
+ set x [font actual xyz -underline]
+ destroy .t.f
+ list [font actual xyz -underline] $x
+} -result {0 1}
+test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} -setup {
+ destroy .t.f .t.b
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
+ font create xyz
+ .t.f config -font xyz
+ button .t.b -font xyz
+ font delete xyz
+ set x [font actual xyz]
+ destroy .t.b
+ list [lindex [font actual xyz] 0] [lindex $x 0]
+} -cleanup {
+ destroy .t.f
+} -result {-family -family}
+
+
+test font-18.1 {FreeFontObjProc} -constraints testfont -setup {
+ destroy .b1
+ set result {}
+} -body {
+ set x [join {Courier 12} { }]
+ button .b1 -font $x
+ set y [join {Courier 12} { }]
+ .b1 configure -font $y
+ set z [join {Courier 12} { }]
+ .b1 configure -font $z
+ lappend result [testfont counts {Courier 12}]
+ set x red
+ lappend result [testfont counts {Courier 12}]
+ set z 32
+ lappend result [testfont counts {Courier 12}]
+ destroy .b1
+ lappend result [testfont counts {Courier 12}]
+ set y bogus
+ return $result
+} -result {{{1 3}} {{1 2}} {{1 1}} {}}
+
+
+test font-19.1 {Tk_FontId} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ .t.f config -font "times 20"
+ update
+} -cleanup {
+ destroy .t.f
+} -result {}
+
+
+test font-20.1 {Tk_GetFontMetrics procedure} -setup {
+ destroy .t.w1 .t.w2
+} -body {
+ button .t.w1 -text abc
+ entry .t.w2 -text abcd
+ update
+ destroy .t.w1 .t.w2
+} -result {}
+
+
+# Procedure used in 21.* tests
+proc psfontname {name} {
+ destroy .t.c
+ canvas .t.c -closeenough 0
+ .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+ pack .t.c
+ update
+ set a [.t.c itemcget text -font]
+ .t.c itemconfig text -text "We need text" -font $name
+ set post [.t.c postscript]
+ .t.c itemconfig text -font $a
+ set end [string first "findfont" $post]
+ incr end -2
+ set post [string range $post [expr $end-70] $end]
+ set start [string first "gsave" $post]
+ destroy .t.c
+ return [string range $post [expr $start+7] end]
+}
+test font-21.1 {Tk_PostscriptFontName procedure: native} -constraints {
+ unix
+} -body {
+ set x [font actual {{itc avant garde} 10} -family]
+ if {[string match *avant*garde $x]} {
+ psfontname "{itc avant garde} 10"
+ } else {
+ set x {AvantGarde-Book}
+ }
+} -result {AvantGarde-Book}
+test font-21.2 {Tk_PostscriptFontName procedure: native} -constraints {
+ win
+} -body {
+ psfontname "arial 10"
+} -result {Helvetica}
+test font-21.3 {Tk_PostscriptFontName procedure: native} -constraints {
+ win
+} -body {
+ psfontname "{times new roman} 10"
+} -result {Times-Roman}
+test font-21.4 {Tk_PostscriptFontName procedure: native} -constraints {
+ win
+} -body {
+ psfontname "{courier new} 10"
+} -result {Courier}
+test font-21.5 {Tk_PostscriptFontName procedure: spaces} -constraints {
+ unix
+} -body {
+ set x [font actual {{lucida bright} 10} -family]
+ if {[string match lucida*bright $x]} {
+ psfontname "{lucida bright} 10"
+ } else {
+ set x {LucidaBright}
+ }
+} -result {LucidaBright}
+test font-21.6 {Tk_PostscriptFontName procedure: spaces} -constraints {
+ unix
+} -body {
+ psfontname "{new century schoolbook} 10"
+} -result {NewCenturySchlbk-Roman}
+
+test font-21.7 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {avantgarde 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x AvantGarde-Book
+ }
+} -result {AvantGarde-Book}
+test font-21.8 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {avantgarde 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x AvantGarde-Demi
+ }
+} -result {AvantGarde-Demi}
+test font-21.9 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {avantgarde 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x AvantGarde-BookOblique
+ }
+} -result {AvantGarde-BookOblique}
+test font-21.10 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {avantgarde 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x AvantGarde-DemiOblique
+ }
+} -result {AvantGarde-DemiOblique}
+
+test font-21.11 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {bookman 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Bookman-Light
+ }
+} -result {Bookman-Light}
+test font-21.12 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {bookman 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Bookman-Demi
+ }
+} -result {Bookman-Demi}
+test font-21.13 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {bookman 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Bookman-LightItalic
+ }
+} -result {Bookman-LightItalic}
+test font-21.14 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {bookman 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Bookman-DemiItalic
+ }
+} -result {Bookman-DemiItalic}
+
+test font-21.15 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {courier 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "courier"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Courier
+ }
+} -result {Courier}
+test font-21.16 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {courier 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "courier"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Courier-Bold
+ }
+} -result {Courier-Bold}
+test font-21.17 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {courier 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "courier"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Courier-Oblique
+ }
+} -result {Courier-Oblique}
+test font-21.18 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {courier 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "courier"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Courier-BoldOblique
+ }
+} -result {Courier-BoldOblique}
+
+test font-21.19 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {helvetica 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Helvetica
+ }
+} -result {Helvetica}
+test font-21.20 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {helvetica 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Helvetica-Bold
+ }
+} -result {Helvetica-Bold}
+test font-21.21 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {helvetica 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Helvetica-Oblique
+ }
+} -result {Helvetica-Oblique}
+test font-21.22 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {helvetica 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Helvetica-BoldOblique
+ }
+} -result {Helvetica-BoldOblique}
+
+test font-21.23 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {{new century schoolbook} 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x NewCenturySchlbk-Roman
+ }
+} -result {NewCenturySchlbk-Roman}
+test font-21.24 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {{new century schoolbook} 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x NewCenturySchlbk-Bold
+ }
+} -result {NewCenturySchlbk-Bold}
+test font-21.25 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {{new century schoolbook} 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x NewCenturySchlbk-Italic
+ }
+} -result {NewCenturySchlbk-Italic}
+test font-21.26 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {{new century schoolbook} 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x NewCenturySchlbk-BoldItalic
+ }
+} -result {NewCenturySchlbk-BoldItalic}
+
+test font-21.27 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {palatino 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Palatino-Roman
+ }
+} -result {Palatino-Roman}
+test font-21.28 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {palatino 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Palatino-Bold
+ }
+} -result {Palatino-Bold}
+test font-21.29 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {palatino 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Palatino-Italic
+ }
+} -result {Palatino-Italic}
+test font-21.30 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {palatino 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Palatino-BoldItalic
+ }
+} -result {Palatino-BoldItalic}
+
+test font-21.31 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {symbol 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Symbol
+ }
+} -result {Symbol}
+test font-21.32 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {symbol 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Symbol
+ }
+} -result {Symbol}
+test font-21.33 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {symbol 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Symbol
+ }
+} -result {Symbol}
+test font-21.34 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {symbol 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Symbol
+ }
+} -result {Symbol}
+
+test font-21.35 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {times 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "times"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Times-Roman
+ }
+} -result {Times-Roman}
+test font-21.36 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {times 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "times"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Times-Bold
+ }
+} -result {Times-Bold}
+test font-21.37 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {times 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "times"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Times-Italic
+ }
+} -result {Times-Italic}
+test font-21.38 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {times 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "times"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Times-BoldItalic
+ }
+} -result {Times-BoldItalic}
+
+test font-21.39 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfchancery 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfChancery-MediumItalic
+ }
+} -result {ZapfChancery-MediumItalic}
+test font-21.40 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfchancery 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfChancery-MediumItalic
+ }
+} -result {ZapfChancery-MediumItalic}
+test font-21.41 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfchancery 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfChancery-MediumItalic
+ }
+} -result {ZapfChancery-MediumItalic}
+test font-21.42 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfchancery 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfChancery-MediumItalic
+ }
+} -result {ZapfChancery-MediumItalic}
+
+test font-21.43 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfdingbats 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfDingbats
+ }
+} -result {ZapfDingbats}
+test font-21.44 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfdingbats 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfDingbats
+ }
+} -result {ZapfDingbats}
+test font-21.45 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfdingbats 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfDingbats
+ }
+} -result {ZapfDingbats}
+test font-21.46 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfdingbats 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfDingbats
+ }
+} -result {ZapfDingbats}
+
+test font-21.47 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {arial 12 roman normal}]
+} -result {Helvetica}
+test font-21.48 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {arial 12 roman bold}]
+} -result {Helvetica-Bold}
+test font-21.49 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {arial 12 italic normal}]
+} -result {Helvetica-Oblique}
+test font-21.50 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {arial 12 italic bold}]
+} -result {Helvetica-BoldOblique}
+
+test font-21.51 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{courier new} 12 roman normal}]
+} -result {Courier}
+test font-21.52 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{courier new} 12 roman bold}]
+} -result {Courier-Bold}
+test font-21.53 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{courier new} 12 italic normal}]
+} -result {Courier-Oblique}
+test font-21.54 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{courier new} 12 italic bold}]
+} -result {Courier-BoldOblique}
+
+test font-21.55 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {helvetica 12 roman normal}]
+} -result {Helvetica}
+test font-21.56 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {helvetica 12 roman bold}]
+} -result {Helvetica-Bold}
+test font-21.57 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {helvetica 12 italic normal}]
+} -result {Helvetica-Oblique}
+test font-21.58 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {helvetica 12 italic bold}]
+} -result {Helvetica-BoldOblique}
+
+test font-21.59 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {symbol 12 roman normal}]
+} -result {Symbol}
+test font-21.60 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {symbol 12 roman bold}]
+} -result {Symbol-Bold}
+test font-21.61 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {symbol 12 italic normal}]
+} -result {Symbol-Italic}
+test font-21.62 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {symbol 12 italic bold}]
+} -result {Symbol-BoldItalic}
+
+test font-21.63 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{times new roman} 12 roman normal}]
+} -result {Times-Roman}
+test font-21.64 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{times new roman} 12 roman bold}]
+} -result {Times-Bold}
+test font-21.65 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{times new roman} 12 italic normal}]
+} -result {Times-Italic}
+test font-21.66 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{times new roman} 12 italic bold}]
+} -result {Times-BoldItalic}
+
+
+test font-22.1 {Tk_TextWidth procedure} -setup {
+ destroy .t.l
+} -body {
+ label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font "Courier -12"
+ pack .t.l
+ set ax [winfo reqwidth .t.l]
+ expr {[font measure [.t.l cget -font] "000"] eq $ax*3}
+} -cleanup {
+ destroy .t.l
+} -result 1
+
+
+test font-23.1 {Tk_UnderlineChars procedure} -setup {
+ destroy .t.t
+} -body {
+ text .t.t
+ .t.t insert 1.0 abc\tdefg
+ .t.t tag config sel -underline 1
+ .t.t tag add sel 1.0 end
+ update
+} -cleanup {
+ destroy .t.t
+} -result {}
+
+
+# Data used in 24.* tests
+destroy .t.l
+label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font "Courier -12"
+pack .t.l
+update
+set ax [winfo reqwidth .t.l]
+set ay [winfo reqheight .t.l]
+test font-24.1 {Tk_ComputeTextLayout: empty string} -body {
+ .t.l config -text ""
+} -result {}
+test font-24.2 {Tk_ComputeTextLayout: simple string} -body {
+ .t.l config -text "000"
+ update
+ list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \
+ [expr {[winfo reqheight .t.l] eq $ay}]
+} -result {1 1}
+test font-24.3 {Tk_ComputeTextLayout: find special chars} -body {
+ .t.l config -text "000\n000"
+ update
+ list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \
+ [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+} -result {1 1}
+test font-24.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} -body {
+ .t.l config -text "000\n000"
+ update
+ list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \
+ [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+} -result {1 1}
+test font-24.5 {Tk_ComputeTextLayout: break line} -body {
+ .t.l config -text "000\t00000" -wrap [expr 9 * $ax]
+ update
+ list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 8}]}] \
+ [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+} -cleanup {
+ .t.l config -wrap 0
+} -result {1 1}
+test font-24.6 {Tk_ComputeTextLayout: normal ended on special char} -body {
+ .t.l config -text "000\n000"
+} -result {}
+test font-24.7 {Tk_ComputeTextLayout: special char was \n} -body {
+ .t.l config -text "000\n0000"
+ update
+ list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}] \
+ [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+} -result {1 1}
+test font-24.8 {Tk_ComputeTextLayout: special char was \t} -body {
+ .t.l config -text "000\t00"
+ update
+ list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 10}]}] \
+ [expr {[winfo reqheight .t.l] eq $ay}]
+} -result {1 1}
+test font-24.9 {Tk_ComputeTextLayout: tab didn't cause break} -body {
+ set x {}
+ .t.l config -text "000\t000"
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 11}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq $ay}]
+ .t.l config -text "000\t000" -wrap [expr 100 * $ax]
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 11}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq $ay}]
+ return $x
+} -cleanup {
+ .t.l config -wrap 0
+} -result {1 1 1 1}
+test font-24.10 {Tk_ComputeTextLayout: tab caused break} -body {
+ set x {}
+ .t.l config -text "000\t"
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 8}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq $ay}]
+ .t.l config -text "000\t00" -wrap [expr $ax * 6]
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 8}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+ return $x
+} -cleanup {
+ .t.l config -wrap 0
+} -result {1 1 1 1}
+test font-24.11 {Tk_ComputeTextLayout: absorb spaces at eol} -body {
+ set x {}
+ .t.l config -text "000 000" -wrap [expr {$ax * 5}]
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+ .t.l config -text "000 "
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq $ay}]
+ return $x
+} -cleanup {
+ .t.l config -wrap 0
+} -result {1 1 1 1}
+test font-24.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} -body {
+ set x {}
+ .t.l config -text "000 0000" -wrap [expr {$ax * 5}]
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+ .t.l config -text "000\t00 0000" -wrap [expr {$ax * 12}]
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 10}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+ return $x
+} -cleanup {
+ .t.l config -wrap 0
+} -result {1 1 1 1}
+test font-24.13 {Tk_ComputeTextLayout: many lines -> realloc line array} -body {
+ .t.l config -text "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n"
+ update
+ list [expr {[winfo reqwidth .t.l] eq 1}] \
+ [expr {[winfo reqheight .t.l] eq [expr {$ay * 129}]}]
+} -result {1 1}
+test font-24.14 {Tk_ComputeTextLayout: text ended with \n} -body {
+ set x {}
+ .t.l config -text "0000"
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq $ay}]
+ .t.l config -text "0000\n"
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+ return $x
+} -result {1 1 1 1}
+destroy .t.l
+
+test font-24.15 {Tk_ComputeTextLayout: justification} -setup {
+ set x {}
+ destroy .t.c
+ canvas .t.c -closeenough 0
+ .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+ pack .t.c
+ update
+} -body {
+ csetup "000\n00000"
+ .t.c itemconfig text -just left
+ lappend x [.t.c index text @[expr $ax*2],0]
+ .t.c itemconfig text -just center
+ lappend x [.t.c index text @[expr $ax*2],0]
+ .t.c itemconfig text -just right
+ lappend x [.t.c index text @[expr $ax*2],0]
+ .t.c itemconfig text -just left
+ return $x
+} -cleanup {
+ destroy .t.c
+} -result {2 1 0}
+
+
+test font-25.1 {Tk_FreeTextLayout procedure} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ .t.f config -text foo
+ .t.f config -text boo
+} -cleanup {
+ destroy .t.f
+} -result {}
+
+
+# Canvas created for tests: 26.*
+destroy .t.c
+canvas .t.c -closeenough 0
+.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+pack .t.c
+update
+test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ .t.f config -text foo
+} -cleanup {
+ destroy .t.f
+} -result {}
+test font-26.2 {Tk_DrawTextLayout procedure: multiple chunks} -body {
+ csetup "000\t00\n000"
+} -result {}
+test font-26.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} -body {
+ csetup "000\t00"
+ .t.c select from text 3
+ .t.c select to text 5
+} -result {}
+test font-26.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} -body {
+ csetup "000\t00"
+ .t.c select from text 3
+ .t.c select to text 5
+} -result {}
+test font-26.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} -body {
+ csetup "000\t00"
+ .t.c select from text 2
+ .t.c select to text 2
+} -result {}
+test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} -body {
+ csetup "000\t00"
+ .t.c select from text 4
+ .t.c select to text 4
+} -result {}
+destroy .t.c
+
+# Label used in 27.* tests
+destroy .t.f
+pack [label .t.f]
+update
+test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} -body {
+ .t.f config -text "foo" -under -1
+} -result {}
+test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} -body {
+ .t.f config -text "000 00000" -wrap [expr $ax*7] -under 10
+} -result {}
+test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} -body {
+ .t.f config -text "000 00000" -wrap [expr $ax*7] -under 5
+ .t.f config -wrap -1 -under -1
+} -result {}
+destroy .t.f
+
+
+
+# Canvas created for tests: 28.*
+destroy .t.c
+canvas .t.c -closeenough 0
+.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+pack .t.c
+update
+test font-28.1 {Tk_PointToChar procedure: above all lines} -body {
+ csetup "000"
+ .t.c index text @-1,0
+} -result {0}
+test font-28.2 {Tk_PointToChar procedure: no chars} -body {
+ # After fixing the following bug:
+ #
+ # In canvas text item, it was impossible to click to position the
+ # insertion point just after the last character.
+ #
+ # introduced another bug that Tk_PointToChar() would return a character
+ # index of 1 if TextLayout contained 0 characters.
+
+ csetup ""
+ .t.c index text @100,100
+} -result {0}
+test font-28.3 {Tk_PointToChar procedure: loop test} -body {
+ csetup "000\n000\n000\n000"
+ .t.c index text @10000,0
+} -result {3}
+test font-28.4 {Tk_PointToChar procedure: intersect line} -body {
+ csetup "000\n000\n000"
+ .t.c index text @0,$ay
+} -result {4}
+test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} -body {
+ csetup "000\n000\n000"
+ .t.c index text @-100,$ay
+} -result {4}
+test font-28.6 {Tk_PointToChar procedure: past any possible chunk} -body {
+ csetup "000\n000\n000"
+ .t.c index text @100000,$ay
+} -result {7}
+test font-28.7 {Tk_PointToChar procedure: which chunk on this line} -body {
+ csetup "000\n000\t000\t000\n000"
+ .t.c index text @[expr $ax*2],$ay
+} -result {6}
+test font-28.8 {Tk_PointToChar procedure: which chunk on this line} -body {
+ csetup "000\n000\t000\t000\n000"
+ .t.c index text @[expr $ax*10],$ay
+} -result {10}
+test font-28.9 {Tk_PointToChar procedure: in special chunk} -body {
+ csetup "000\n000\t000\t000\n000"
+ .t.c index text @[expr $ax*6],$ay
+} -result {7}
+test font-28.10 {Tk_PointToChar procedure: past all chars in chunk} -body {
+ csetup "000 0000000"
+ .t.c itemconfig text -width [expr $ax*5]
+ set x [.t.c index text @[expr $ax*5],0]
+ .t.c itemconfig text -width 0
+ return $x
+} -result {3}
+test font-28.11 {Tk_PointToChar procedure: below all chunks} -body {
+ csetup "000 0000000"
+ .t.c index text @0,1000000
+} -result {11}
+destroy .t.c
+
+
+# Label used in 29.* tests
+destroy .t.f
+pack [label .t.f]
+update
+test font-29.1 {Tk_CharBBox procedure: index < 0} -body {
+ .t.f config -text "000" -underline -1
+} -result {}
+test font-29.2 {Tk_CharBBox procedure: loop} -body {
+ .t.f config -text "000\t000\t000\t000" -underline 9
+} -result {}
+test font-29.3 {Tk_CharBBox procedure: special char} -body {
+ .t.f config -text "000\t000\t000" -underline 7
+} -result {}
+test font-29.4 {Tk_CharBBox procedure: normal char} -body {
+ .t.f config -text "000" -underline 1
+} -result {}
+test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} -body {
+ .t.f config -text "0 0000" -wrap [expr $ax*4] -under 2
+ .t.f config -wrap 0
+} -result {}
+test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} -body {
+ .t.f config -text "0 0000" -wrap [expr $ax*4] -under 3
+ .t.f config -wrap 0
+} -result {}
+destroy .t.f
+
+
+
+# Canvas created for tests: 30.*
+destroy .t.c
+canvas .t.c -closeenough 0
+.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+pack .t.c
+update
+test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} -body {
+ csetup "000\n000\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
+ set x {}
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x 0 -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {0}
+test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} -body {
+ csetup "000\n000\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
+ set x {}
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x $ax -y $ay
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {5}
+test font-30.3 {Tk_DistanceToTextLayout procedure: loop to end} -body {
+ csetup "000\n0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
+ set x {}
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x [expr $ax*2] -y $ay
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+test font-30.4 {Tk_DistanceToTextLayout procedure: hit a special char (tab)} -body {
+ csetup "000\t000\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
+ set x {}
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x [expr $ax*6] -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {3}
+test font-30.5 {Tk_DistanceToTextLayout procedure: ignore newline} -body {
+ csetup "000\n0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
+ set x {}
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x [expr $ax*2] -y $ay
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+test font-30.6 {Tk_DistanceToTextLayout procedure: ignore spaces at eol} -body {
+ csetup "000\n000 000000000"
+ .t.c itemconfig text -width [expr $ax*10]
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
+ set x {}
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x [expr $ax*5] -y $ay
+ .t.c itemconfig text -width 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+.t.c itemconfig text -justify center
+test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} -body {
+ csetup "0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
+ set x {}
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x 0 -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+test font-30.8 {Tk_DistanceToTextLayout procedure: on right side} -body {
+ csetup "0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
+ set x {}
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x [expr $ax*2] -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+test font-30.9 {Tk_DistanceToTextLayout procedure: inside line} -body {
+ csetup "0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
+ set x {}
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x $ax -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {0}
+test font-30.10 {Tk_DistanceToTextLayout procedure: above line} -body {
+ csetup "0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
+ set x {}
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x 0 -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+test font-30.11 {Tk_DistanceToTextLayout procedure: below line} -body {
+ csetup "000\n0"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
+ set x {}
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x 0 -y $ay
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+test font-30.12 {Tk_DistanceToTextLayout procedure: in line} -body {
+ csetup "0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
+ set x {}
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x $ax -y $ay
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {3}
+.t.c itemconfig text -justify left
+test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} -body {
+ csetup "000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
+ set x {}
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x $ax -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {1}
+destroy .t.c
+
+
+# Canvas created for tests 31.*
+destroy .t.c
+canvas .t.c -closeenough 0
+.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+pack .t.c
+update
+test font-31.1 {Tk_IntersectTextLayout procedure: loop once} -body {
+ csetup "000\n000\n000"
+ .t.c find overlapping 0 0 0 0
+} -result [.t.c find withtag text]
+test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} -body {
+ csetup "000\t000\t000"
+ .t.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0
+} -result [.t.c find withtag text]
+test font-31.3 {Tk_IntersectTextLayout procedure: loop to end} -body {
+ csetup "0\n000"
+ .t.c find overlapping [expr $ax*2] 0 [expr $ax*2] 0
+} -result {}
+test font-31.4 {Tk_IntersectTextLayout procedure: hit a special char (tab)} -body {
+ csetup "000\t000"
+ .t.c find overlapping [expr $ax*6] 0 [expr $ax*6] 0
+} -result [.t.c find withtag text]
+test font-31.5 {Tk_IntersectTextLayout procedure: ignore newlines} -body {
+ csetup "000\n0\n000"
+ .t.c find overlapping $ax $ay $ax $ay
+} -result {}
+test font-31.6 {Tk_IntersectTextLayout procedure: ignore spaces at eol} -body {
+ csetup "000\n000 000000000"
+ .t.c itemconfig text -width [expr $ax*10]
+ set x [.t.c find overlapping [expr $ax*5] $ay [expr $ax*5] $ay]
+ .t.c itemconfig text -width 0
+ return $x
+} -result {}
+destroy .t.c
+
+
+test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} -setup {
+ destroy .t.c
+ canvas .t.c -closeenough 0
+ .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+ pack .t.c
+ update
+} -body {
+ # If there were a whole bunch of returns or tabs in a row, then the
+ # temporary buffer could overflow and write on the stack.
+ csetup "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n"
+ .t.c itemconfig text -width 800
+ .t.c insert text end "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n"
+ .t.c insert text end "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n"
+ .t.c insert text end "end"
+ set x [.t.c postscript]
+ set i [string first "(qwerty" $x]
+ string range $x $i [expr {$i + 278}]
+} -cleanup {
+ destroy .t.c
+} -result {(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)]
+[(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[()]
+[(end)]
+}
+
+
+test font-33.1 {Tk_TextWidth procedure} -body {
+} -result {}
+
+
+test font-34.1 {ConfigAttributesObj procedure: arguments} -setup {
+ catch {font delete xyz}
+} -body {
+ # (Tcl_GetIndexFromObj() != TCL_OK)
+ font create xyz -xyz
+} -returnCodes {
+ error
+} -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}
+test font-34.2 {ConfigAttributesObj procedure: arguments} -setup {
+ catch {font delete xyz}
+} -body {
+ # (objc & 1)
+ font create xyz -family
+} -returnCodes error -result {value for "-family" option missing}
+
+test font-34.3 {ConfigAttributesObj procedure: family} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -family xyz
+ lappend x [font config xyz -family]
+ font config xyz -family times
+ lappend x [font config xyz -family]
+} -cleanup {
+ font delete xyz
+} -result {xyz times}
+test font-34.4 {ConfigAttributesObj procedure: size} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -size 20
+ lappend x [font config xyz -size]
+ font config xyz -size 40
+ lappend x [font config xyz -size]
+} -cleanup {
+ font delete xyz
+} -result {20 40}
+test font-34.5 {ConfigAttributesObj procedure: weight} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -weight normal
+ lappend x [font config xyz -weight]
+ font config xyz -weight bold
+ lappend x [font config xyz -weight]
+} -cleanup {
+ font delete xyz
+} -result {normal bold}
+test font-34.6 {ConfigAttributesObj procedure: slant} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -slant roman
+ lappend x [font config xyz -slant]
+ font config xyz -slant italic
+ lappend x [font config xyz -slant]
+} -cleanup {
+ font delete xyz
+} -result {roman italic}
+test font-34.7 {ConfigAttributesObj procedure: underline} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -underline 0
+ lappend x [font config xyz -underline]
+ font config xyz -underline 1
+ lappend x [font config xyz -underline]
+} -cleanup {
+ font delete xyz
+} -result {0 1}
+test font-34.8 {ConfigAttributesObj procedure: overstrike} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -overstrike 0
+ lappend x [font config xyz -overstrike]
+ font config xyz -overstrike 1
+ lappend x [font config xyz -overstrike]
+} -cleanup {
+ font delete xyz
+} -result {0 1}
+
+test font-34.9 {ConfigAttributesObj procedure: size} -body {
+ font create xyz -size xyz
+} -returnCodes error -result {expected integer but got "xyz"}
+test font-34.10 {ConfigAttributesObj procedure: weight} -body {
+ font create xyz -weight xyz
+} -returnCodes error -result {bad -weight value "xyz": must be normal, or bold}
+test font-34.11 {ConfigAttributesObj procedure: slant} -body {
+ font create xyz -slant xyz
+} -returnCodes error -result {bad -slant value "xyz": must be roman, or italic}
+test font-34.12 {ConfigAttributesObj procedure: underline} -body {
+ font create xyz -underline xyz
+} -returnCodes error -result {expected boolean value but got "xyz"}
+test font-34.13 {ConfigAttributesObj procedure: overstrike} -body {
+ font create xyz -overstrike xyz
+} -returnCodes error -result {expected boolean value but got "xyz"}
+
+
+test font-35.1 {GetAttributeInfoObj procedure: one attribute} -setup {
+ catch {font delete xyz}
+} -body {
+ # (objPtr != NULL)
+ font create xyz -family xyz
+ font config xyz -family
+} -cleanup {
+ font delete xyz
+} -result {xyz}
+
+
+test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} -setup {
+ catch {font delete xyz}
+} -body {
+ # (Tcl_GetIndexFromObj() != TCL_OK)
+ font create xyz
+ font config xyz -xyz
+} -cleanup {
+ font delete xyz
+} -returnCodes {
+ error
+} -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}
+
+
+test font-37.1 {GetAttributeInfoObj procedure: all attributes} -setup {
+ catch {font delete xyz}
+} -body {
+ # not (objPtr != NULL)
+ font create xyz -family xyz
+ font config xyz
+} -cleanup {
+ font delete xyz
+} -result {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0}
+test font-37.2 {GetAttributeInfo procedure: family} -setup {
+ catch {font delete xyz}
+} -body {
+ font create xyz -family xyz
+ font config xyz -family
+} -cleanup {
+ font delete xyz
+} -result {xyz}
+test font-37.3 {GetAttributeInfo procedure: size} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -size 20
+ font config xyz -size
+} -cleanup {
+ font delete xyz
+} -result {20}
+test font-37.4 {GetAttributeInfo procedure: weight} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -weight normal
+ font config xyz -weight
+} -cleanup {
+ font delete xyz
+} -result {normal}
+test font-37.5 {GetAttributeInfo procedure: slant} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -slant italic
+ font config xyz -slant
+} -cleanup {
+ font delete xyz
+} -result {italic}
+test font-37.6 {GetAttributeInfo procedure: underline} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -underline yes
+ font config xyz -underline
+} -cleanup {
+ font delete xyz
+} -result {1}
+test font-37.7 {GetAttributeInfo procedure: overstrike} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -overstrike no
+ font config xyz -overstrike
+} -cleanup {
+ font delete xyz
+} -result {0}
+
+
+# In tests below, one field is set to "xyz" so that font name doesn't
+# look like a native X font, so that ParseFontNameObj or TkParseXLFD will
+# be called.
+
+test font-38.1 {ParseFontNameObj procedure: begins with -} -body {
+ lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1
+} -result [font actual {times 0} -family]
+test font-38.2 {ParseFontNameObj procedure: begins with -*} -body {
+ lindex [font actual -*-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1
+} -result [font actual {times 0} -family]
+test font-38.3 {ParseFontNameObj procedure: begins with -, doesn't look like list} -body {
+ lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1
+} -result [font actual {times 0} -family]
+test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} -body {
+ lindex [font actual {-family times}] 1
+} -result [font actual {times 0} -family]
+test font-38.5 {ParseFontNameObj procedure: begins with *} -body {
+ lindex [font actual *-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1
+} -result [font actual {times 0} -family]
+test font-38.6 {ParseFontNameObj procedure: begins with *} -body {
+ font actual *-times-xyz -family
+} -result [font actual {times 0} -family]
+test font-38.7 {ParseFontNameObj procedure: arguments} -constraints noExceed -body {
+ font actual "\{xyz"
+} -returnCodes error -result "font \"{xyz\" doesn't exist"
+test font-38.8 {ParseFontNameObj procedure: arguments} -constraints noExceed -body {
+ font actual ""
+} -returnCodes error -result {font "" doesn't exist}
+test font-38.9 {ParseFontNameObj procedure: arguments} -body {
+ font actual {times 20 xyz xyz}
+} -returnCodes error -result {unknown font style "xyz"}
+test font-38.10 {ParseFontNameObj procedure: arguments} -body {
+ font actual {times xyz xyz}
+} -returnCodes error -result {expected integer but got "xyz"}
+test font-38.11 {ParseFontNameObj procedure: stylelist loop} -constraints {
+ unixOrPc
+} -body {
+ lrange [font actual {times 12 bold italic overstrike underline}] 4 end
+} -result {-weight bold -slant italic -underline 1 -overstrike 1}
+test font-38.12 {ParseFontNameObj procedure: stylelist error} -body {
+ font actual {times 12 bold xyz}
+} -returnCodes error -result {unknown font style "xyz"}
+test font-38.13 "ParseFontNameObj: options with hyphenated family: bug #2791352" -body {
+ font actual {-family sans-serif -size 12 -weight bold -slant roman -underline 0 -overstrike 0}
+} -returnCodes ok -result [font actual {sans-serif 12 bold}]
+test font-38.14 "ParseFontNameObj: bug #2791352" -body {
+ font actual {-invalidfont 8 bold}
+} -returnCodes error -match glob -result {bad option "-invalidfont": *}
+
+
+test font-39.1 {NewChunk procedure: test realloc} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ .t.f config -text "xxx\nxxx\txxx\nxxx\t\t\t"
+} -cleanup {
+ destroy .t.f
+} -result {}
+
+
+test font-40.1 {TkFontParseXLFD procedure: initial dash} -body {
+ font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-* -family
+} -result [font actual {times 0} -family]
+test font-40.2 {TkFontParseXLFD procedure: no initial dash} -body {
+ font actual *-times-*-*-*-*-*-*-*-*-*-*-*-xyz -family
+} -result [font actual {times 0} -family]
+test font-40.3 {TkFontParseXLFD procedure: not enough fields} -body {
+ font actual -xyz-times-*-*-* -family
+} -result [font actual {times 0} -family]
+test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} -body {
+ lindex [font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*] 0
+} -result {-family}
+test font-40.5 {TkFontParseXLFD procedure: all fields specified} -body {
+ lindex [font actual \
+ -foundry-times-weight-slant-setwidth-addstyle-10-10-10-10-spacing-avgwidth-registry-encoding] 1
+} -result [font actual {times 0} -family]
+
+
+test font-41.1 {TkParseXLFD procedure: arguments} -body {
+ # XLFD with bad pointsize: fallback to some system font.
+ font actual -*-*-*-*-*-*-xyz-*-*-*-*-*-*-*
+ set x {}
+} -result {}
+
+
+test font-42.1 {TkFontParseXLFD procedure: arguments} -body {
+ # XLFD with bad pixelsize: fallback to some system font.
+ font actual -*-*-*-*-*-*-*-xyz-*-*-*-*-*-*
+ set x {}
+} -result {}
+test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} -body {
+ font metrics -xyz-times-*-*-*-*-12-*-*-*-*-*-*-* -linespace
+ set x {}
+} -result {}
+test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} -body {
+ font metrics {-xyz-times-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*-*} -linespace
+ set x {}
+} -result {}
+test font-42.4 {TkFontParseXLFD procedure: pointsize specified} -body {
+ font metrics -xyz-times-*-*-*-*-*-120-*-*-*-*-*-* -linespace
+ set x {}
+} -result {}
+test font-42.5 {TkFontParseXLFD procedure: weird pointsize specified} -body {
+ font metrics {-xyz-times-*-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*} -linespace
+ set x {}
+} -result {}
+
+
+test font-43.1 {FieldSpecified procedure: specified vs. non-specified} -body {
+ font actual -xyz--*-*-*-*-*-*-*-*-*-*-*-*
+ font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*
+ font actual -xyz-?-*-*-*-*-*-*-*-*-*-*-*-*
+ lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1
+} -result [font actual {times 0} -family]
+
+
+test font-44.1 {TkFontGetPixels: size < 0} -setup {
+ set oldscale [tk scaling]
+} -body {
+ tk scaling 0.5
+ font actual {times -12} -size
+} -cleanup {
+ tk scaling $oldscale
+} -result {24}
+test font-44.2 {TkFontGetPoints: size >= 0} -constraints noExceed -setup {
+ set oldscale [tk scaling]
+} -body {
+ tk scaling 0.5
+ font actual {times 12} -size
+} -cleanup {
+ tk scaling $oldscale
+} -result {12}
+
+
+test font-45.1 {TkFontGetAliasList: no match} -body {
+ font actual {snarky 10} -family
+} -result [font actual {-size 10} -family]
+test font-45.2 {TkFontGetAliasList: match} -constraints win -body {
+ font actual {times 10} -family
+} -result {Times New Roman}
+test font-45.3 {TkFontGetAliasList: match} -constraints {unix noExceed} -body {
+ # can fail on Unix systems that have a real "times new roman" font
+ font actual {{times new roman} 10} -family
+} -result [font actual {times 10} -family]
+
+
+test font-46.1 {font actual, with character, no option, no --} -body {
+ font actual {times 10} a
+} -match glob -result [list -family [font actual {times 10} -family] -size *\
+ -slant roman -underline 0 -overstrike 0]
+
+test font-46.2 {font actual, with character introduced by --} -body {
+ font actual {times 10} -- -
+} -match glob -result [list -family [font actual {times 10} -family] -size *\
+ -slant roman -underline 0 -overstrike 0]
+
+test font-46.3 {font actual, with character and option} -body {
+ font actual {times 10} -family a
+} -result [font actual {times 10} -family]
+
+test font-46.4 {font actual, with character, option and --} -body {
+ font actual {times 10} -family -- -
+} -result [font actual {times 10} -family]
+
+test font-46.5 {font actual, too many chars} -body {
+ font actual {times 10} 123456789012345678901234567890123456789012345678901
+} -returnCodes error -result {expected a single character but got "1234567890123456789012345678901234567..."}
+
+test font-47.1 {Bug f214b8ad5b} -body {
+ interp create one
+ interp create two
+ load {} Tk one
+ load {} Tk two
+ one eval menu .menubar
+ two eval menu .menubar
+ interp delete one
+ interp delete two
+} -result {}
+
+# cleanup
+cleanupTests
+return
+
+
+
+
diff --git a/tk8.6/tests/fontchooser.test b/tk8.6/tests/fontchooser.test
new file mode 100644
index 0000000..4dad5da
--- /dev/null
+++ b/tk8.6/tests/fontchooser.test
@@ -0,0 +1,201 @@
+# Test the "tk::fontchooser" command
+#
+# Copyright (c) 2008 Pat Thoyts
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# the following helper functions are related to the functions used
+# in winDialog.test where they are used to send messages to the win32
+# dialog (hence the wierdness).
+
+proc start {cmd} {
+ set ::tk_dialog {}
+ set ::iter_after 0
+ after 1 $cmd
+}
+proc then {cmd} {
+ set ::command $cmd
+ set ::dialogresult {}
+ set ::testfont {}
+ afterbody
+ vwait ::dialogresult
+ return $::dialogresult
+}
+proc afterbody {} {
+ if {$::tk_dialog == {}} {
+ if {[incr ::iter_after] > 30} {
+ set ::dialogresult ">30 iterations waiting for tk_dialog"
+ return
+ }
+ after 150 {afterbody}
+ return
+ }
+ uplevel #0 {set dialogresult [eval $command]}
+}
+proc Click {button} {
+ switch -exact -- $button {
+ ok { $::tk_dialog.ok invoke }
+ cancel { $::tk_dialog.cancel invoke }
+ apply { $::tk_dialog.apply invoke }
+ default { return -code error "invalid button name \"$button\"" }
+ }
+}
+proc ApplyFont {font} {
+# puts stderr "apply: $font"
+ set ::testfont $font
+}
+
+# -------------------------------------------------------------------------
+
+test fontchooser-1.1 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser -z
+} -result {unknown or ambiguous subcommand "-z": must be configure, hide, or show}
+
+test fontchooser-1.2 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -z
+} -match glob -result {bad option "-z":*}
+
+test fontchooser-1.3 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -parent . -font
+} -result {value for "-font" missing}
+
+test fontchooser-1.4 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -parent . -title
+} -result {value for "-title" missing}
+
+test fontchooser-1.5 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -parent . -command
+} -result {value for "-command" missing}
+
+test fontchooser-1.6 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -title . -parent
+} -result {value for "-parent" missing}
+
+test fontchooser-1.7 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -parent abc
+} -result {bad window path name "abc"}
+
+test fontchooser-1.8 {tk fontchooser: usage} -returnCodes ok -body {
+ tk fontchooser configure -visible
+} -result {0}
+
+test fontchooser-1.9 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -visible 1
+} -match glob -result {*}
+
+# -------------------------------------------------------------------------
+#
+# The remaining tests in this file are only relevant for the script
+# implementation. They can be tested by sourcing the script file but
+# the Tk tests are run with -singleproc 1 and doing this affects the
+# result of later attempts to test the native implementations.
+#
+testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]]
+
+test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -title "Hello"
+ tk::fontchooser::Show
+ }
+ then {
+ set x [wm title $::tk_dialog]
+ Click cancel
+ }
+ set x
+} -result {Hello}
+
+test fontchooser-2.1 {fontchooser -title (cyrillic)} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure \
+ -title "\u041f\u0440\u0438\u0432\u0435\u0442"
+ tk::fontchooser::Show
+ }
+ then {
+ set x [wm title $::tk_dialog]
+ Click cancel
+ }
+ set x
+} -result "\u041f\u0440\u0438\u0432\u0435\u0442"
+
+test fontchooser-3.0 {fontchooser -parent} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -parent .
+ tk::fontchooser::Show
+ }
+ then {
+ set x [winfo parent $::tk_dialog]
+ Click cancel
+ }
+ set x
+} -result {.}
+
+test fontchooser-3.1 {fontchooser -parent (invalid)} -constraints scriptImpl -body {
+ tk::fontchooser::Configure -parent junk
+} -returnCodes error -match glob -result {bad window path *}
+
+test fontchooser-4.0 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font courier
+ tk::fontchooser::Show
+ }
+ then {
+ Click cancel
+ }
+ set ::testfont
+} -result {}
+
+test fontchooser-4.1 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font courier
+ tk::fontchooser::Show
+ }
+ then {
+ Click ok
+ }
+ expr {$::testfont ne {}}
+} -result {1}
+
+test fontchooser-4.2 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font TkDefaultFont
+ tk::fontchooser::Show
+ }
+ then {
+ Click ok
+ }
+ expr {$::testfont ne {}}
+} -result {1}
+
+test fontchooser-4.3 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
+ tk::fontchooser::Show
+ }
+ then {
+ Click ok
+ }
+ expr {$::testfont ne {}}
+} -result {1}
+
+test fontchooser-4.4 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
+ tk::fontchooser::Show
+ }
+ then {
+ Click ok
+ }
+ lrange $::testfont 1 end
+} -result {14 bold}
+
+# -------------------------------------------------------------------------
+
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tk8.6/tests/frame.test b/tk8.6/tests/frame.test
new file mode 100644
index 0000000..c7b0ed8
--- /dev/null
+++ b/tk8.6/tests/frame.test
@@ -0,0 +1,1529 @@
+# This file is a Tcl script to test out the "frame" and "toplevel"
+# commands of Tk. It is organized in the standard fashion for Tcl
+# tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# eatColors --
+# Creates a toplevel window and allocates enough colors in it to
+# use up all the slots in the colormap.
+#
+# Arguments:
+# w - Name of toplevel window to create.
+
+proc eatColors {w} {
+ catch {destroy $w}
+ toplevel $w
+ wm geom $w +0+0
+ canvas $w.c -width 400 -height 200 -bd 0
+ pack $w.c
+ for {set y 0} {$y < 8} {incr y} {
+ for {set x 0} {$x < 40} {incr x} {
+ set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
+ $w.c create rectangle [expr 10*$x] [expr 20*$y] \
+ [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
+ -fill $color
+ }
+ }
+ update
+}
+
+# colorsFree --
+#
+# Returns 1 if there appear to be free colormap entries in a window,
+# 0 otherwise.
+#
+# Arguments:
+# w - Name of window in which to check.
+# red, green, blue - Intensities to use in a trial color allocation
+# to see if there are colormap entries free.
+
+proc colorsFree {w {red 31} {green 245} {blue 192}} {
+ set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
+ expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
+ && ([lindex $vals 2]/256 == $blue)
+}
+
+
+test frame-1.1 {frame configuration options} -setup {
+ deleteWindows
+} -body {
+ frame .f -class NewFrame
+ .f configure -class
+} -cleanup {
+ deleteWindows
+} -result {-class class Class Frame NewFrame}
+test frame-1.2 {frame configuration options} -setup {
+ deleteWindows
+} -body {
+ frame .f -class NewFrame
+ .f configure -class Different
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't modify -class option after widget is created}
+
+test frame-1.3 {frame configuration options} -setup {
+ deleteWindows
+} -body {
+ frame .f -colormap new
+ .f configure -colormap
+} -cleanup {
+ deleteWindows
+} -result {-colormap colormap Colormap {} new}
+test frame-1.4 {frame configuration options} -setup {
+ deleteWindows
+} -body {
+ frame .f -colormap new
+ .f configure -colormap .
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't modify -colormap option after widget is created}
+
+test frame-1.5 {frame configuration options} -setup {
+ deleteWindows
+} -body {
+ frame .f -visual default
+ .f configure -visual
+} -cleanup {
+ deleteWindows
+} -result {-visual visual Visual {} default}
+test frame-1.6 {frame configuration options} -setup {
+ deleteWindows
+} -body {
+ frame .f -visual default
+ .f configure -visual best
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't modify -visual option after widget is created}
+
+test frame-1.7 {frame configuration options} -setup {
+ deleteWindows
+} -body {
+ frame .f -screen bogus
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown option "-screen"}
+test frame-1.8 {frame configuration options} -setup {
+ deleteWindows
+} -body {
+ frame .f -container true
+} -cleanup {
+ deleteWindows
+} -result {.f}
+test frame-1.9 {frame configuration options} -setup {
+ deleteWindows
+} -body {
+ frame .f -container true
+ .f configure -container
+} -cleanup {
+ deleteWindows
+} -result {-container container Container 0 1}
+test frame-1.10 {frame configuration options} -setup {
+ deleteWindows
+} -body {
+ frame .f -container bogus
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected boolean value but got "bogus"}
+test frame-1.11 {frame configuration options} -setup {
+ deleteWindows
+} -body {
+ frame .f
+ .f configure -container 1
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't modify -container option after widget is created}
+test frame-1.12 {frame configuration options} -setup {
+ deleteWindows
+} -body {
+ # Make sure all options can be set to the default value
+ frame .f
+ set opts {}
+ foreach opt [.f configure] {
+ if {[llength $opt] == 5} {
+ lappend opts [lindex $opt 0] [lindex $opt 4]
+ }
+ }
+ eval frame .g $opts
+ destroy .f .g
+} -cleanup {
+ deleteWindows
+} -result {}
+
+destroy .f
+frame .f
+test frame-1.13 {frame configuration options} -body {
+ .f configure -background #ff0000
+ lindex [.f configure -background] 4
+} -cleanup {
+ .f configure -background [lindex [.f configure -background] 3]
+} -result {#ff0000}
+test frame-1.14 {frame configuration options} -body {
+ .f configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test frame-1.15 {frame configuration options} -body {
+ .f configure -bd 4
+ lindex [.f configure -bd] 4
+} -cleanup {
+ .f configure -bd [lindex [.f configure -bd] 3]
+} -result {4}
+test frame-1.16 {frame configuration options} -body {
+ .f configure -bd badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-1.17 {frame configuration options} -body {
+ .f configure -bg #00ff00
+ lindex [.f configure -bg] 4
+} -cleanup {
+ .f configure -bg [lindex [.f configure -bg] 3]
+} -result {#00ff00}
+test frame-1.18 {frame configuration options} -body {
+ .f configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test frame-1.19 {frame configuration options} -body {
+ .f configure -borderwidth 1.3
+ lindex [.f configure -borderwidth] 4
+} -cleanup {
+ .f configure -borderwidth [lindex [.f configure -borderwidth] 3]
+} -result {1}
+test frame-1.20 {frame configuration options} -body {
+ .f configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-1.21 {frame configuration options} -body {
+ .f configure -cursor arrow
+ lindex [.f configure -cursor] 4
+} -cleanup {
+ .f configure -cursor [lindex [.f configure -cursor] 3]
+} -result {arrow}
+test frame-1.22 {frame configuration options} -body {
+ .f configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test frame-1.23 {frame configuration options} -body {
+ .f configure -height 100
+ lindex [.f configure -height] 4
+} -cleanup {
+ .f configure -height [lindex [.f configure -height] 3]
+} -result {100}
+test frame-1.24 {frame configuration options} -body {
+ .f configure -height not_a_number
+} -returnCodes error -result {bad screen distance "not_a_number"}
+test frame-1.25 {frame configuration options} -body {
+ .f configure -highlightbackground #112233
+ lindex [.f configure -highlightbackground] 4
+} -cleanup {
+ .f configure -highlightbackground [lindex [.f configure -highlightbackground] 3]
+} -result {#112233}
+test frame-1.26 {frame configuration options} -body {
+ .f configure -highlightbackground ugly
+} -returnCodes error -result {unknown color name "ugly"}
+test frame-1.27 {frame configuration options} -body {
+ .f configure -highlightcolor #123456
+ lindex [.f configure -highlightcolor] 4
+} -cleanup {
+ .f configure -highlightcolor [lindex [.f configure -highlightcolor] 3]
+} -result {#123456}
+test frame-1.28 {frame configuration options} -body {
+ .f configure -highlightcolor non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test frame-1.29 {frame configuration options} -body {
+ .f configure -highlightthickness 6
+ lindex [.f configure -highlightthickness] 4
+} -cleanup {
+ .f configure -highlightthickness [lindex [.f configure -highlightthickness] 3]
+} -result {6}
+test frame-1.30 {frame configuration options} -body {
+ .f configure -highlightthickness badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-1.31 {frame configuration options} -body {
+ .f configure -padx 3
+ lindex [.f configure -padx] 4
+} -cleanup {
+ .f configure -padx [lindex [.f configure -padx] 3]
+} -result {3}
+test frame-1.32 {frame configuration options} -body {
+ .f configure -padx badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-1.33 {frame configuration options} -body {
+ .f configure -pady 4
+ lindex [.f configure -pady] 4
+} -cleanup {
+ .f configure -pady [lindex [.f configure -pady] 3]
+} -result {4}
+test frame-1.34 {frame configuration options} -body {
+ .f configure -pady badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-1.35 {frame configuration options} -body {
+ .f configure -relief ridge
+ lindex [.f configure -relief] 4
+} -cleanup {
+ .f configure -relief [lindex [.f configure -relief] 3]
+} -result {ridge}
+test frame-1.36 {frame configuration options} -body {
+ .f configure -relief badValue
+} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}
+test frame-1.37 {frame configuration options} -body {
+ .f configure -takefocus {any string}
+ lindex [.f configure -takefocus] 4
+} -cleanup {
+ .f configure -takefocus [lindex [.f configure -takefocus] 3]
+} -result {any string}
+test frame-1.38 {frame configuration options} -body {
+ .f configure -width 32
+ lindex [.f configure -width] 4
+} -cleanup {
+ .f configure -width [lindex [.f configure -width] 3]
+} -result {32}
+test frame-1.39 {frame configuration options} -body {
+ .f configure -width badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+destroy .f
+
+
+test frame-2.1 {toplevel configuration options} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 200 -height 100 -class NewClass
+ wm geometry .t +0+0
+ .t configure -class
+} -cleanup {
+ deleteWindows
+} -result {-class class Class Toplevel NewClass}
+test frame-2.2 {toplevel configuration options} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 200 -height 100 -class NewClass
+ wm geometry .t +0+0
+ .t configure -class Another
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't modify -class option after widget is created}
+
+test frame-2.3 {toplevel configuration options} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 200 -height 100 -colormap new
+ wm geometry .t +0+0
+ .t configure -colormap
+} -cleanup {
+ deleteWindows
+} -result {-colormap colormap Colormap {} new}
+test frame-2.4 {toplevel configuration options} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 200 -height 100 -colormap new
+ wm geometry .t +0+0
+ .t configure -colormap .
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't modify -colormap option after widget is created}
+
+test frame-2.5 {toplevel configuration options} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 200 -height 100
+ wm geometry .t +0+0
+ .t configure -container 1
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't modify -container option after widget is created}
+test frame-2.6 {toplevel configuration options} -setup {
+ deleteWindows
+} -body {
+ catch {destroy .t}
+ toplevel .t -width 200 -height 100
+ wm geometry .t +0+0
+ catch {.t configure -container 1}
+ .t configure -container
+} -cleanup {
+ deleteWindows
+} -result {-container container Container 0 0}
+
+test frame-2.7 {toplevel configuration options} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 200 -height 100 -colormap bogus
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad window path name "bogus"}
+
+
+test frame-2.8 {toplevel configuration options} -constraints {
+ win
+} -setup {
+ deleteWindows
+} -body {
+ catch {destroy .t}
+ toplevel .t -width 200 -height 100
+ wm geometry .t +0+0
+ .t configure -use 0x44022
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {window "0x44022" doesn't exist}
+test frame-2.9 {toplevel configuration options} -constraints {
+ win
+} -setup {
+ deleteWindows
+} -body {
+ catch {destroy .t}
+ toplevel .t -width 200 -height 100
+ wm geometry .t +0+0
+ catch {.t configure -use 0x44022}
+ .t configure -use
+} -cleanup {
+ deleteWindows
+} -result {-use use Use {} {}}
+
+test frame-2.10 {toplevel configuration options} -constraints {
+ nonwin
+} -setup {
+ deleteWindows
+} -body {
+ catch {destroy .t}
+ toplevel .t -width 200 -height 100
+ wm geometry .t +0+0
+ .t configure -use 0x44022
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't modify -use option after widget is created}
+test frame-2.11 {toplevel configuration options} -constraints {
+ nonwin
+} -setup {
+ deleteWindows
+} -body {
+ catch {destroy .t}
+ toplevel .t -width 200 -height 100
+ wm geometry .t +0+0
+ catch {.t configure -use 0x44022}
+ .t configure -use
+} -cleanup {
+ deleteWindows
+} -result {-use use Use {} {}}
+
+test frame-2.12 {toplevel configuration options} -setup {
+ deleteWindows
+} -body {
+ catch {destroy .t}
+ toplevel .t -width 200 -height 100 -visual default
+ wm geometry .t +0+0
+ .t configure -visual
+} -cleanup {
+ deleteWindows
+} -result {-visual visual Visual {} default}
+test frame-2.13 {toplevel configuration options} -setup {
+ deleteWindows
+} -body {
+ catch {destroy .t}
+ toplevel .t -width 200 -height 100 -visual default
+ wm geometry .t +0+0
+ .t configure -visual best
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't modify -visual option after widget is created}
+
+test frame-2.14 {toplevel configuration options} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 200 -height 100 -visual who_knows?
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}
+test frame-2.15 {toplevel configuration options} -constraints haveDISPLAY -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
+ wm geometry .t +0+0
+ string compare [.t configure -screen] "-screen screen Screen {} $env(DISPLAY)"
+} -cleanup {
+ deleteWindows
+} -result {0}
+test frame-2.16 {toplevel configuration options} -constraints haveDISPLAY -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
+ wm geometry .t +0+0
+ .t configure -screen another
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't modify -screen option after widget is created}
+
+test frame-2.17 {toplevel configuration options} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 200 -height 100 -screen bogus
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {couldn't connect to display "bogus"}
+test frame-2.18 {toplevel configuration options} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -container 1 -width 300 -height 120
+ wm geometry .t +0+0
+ toplevel .x -container 1 -use [winfo id .t]
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {windows cannot have both the -use and the -container option set}
+test frame-2.19 {toplevel configuration options} -setup {
+ deleteWindows
+ set opts {}
+} -body {
+ # Make sure all options can be set to the default value
+ toplevel .f
+ foreach opt [.f configure] {
+ if {[llength $opt] == 5} {
+ lappend opts [lindex $opt 0] [lindex $opt 4]
+ }
+ }
+ eval toplevel .g $opts
+ destroy .f .g
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+destroy .t
+toplevel .t -width 300 -height 150
+wm geometry .t +0+0
+update
+test frame-2.20 {toplevel configuration options} -body {
+ .t configure -background #ff0000
+ lindex [.t configure -background] 4
+} -result {#ff0000}
+test frame-2.21 {toplevel configuration options} -body {
+ .t configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test frame-2.22 {toplevel configuration options} -body {
+ .t configure -bd 4
+ lindex [.t configure -bd] 4
+} -result {4}
+test frame-2.23 {toplevel configuration options} -body {
+ .t configure -bd badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-2.24 {toplevel configuration options} -body {
+ .t configure -bg #00ff00
+ lindex [.t configure -bg] 4
+} -result {#00ff00}
+test frame-2.25 {toplevel configuration options} -body {
+ .t configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test frame-2.26 {toplevel configuration options} -body {
+ .t configure -borderwidth 1.3
+ lindex [.t configure -borderwidth] 4
+} -result {1}
+test frame-2.27 {toplevel configuration options} -body {
+ .t configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-2.28 {toplevel configuration options} -body {
+ .t configure -cursor arrow
+ lindex [.t configure -cursor] 4
+} -result {arrow}
+test frame-2.29 {toplevel configuration options} -body {
+ .t configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test frame-2.30 {toplevel configuration options} -body {
+ .t configure -height 100
+ lindex [.t configure -height] 4
+} -result {100}
+test frame-2.31 {toplevel configuration options} -body {
+ .t configure -height not_a_number
+} -returnCodes error -result {bad screen distance "not_a_number"}
+test frame-2.32 {toplevel configuration options} -body {
+ .t configure -highlightcolor #123456
+ lindex [.t configure -highlightcolor] 4
+} -result {#123456}
+test frame-2.33 {toplevel configuration options} -body {
+ .t configure -highlightcolor non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test frame-2.34 {toplevel configuration options} -body {
+ .t configure -highlightthickness 3
+ lindex [.t configure -highlightthickness] 4
+} -result {3}
+test frame-2.35 {toplevel configuration options} -body {
+ .t configure -highlightthickness badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-2.36 {toplevel configuration options} -body {
+ .t configure -padx 3
+ lindex [.t configure -padx] 4
+} -result {3}
+test frame-2.37 {toplevel configuration options} -body {
+ .t configure -padx badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-2.38 {toplevel configuration options} -body {
+ .t configure -pady 4
+ lindex [.t configure -pady] 4
+} -result {4}
+test frame-2.39 {toplevel configuration options} -body {
+ .t configure -pady badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-2.40 {toplevel configuration options} -body {
+ .t configure -relief ridge
+ lindex [.t configure -relief] 4
+} -result {ridge}
+test frame-2.41 {toplevel configuration options} -body {
+ .t configure -relief badValue
+} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}
+test frame-2.42 {toplevel configuration options} -body {
+ .t configure -width 32
+ lindex [.t configure -width] 4
+} -result {32}
+test frame-2.43 {toplevel configuration options} -body {
+ .t configure -width badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+destroy .t
+
+
+test frame-3.1 {TkCreateFrame procedure} -body {
+ frame
+} -returnCodes error -result {wrong # args: should be "frame pathName ?-option value ...?"}
+test frame-3.2 {TkCreateFrame procedure} -setup {
+ deleteWindows
+ frame .f
+} -body {
+ .f configure -class
+} -cleanup {
+ deleteWindows
+} -result {-class class Class Frame Frame}
+test frame-3.3 {TkCreateFrame procedure} -setup {
+ deleteWindows
+ toplevel .t
+ wm geometry .t +0+0
+} -body {
+ .t configure -class
+} -cleanup {
+ deleteWindows
+} -result {-class class Class Toplevel Toplevel}
+test frame-3.4 {TkCreateFrame procedure} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 350 -class NewClass -bg black -visual default -height 90
+ wm geometry .t +0+0
+ update
+ list [lindex [.t configure -width] 4] \
+ [lindex [.t configure -background] 4] \
+ [lindex [.t configure -height] 4]
+} -cleanup {
+ deleteWindows
+} -result {350 black 90}
+
+# Be sure that the -class, -colormap, and -visual options are processed
+# before configuring the widget.
+test frame-3.5 {TkCreateFrame procedure} -setup {
+ deleteWindows
+} -body {
+ option add *NewFrame.background #123456
+ frame .f -class NewFrame
+ lindex [.f configure -background] 4
+} -cleanup {
+ deleteWindows
+ option clear
+} -result {#123456}
+test frame-3.6 {TkCreateFrame procedure} -setup {
+ deleteWindows
+} -body {
+ option add *NewFrame.background #123456
+ frame .f -class NewFrame
+ lindex [.f configure -background] 4
+} -cleanup {
+ deleteWindows
+ option clear
+} -result {#123456}
+test frame-3.7 {TkCreateFrame procedure} -setup {
+ deleteWindows
+} -body {
+ option add *NewFrame.background #332211
+ option add *f.class NewFrame
+ frame .f
+ list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]
+} -cleanup {
+ deleteWindows
+ option clear
+} -result {NewFrame #332211}
+test frame-3.8 {TkCreateFrame procedure} -setup {
+ deleteWindows
+} -body {
+ option add *Silly.background #122334
+ option add *f.Class Silly
+ frame .f
+ list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]
+} -cleanup {
+ deleteWindows
+ option clear
+} -result {Silly #122334}
+test frame-3.9 {TkCreateFrame procedure, -use option} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -container 1 -width 300 -height 120
+ wm geometry .t +0+0
+ toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green
+ tkwait visibility .x
+ list [expr {[winfo rootx .x] - [winfo rootx .t]}] \
+ [expr {[winfo rooty .x] - [winfo rooty .t]}] \
+ [winfo width .t] [winfo height .t]
+} -cleanup {
+ deleteWindows
+} -result {0 0 140 300}
+test frame-3.10 {TkCreateFrame procedure, -use option} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -container 1 -width 300 -height 120
+ wm geometry .t +0+0
+ option add *x.use [winfo id .t]
+ toplevel .x -width 140 -height 300 -bg green
+ tkwait visibility .x
+ list [expr {[winfo rootx .x] - [winfo rootx .t]}] \
+ [expr {[winfo rooty .x] - [winfo rooty .t]}] \
+ [winfo width .t] [winfo height .t]
+} -cleanup {
+ destroy .t
+ option clear
+} -result {0 0 140 300}
+
+# The tests below require specific display characteristics (i.e. that
+# they are run on a pseudocolor display of depth 8). Even so, they
+# are non-portable: some machines don't seem to ever run out of
+# colors.
+if {[testConstraint defaultPseudocolor8]} {
+ eatColors .t1
+}
+test frame-3.11 {TkCreateFrame procedure} -constraints {
+ defaultPseudocolor8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 300 -height 200 -bg #475601
+ wm geometry .t +0+0
+ update
+ colorsFree .t
+} -cleanup {
+ deleteWindows
+} -result {0}
+test frame-3.12 {TkCreateFrame procedure} -constraints {
+ defaultPseudocolor8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 300 -height 200 -bg #475601 -colormap new
+ wm geometry .t +0+0
+ update
+ colorsFree .t
+} -cleanup {
+ deleteWindows
+} -result {1}
+test frame-3.13 {TkCreateFrame procedure} -constraints {
+ defaultPseudocolor8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ option add *t.class Toplevel2
+ option add *Toplevel2.colormap new
+ toplevel .t -width 300 -height 200 -bg #475601
+ wm geometry .t +0+0
+ update
+ option clear
+ colorsFree .t
+} -cleanup {
+ deleteWindows
+} -result {1}
+test frame-3.14 {TkCreateFrame procedure} -constraints {
+ defaultPseudocolor8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ option add *t.class Toplevel3
+ option add *Toplevel3.Colormap new
+ toplevel .t -width 300 -height 200 -bg #475601 -colormap new
+ wm geometry .t +0+0
+ update
+ option clear
+ colorsFree .t
+} -cleanup {
+ deleteWindows
+} -result {1}
+test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -constraints {
+ defaultPseudocolor8 unix nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -container 1 -width 300 -height 120
+ wm geometry .t +0+0
+ toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new
+ tkwait visibility .x
+ list [colorsFree .t] [colorsFree .x]
+} -cleanup {
+ destroy .t
+} -result {0 1}
+test frame-3.16 {TkCreateFrame procedure} -constraints {
+ defaultPseudocolor8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 300 -height 200 -bg #475601 -visual default
+ wm geometry .t +0+0
+ update
+ colorsFree .t
+} -cleanup {
+ deleteWindows
+} -result {0}
+test frame-3.17 {TkCreateFrame procedure} -constraints {
+ defaultPseudocolor8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 300 -height 200 -bg #475601 -visual default \
+ -colormap new
+ wm geometry .t +0+0
+ update
+ colorsFree .t
+} -cleanup {
+ deleteWindows
+} -result {1}
+test frame-3.18 {TkCreateFrame procedure} -constraints {
+ defaultPseudocolor8 haveGrayscale8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343
+ wm geometry .t +0+0
+ update
+ colorsFree .t 131 131 131
+} -cleanup {
+ deleteWindows
+} -result {1}
+test frame-3.19 {TkCreateFrame procedure} -constraints {
+ defaultPseudocolor8 haveGrayscale8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ option add *t.class T4
+ option add *T4.visual {grayscale 8}
+ toplevel .t -width 300 -height 200 -bg #434343
+ wm geometry .t +0+0
+ update
+ option clear
+ list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
+} -cleanup {
+ deleteWindows
+} -result {1 {grayscale 8}}
+test frame-3.20 {TkCreateFrame procedure} -constraints {
+ defaultPseudocolor8 haveGrayscale8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ set x ok
+ option add *t.class T5
+ option add *T5.Visual {grayscale 8}
+ toplevel .t -width 300 -height 200 -bg #434343
+ wm geometry .t +0+0
+ update
+ option clear
+ list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
+} -cleanup {
+ deleteWindows
+} -result {1 {grayscale 8}}
+test frame-3.21 {TkCreateFrame procedure} -constraints {
+ defaultPseudocolor8 haveGrayscale8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ set x ok
+ toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343
+ wm geometry .t +0+0
+ update
+ colorsFree .t 131 131 131
+} -cleanup {
+ deleteWindows
+} -result {1}
+if {[testConstraint defaultPseudocolor8]} {
+ destroy .t1
+}
+
+test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup {
+ deleteWindows
+} -body {
+ toplevel .t
+ wm geometry .t +0+0
+ update
+ set result "[winfo reqwidth .t] [winfo reqheight .t]"
+ frame .t.f -bg red
+ pack .t.f
+ update
+ lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f]
+} -cleanup {
+ deleteWindows
+} -result {200 200 1 1}
+test frame-3.23 {TkCreateFrame procedure} -setup {
+ deleteWindows
+} -body {
+ frame .f -gorp glob
+} -returnCodes error -result {unknown option "-gorp"}
+test frame-3.24 {TkCreateFrame procedure} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 300 -height 200 -colormap new -bogus option
+ wm geometry .t +0+0
+} -returnCodes error -result {unknown option "-bogus"}
+
+
+test frame-4.1 {TkCreateFrame procedure} -setup {
+ deleteWindows
+} -body {
+ catch {frame .f -gorp glob}
+ winfo exists .f
+} -result 0
+test frame-4.2 {TkCreateFrame procedure} -setup {
+ deleteWindows
+} -body {
+ list [frame .f -width 200 -height 100] [winfo exists .f]
+} -cleanup {
+ deleteWindows
+} -result {.f 1}
+
+
+frame .f -highlightcolor black
+test frame-5.1 {FrameWidgetCommand procedure} -body {
+ .f
+} -returnCodes error -result {wrong # args: should be ".f option ?arg ...?"}
+test frame-5.2 {FrameWidgetCommand procedure, cget option} -body {
+ .f cget
+} -returnCodes error -result {wrong # args: should be ".f cget option"}
+test frame-5.3 {FrameWidgetCommand procedure, cget option} -body {
+ .f cget a b
+} -returnCodes error -result {wrong # args: should be ".f cget option"}
+test frame-5.4 {FrameWidgetCommand procedure, cget option} -body {
+ .f cget -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test frame-5.5 {FrameWidgetCommand procedure, cget option} -body {
+ .f cget -highlightcolor
+} -result {black}
+test frame-5.6 {FrameWidgetCommand procedure, cget option} -body {
+ .f cget -screen
+} -returnCodes error -result {unknown option "-screen"}
+test frame-5.7 {FrameWidgetCommand procedure, cget option} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ .t cget -screen
+} -cleanup {
+ destroy .t
+} -returnCodes ok -match glob -result *
+
+test frame-5.8 {FrameWidgetCommand procedure, configure option} -body {
+ llength [.f configure]
+} -result {18}
+test frame-5.9 {FrameWidgetCommand procedure, configure option} -body {
+ .f configure -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test frame-5.10 {FrameWidgetCommand procedure, configure option} -body {
+ .f configure -gorp bogus
+} -returnCodes error -result {unknown option "-gorp"}
+test frame-5.11 {FrameWidgetCommand procedure, configure option} -body {
+ .f configure -width 200 -height
+} -returnCodes error -result {value for "-height" missing}
+test frame-5.12 {FrameWidgetCommand procedure} -body {
+ .f swizzle
+} -returnCodes error -result {bad option "swizzle": must be cget or configure}
+test frame-5.13 {FrameWidgetCommand procedure, configure option} -body {
+ llength [. configure]
+} -result {21}
+destroy .f
+
+test frame-6.1 {ConfigureFrame procedure} -setup {
+ deleteWindows
+} -body {
+ frame .f -width 150
+ list [winfo reqwidth .f] [winfo reqheight .f]
+} -cleanup {
+ deleteWindows
+} -result {150 1}
+test frame-6.2 {ConfigureFrame procedure} -setup {
+ deleteWindows
+} -body {
+ frame .f -height 97
+ list [winfo reqwidth .f] [winfo reqheight .f]
+} -cleanup {
+ deleteWindows
+} -result {1 97}
+test frame-6.3 {ConfigureFrame procedure} -setup {
+ deleteWindows
+} -body {
+ frame .f
+ set result {}
+ lappend result [winfo reqwidth .f] [winfo reqheight .f]
+ .f configure -width 100 -height 180
+ lappend result [winfo reqwidth .f] [winfo reqheight .f]
+ .f configure -width 0 -height 0
+ lappend result [winfo reqwidth .f] [winfo reqheight .f]
+} -cleanup {
+ deleteWindows
+} -result {1 1 100 180 100 180}
+
+test frame-7.1 {FrameEventProc procedure} -setup {
+ deleteWindows
+} -body {
+ frame .frame2
+ set result [info commands .frame2]
+ destroy .frame2
+ lappend result [info commands .frame2]
+} -result {.frame2 {}}
+test frame-7.2 {FrameEventProc procedure} -setup {
+ deleteWindows
+ set x {}
+} -body {
+ frame .f1 -bg #543210
+ rename .f1 .f2
+ lappend x [winfo children .]
+ lappend x [.f2 cget -bg]
+ destroy .f1
+ lappend x [info command .f*] [winfo children .]
+} -cleanup {
+ deleteWindows
+} -result {.f1 #543210 {} {}}
+
+test frame-8.1 {FrameCmdDeletedProc procedure} -setup {
+ deleteWindows
+} -body {
+ frame .f1
+ rename .f1 {}
+ list [info command .f*] [winfo children .]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test frame-8.2 {FrameCmdDeletedProc procedure} -setup {
+ deleteWindows
+} -body {
+ toplevel .f1 -menu .m
+ wm geometry .f1 +0+0
+ update
+ rename .f1 {}
+ update
+ list [info command .f*] [winfo children .]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+#
+# This one fails with the dash-patch!!!! Still don't know why :-(
+#
+#test frame-8.3 {FrameCmdDeletedProc procedure} -setup {
+# eval destroy [winfo children .]
+# deleteWindows
+#} -body {
+# toplevel .f1 -menu .m
+# wm geometry .f1 +0+0
+# menu .m
+# update
+# rename .f1 {}
+# update
+# list [info command .f*] [winfo children .]
+#} -cleanup {
+# eval destroy [winfo children .]
+# deleteWindows
+#} -result {{} .m}
+
+test frame-9.1 {MapFrame procedure} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 100 -height 400
+ wm geometry .t +0+0
+ set result [winfo ismapped .t]
+ update idletasks
+ lappend result [winfo ismapped .t]
+} -cleanup {
+ deleteWindows
+} -result {0 1}
+test frame-9.2 {MapFrame procedure} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -width 100 -height 400
+ wm geometry .t +0+0
+ destroy .t
+ update
+ winfo exists .t
+} -result {0}
+test frame-9.3 {MapFrame procedure, window deleted while mapping} -setup {
+ deleteWindows
+} -body {
+ toplevel .t2 -width 200 -height 200
+ wm geometry .t2 +0+0
+ tkwait visibility .t2
+ toplevel .t -width 100 -height 400
+ wm geometry .t +0+0
+ frame .t2.f -width 50 -height 50
+ bind .t2.f <Configure> {destroy .t}
+ pack .t2.f -side top
+ update idletasks
+ winfo exists .t
+} -cleanup {
+ deleteWindows
+} -result {0}
+
+
+test frame-10.1 {frame widget vs hidden commands} -setup {
+ deleteWindows
+} -body {
+ set l [interp hidden]
+ frame .t
+ interp hide {} .t
+ destroy .t
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 eq $res2}
+} -result 1
+
+
+test frame-11.1 {TkInstallFrameMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m1.system
+ menu .m1.system -tearoff 0
+ .m1.system add command -label foo
+ toplevel .t -menu .m1
+} -cleanup {
+ deleteWindows
+} -result {.t}
+test frame-11.2 {TkInstallFrameMenu - frame renamed} -setup {
+ deleteWindows
+} -body {
+ catch {rename foo {}}
+ menu .m1
+ .m1 add cascade -menu .m1.system
+ menu .m1.system -tearoff 0
+ .m1.system add command -label foo
+ toplevel .t
+ rename .t foo
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test frame-12.1 {FrameWorldChanged procedure} -setup {
+ deleteWindows
+} -body {
+ # Test -bd -padx and -pady
+ frame .f -borderwidth 2 -padx 3 -pady 4
+ place .f -x 0 -y 0 -width 40 -height 40
+ pack [frame .f.f] -fill both -expand 1
+ update
+ list [winfo x .f.f] [winfo y .f.f] [winfo width .f.f] [winfo height .f.f]
+} -cleanup {
+ deleteWindows
+} -result {5 6 30 28}
+test frame-12.2 {FrameWorldChanged procedure} -setup {
+ deleteWindows
+} -body {
+ # Test all -labelanchor positions
+ set font {helvetica 12}
+ labelframe .f -highlightthickness 1 -bd 3 -padx 1 -pady 2 -font $font \
+ -text "Mupp"
+ set fh [expr {[font metrics $font -linespace] + 2 - 3}]
+ set fw [expr {[font measure $font "Mupp"] + 2 - 3}]
+ if {$fw < 0} {set fw 0}
+ if {$fh < 0} {set fh 0}
+ place .f -x 0 -y 0 -width 100 -height 100
+ pack [frame .f.f] -fill both -expand 1
+
+ set result {}
+ foreach lp {nw n ne en e es se s sw ws w wn} {
+ .f configure -labelanchor $lp
+ update
+ set expx 5
+ set expy 6
+ set expw 90
+ set exph 88
+ switch -glob $lp {
+ n* {incr expy $fh ; incr exph -$fh}
+ s* {incr exph -$fh}
+ w* {incr expx $fw ; incr expw -$fw}
+ e* {incr expw -$fw}
+ }
+ lappend result [expr {\
+ [winfo x .f.f] == $expx && [winfo y .f.f] == $expy &&\
+ [winfo width .f.f] == $expw && [winfo height .f.f] == $exph}]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {1 1 1 1 1 1 1 1 1 1 1 1}
+test frame-12.3 {FrameWorldChanged procedure} -setup {
+ deleteWindows
+} -body {
+ # Check reaction on font change
+ font create myfont -family courier -size 10
+ labelframe .f -font myfont -text Mupp
+ place .f -x 0 -y 0 -width 40 -height 40
+ pack [frame .f.f] -fill both -expand 1
+ update
+ set h1 [font metrics myfont -linespace]
+ set y1 [winfo y .f.f]
+ font configure myfont -size 20
+ update
+ set h2 [font metrics myfont -linespace]
+ set y2 [winfo y .f.f]
+ expr {($h2 - $h1) - ($y2 - $y1)}
+} -cleanup {
+ deleteWindows
+ font delete myfont
+} -result {0}
+
+
+test frame-13.1 {labelframe configuration options} -setup {
+ deleteWindows
+} -body {
+ labelframe .f -class NewFrame
+ .f configure -class
+} -cleanup {
+ deleteWindows
+} -result {-class class Class Labelframe NewFrame}
+test frame-13.2 {labelframe configuration options} -setup {
+ deleteWindows
+} -body {
+ labelframe .f -class NewFrame
+ .f configure -class Different
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't modify -class option after widget is created}
+test frame-13.3 {labelframe configuration options} -setup {
+ deleteWindows
+} -body {
+ labelframe .f -colormap new
+} -cleanup {
+ deleteWindows
+} -result {.f}
+test frame-13.4 {labelframe configuration options} -setup {
+ deleteWindows
+} -body {
+ labelframe .f -visual default
+} -cleanup {
+ deleteWindows
+} -result {.f}
+test frame-13.5 {labelframe configuration options} -setup {
+ deleteWindows
+} -body {
+ labelframe .f -screen bogus
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown option "-screen"}
+test frame-13.6 {labelframe configuration options} -setup {
+ deleteWindows
+} -body {
+ labelframe .f -container true
+} -cleanup {
+ deleteWindows
+} -result {.f}
+test frame-13.7 {labelframe configuration options} -setup {
+ deleteWindows
+} -body {
+ labelframe .f -container true
+ .f configure -container
+} -cleanup {
+ deleteWindows
+} -result {-container container Container 0 1}
+test frame-13.8 {labelframe configuration options} -setup {
+ deleteWindows
+} -body {
+ labelframe .f -container bogus
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected boolean value but got "bogus"}
+test frame-13.9 {labelframe configuration options} -setup {
+ deleteWindows
+} -body {
+ labelframe .f
+ .f configure -container 1
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't modify -container option after widget is created}
+
+destroy .f
+labelframe .f
+test frame-13.10 {labelframe configuration options} -body {
+ .f configure -background #ff0000
+ lindex [.f configure -background] 4
+} -cleanup {
+ .f configure -background [lindex [.f configure -background] 3]
+} -result {#ff0000}
+test frame-13.11 {labelframe configuration options} -body {
+ .f configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test frame-13.12 {labelframe configuration options} -body {
+ .f configure -bd 4
+ lindex [.f configure -bd] 4
+} -cleanup {
+ .f configure -bd [lindex [.f configure -bd] 3]
+} -result {4}
+test frame-13.13 {labelframe configuration options} -body {
+ .f configure -bd badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-13.14 {labelframe configuration options} -body {
+ .f configure -bg #00ff00
+ lindex [.f configure -bg] 4
+} -cleanup {
+ .f configure -bg [lindex [.f configure -bg] 3]
+} -result {#00ff00}
+test frame-13.15 {labelframe configuration options} -body {
+ .f configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test frame-13.16 {labelframe configuration options} -body {
+ .f configure -borderwidth 1.3
+ lindex [.f configure -borderwidth] 4
+} -cleanup {
+ .f configure -borderwidth [lindex [.f configure -borderwidth] 3]
+} -result {1}
+test frame-13.17 {labelframe configuration options} -body {
+ .f configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-13.18 {labelframe configuration options} -body {
+ .f configure -cursor arrow
+ lindex [.f configure -cursor] 4
+} -cleanup {
+ .f configure -cursor [lindex [.f configure -cursor] 3]
+} -result {arrow}
+test frame-13.19 {labelframe configuration options} -body {
+ .f configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test frame-13.20 {labelframe configuration options} -body {
+ .f configure -fg #0000ff
+ lindex [.f configure -fg] 4
+} -cleanup {
+ .f configure -fg [lindex [.f configure -fg] 3]
+} -result {#0000ff}
+test frame-13.21 {labelframe configuration options} -body {
+ .f configure -fg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test frame-13.22 {labelframe configuration options} -body {
+ .f configure -font {courier 8}
+ lindex [.f configure -font] 4
+} -cleanup {
+ .f configure -font [lindex [.f configure -font] 3]
+} -result {courier 8}
+test frame-13.23 {labelframe configuration options} -body {
+ .f configure -foreground #ff0000
+ lindex [.f configure -foreground] 4
+} -cleanup {
+ .f configure -foreground [lindex [.f configure -foreground] 3]
+} -result {#ff0000}
+test frame-13.24 {labelframe configuration options} -body {
+ .f configure -foreground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test frame-13.25 {labelframe configuration options} -body {
+ .f configure -height 100
+ lindex [.f configure -height] 4
+} -cleanup {
+ .f configure -height [lindex [.f configure -height] 3]
+} -result {100}
+test frame-13.26 {labelframe configuration options} -body {
+ .f configure -height not_a_number
+} -returnCodes error -result {bad screen distance "not_a_number"}
+test frame-13.27 {labelframe configuration options} -body {
+ .f configure -highlightbackground #112233
+ lindex [.f configure -highlightbackground] 4
+} -cleanup {
+ .f configure -highlightbackground [lindex [.f configure -highlightbackground] 3]
+} -result {#112233}
+test frame-13.28 {labelframe configuration options} -body {
+ .f configure -highlightbackground ugly
+} -returnCodes error -result {unknown color name "ugly"}
+test frame-13.29 {labelframe configuration options} -body {
+ .f configure -highlightcolor #123456
+ lindex [.f configure -highlightcolor] 4
+} -cleanup {
+ .f configure -highlightcolor [lindex [.f configure -highlightcolor] 3]
+} -result {#123456}
+test frame-13.30 {labelframe configuration options} -body {
+ .f configure -highlightcolor non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test frame-13.31 {labelframe configuration options} -body {
+ .f configure -highlightthickness 6
+ lindex [.f configure -highlightthickness] 4
+} -cleanup {
+ .f configure -highlightthickness [lindex [.f configure -highlightthickness] 3]
+} -result {6}
+test frame-13.32 {labelframe configuration options} -body {
+ .f configure -highlightthickness badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-13.33 {labelframe configuration options} -body {
+ .f configure -labelanchor se
+ lindex [.f configure -labelanchor] 4
+} -cleanup {
+ .f configure -labelanchor [lindex [.f configure -labelanchor] 3]
+} -result {se}
+test frame-13.34 {labelframe configuration options} -body {
+ .f configure -labelanchor badValue
+} -returnCodes error -result {bad labelanchor "badValue": must be e, en, es, n, ne, nw, s, se, sw, w, wn, or ws}
+test frame-13.35 {labelframe configuration options} -body {
+ .f configure -padx 3
+ lindex [.f configure -padx] 4
+} -cleanup {
+ .f configure -padx [lindex [.f configure -padx] 3]
+} -result {3}
+test frame-13.36 {labelframe configuration options} -body {
+ .f configure -padx badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-13.37 {labelframe configuration options} -body {
+ .f configure -pady 4
+ lindex [.f configure -pady] 4
+} -cleanup {
+ .f configure -pady [lindex [.f configure -pady] 3]
+} -result {4}
+test frame-13.38 {labelframe configuration options} -body {
+ .f configure -pady badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test frame-13.39 {labelframe configuration options} -body {
+ .f configure -relief ridge
+ lindex [.f configure -relief] 4
+} -cleanup {
+ .f configure -relief [lindex [.f configure -relief] 3]
+} -result {ridge}
+test frame-13.40 {labelframe configuration options} -body {
+ .f configure -relief badValue
+} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}
+test frame-13.41 {labelframe configuration options} -body {
+ .f configure -takefocus {any string}
+ lindex [.f configure -takefocus] 4
+} -cleanup {
+ .f configure -takefocus [lindex [.f configure -takefocus] 3]
+} -result {any string}
+test frame-13.42 {labelframe configuration options} -body {
+ .f configure -text {any string}
+ lindex [.f configure -text] 4
+} -cleanup {
+ .f configure -text [lindex [.f configure -text] 3]
+} -result {any string}
+test frame-13.43 {labelframe configuration options} -body {
+ .f configure -width 32
+ lindex [.f configure -width] 4
+} -cleanup {
+ .f configure -width [lindex [.f configure -width] 3]
+} -result {32}
+test frame-13.44 {labelframe configuration options} -body {
+ .f configure -width badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+destroy .f
+
+
+test frame-14.1 {labelframe labelwidget option} -setup {
+ deleteWindows
+} -body {
+ # Test that label is moved in stacking order
+ label .l -text Mupp -font {helvetica 8}
+ labelframe .f -labelwidget .l
+ pack .f
+ frame .f.f -width 50 -height 50
+ pack .f.f
+ update
+ list [winfo children .] [winfo width .f] \
+ [expr {[winfo height .f] - [winfo height .l]}]
+} -cleanup {
+ deleteWindows
+} -result {{.f .l} 54 52}
+test frame-14.2 {labelframe labelwidget option} -setup {
+ deleteWindows
+} -body {
+ # Test the labelframe's reaction if the label is destroyed
+ label .l -text Aratherlonglabel
+ labelframe .f -labelwidget .l
+ pack .f
+ label .f.l -text Mupp
+ pack .f.l
+ update
+ set res [list [.f cget -labelwidget]]
+ lappend res [expr {[winfo width .f] - [winfo width .l]}]
+ destroy .l
+ lappend res [.f cget -labelwidget]
+ update
+ lappend res [expr {[winfo width .f] - [winfo width .f.l]}]
+} -cleanup {
+ deleteWindows
+} -result {.l 12 {} 4}
+test frame-14.3 {labelframe labelwidget option} -setup {
+ deleteWindows
+} -body {
+ # Test the labelframe's reaction if the label is stolen
+ label .l -text Aratherlonglabel
+ labelframe .f -labelwidget .l
+ pack .f
+ label .f.l -text Mupp
+ pack .f.l
+ update
+ set res [list [.f cget -labelwidget]]
+ lappend res [expr {[winfo width .f] - [winfo width .l]}]
+ pack .l
+ lappend res [.f cget -labelwidget]
+ update
+ lappend res [expr {[winfo width .f] - [winfo width .f.l]}]
+} -cleanup {
+ deleteWindows
+} -result {.l 12 {} 4}
+test frame-14.4 {labelframe labelwidget option} -setup {
+ deleteWindows
+} -body {
+ # Test the label's reaction if the labelframe is destroyed
+ label .l -text Mupp
+ labelframe .f -labelwidget .l
+ pack .f
+ update
+ set res [list [winfo manager .l]]
+ destroy .f
+ lappend res [winfo manager .l]
+} -cleanup {
+ deleteWindows
+} -result {labelframe {}}
+test frame-14.5 {labelframe labelwidget option} -setup {
+ deleteWindows
+} -body {
+ # Test that the labelframe reacts on changes in label
+ label .l -text Aratherlonglabel
+ labelframe .f -labelwidget .l
+ pack .f
+ label .f.l -text Mupp
+ pack .f.l
+ update
+ set first [winfo width .f]
+ set res [expr {[winfo width .f] - [winfo width .l]}]
+ .l configure -text Shorter
+ update
+ lappend res [expr {[winfo width .f] - [winfo width .l]}]
+ lappend res [expr {[winfo width .f] < $first}]
+ .l configure -text Alotlongerthananytimebefore
+ update
+ lappend res [expr {[winfo width .f] - [winfo width .l]}]
+ lappend res [expr {[winfo width .f] > $first}]
+} -cleanup {
+ deleteWindows
+} -result {12 12 1 12 1}
+test frame-14.6 {labelframe labelwidget option} -setup {
+ deleteWindows
+} -body {
+ # Destroying a labelframe with a child label caused a crash
+ # when not handling mapping of the label correctly.
+ # This test does not test anything directly, it's just ment
+ # to catch if the same mistake is made again.
+ labelframe .f
+ pack .f
+ label .f.l -text Mupp
+ .f configure -labelwidget .f.l
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+deleteWindows
+rename eatColors {}
+rename colorsFree {}
+
+# cleanup
+cleanupTests
+return
+
+
+
+
diff --git a/tk8.6/tests/geometry.test b/tk8.6/tests/geometry.test
new file mode 100644
index 0000000..13cc515
--- /dev/null
+++ b/tk8.6/tests/geometry.test
@@ -0,0 +1,291 @@
+# This file is a Tcl script to test the procedures in the file
+# tkGeometry.c (generic support for geometry managers). It is
+# organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+proc getsize w {
+ regexp {(^[^+-]*)} [wm geometry $w] foo x
+ return $x
+}
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+
+wm geometry . 300x300
+raise .
+update
+
+frame .f -bd 2 -relief raised
+frame .f.f -bd 2 -relief sunken
+frame .f.f.f -bd 2 -relief raised
+button .b1 -text .b1
+button .b2 -text .b2
+button .b3 -text .b3
+button .f.f.b4 -text .b4
+
+test geometry-1.1 {Tk_ManageGeometry procedure} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+} -body {
+ place .b1 -x 120 -y 80
+ update
+ list [winfo x .b1] [winfo y .b1]
+} -result {120 80}
+test geometry-1.2 {Tk_ManageGeometry procedure} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+} -body {
+ place .f -x 20 -y 30 -width 200 -height 200
+ place .b1 -in .f -x 40 -y 30
+ update
+ pack .b1 -side top -anchor w
+ place .f -x 30 -y 40
+ update
+ list [winfo x .b1] [winfo y .b1]
+} -result {0 0}
+
+
+test geometry-2.1 {Tk_GeometryRequest procedure} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+ destroy .f2
+} -body {
+ frame .f2
+ set result [list [winfo reqwidth .f2] [winfo reqheight .f2]]
+ .f2 configure -width 150 -height 300
+ update
+ lappend result [winfo reqwidth .f2] [winfo reqheight .f2] \
+ [winfo geom .f2]
+ place .f2 -x 10 -y 20
+ update
+ lappend result [winfo geom .f2]
+ .f2 configure -width 100 -height 80
+ update
+ lappend result [winfo geom .f2]
+} -cleanup {
+ destroy .f2
+} -result {1 1 150 300 1x1+0+0 150x300+10+20 100x80+10+20}
+
+
+test geometry-3.1 {Tk_SetInternalBorder procedure} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+} -body {
+ place .f -x 20 -y 30 -width 200 -height 200
+ place .b1 -in .f -x 50 -y 5
+ update
+ set x [list [winfo x .b1] [winfo y .b1]]
+ .f configure -bd 5
+ update
+ lappend x [winfo x .b1] [winfo y .b1]
+} -cleanup {
+ .f configure -bd 2
+} -result {72 37 75 40}
+
+
+test geometry-4.1 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+} -body {
+ place .f -x 20 -y 30 -width 200 -height 200
+ place .f.f -x 15 -y 5 -width 150 -height 120
+ place .f.f.f -width 100 -height 80
+ place .b1 -in .f.f.f -x 50 -y 5
+ update
+ list [winfo x .b1] [winfo y .b1]
+} -result {91 46}
+test geometry-4.2 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+} -body {
+ place .f -x 20 -y 30 -width 200 -height 200
+ place .f.f -x 15 -y 5 -width 150 -height 120
+ place .f.f.f -width 100 -height 80
+ place .b1 -in .f.f.f -x 50 -y 5
+ place .b2 -in .f.f.f -x 10 -y 25
+ place .b3 -in .f.f.f -x 50 -y 25
+ update
+ place .f -x 30 -y 25
+ update
+ list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \
+ [winfo x .b3] [winfo y .b3]
+} -result {101 41 61 61 101 61}
+test geometry-4.3 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+} -body {
+ place .f -x 20 -y 30 -width 200 -height 200
+ place .f.f -x 15 -y 5 -width 150 -height 120
+ place .f.f.f -width 100 -height 80
+ place .b1 -in .f.f.f -x 50 -y 5
+ place .b2 -in .f.f.f -x 10 -y 25
+ place .b3 -in .f.f.f -x 50 -y 25
+ update
+ destroy .b1
+ button .b1 -text .b1
+ place .f.f -x 10 -y 25
+ update
+ list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \
+ [winfo x .b3] [winfo y .b3]
+} -result {0 0 46 86 86 86}
+test geometry-4.4 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+} -body {
+ place .f -x 20 -y 30 -width 200 -height 200
+ place .f.f -x 15 -y 5 -width 150 -height 120
+ place .f.f.f -width 100 -height 80
+ place .b1 -in .f.f.f -x 50 -y 5
+ place .b2 -in .f.f.f -x 10 -y 25
+ place .b3 -in .f.f.f -x 50 -y 25
+ update
+ destroy .b2
+ button .b2 -text .b2
+ place .f.f.f -x 2 -y 3
+ update
+ list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \
+ [winfo x .b3] [winfo y .b3]
+} -result {93 49 0 0 93 69}
+test geometry-4.5 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+} -body {
+ place .f -x 20 -y 30 -width 200 -height 200
+ place .f.f -x 15 -y 5 -width 150 -height 120
+ place .f.f.f -width 100 -height 80
+ place .b1 -in .f.f.f -x 50 -y 5
+ place .b2 -in .f.f.f -x 10 -y 25
+ place .b3 -in .f.f.f -x 50 -y 25
+ update
+ destroy .b3
+ button .b3 -text .b3
+ place .f.f.f -x 2 -y 3
+ update
+ list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \
+ [winfo x .b3] [winfo y .b3]
+} -result {93 49 53 69 0 0}
+test geometry-4.6 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+} -body {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3 .f.f.b4} {
+ place forget $w
+ }
+ place .f -x 20 -y 30 -width 200 -height 200
+ place .f.f -x 15 -y 5 -width 150 -height 120
+ place .f.f.f -width 100 -height 80
+ place .f.f.b4 -in .f.f.f -x 50 -y 5
+ place .b2 -in .f.f.f -x 10 -y 25
+ update
+ place .f -x 25 -y 35
+ update
+ list [winfo x .f.f.b4] [winfo y .f.f.b4] [winfo x .b2] [winfo y .b2]
+} -result {54 9 56 71}
+test geometry-4.7 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+} -body {
+ bind .b1 <Configure> {lappend x configure}
+ place .f -x 20 -y 30 -width 200 -height 200
+ place .f.f -x 15 -y 5 -width 150 -height 120
+ place .f.f.f -width 100 -height 80
+ place .f.f.b4 -in .f.f.f -x 50 -y 5
+ place .b1 -in .f.f.f -x 10 -y 25
+ update
+ set x init
+ place .f -x 25 -y 35
+ update
+ lappend x |
+ place .f -x 30 -y 40
+ place .f.f -x 10 -y 0
+ update
+ return $x
+} -cleanup {
+ bind .b1 <Configure> {}
+} -result {init configure |}
+test geometry-4.8 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+} -body {
+ place .f -x 20 -y 30 -width 200 -height 200
+ place .f.f -x 15 -y 5 -width 150 -height 120
+ place .f.f.f -width 100 -height 80
+ place .b1 -in .f.f.f -x 50 -y 5
+ place .b2 -in .f.f.f -x 10 -y 25
+ place .b3 -in .f.f.f -x 50 -y 25
+ update
+ destroy .f.f
+ frame .f.f -bd 2 -relief raised
+ frame .f.f.f -bd 2 -relief raised
+ place .f -x 30 -y 25
+ update
+ list [winfo x .b1] [winfo y .b1] [winfo ismapped .b1] \
+ [winfo x .b2] [winfo y .b2] [winfo ismapped .b2] \
+ [winfo x .b3] [winfo y .b3] [winfo ismapped .b3]
+} -result {91 46 0 51 66 0 91 66 0}
+test geometry-4.9 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+} -body {
+ place .f -x 20 -y 30 -width 200 -height 200
+ place .f.f -x 15 -y 5 -width 150 -height 120
+ place .f.f.f -width 100 -height 80
+ place .b1 -in .f.f.f -x 50 -y 5
+ update
+ set result [winfo ismapped .b1]
+ place forget .f.f
+ update
+ lappend result [winfo ismapped .b1]
+ place .f.f -x 15 -y 5 -width 150 -height 120
+ update
+ lappend result [winfo ismapped .b1]
+} -result {1 0 1}
+test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup {
+ foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+ place forget $w
+ }
+ destroy .t
+} -body {
+ toplevel .t
+ wm geometry .t +0+0
+ tkwait visibility .t
+ update
+ pack [frame .t.f]
+ button .t.quit -text Quit -command exit
+ pack .t.quit -in .t.f
+ wm iconify .t
+ set x 0
+ after 500 {set x 1}
+ tkwait variable x
+ wm deiconify .t
+ update
+ winfo ismapped .t.quit
+} -cleanup {
+ destroy .t
+} -result {1}
+
+
+# cleanup
+cleanupTests
+return
+
diff --git a/tk8.6/tests/get.test b/tk8.6/tests/get.test
new file mode 100644
index 0000000..ea08c8c
--- /dev/null
+++ b/tk8.6/tests/get.test
@@ -0,0 +1,138 @@
+# This file is a Tcl script to test out the procedures in the file
+# tkGet.c. It is organized in the standard fashion for Tcl
+# white-box tests.
+#
+# Copyright (c) 1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+test get-1.1 {Tk_GetAnchorFromObj} -setup {
+ button .b
+} -body {
+ .b configure -anchor n
+ .b cget -anchor
+} -cleanup {
+ destroy .b
+} -result {n}
+test get-1.2 {Tk_GetAnchorFromObj} -setup {
+ button .b
+} -body {
+ .b configure -anchor ne
+ .b cget -anchor
+} -cleanup {
+ destroy .b
+} -result {ne}
+test get-1.3 {Tk_GetAnchorFromObj} -setup {
+ button .b
+} -body {
+ .b configure -anchor e
+ .b cget -anchor
+} -cleanup {
+ destroy .b
+} -result {e}
+test get-1.4 {Tk_GetAnchorFromObj} -setup {
+ button .b
+} -body {
+ .b configure -anchor se
+ .b cget -anchor
+} -cleanup {
+ destroy .b
+} -result {se}
+test get-1.5 {Tk_GetAnchorFromObj} -setup {
+ button .b
+} -body {
+ .b configure -anchor s
+ .b cget -anchor
+} -cleanup {
+ destroy .b
+} -result {s}
+test get-1.6 {Tk_GetAnchorFromObj} -setup {
+ button .b
+} -body {
+ .b configure -anchor sw
+ .b cget -anchor
+} -cleanup {
+ destroy .b
+} -result {sw}
+test get-1.7 {Tk_GetAnchorFromObj} -setup {
+ button .b
+} -body {
+ .b configure -anchor w
+ .b cget -anchor
+} -cleanup {
+ destroy .b
+} -result {w}
+test get-1.8 {Tk_GetAnchorFromObj} -setup {
+ button .b
+} -body {
+ .b configure -anchor nw
+ .b cget -anchor
+} -cleanup {
+ destroy .b
+} -result {nw}
+test get-1.9 {Tk_GetAnchorFromObj} -setup {
+ button .b
+} -body {
+ .b configure -anchor n
+ .b cget -anchor
+} -cleanup {
+ destroy .b
+} -result {n}
+test get-1.10 {Tk_GetAnchorFromObj} -setup {
+ button .b
+} -body {
+ .b configure -anchor center
+ .b cget -anchor
+} -cleanup {
+ destroy .b
+} -result {center}
+test get-1.11 {Tk_GetAnchorFromObj - error} -setup {
+ button .b
+} -body {
+ .b configure -anchor unknown
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad anchor "unknown": must be n, ne, e, se, s, sw, w, nw, or center}
+
+
+test get-2.1 {Tk_GetJustifyFromObj} -setup {
+ button .b
+} -body {
+ .b configure -justify left
+ .b cget -justify
+} -cleanup {
+ destroy .b
+} -result {left}
+test get-2.2 {Tk_GetJustifyFromObj} -setup {
+ button .b
+} -body {
+ .b configure -justify right
+ .b cget -justify
+} -cleanup {
+ destroy .b
+} -result {right}
+test get-2.3 {Tk_GetJustifyFromObj} -setup {
+ button .b
+} -body {
+ .b configure -justify center
+ .b cget -justify
+} -cleanup {
+ destroy .b
+} -result {center}
+test get-2.4 {Tk_GetJustifyFromObj - error} -setup {
+ button .b
+} -body {
+ .b configure -justify stupid
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad justification "stupid": must be left, right, or center}
+
+# cleanup
+cleanupTests
+return
+
diff --git a/tk8.6/tests/grab.test b/tk8.6/tests/grab.test
new file mode 100644
index 0000000..33399cb
--- /dev/null
+++ b/tk8.6/tests/grab.test
@@ -0,0 +1,188 @@
+# Tests for the grab command.
+#
+# This file contains a collection of tests for one or more of the Tk
+# built-in commands. Sourcing this file runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+# There's currently no way to test the actual grab effect, per se,
+# in an automated test. Therefore, this test suite only covers the
+# interface to the grab command (ie, error messages, etc.)
+
+
+test grab-1.1 {Tk_GrabObjCmd} -body {
+ grab
+} -returnCodes error -result {wrong # args: should be "grab ?-global? window" or "grab option ?arg ...?"}
+test grab-1.2 {Tk_GrabObjCmd} -body {
+ rename grab grabTest1.2
+ grabTest1.2
+} -cleanup {
+ rename grabTest1.2 grab
+} -returnCodes error -result {wrong # args: should be "grabTest1.2 ?-global? window" or "grabTest1.2 option ?arg ...?"}
+
+test grab-1.3 {Tk_GrabObjCmd, "grab ?-global? window"} -body {
+ grab .foo bar baz
+} -returnCodes error -result {wrong # args: should be "grab ?-global? window"}
+test grab-1.4 {Tk_GrabObjCmd, "grab ?-global? window"} -body {
+ destroy .foo
+ grab .foo
+} -returnCodes error -result {bad window path name ".foo"}
+test grab-1.5 {Tk_GrabObjCmd, "grab ?-global? window"} -body {
+ grab -foo bar
+} -returnCodes error -result {bad option "-foo": must be -global}
+test grab-1.6 {Tk_GrabObjCmd, "grab ?-global? window"} -body {
+ destroy .foo
+ grab -global .foo
+} -returnCodes error -result {bad window path name ".foo"}
+
+test grab-1.7 {Tk_GrabObjCmd} -body {
+ grab foo
+} -returnCodes error -result {bad option "foo": must be current, release, set, or status}
+
+test grab-1.8 {Tk_GrabObjCmd, "grab current ?window?"} -body {
+ grab current foo bar
+} -returnCodes error -result {wrong # args: should be "grab current ?window?"}
+test grab-1.9 {Tk_GrabObjCmd, "grab current ?window?"} -body {
+ destroy .foo
+ grab current .foo
+} -returnCodes error -result {bad window path name ".foo"}
+
+test grab-1.10 {Tk_GrabObjCmd, "grab release window"} -body {
+ grab release
+} -returnCodes error -result {wrong # args: should be "grab release window"}
+test grab-1.11 {Tk_GrabObjCmd, "grab release window"} -body {
+ destroy .foo
+ grab release .foo
+} -returnCodes ok -result {}
+test grab-1.12 {Tk_GrabObjCmd, "grab release window"} -body {
+ grab release foo
+} -returnCodes ok -result {}
+
+test grab-1.13 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
+ grab set
+} -returnCodes error -result {wrong # args: should be "grab set ?-global? window"}
+test grab-1.14 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
+ grab set foo bar baz
+} -returnCodes error -result {wrong # args: should be "grab set ?-global? window"}
+test grab-1.15 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
+ destroy .foo
+ grab set .foo
+} -returnCodes error -result {bad window path name ".foo"}
+test grab-1.16 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
+ grab set -foo bar
+} -returnCodes error -result {bad option "-foo": must be -global}
+test grab-1.17 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
+ destroy .foo
+ grab set -global .foo
+} -returnCodes error -result {bad window path name ".foo"}
+
+test grab-1.18 {Tk_GrabObjCmd, "grab status window"} -body {
+ grab status
+} -returnCodes error -result {wrong # args: should be "grab status window"}
+test grab-1.19 {Tk_GrabObjCmd, "grab status window"} -body {
+ grab status foo bar
+} -returnCodes error -result {wrong # args: should be "grab status window"}
+test grab-1.20 {Tk_GrabObjCmd, "grab status window"} -body {
+ destroy .foo
+ grab status .foo
+} -returnCodes error -result {bad window path name ".foo"}
+
+
+test grab-2.1 {Tk_GrabObjCmd, grab status gives correct status} -body {
+ set curr [grab current .]
+ if { [string length $curr] > 0 } {
+ grab release $curr
+ }
+ grab status .
+} -cleanup {
+ grab release .
+} -result {none}
+test grab-2.2 {Tk_GrabObjCmd, grab status gives correct status} -body {
+ set curr [grab current .]
+ if { [string length $curr] > 0 } {
+ grab release $curr
+ }
+ grab .
+ grab status .
+} -cleanup {
+ grab release .
+} -result {local}
+test grab-2.3 {Tk_GrabObjCmd, grab status gives correct status} -body {
+ set curr [grab current .]
+ if { [string length $curr] > 0 } {
+ grab release $curr
+ }
+ grab -global .
+ grab status .
+} -cleanup {
+ grab release .
+} -result {global}
+
+
+test grab-3.1 {Tk_GrabObjCmd, grab current gives correct information} -body {
+ set curr [grab current .]
+ if { [string length $curr] > 0 } {
+ grab release $curr
+ }
+ return $curr
+} -result {}
+test grab-3.2 {Tk_GrabObjCmd, grab current gives correct information} -body {
+ set curr [grab current .]
+ if { [string length $curr] > 0 } {
+ grab release $curr
+ }
+ grab .
+ grab current
+} -cleanup {
+ grab release .
+} -result {.}
+
+
+test grab-4.1 {Tk_GrabObjCmd, grab release releases grab} -body {
+ set curr [grab current .]
+ if { [string length $curr] > 0 } {
+ grab release $curr
+ }
+ grab .
+ set result [grab status .]
+ grab release .
+ lappend result [grab status .]
+ grab -global .
+ lappend result [grab status .]
+ grab release .
+ lappend result [grab status .]
+} -result {local none global none}
+
+
+test grab-5.1 {Tk_GrabObjCmd, grab set} -body {
+ set curr [grab current .]
+ if { [string length $curr] > 0 } {
+ grab release $curr
+ }
+ grab set .
+ list [grab current .] [grab status .]
+} -cleanup {
+ grab release .
+} -result {. local}
+test grab-5.2 {Tk_GrabObjCmd, grab set} -body {
+ set curr [grab current .]
+ if { [string length $curr] > 0 } {
+ grab release $curr
+ }
+ grab set -global .
+ list [grab current .] [grab status .]
+} -cleanup {
+ grab release .
+} -result {. global}
+
+
+cleanupTests
+return
+
diff --git a/tk8.6/tests/grid.test b/tk8.6/tests/grid.test
new file mode 100644
index 0000000..c1d9d06
--- /dev/null
+++ b/tk8.6/tests/grid.test
@@ -0,0 +1,2008 @@
+# This file is a Tcl script to test out the *NEW* "grid" command of Tk. It is
+# (almost) organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+# helper routine to return "." to a sane state after a test.
+# The variable GRID_VERBOSE can be used to "look" at the result of one or all
+# of the tests
+
+proc grid_reset {{test ?} {top .}} {
+ global GRID_VERBOSE
+ if {[info exists GRID_VERBOSE]} {
+ if {$GRID_VERBOSE eq "" || $GRID_VERBOSE eq $test} {
+ puts -nonewline "grid test $test: "
+ flush stdout
+ gets stdin
+ }
+ }
+ eval destroy [winfo children $top]
+ update
+ foreach {cols rows} [grid size .] {}
+ for {set i 0} {$i <= $cols} {incr i} {
+ grid columnconfigure . $i -weight 0 -minsize 0 -pad 0 -uniform ""
+ }
+ for {set i 0} {$i <= $rows} {incr i} {
+ grid rowconfigure . $i -weight 0 -minsize 0 -pad 0 -uniform ""
+ }
+ grid propagate . 1
+ grid anchor . nw
+ update
+}
+
+grid_reset 0.0
+wm geometry . {}
+
+test grid-1.1 {basic argument checking} -body {
+ grid
+} -returnCodes error -result {wrong # args: should be "grid option arg ?arg ...?"}
+test grid-1.2 {basic argument checking} -body {
+ grid foo bar
+} -returnCodes error -result {bad option "foo": must be anchor, bbox, columnconfigure, configure, forget, info, location, propagate, remove, rowconfigure, size, or slaves}
+test grid-1.3 {basic argument checking} -body {
+ button .b
+ grid .b -row 0 -column
+} -cleanup {
+ grid_reset 1.3
+} -returnCodes error -result {extra option or option with no value}
+test grid-1.4 {basic argument checking} -body {
+ button .b
+ grid configure .b - foo
+} -cleanup {
+ grid_reset 1.4
+} -returnCodes error -result {unexpected parameter "foo" in configure list: should be window name or option}
+test grid-1.5 {basic argument checking} -body {
+ grid .
+} -returnCodes error -result {can't manage ".": it's a top-level window}
+test grid-1.6 {basic argument checking} -body {
+ grid x
+} -returnCodes error -result {can't determine master window}
+test grid-1.7 {basic argument checking} -body {
+ grid configure x
+} -returnCodes error -result {can't determine master window}
+test grid-1.8 {basic argument checking} -body {
+ button .b
+ grid x .b
+} -cleanup {
+ grid_reset 1.8
+} -returnCodes ok -result {}
+test grid-1.9 {basic argument checking} -body {
+ button .b
+ grid configure x .b
+} -cleanup {
+ grid_reset 1.9
+} -returnCodes ok -result {}
+
+test grid-2.1 {bbox} -body {
+ grid bbox .
+} -result {0 0 0 0}
+test grid-2.2 {bbox} -body {
+ button .b
+ grid .b
+ destroy .b
+ update
+ grid bbox .
+} -result {0 0 0 0}
+test grid-2.3 {bbox: argument checking} -body {
+ grid bbox . 0 0 5
+} -returnCodes error -result {wrong # args: should be "grid bbox master ?column row ?column row??"}
+test grid-2.4 {bbox} -body {
+ grid bbox .bad 0 0
+} -returnCodes error -result {bad window path name ".bad"}
+test grid-2.5 {bbox} -body {
+ grid bbox . x 0
+} -returnCodes error -result {expected integer but got "x"}
+test grid-2.6 {bbox} -body {
+ grid bbox . 0 x
+} -returnCodes error -result {expected integer but got "x"}
+test grid-2.7 {bbox} -body {
+ grid bbox . 0 0 x 0
+} -returnCodes error -result {expected integer but got "x"}
+test grid-2.8 {bbox} -body {
+ grid bbox . 0 0 0 x
+} -returnCodes error -result {expected integer but got "x"}
+test grid-2.9 {bbox} -body {
+ frame .1 -width 75 -height 75 -bg red
+ frame .2 -width 90 -height 90 -bg red
+ grid .1 -row 0 -column 0
+ grid .2 -row 1 -column 1
+ update
+ set a ""
+ lappend a [grid bbox .]
+ lappend a [grid bbox . 0 0]
+ lappend a [grid bbox . 0 0 1 1]
+ lappend a [grid bbox . 1 1]
+ return $a
+} -cleanup {
+ grid_reset 2.9
+} -result {{0 0 165 165} {0 0 75 75} {0 0 165 165} {75 75 90 90}}
+test grid-2.10 {bbox} -body {
+ frame .1 -width 75 -height 75 -bg red
+ frame .2 -width 90 -height 90 -bg red
+ grid .1 -row 0 -column 0
+ grid .2 -row 1 -column 1
+ update
+ set a ""
+ lappend a [grid bbox . 10 10 0 0]
+ lappend a [grid bbox . -2 -2 -1 -1]
+ lappend a [grid bbox . 10 10 12 12]
+ return $a
+} -cleanup {
+ grid_reset 2.10
+} -result {{0 0 165 165} {0 0 0 0} {165 165 0 0}}
+
+test grid-3.1 {configure: basic argument checking} -body {
+ grid configure foo
+} -returnCodes error -result {bad argument "foo": must be name of window}
+test grid-3.2 {configure: basic argument checking} -body {
+ button .b
+ grid configure .b
+ grid slaves .
+} -cleanup {
+ grid_reset 3.2
+} -result {.b}
+test grid-3.3 {configure: basic argument checking} -body {
+ button .b
+ grid .b -row -1
+} -cleanup {
+ grid_reset 3.3
+} -returnCodes error -result {bad row value "-1": must be a non-negative integer}
+test grid-3.4 {configure: basic argument checking} -body {
+ button .b
+ grid .b -column -1
+} -cleanup {
+ grid_reset 3.4
+} -returnCodes error -result {bad column value "-1": must be a non-negative integer}
+test grid-3.5 {configure: basic argument checking} -body {
+ button .b
+ grid .b -rowspan 0
+} -cleanup {
+ grid_reset 3.5
+} -returnCodes error -result {bad rowspan value "0": must be a positive integer}
+test grid-3.6 {configure: basic argument checking} -body {
+ button .b
+ grid .b -columnspan 0
+} -cleanup {
+ grid_reset 3.6
+} -returnCodes error -result {bad columnspan value "0": must be a positive integer}
+test grid-3.7 {configure: basic argument checking} -body {
+ frame .f
+ button .f.b
+ grid .f .f.b
+} -cleanup {
+ grid_reset 3.7
+} -returnCodes error -result {can't put .f.b inside .}
+test grid-3.8 {configure: basic argument checking} -body {
+ button .b
+ grid configure x .b
+ grid slaves .
+} -cleanup {
+ grid_reset 3.8
+} -result {.b}
+test grid-3.9 {configure: basic argument checking} -body {
+ button .b
+ grid configure y .b
+} -cleanup {
+ grid_reset 3.9
+} -returnCodes error -result {invalid window shortcut, "y" should be '-', 'x', or '^'}
+
+test grid-4.1 {forget: basic argument checking} -body {
+ grid forget foo
+} -returnCodes error -result {bad window path name "foo"}
+test grid-4.2 {forget} -body {
+ button .c
+ grid [button .b]
+ set a [grid slaves .]
+ grid forget .b .c
+ lappend a [grid slaves .]
+ return $a
+} -cleanup {
+ grid_reset 4.2
+} -result {.b {}}
+test grid-4.3 {forget} -body {
+ button .c
+ grid .c -row 2 -column 2 -rowspan 2 -columnspan 2 -padx 3 -pady 4 -sticky ns
+ grid forget .c
+ grid .c -row 0 -column 0
+ grid info .c
+} -cleanup {
+ grid_reset 4.3
+} -result {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}}
+test grid-4.4 {forget} -body {
+ button .c
+ grid .c -row 2 -column 2 -rowspan 2 -columnspan 2 -padx {3 5} -pady {4 7} -sticky ns
+ grid forget .c
+ grid .c -row 0 -column 0
+ grid info .c
+} -cleanup {
+ grid_reset 4.3.1
+} -result {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}}
+test grid-4.5 {forget, calling Tk_UnmaintainGeometry} -body {
+ frame .f -bd 2 -relief raised
+ place .f -x 10 -y 20 -width 200 -height 100
+ frame .f2 -width 50 -height 30 -bg red
+ grid .f2 -in .f
+ update
+ set x [winfo ismapped .f2]
+ grid forget .f2
+ place .f -x 30
+ update
+ lappend x [winfo ismapped .f2]
+} -cleanup {
+ grid_reset 4.4
+} -result {1 0}
+
+test grid-5.1 {info: basic argument checking} -body {
+ grid info a b
+} -returnCodes error -result {wrong # args: should be "grid info window"}
+test grid-5.2 {info} -body {
+ frame .1 -width 75 -height 75 -bg red
+ grid .1 -row 0 -column 0
+ update
+ grid info .x
+} -cleanup {
+ grid_reset 5.2
+} -returnCodes error -result {bad window path name ".x"}
+test grid-5.3 {info} -body {
+ frame .1 -width 75 -height 75 -bg red
+ grid .1 -row 0 -column 0
+ update
+ grid info .1
+} -cleanup {
+ grid_reset 5.3
+} -result {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}}
+test grid-5.4 {info} -body {
+ frame .1 -width 75 -height 75 -bg red
+ update
+ grid info .1
+} -cleanup {
+ grid_reset 5.4
+} -returnCodes ok -result {}
+
+test grid-6.1 {location: basic argument checking} -body {
+ grid location .
+} -returnCodes error -result {wrong # args: should be "grid location master x y"}
+test grid-6.2 {location: basic argument checking} -body {
+ grid location .bad 0 0
+} -returnCodes error -result {bad window path name ".bad"}
+test grid-6.3 {location: basic argument checking} -body {
+ grid location . x y
+} -returnCodes error -result {bad screen distance "x"}
+test grid-6.4 {location: basic argument checking} -body {
+ grid location . 1c y
+} -returnCodes error -result {bad screen distance "y"}
+test grid-6.5 {location: basic argument checking} -body {
+ frame .f
+ grid location .f 10 10
+} -cleanup {
+ grid_reset 6.5
+} -result {-1 -1}
+test grid-6.6 {location (x)} -body {
+ frame .f -width 200 -height 100 -highlightthickness 0 -bg red
+ grid .f
+ update
+ set got ""
+ set result ""
+ for {set x -10} { $x < 220} { incr x} {
+ set a [grid location . $x 0]
+ if {$a != $got} {
+ lappend result $x->$a
+ set got $a
+ }
+ }
+ return $result
+} -cleanup {
+ grid_reset 6.6
+} -result {{-10->-1 0} {0->0 0} {201->1 0}}
+test grid-6.7 {location (y)} -body {
+ frame .f -width 200 -height 100 -highlightthickness 0 -bg red
+ grid .f
+ update
+ set got ""
+ set result ""
+ for {set y -10} { $y < 110} { incr y} {
+ set a [grid location . 0 $y]
+ if {$a != $got} {
+ lappend result $y->$a
+ set got $a
+ }
+ }
+ return $result
+} -cleanup {
+ grid_reset 6.7
+} -result {{-10->0 -1} {0->0 0} {101->0 1}}
+test grid-6.8 {location (weights)} -body {
+ frame .f -width 300 -height 100 -highlightthickness 0 -bg red
+ frame .a
+ grid .a
+ grid .f -in .a
+ grid rowconfigure .f 0 -weight 1
+ grid columnconfigure .f 0 -weight 1
+ grid propagate .a 0
+ .a configure -width 200 -height 15
+ update
+ set got ""
+ set result ""
+ for {set y -10} { $y < 210} { incr y} {
+ set a [grid location . $y $y]
+ if {$a != $got} {
+ lappend result $y->$a
+ set got $a
+ }
+ }
+ return $result
+} -cleanup {
+ grid_reset 6.8
+} -result {{-10->-1 -1} {0->0 0} {16->0 1} {201->1 1}}
+test grid-6.9 {location: check updates pending} -constraints {
+ nonPortable
+} -body {
+ set a ""
+ foreach i {0 1 2} {
+ frame .$i -width 120 -height 75 -bg red
+ lappend a [grid location . 150 90]
+ grid .$i -row $i -column $i
+ }
+ return $a
+} -cleanup {
+ grid_reset 6.9
+} -result {{0 0} {1 1} {1 1}}
+
+test grid-7.1 {propagate} -body {
+ grid propagate . 1 xxx
+} -cleanup {
+ grid_reset 7.1
+} -returnCodes error -result {wrong # args: should be "grid propagate window ?boolean?"}
+test grid-7.2 {propagate} -body {
+ grid propagate .
+} -cleanup {
+ grid_reset 7.2
+} -result {1}
+test grid-7.3 {propagate} -body {
+ grid propagate . 0;grid propagate .
+} -cleanup {
+ grid_reset 7.3
+} -result {0}
+test grid-7.4 {propagate} -body {
+ grid propagate .x
+} -cleanup {
+ grid_reset 7.4
+} -returnCodes error -result {bad window path name ".x"}
+test grid-7.5 {propagate} -body {
+ grid propagate . x
+} -cleanup {
+ grid_reset 7.5
+} -returnCodes error -result {expected boolean value but got "x"}
+test grid-7.6 {propagate} -body {
+ frame .f -width 100 -height 100 -bg red
+ grid .f -row 0 -column 0
+ update
+ set a [winfo width .f]x[winfo height .f]
+ grid propagate .f 0
+ frame .g -width 75 -height 85 -bg green
+ grid .g -in .f -row 0 -column 0
+ update
+ lappend a [winfo width .f]x[winfo height .f]
+ grid propagate .f 1
+ update
+ lappend a [winfo width .f]x[winfo height .f]
+ return $a
+} -cleanup {
+ grid_reset 7.6
+} -result {100x100 100x100 75x85}
+test grid-7.7 {propagate} -body {
+ grid propagate . 1
+ set res [list [grid propagate .]]
+ grid propagate . 0
+ lappend res [grid propagate .]
+ grid propagate . 0
+ lappend res [grid propagate .]
+ return $res
+} -cleanup {
+ grid_reset 7.7
+} -result [list 1 0 0]
+
+test grid-8.1 {size} -body {
+ grid size . foo
+} -cleanup {
+ grid_reset 8.1
+} -returnCodes error -result {wrong # args: should be "grid size window"}
+test grid-8.2 {size} -body {
+ grid size .x
+} -cleanup {
+ grid_reset 8.2
+} -returnCodes error -result {bad window path name ".x"}
+test grid-8.3 {size} -body {
+ frame .f
+ grid size .f
+} -cleanup {
+ grid_reset 8.3
+} -result {0 0}
+test grid-8.4 {size} -body {
+ catch {unset a}
+ scale .f
+ grid .f -row 0 -column 0
+ update
+ lappend a [grid size .]
+ grid .f -row 4 -column 5
+ update
+ lappend a [grid size .]
+ grid .f -row 947 -column 663
+ update
+ lappend a [grid size .]
+ grid .f -row 0 -column 0
+ update
+ lappend a [grid size .]
+ return $a
+} -cleanup {
+ grid_reset 8.4
+} -result {{1 1} {6 5} {664 948} {1 1}}
+test grid-8.5 {size} -body {
+ catch {unset a}
+ scale .f
+ grid .f -row 0 -column 0
+ update
+ lappend a [grid size .]
+ grid rowconfigure . 17 -weight 1
+ update
+ lappend a [grid size .]
+ grid columnconfigure . 63 -weight 1
+ update
+ lappend a [grid size .]
+ grid columnconfigure . 63 -weight 0
+ grid rowconfigure . 17 -weight 0
+ update
+ lappend a [grid size .]
+ return $a
+} -cleanup {
+ grid_reset 8.5
+} -result {{1 1} {1 18} {64 18} {1 1}}
+test grid-8.6 {size} -body {
+ catch {unset a}
+ scale .f
+ grid .f -row 10 -column 50
+ update
+ lappend a [grid size .]
+ grid columnconfigure . 15 -weight 1
+ grid columnconfigure . 30 -weight 1
+ update
+ lappend a [grid size .]
+ grid .f -row 10 -column 20
+ update
+ lappend a [grid size .]
+ grid columnconfigure . 30 -weight 0
+ update
+ lappend a [grid size .]
+ grid .f -row 0 -column 0
+ update
+ lappend a [grid size .]
+ grid columnconfigure . 15 -weight 0
+ update
+ lappend a [grid size .]
+ return $a
+} -cleanup {
+ grid_reset 8.6
+} -result {{51 11} {51 11} {31 11} {21 11} {16 1} {1 1}}
+
+test grid-9.1 {slaves} -body {
+ grid slaves .
+} -returnCodes ok -result {}
+test grid-9.2 {slaves} -body {
+ grid slaves .foo
+} -returnCodes error -result {bad window path name ".foo"}
+test grid-9.3 {slaves} -body {
+ grid slaves a b
+} -returnCodes error -result {wrong # args: should be "grid slaves window ?-option value ...?"}
+test grid-9.4 {slaves} -body {
+ grid slaves . a b
+} -returnCodes error -result {bad option "a": must be -column or -row}
+test grid-9.5 {slaves} -body {
+ grid slaves . -column x
+} -returnCodes error -result {expected integer but got "x"}
+test grid-9.6 {slaves} -body {
+ grid slaves . -row -3
+} -returnCodes error -result {-3 is an invalid value: should NOT be < 0}
+test grid-9.7 {slaves} -body {
+ grid slaves . -foo 3
+} -returnCodes error -result {bad option "-foo": must be -column or -row}
+test grid-9.8 {slaves} -body {
+ grid slaves .x -row 3
+} -returnCodes error -result {bad window path name ".x"}
+test grid-9.9 {slaves} -body {
+ grid slaves . -row 3
+} -returnCodes ok -result {}
+test grid-9.10 {slaves} -body {
+ foreach i {0 1 2} {
+ label .$i -text $i
+ grid .$i -row $i -column $i
+ }
+ grid slaves .
+} -cleanup {
+ grid_reset 9.10
+} -result {.2 .1 .0}
+test grid-9.11 {slaves} -body {
+ catch {unset a}
+ foreach i {0 1 2} {
+ label .$i -text $i
+ label .$i-x -text $i-x
+ grid .$i -row $i -column $i
+ grid .$i-x -row $i -column [incr i]
+ }
+ foreach row {0 1 2 3} {
+ lappend a $row{[grid slaves . -row $row]}
+ }
+ foreach col {0 1 2 3} {
+ lappend a $col{[grid slaves . -column $col]}
+ }
+ return $a
+} -cleanup {
+ grid_reset 9.11
+} -result {{0{.0-x .0}} {1{.1-x .1}} {2{.2-x .2}} 3{} 0{.0} {1{.1 .0-x}} {2{.2 .1-x}} 3{.2-x}}
+
+# column/row configure
+test grid-10.1 {column/row configure} -body {
+ grid columnconfigure .
+} -cleanup {
+ grid_reset 10.1
+} -returnCodes error -result {wrong # args: should be "grid columnconfigure master index ?-option value ...?"}
+test grid-10.2 {column/row configure} -body {
+ grid columnconfigure . 0 -weight 0 -pad
+} -cleanup {
+ grid_reset 10.2
+} -returnCodes error -result {wrong # args: should be "grid columnconfigure master index ?-option value ...?"}
+test grid-10.3 {column/row configure} -body {
+ grid columnconfigure .f 0 -weight
+} -cleanup {
+ grid_reset 10.3
+} -returnCodes error -result {bad window path name ".f"}
+test grid-10.4 {column/row configure} -body {
+ grid columnconfigure . nine -weight
+} -cleanup {
+ grid_reset 10.4
+} -returnCodes error -result {expected integer but got "nine" (when retrieving options only integer indices are allowed)}
+test grid-10.5 {column/row configure} -body {
+ grid columnconfigure . 265 -weight
+} -cleanup {
+ grid_reset 10.5
+} -result {0}
+test grid-10.6 {column/row configure} -body {
+ grid columnconfigure . 0
+} -cleanup {
+ grid_reset 10.6
+} -result {-minsize 0 -pad 0 -uniform {} -weight 0}
+test grid-10.7 {column/row configure} -body {
+ grid columnconfigure . 0 -foo
+} -cleanup {
+ grid_reset 10.7
+} -returnCodes error -result {bad option "-foo": must be -minsize, -pad, -uniform, or -weight}
+test grid-10.8 {column/row configure} -body {
+ grid columnconfigure . 0 -minsize foo
+} -cleanup {
+ grid_reset 10.8
+} -returnCodes error -result {bad screen distance "foo"}
+test grid-10.9 {column/row configure} -body {
+ grid columnconfigure . 0 -minsize foo
+} -cleanup {
+ grid_reset 10.9
+} -returnCodes error -result {bad screen distance "foo"}
+test grid-10.10 {column/row configure} -body {
+ grid columnconfigure . 0 -minsize 10
+ grid columnconfigure . 0 -minsize
+} -cleanup {
+ grid_reset 10.10
+} -result {10}
+test grid-10.11 {column/row configure} -body {
+ grid columnconfigure . 0 -weight bad
+} -cleanup {
+ grid_reset 10.11
+} -returnCodes error -result {expected integer but got "bad"}
+test grid-10.12 {column/row configure} -body {
+ grid columnconfigure . 0 -weight -3
+} -cleanup {
+ grid_reset 10.12
+} -returnCodes error -result {invalid arg "-weight": should be non-negative}
+test grid-10.13 {column/row configure} -body {
+ grid columnconfigure . 0 -weight 3
+ grid columnconfigure . 0 -weight
+} -cleanup {
+ grid_reset 10.13
+} -result {3}
+test grid-10.14 {column/row configure} -body {
+ grid columnconfigure . 0 -pad foo
+} -cleanup {
+ grid_reset 10.14
+} -returnCodes error -result {bad screen distance "foo"}
+test grid-10.15 {column/row configure} -body {
+ grid columnconfigure . 0 -pad -3
+} -cleanup {
+ grid_reset 10.15
+} -returnCodes error -result {invalid arg "-pad": should be non-negative}
+test grid-10.16 {column/row configure} -body {
+ grid columnconfigure . 0 -pad 3
+ grid columnconfigure . 0 -pad
+} -cleanup {
+ grid_reset 10.16
+} -result {3}
+test grid-10.17 {column/row configure} -body {
+ frame .f
+ set a ""
+ grid columnconfigure .f 0 -weight 0
+ lappend a [grid columnconfigure .f 0 -weight]
+ grid columnconfigure .f 0 -weight 1
+ lappend a [grid columnconfigure .f 0 -weight]
+ grid rowconfigure .f 0 -weight 0
+ lappend a [grid rowconfigure .f 0 -weight]
+ grid rowconfigure .f 0 -weight 1
+ lappend a [grid columnconfigure .f 0 -weight]
+ grid columnconfigure .f 0 -weight 0
+ return $a
+} -cleanup {
+ grid_reset 10.17
+} -result {0 1 0 1}
+test grid-10.18 {column/row configure} -body {
+ frame .f
+ grid columnconfigure .f {0 2} -minsize 10 -weight 1
+ list [grid columnconfigure .f 0 -minsize] \
+ [grid columnconfigure .f 1 -minsize] \
+ [grid columnconfigure .f 2 -minsize] \
+ [grid columnconfigure .f 0 -weight] \
+ [grid columnconfigure .f 1 -weight] \
+ [grid columnconfigure .f 2 -weight]
+} -cleanup {
+ grid_reset 10.18
+} -result {10 0 10 1 0 1}
+test grid-10.19 {column/row configure} -body {
+ grid columnconfigure . {0 -1 2} -weight 1
+} -cleanup {
+ grid_reset 10.19
+} -returnCodes error -result {"-1" is out of range}
+test grid-10.20 {column/row configure} -body {
+ grid columnconfigure . 0 -uniform foo
+ grid columnconfigure . 0 -uniform
+} -cleanup {
+ grid_reset 10.20
+} -result {foo}
+test grid-10.21 {column/row configure} -body {
+ grid columnconfigure . .b -weight 1
+} -cleanup {
+ grid_reset 10.21
+} -returnCodes error -result {illegal index ".b"}
+test grid-10.22 {column/row configure} -body {
+ button .b
+ grid columnconfigure . .b -weight 1
+} -cleanup {
+ grid_reset 10.22
+} -returnCodes error -result {the window ".b" is not managed by "."}
+test grid-10.23 {column/row configure} -body {
+ button .b
+ grid .b -column 1 -columnspan 2
+ grid columnconfigure . .b -weight 1
+ set res {}
+ foreach i {0 1 2 3} {
+ lappend res [grid columnconfigure . $i -weight]
+ }
+ return $res
+} -cleanup {
+ grid_reset 10.23
+} -result {0 1 1 0}
+test grid-10.24 {column/row configure} -body {
+ button .b
+ button .c
+ button .d
+ grid .b -column 1 -columnspan 2
+ grid .c -column 2 -columnspan 3
+ grid .d -column 4 -columnspan 2
+ grid columnconfigure . {.b .d} -weight 1
+ grid columnconfigure . .c -weight 2
+ set res {}
+ foreach i {0 1 2 3 4 5 6} {
+ lappend res [grid columnconfigure . $i -weight]
+ }
+ return $res
+} -cleanup {
+ grid_reset 10.24
+} -result {0 1 2 2 2 1 0}
+test grid-10.25 {column/row configure} -body {
+ button .b
+ button .c
+ button .d
+ grid .b -row 1 -rowspan 2
+ grid .c -row 2 -rowspan 3
+ grid .d -row 4 -rowspan 2
+ grid rowconfigure . {7 all} -weight 1
+ grid rowconfigure . {1 .d} -weight 2
+ set res {}
+ foreach i {0 1 2 3 4 5 6 7} {
+ lappend res [grid rowconfigure . $i -weight]
+ }
+ return $res
+} -cleanup {
+ grid_reset 10.25
+} -result {0 2 1 1 2 2 0 1}
+test grid-10.26 {column/row configure} -body {
+ button .b
+ grid columnconfigure .b 0
+} -cleanup {
+ grid_reset 10.26
+} -result {-minsize 0 -pad 0 -uniform {} -weight 0}
+test grid-10.27 {column/row configure - no indices} -body {
+ # Bug 1422430
+ set t [toplevel .test]
+ grid columnconfigure $t "" -weight 1
+} -cleanup {
+ destroy $t
+} -returnCodes error -result {no column indices specified}
+test grid-10.28 {column/row configure - no indices} -body {
+ set t [toplevel .test]
+ grid rowconfigure $t "" -weight 1
+} -cleanup {
+ destroy $t
+} -returnCodes error -result {no row indices specified}
+test grid-10.29 {column/row configure - invalid indices} -body {
+ grid columnconfigure . {0 1 2} -weight
+} -returnCodes error -result {must specify a single element on retrieval}
+test grid-10.30 {column/row configure - invalid indices} -body {
+ grid rowconfigure . {0 1 2} -weight
+} -returnCodes error -result {must specify a single element on retrieval}
+test grid-10.31 {column/row configure - empty 'all' configure} -body {
+ # Bug 1422430
+ set t [toplevel .test]
+ grid rowconfigure $t all -weight 1
+ destroy $t
+} -result {}
+test grid-10.32 {column/row configure} -body {
+ # Test that no lingering message is there
+ frame .f
+ set res [grid columnconfigure .f all -weight 1]
+ append res [grid columnconfigure .f {0 all} -weight 1]
+ frame .f.f
+ grid .f.f
+ append res [grid columnconfigure .f {.f.f} -weight 1]
+ append res [grid columnconfigure .f {.f.f 1} -weight 1]
+ append res [grid columnconfigure .f {2 .f.f} -weight 1]
+ destroy .f
+ return $res
+} -cleanup {
+ grid_reset 10.35
+} -result {}
+test grid-10.33 {column/row configure} -body {
+ grid columnconfigure . all
+} -cleanup {
+ grid_reset 10.36
+} -returnCodes error -result {expected integer but got "all" (when retrieving options only integer indices are allowed)}
+test grid-10.34 {column/row configure} -body {
+ grid columnconfigure . 100000
+} -cleanup {
+ grid_reset 10.37
+} -result {-minsize 0 -pad 0 -uniform {} -weight 0}
+test grid-10.35 {column/row configure} -body {
+ # This is a test for bug 1423666 where a column >= 10000 caused
+ # a crash in layout. The update is needed to reach the layout stage.
+ # Test different combinations of row/column overflow
+ frame .f
+ set res {}
+ lappend res [catch {grid .f -row 10 -column 9999} msg] $msg ; update
+ lappend res [catch {grid .f -row 9999 -column 10} msg] $msg ; update
+ lappend res [catch {grid .f -columnspan 2 -column 9998} msg] $msg ; update
+ lappend res [catch {grid .f -rowspan 2 -row 9998} msg] $msg ; update
+ lappend res [catch {grid .f -column 9998 -columnspan 2} msg] $msg ; update
+ lappend res [catch {grid .f -row 9998 -rowspan 2} msg] $msg ; update
+ return $res
+} -cleanup {destroy .f} -result [lrange {
+ 1 {column out of bounds}
+ 1 {row out of bounds}
+ 1 {column out of bounds}
+ 1 {row out of bounds}
+ 1 {column out of bounds}
+ 1 {row out of bounds}
+} 0 end]
+grid_reset 10.38
+test grid-10.36 {column/row configure} -body {
+ # Additional tests for row/column overflow
+ frame .f
+ frame .g
+ set res {}
+ grid .f -row 9998 -column 0
+ lappend res [catch {grid ^ -in .} msg] $msg ; update
+ lappend res [catch {grid .g} msg] $msg ; update
+ grid forget .f .g
+ lappend res [catch {grid .f - -column 9998} msg] $msg ; update
+ grid forget .f .g
+ lappend res [catch {eval grid [string repeat " x " 9999] .f} msg] $msg
+ update
+ return $res
+} -cleanup {destroy .f .g} -result [lrange {
+ 1 {row out of bounds}
+ 1 {row out of bounds}
+ 1 {column out of bounds}
+ 1 {column out of bounds}
+} 0 end]
+grid_reset 10.39
+
+# auto-placement tests
+test grid-11.1 {default widget placement} -body {
+ grid ^
+} -cleanup {
+ grid_reset 11.1
+} -returnCodes error -result {can't use '^', cant find master}
+test grid-11.2 {default widget placement} -body {
+ button .b
+ grid .b ^
+} -cleanup {
+ grid_reset 11.2
+} -returnCodes error -result {can't find slave to extend with "^"}
+test grid-11.3 {default widget placement} -body {
+ button .b
+ grid .b - - .c
+} -cleanup {
+ grid_reset 11.3
+} -returnCodes error -result {bad window path name ".c"}
+test grid-11.4 {default widget placement} -body {
+ button .b
+ grid .b - - = -
+} -cleanup {
+ grid_reset 11.4
+} -returnCodes error -result {invalid window shortcut, "=" should be '-', 'x', or '^'}
+test grid-11.5 {default widget placement} -body {
+ button .b
+ grid .b - x -
+} -cleanup {
+ grid_reset 11.5
+} -returnCodes error -result {must specify window before shortcut '-'}
+test grid-11.6 {default widget placement} -body {
+ foreach i {1 2 3 4 5 6} {
+ frame .f$i -width 50 -height 50 -highlightthickness 0 -bg red
+ }
+ grid .f1 .f2 .f3 .f4
+ grid .f5 - x .f6 -sticky nsew
+ update
+ set a ""
+ foreach i {5 6} {
+ lappend a "[winfo x .f$i],[winfo y .f$i] \
+ [winfo width .f$i],[winfo height .f$i]"
+ }
+ return $a
+} -cleanup {
+ grid_reset 11.6
+} -result {{0,50 100,50} {150,50 50,50}}
+test grid-11.7 {default widget placement} -body {
+ frame .f -width 20 -height 20 -highlightthickness 0 -bg red
+ grid .f -row 5 -column 5
+ grid .f x -
+} -cleanup {
+ grid_reset 11.7
+} -returnCodes error -result {must specify window before shortcut '-'}
+test grid-11.8 {default widget placement} -body {
+ frame .f -width 20 -height 20 -highlightthickness 0 -bg red
+ grid .f -row 5 -column 5
+ grid .f ^ -
+} -cleanup {
+ grid_reset 11.8
+} -returnCodes error -result {must specify window before shortcut '-'}
+test grid-11.9 {default widget placement} -body {
+ frame .f -width 20 -height 20 -highlightthickness 0 -bg red
+ grid .f -row 5 -column 5
+ grid .f x ^
+} -cleanup {
+ grid_reset 11.9
+} -returnCodes error -result {can't find slave to extend with "^"}
+test grid-11.10 {default widget placement} -body {
+ foreach i {1 2 3} {
+ frame .f$i -width 100 -height 50 -highlightthickness 0 -bg red
+ }
+ grid .f1 .f2 -sticky nsew
+ grid .f3 ^ -sticky nsew
+ update
+ set a ""
+ foreach i {1 2 3} {
+ lappend a "[winfo x .f$i],[winfo y .f$i] \
+ [winfo width .f$i],[winfo height .f$i]"
+ }
+ return $a
+} -cleanup {
+ grid_reset 11.10
+} -result {{0,0 100,50} {100,0 100,100} {0,50 100,50}}
+test grid-11.11 {default widget placement} -body {
+ foreach i {1 2 3 4 5 6 7 8 9 10 11 12} {
+ frame .f$i -width 50 -height 50 -highlightthickness 1 -highlightbackground black
+ }
+ grid .f1 .f2 .f3 .f4 -sticky nsew
+ grid .f5 .f6 - .f7 -sticky nsew
+ grid .f8 ^ ^ .f9 -sticky nsew
+ grid .f10 ^ ^ .f11 -sticky nsew
+ grid .f12 - - - -sticky nsew
+ update
+ set a ""
+ foreach i {5 6 7 8 9 10 11 12 } {
+ lappend a "[winfo x .f$i],[winfo y .f$i] \
+ [winfo width .f$i],[winfo height .f$i]"
+ }
+ return $a
+} -cleanup {
+ grid_reset 11.11
+} -result {{0,50 50,50} {50,50 100,150} {150,50 50,50} {0,100 50,50} {150,100 50,50} {0,150 50,50} {150,150 50,50} {0,200 200,50}}
+test grid-11.12 {default widget placement} -body {
+ foreach i {1 2 3 4} {
+ frame .f$i -width 75 -height 50 -highlightthickness 1 -highlightbackground black
+ }
+ grid .f1 .f2 .f3 -sticky nsew
+ grid .f4 ^ -sticky nsew
+ update
+ set a ""
+ foreach i {1 2 3 4} {
+ lappend a "[winfo x .f$i],[winfo y .f$i] \
+ [winfo width .f$i],[winfo height .f$i]"
+ }
+ grid .f4 ^ -column 1
+ update
+ foreach i {1 2 3 4} {
+ lappend a "[winfo x .f$i],[winfo y .f$i] \
+ [winfo width .f$i],[winfo height .f$i]"
+ }
+ return $a
+} -cleanup {
+ grid_reset 11.12
+} -result {{0,0 75,50} {75,0 75,100} {150,0 75,50} {0,50 75,50} {0,0 75,50} {75,0 75,100} {150,0 75,100} {75,50 75,50}}
+test grid-11.13 {default widget placement} -body {
+ foreach i {1 2 3 4 5 6 7} {
+ frame .f$i -width 40 -height 50 -highlightthickness 1 -highlightbackground black
+ }
+ grid .f1 .f2 .f3 .f4 .f5 -sticky nsew
+ grid .f6 - .f7 -sticky nsew -columnspan 2
+ update
+ set a ""
+ foreach i {6 7} {
+ lappend a "[winfo x .f$i],[winfo y .f$i] \
+ [winfo width .f$i],[winfo height .f$i]"
+ }
+ return $a
+} -cleanup {
+ grid_reset 11.13
+} -result {{0,50 120,50} {120,50 80,50}}
+test grid-11.14 {default widget placement} -body {
+ foreach i {1 2 3} {
+ frame .f$i -width 60 -height 60 -highlightthickness 0 -bg red
+ }
+ grid .f1 .f2
+ grid ^ .f3
+ update
+ set a ""
+ foreach i {1 2 3} {
+ lappend a "[winfo x .f$i],[winfo y .f$i] \
+ [winfo width .f$i],[winfo height .f$i]"
+ }
+ return $a
+} -cleanup {
+ grid_reset 11.14
+} -result {{0,30 60,60} {60,0 60,60} {60,60 60,60}}
+test grid-11.15 {^ ^ test with multiple windows} -body {
+ foreach i {1 2 3 4} {
+ frame .f$i -width 50 -height 50 -bd 1 -relief solid
+ }
+ grid .f1 .f2 .f3 -sticky ns
+ grid .f4 ^ ^
+ update
+ set a ""
+ foreach i {1 2 3 4} {
+ lappend a "[winfo x .f$i],[winfo y .f$i]\
+ [winfo width .f$i],[winfo height .f$i]"
+ }
+ return $a
+} -cleanup {
+ grid_reset 11.15
+} -result {{0,0 50,50} {50,0 50,100} {100,0 50,100} {0,50 50,50}}
+test grid-11.16 {default widget placement} -body {
+ foreach l {a b c d e} {
+ frame .$l -width 50 -height 50
+ }
+ grid .a .b .c .d -sticky news
+ grid x ^ x .e -sticky news
+ update
+ set res ""
+ lappend res [winfo height .a]
+ lappend res [winfo height .b]
+ lappend res [winfo height .c]
+} -cleanup {
+ grid_reset 11.16
+} -result {50 100 50}
+test grid-11.17 {default widget placement} -body {
+ foreach l {a b c d e} {
+ frame .$l -width 50 -height 50
+ }
+ grid .a .b .c .d -sticky news
+ grid ^ x ^ .e -sticky news
+ update
+ set res ""
+ lappend res [winfo height .a]
+ lappend res [winfo height .b]
+ lappend res [winfo height .c]
+} -cleanup {
+ grid_reset 11.17
+} -result {100 50 100}
+test grid-11.18 {default widget placement} -body {
+ foreach l {a b c d e} {
+ frame .$l -width 50 -height 50
+ }
+ grid .a .b .c .d -sticky news
+ grid ^ ^ ^ x -in . ;# ^ and no child should work with -in.
+ grid rowconfigure . {0 1} -uniform a
+ update
+ set res ""
+ lappend res [winfo height .a]
+ lappend res [winfo height .b]
+ lappend res [winfo height .c]
+ lappend res [winfo height .d]
+} -cleanup {
+ grid_reset 11.18
+} -result {100 100 100 50}
+test grid-11.19 {default widget placement} -body {
+ foreach l {a b c d e} {
+ frame .$l -width 50 -height 50
+ }
+ grid .a .b -sticky news
+ grid .c .d -sticky news
+ grid ^ -in . -row 2
+ grid x ^ -in . -row 1
+ grid rowconfigure . {0 1 2} -uniform a
+ update
+ set res ""
+ lappend res [winfo height .a]
+ lappend res [winfo height .b]
+ lappend res [winfo height .c]
+ lappend res [winfo height .d]
+} -cleanup {
+ grid_reset 11.19
+} -result {50 100 100 50}
+
+test grid-12.1 {-sticky} -body {
+ catch {unset data}
+ frame .f -width 200 -height 100 -highlightthickness 0 -bg red
+ set a ""
+ grid .f
+ grid rowconfigure . 0 -weight 1
+ grid columnconfigure . 0 -weight 1
+ grid propagate . 0
+ . configure -width 250 -height 150
+ foreach i { {} n s e w ns ew nw ne se sw nse nsw sew new nsew} {
+ grid .f -sticky $i
+ update
+ array set data [grid info .f]
+ append a "($data(-sticky)) [winfo x .f] [winfo y .f] [winfo width .f] [winfo height .f]\n"
+ }
+ return $a
+} -cleanup {
+ grid_reset 12.1
+} -result {() 25 25 200 100
+(n) 25 0 200 100
+(s) 25 50 200 100
+(e) 50 25 200 100
+(w) 0 25 200 100
+(ns) 25 0 200 150
+(ew) 0 25 250 100
+(nw) 0 0 200 100
+(ne) 50 0 200 100
+(es) 50 50 200 100
+(sw) 0 50 200 100
+(nes) 50 0 200 150
+(nsw) 0 0 200 150
+(esw) 0 50 250 100
+(new) 0 0 250 100
+(nesw) 0 0 250 150
+}
+test grid-12.2 {-sticky} -body {
+ frame .f -bg red
+ grid .f -sticky glue
+} -cleanup {
+ grid_reset 12.2
+} -returnCodes error -result {bad stickyness value "glue": must be a string containing n, e, s, and/or w}
+test grid-12.3 {-sticky} -body {
+ frame .f -bg red
+ grid .f -sticky {n,s,e,w}
+ array set A [grid info .f]
+ set A(-sticky)
+} -cleanup {
+ grid_reset 12.3
+} -result {nesw}
+
+test grid-13.1 {-in} -body {
+ frame .f -bg red
+ grid .f -in .f
+} -cleanup {
+ grid_reset 13.1
+} -returnCodes error -result {window can't be managed in itself}
+test grid-13.2 {-in} -body {
+ frame .f -bg red
+ list [winfo manager .f] \
+ [catch {grid .f -in .f} err] $err \
+ [winfo manager .f]
+} -cleanup {
+ grid_reset 13.1.1
+} -result {{} 1 {window can't be managed in itself} {}}
+test grid-13.3 {-in} -body {
+ frame .f -bg red
+ grid .f -in .bad
+} -cleanup {
+ grid_reset 13.2
+} -returnCodes error -result {bad window path name ".bad"}
+test grid-13.4 {-in} -body {
+ frame .f -bg red
+ toplevel .top
+ grid .f -in .top
+} -cleanup {
+ grid_reset 13.3
+} -returnCodes error -result {can't put .f inside .top}
+destroy .top
+test grid-13.5 {-ipadx} -body {
+ frame .f -width 20 -height 20 -highlightthickness 0 -bg red
+ grid .f -ipadx x
+} -cleanup {
+ grid_reset 13.4
+} -returnCodes error -result {bad ipadx value "x": must be positive screen distance}
+test grid-13.6 {-ipadx} -body {
+ frame .f -width 20 -height 20 -highlightthickness 0 -bg red
+ grid .f -ipadx {5 5}
+} -cleanup {
+ grid_reset 13.4.1
+} -returnCodes error -result {bad ipadx value "5 5": must be positive screen distance}
+test grid-13.7 {-ipadx} -body {
+ frame .f -width 200 -height 100 -highlightthickness 0 -bg red
+ grid .f
+ update
+ set a [winfo width .f]
+ grid .f -ipadx 1
+ update
+ list $a [winfo width .f]
+} -cleanup {
+ grid_reset 13.5
+} -result {200 202}
+test grid-13.8 {-ipady} -body {
+ frame .f -width 20 -height 20 -highlightthickness 0 -bg red
+ grid .f -ipady x
+} -cleanup {
+ grid_reset 13.6
+} -returnCodes error -result {bad ipady value "x": must be positive screen distance}
+test grid-13.9 {-ipady} -body {
+ frame .f -width 20 -height 20 -highlightthickness 0 -bg red
+ grid .f -ipady {5 5}
+} -cleanup {
+ grid_reset 13.6.1
+} -returnCodes error -result {bad ipady value "5 5": must be positive screen distance}
+test grid-13.10 {-ipady} -body {
+ frame .f -width 200 -height 100 -highlightthickness 0 -bg red
+ grid .f
+ update
+ set a [winfo height .f]
+ grid .f -ipady 1
+ update
+ list $a [winfo height .f]
+} -cleanup {
+ grid_reset 13.7
+} -result {100 102}
+test grid-13.11 {-padx} -body {
+ frame .f -width 20 -height 20 -highlightthickness 0 -bg red
+ grid .f -padx x
+} -cleanup {
+ grid_reset 13.8
+} -returnCodes error -result {bad pad value "x": must be positive screen distance}
+test grid-13.12 {-padx} -body {
+ frame .f -width 20 -height 20 -highlightthickness 0 -bg red
+ grid .f -padx {10 x}
+} -cleanup {
+ grid_reset 13.8.1
+} -returnCodes error -result {bad 2nd pad value "x": must be positive screen distance}
+test grid-13.13 {-padx} -body {
+ frame .f -width 200 -height 100 -highlightthickness 0 -bg red
+ grid .f
+ update
+ set a "[winfo width .f] [winfo width .]"
+ grid .f -padx 1
+ update
+ list $a "[winfo width .f] [winfo width .] [winfo x .f]"
+} -cleanup {
+ grid_reset 13.9
+} -result {{200 200} {200 202 1}}
+test grid-13.14 {-padx} -body {
+ frame .f -width 200 -height 100 -highlightthickness 0 -bg red
+ grid .f
+ update
+ set a "[winfo width .f] [winfo width .]"
+ grid .f -padx {10 5}
+ update
+ list $a "[winfo width .f] [winfo width .] [winfo x .f]"
+} -cleanup {
+ grid_reset 13.9.1
+} -result {{200 200} {200 215 10}}
+test grid-13.15 {-pady} -body {
+ frame .f -width 20 -height 20 -highlightthickness 0 -bg red
+ grid .f -pady x
+} -cleanup {
+ grid_reset 13.10
+} -returnCodes error -result {bad pad value "x": must be positive screen distance}
+test grid-13.16 {-pady} -body {
+ frame .f -width 20 -height 20 -highlightthickness 0 -bg red
+ grid .f -pady {10 x}
+} -cleanup {
+ grid_reset 13.10.1
+} -returnCodes error -result {bad 2nd pad value "x": must be positive screen distance}
+test grid-13.17 {-pady} -body {
+ frame .f -width 200 -height 100 -highlightthickness 0 -bg red
+ grid .f
+ update
+ set a "[winfo height .f] [winfo height .]"
+ grid .f -pady 1
+ update
+ list $a "[winfo height .f] [winfo height .] [winfo y .f]"
+} -cleanup {
+ grid_reset 13.11
+} -result {{100 100} {100 102 1}}
+test grid-13.18 {-pady} -body {
+ frame .f -width 200 -height 100 -highlightthickness 0 -bg red
+ grid .f
+ update
+ set a "[winfo height .f] [winfo height .]"
+ grid .f -pady {4 16}
+ update
+ list $a "[winfo height .f] [winfo height .] [winfo y .f]"
+} -cleanup {
+ grid_reset 13.11.1
+} -result {{100 100} {100 120 4}}
+test grid-13.19 {-ipad x and y} -body {
+ frame .f -width 20 -height 20 -highlightthickness 0 -bg red
+ grid columnconfigure . 0 -minsize 150
+ grid rowconfigure . 0 -minsize 100
+ set a ""
+ foreach x {0 5} {
+ foreach y {0 5} {
+ grid .f -ipadx $x -ipady $y
+ update
+ append a " $x,$y:"
+ foreach prop {x y width height} {
+ append a ,[winfo $prop .f]
+ }
+ }
+ }
+ return $a
+} -cleanup {
+ grid_reset 13.12
+} -result { 0,0:,65,40,20,20 0,5:,65,35,20,30 5,0:,60,40,30,20 5,5:,60,35,30,30}
+test grid-13.20 {reparenting} -body {
+ frame .1
+ frame .2
+ button .b
+ grid .1 .2
+ grid .b -in .1
+ set a ""
+ catch {unset info}; array set info [grid info .b]
+ lappend a [grid slaves .1],[grid slaves .2],$info(-in)
+ grid .b -in .2
+ catch {unset info}; array set info [grid info .b]
+ lappend a [grid slaves .1],[grid slaves .2],$info(-in)
+ unset info
+ return $a
+} -cleanup {
+ grid_reset 13.13
+} -result {.b,,.1 ,.b,.2}
+
+test grid-14.1 {structure notify} -body {
+ frame .f -width 200 -height 100 -highlightthickness 0 -bg red
+ frame .g -width 200 -height 100 -highlightthickness 0 -bg red
+ grid .f
+ grid .g -in .f
+ update
+ set a ""
+ lappend a "[winfo x .g],[winfo y .g] \
+ [winfo width .g],[winfo height .g]"
+ .f configure -bd 5 -relief raised
+ update
+ lappend a "[winfo x .g],[winfo y .g] \
+ [winfo width .g],[winfo height .g]"
+ return $a
+} -cleanup {
+ grid_reset 14.1
+} -result {{0,0 200,100} {5,5 200,100}}
+test grid-14.2 {structure notify} -body {
+ frame .f -width 200 -height 100
+ frame .f.g -width 200 -height 100
+ grid .f
+ grid .f.g
+ update
+ set a ""
+ lappend a [grid bbox .],[grid bbox .f]
+ .f config -bd 20
+ update
+ lappend a [grid bbox .],[grid bbox .f]
+} -cleanup {
+ grid_reset 14.2
+} -result {{0 0 200 100,0 0 200 100} {0 0 240 140,20 20 200 100}}
+test grid-14.3 {map notify: bug 1648} -constraints {nonPortable} -body {
+ # This test is nonPortable because the number of times
+ # A(.) will be incremented is unspecified--the behavior
+ # is different accross window managers.
+ global A
+ catch {unset A}
+ bind . <Configure> {incr A(%W)}
+ set A(.) 0
+ foreach i {0 1 2} {
+ frame .$i -width 100 -height 75
+ set A(.$i) 0
+ }
+ grid .0 .1 .2
+ update
+ bind <Configure> .1 {destroy .0}
+ .2 configure -bd 10
+ update
+ bind . <Configure> {}
+ array get A
+} -cleanup {
+ grid_reset 14.3
+} -result {.2 2 .0 1 . 2 .1 1}
+
+test grid-15.1 {lost slave} -body {
+ button .b
+ grid .b
+ set a [grid slaves .]
+ pack .b
+ lappend a [grid slaves .]
+ grid .b
+ lappend a [grid slaves .]
+} -cleanup {
+ grid_reset 15.1
+} -result {.b {} .b}
+test grid-15.2 {lost slave} -body {
+ frame .f
+ grid .f
+ button .b
+ grid .b -in .f
+ set a [grid slaves .f]
+ pack .b -in .f
+ lappend a [grid slaves .f]
+ grid .b -in .f
+ lappend a [grid slaves .f]
+} -cleanup {
+ grid_reset 15.2
+} -result {.b {} .b}
+
+test grid-16.1 {layout centering} -body {
+ foreach i {0 1 2} {
+ frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge
+ grid .$i -row $i -column $i -sticky nswe
+ }
+ grid propagate . 0
+ grid anchor . center
+ . configure -width 300 -height 250
+ update
+ grid bbox .
+} -cleanup {
+ grid_reset 16.1
+} -result {37 50 225 150}
+test grid-16.2 {layout weights (expanding)} -body {
+ foreach i {0 1 2} {
+ frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge
+ grid .$i -row $i -column $i -sticky nswe
+ grid rowconfigure . $i -weight [expr $i + 1]
+ grid columnconfigure . $i -weight [expr $i + 1]
+ }
+ grid propagate . 0
+ . configure -width 500 -height 300
+ set a ""
+ update
+ foreach i {0 1 2} {
+ lappend a [winfo width .$i]-[winfo height .$i]
+ }
+ return $a
+} -cleanup {
+ grid_reset 16.2
+} -result {120-75 167-100 213-125}
+test grid-16.3 {layout weights (shrinking)} -body {
+ foreach i {0 1 2} {
+ frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge
+ grid .$i -row $i -column $i -sticky nswe
+ grid rowconfigure . $i -weight [expr $i + 1]
+ grid columnconfigure . $i -weight [expr $i + 1]
+ }
+ grid propagate . 0
+ . configure -width 200 -height 150
+ set a ""
+ update
+ foreach i {0 1 2} {
+ lappend a [winfo width .$i]-[winfo height .$i]
+ }
+ return $a
+} -cleanup {
+ grid_reset 16.3
+} -result {84-63 66-50 50-37}
+test grid-16.4 {layout weights (shrinking with minsize)} -body {
+ foreach i {0 1 2} {
+ frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge
+ grid .$i -row $i -column $i -sticky nswe
+ grid rowconfigure . $i -weight [expr $i + 1] -minsize 45
+ grid columnconfigure . $i -weight [expr $i + 1] -minsize 65
+ }
+ grid propagate . 0
+ . configure -width 200 -height 150
+ set a ""
+ update
+ foreach i {0 1 2} {
+ lappend a [winfo width .$i]-[winfo height .$i]
+ }
+ return $a
+} -cleanup {
+ grid_reset 16.4
+} -result {70-60 65-45 65-45}
+test grid-16.5 {layout weights (shrinking at minsize)} -body {
+ foreach i {0 1 2} {
+ frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge
+ grid .$i -row $i -column $i -sticky nswe
+ grid rowconfigure . $i -weight 0 -minsize 70
+ grid columnconfigure . $i -weight 0 -minsize 90
+ }
+ grid propagate . 0
+ . configure -width 100 -height 75
+ set a ""
+ update
+ foreach i {0 1 2} {
+ lappend a [winfo width .$i]-[winfo height .$i]
+ }
+ return $a
+} -cleanup {
+ grid_reset 16.5
+} -result {100-75 100-75 100-75}
+test grid-16.6 {layout weights (shrinking at minsize)} -body {
+ foreach i {0 1 2} {
+ frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge
+ grid .$i -row $i -column $i -sticky nswe
+ grid rowconfigure . $i -weight [expr $i + 1] -minsize 52
+ grid columnconfigure . $i -weight [expr $i + 1] -minsize 69
+ }
+ grid propagate . 0
+ . configure -width 200 -height 150
+ set a ""
+ update
+ foreach i {0 1 2} {
+ lappend a [winfo width .$i]-[winfo height .$i]
+ }
+ return $a
+} -cleanup {
+ grid_reset 16.6
+} -result {69-52 69-52 69-52}
+# test fails when run alone
+# reason (I think): -minsize 0 causes both:
+# [winfo ismapped .$i] => 0 and
+# not responding for width ang height settings, so that
+# [winfo width .$i] [winfo height .$i] take different values
+# That doesn't happen if previous tests run
+test grid-16.7 {layout weights (shrinking at minsize)} -body {
+ foreach i {0 1 2} {
+ frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge
+ grid .$i -row $i -column $i -sticky nswe
+ }
+ grid propagate . 0
+ grid columnconfigure . 1 -weight 1 -minsize 0
+ grid rowconfigure . 1 -weight 1 -minsize 0
+ . configure -width 100 -height 1
+ set a ""
+ update
+ foreach i {0 1 2} {
+ lappend a [winfo width .$i]-[winfo height .$i]-[winfo ismapped .$i]
+ }
+ return $a
+} -cleanup {
+ grid_reset 16.7
+} -result {100-75-1 1-1-0 100-75-1}
+test grid-16.8 {layout internal constraints} -body {
+ foreach i {0 1 2 3 4} {
+ frame .$i -bg gray -width 30 -height 25 -bd 2 -relief ridge
+ grid .$i -row $i -column $i -sticky nswe
+ }
+ frame .f -bg red -width 250 -height 200
+ frame .g -bg green -width 200 -height 180
+ lower .f
+ raise .g .f
+ grid .f -row 1 -column 1 -rowspan 3 -columnspan 3 -sticky nswe
+ grid .g -row 1 -column 1 -rowspan 2 -columnspan 2 -sticky nswe
+ update
+ set a ""
+ foreach i {0 1 2 3 4} {
+ append a "[winfo x .$i] "
+ }
+ append a ", "
+ grid remove .f
+ update
+ foreach i {0 1 2 3 4} {
+ append a "[winfo x .$i] "
+ }
+ append a ", "
+ grid remove .g
+ grid .f
+ update
+ foreach i {0 1 2 3 4} {
+ append a "[winfo x .$i] "
+ }
+ append a ", "
+ grid remove .f
+ update
+ foreach i {0 1 2 3 4} {
+ append a "[winfo x .$i] "
+ }
+ return $a
+} -cleanup {
+ grid_reset 16.8
+} -result {0 30 130 230 280 , 0 30 130 230 260 , 0 30 113 196 280 , 0 30 60 90 120 }
+test grid-16.9 {layout uniform} -body {
+ frame .f1 -width 75 -height 50
+ frame .f2 -width 60 -height 25
+ frame .f3 -width 95 -height 75
+ frame .f4 -width 135 -height 100
+ frame .f5 -width 80 -height 40
+ for {set t 1} {$t <= 5} {incr t} {
+ grid .f$t
+ }
+ grid rowconfigure . {0 2} -uniform a
+ grid rowconfigure . {1 3} -uniform b
+ update
+ list [grid bbox . 0 0] [grid bbox . 0 1] [grid bbox . 0 2] \
+ [grid bbox . 0 3] [grid bbox . 0 4]
+} -cleanup {
+ grid_reset 16.9
+} -result {{0 0 135 75} {0 75 135 100} {0 175 135 75} {0 250 135 100} {0 350 135 40}}
+test grid-16.10 {layout uniform} -body {
+ grid [frame .f1 -width 75 -height 50] -row 0 -column 0
+ grid [frame .f2 -width 60 -height 30] -row 1 -column 2
+ grid [frame .f3 -width 95 -height 90] -row 2 -column 1
+ grid [frame .f4 -width 60 -height 100] -row 3 -column 4
+ grid [frame .f5 -width 60 -height 40] -row 4 -column 3
+ grid rowconfigure . {0 1} -uniform a
+ grid rowconfigure . {2 4} -uniform b
+ grid rowconfigure . {0 2} -weight 2
+ grid columnconfigure . {0 2} -uniform a
+ grid columnconfigure . {3 4} -uniform b
+ grid columnconfigure . {2 4} -weight 2
+ grid columnconfigure . 3 -minsize 70
+ grid columnconfigure . 4 -minsize 130
+ update
+ list [grid bbox . 0 0] [grid bbox . 2 1] [grid bbox . 1 2] \
+ [grid bbox . 4 3] [grid bbox . 3 4]
+} -cleanup {
+ grid_reset 16.10
+} -result {{0 0 75 60} {170 60 150 30} {75 90 95 90} {390 180 140 100} {320 280 70 45}}
+test grid-16.11 {layout uniform (shrink)} -body {
+ frame .f1 -width 75 -height 50
+ frame .f2 -width 100 -height 95
+ grid .f1 .f2 -sticky news
+ grid columnconfigure . {0 1} -uniform a
+ grid columnconfigure . 0 -weight 1
+ update
+ set res {}
+ lappend res [grid bbox . 0 0] [grid bbox . 1 0]
+ grid propagate . 0
+ . configure -width 150 -height 95
+ update
+ lappend res [grid bbox . 0 0] [grid bbox . 1 0]
+} -cleanup {
+ grid_reset 16.11
+} -result {{0 0 100 95} {100 0 100 95} {0 0 50 95} {50 0 100 95}}
+test grid-16.12 {layout uniform (grow)} -body {
+ frame .f1 -width 40 -height 50
+ frame .f2 -width 50 -height 95
+ frame .f3 -width 60 -height 50
+ frame .f4 -width 70 -height 95
+ grid .f1 .f2 .f3 .f4 -sticky news
+ grid columnconfigure . {0 1 2} -uniform a
+ # Put weight 2 on the biggest in the group to see that the groups
+ # adapt to one of the smaller.
+ grid columnconfigure . 2 -weight 2
+ grid columnconfigure . {0 3} -weight 1
+ update
+ set res {}
+ lappend res [grid bbox . 0 0] [grid bbox . 1 0]
+ lappend res [grid bbox . 2 0] [grid bbox . 3 0]
+ grid propagate . 0
+ . configure -width 350 -height 95
+ update
+ lappend res [grid bbox . 0 0] [grid bbox . 1 0]
+ lappend res [grid bbox . 2 0] [grid bbox . 3 0]
+} -cleanup {
+ grid_reset 16.12
+} -result [list {0 0 50 95} {50 0 50 95} {100 0 100 95} {200 0 70 95} \
+ {0 0 70 95} {70 0 50 95} {120 0 140 95} {260 0 90 95}]
+test grid-16.13 {layout span} -body {
+ frame .f1 -width 24 -height 20
+ frame .f2 -width 38 -height 20
+ frame .f3 -width 150 -height 20
+ grid .f1 - - .f2
+ grid .f3 - - -
+ set res {}
+ foreach w {{0 1 0 0} {0 0 1 0} {1 3 4 0} {1 2 1 2} {1 1 1 12}} {
+ for {set c 0} {$c < 4} {incr c} {
+ grid columnconfigure . $c -weight [lindex $w $c]
+ }
+ update
+ set res2 {}
+ for {set c 0} {$c <= 4} {incr c} {
+ lappend res2 [lindex [grid bbox . $c 0] 2]
+ }
+ lappend res $res2
+ }
+ return $res
+ # The last result below should ideally be 8 8 8 126 but the current
+ # implementation is not exact enough.
+} -cleanup {
+ grid_reset 16.13
+} -result [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 14 42 56 38 0] \
+ [list 18 38 18 76 0] [list 7 8 9 126 0]]
+test grid-16.14 {layout span} -body {
+ frame .f1 -width 110 -height 20
+ frame .f2 -width 38 -height 20
+ frame .f3 -width 150 -height 20
+ grid .f1 - - .f2
+ grid .f3 - - -
+ set res {}
+ foreach w {{0 1 0 0} {0 0 1 0} {1 3 4 0} {1 2 1 3} {1 1 1 12}} {
+ for {set c 0} {$c < 4} {incr c} {
+ grid columnconfigure . $c -weight [lindex $w $c]
+ }
+ update
+ set res2 {}
+ for {set c 0} {$c <= 4} {incr c} {
+ lappend res2 [lindex [grid bbox . $c 0] 2]
+ }
+ lappend res $res2
+ }
+ return $res
+} -cleanup {
+ grid_reset 16.14
+} -result [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 14 42 56 38 0] \
+ [list 27 55 28 40 0] [list 36 37 37 40 0]]
+test grid-16.15 {layout span} -body {
+ frame .f1 -width 24 -height 20
+ frame .f2 -width 38 -height 20
+ frame .f3 -width 150 -height 20
+ grid .f1 - - .f2
+ grid x .f3 - -
+ set res {}
+ foreach w {{0 1 0 0} {0 0 1 0} {1 0 1 0} {0 0 0 0} {1 0 0 6}} {
+ for {set c 0} {$c < 4} {incr c} {
+ grid columnconfigure . $c -weight [lindex $w $c]
+ }
+ update
+ set res2 {}
+ for {set c 0} {$c <= 4} {incr c} {
+ lappend res2 [lindex [grid bbox . $c 0] 2]
+ }
+ lappend res $res2
+ }
+ return $res
+} -cleanup {
+ grid_reset 16.15
+} -result [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 0 0 112 38 0] \
+ [list 0 37 37 76 0] [list 0 12 12 126 0]]
+test grid-16.16 {layout span} -body {
+ frame .f1 -width 64 -height 20
+ frame .f2 -width 38 -height 20
+ frame .f3 -width 150 -height 20
+ frame .f4 -width 15 -height 20
+ frame .f5 -width 18 -height 20
+ frame .f6 -width 20 -height 20
+ grid .f1 - x .f2
+ grid .f3 - - -
+ grid .f4 .f5 .f6
+ set res {}
+ foreach w {{1 1 5 1} {0 0 1 0} {1 3 4 0} {1 2 1 2} {1 1 1 12}} {
+ for {set c 0} {$c < 4} {incr c} {
+ grid columnconfigure . $c -weight [lindex $w $c]
+ }
+ update
+ set res2 {}
+ for {set c 0} {$c <= 4} {incr c} {
+ lappend res2 [lindex [grid bbox . $c 0] 2]
+ }
+ lappend res $res2
+ }
+ return $res
+} -cleanup {
+ grid_reset 16.16
+} -result [list [list 30 34 43 43 0] [list 30 34 48 38 0] [list 22 42 48 38 0] \
+ [list 25 39 29 57 0] [list 30 34 22 64 0]]
+test grid-16.17 {layout weights (shrinking at minsize)} -body {
+ foreach i {0 1 2 3} {
+ frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge
+ grid .$i -row $i -column $i -sticky nswe
+ }
+ grid propagate . 0
+ grid columnconfigure . {0 1} -weight 1 -minsize 0
+ grid rowconfigure . {0 1} -weight 1 -minsize 0
+ set a ""
+ . configure -width 250 -height 200
+ update
+ foreach i {0 1 2 3} {
+ lappend a [winfo width .$i]-[winfo height .$i]-[winfo ismapped .$i]
+ }
+ . configure -width 150 -height 100
+ update
+ foreach i {0 1 2 3} {
+ lappend a [winfo width .$i]-[winfo height .$i]-[winfo ismapped .$i]
+ }
+ return $a
+} -cleanup {
+ grid_reset 16.17
+} -result {25-25-1 25-25-1 100-75-1 100-75-1 25-25-0 25-25-0 100-75-1 100-75-1}
+test grid-16.18 {layout span} -body {
+ frame .f1 -width 30 -height 20
+ frame .f2 -width 166 -height 20
+ frame .f3 -width 39 -height 20
+ frame .f4 -width 10 -height 20
+ grid .f1 .f3 -
+ grid .f2 - .f4
+ grid columnconfigure . 0 -weight 1
+ set res {}
+ foreach w {{1 0 0} {0 1 0} {0 0 1}} {
+ for {set c 0} {$c < 3} {incr c} {
+ grid columnconfigure . $c -weight [lindex $w $c]
+ }
+ update
+ set res2 {}
+ for {set c 0} {$c <= 2} {incr c} {
+ lappend res2 [lindex [grid bbox . $c 0] 2]
+ }
+ lappend res $res2
+ }
+ return $res
+} -cleanup {
+ grid_reset 16.18
+} -result [list [list 137 29 10] [list 30 136 10] [list 98 68 10]]
+test grid-16.19 {layout span} -constraints { knownBug } -body {
+ # This test shows the problem in Bug 2075285
+ # Several overlapping multi-span widgets is a weak spot
+ # in the current implementation.
+ # Test present as a reminder in case a future algorithm update is made.
+ frame .f1 -width 100 -height 20
+ frame .f2 -width 20 -height 20
+ frame .f3 -width 10 -height 20
+ frame .f4 -width 20 -height 20
+ grid .f1 - - - - - -sticky we
+ grid .f2 - .f3 - .f4 - -sticky we
+ grid columnconfigure . {1 5} -weight 1
+ set res {}
+ update
+ for {set c 0} {$c <= 5} {incr c} {
+ lappend res [lindex [grid bbox . $c 0] 2]
+ }
+ return $res
+} -cleanup {
+ grid_reset 16.19
+} -result [list 0 45 5 5 0 45]
+
+test grid-17.1 {forget and pending idle handlers} -body {
+ # This test is intended to detect a crash caused by a failure to remove
+ # pending idle handlers when grid forget is invoked.
+ toplevel .t
+ wm geometry .t +0+0
+ frame .t.f
+ label .t.f.l -text foobar
+ grid .t.f.l
+ grid .t.f
+ update
+ grid forget .t.f.l
+ grid forget .t.f
+ destroy .t
+ toplevel .t
+ frame .t.f
+ label .t.f.l -text foobar
+ grid .t.f.l
+ destroy .t
+ set result ok
+} -result ok
+
+
+test grid-18.1 {test respect for internalborder} -body {
+ toplevel .pack
+ wm geometry .pack 200x200
+ frame .pack.l -width 15 -height 10
+ labelframe .pack.lf -labelwidget .pack.l
+ pack .pack.lf -fill both -expand 1
+ frame .pack.lf.f
+ grid .pack.lf.f -sticky news
+ grid columnconfigure .pack.lf 0 -weight 1
+ grid rowconfigure .pack.lf 0 -weight 1
+ update
+ set res [list [winfo geometry .pack.lf.f]]
+ .pack.lf configure -labelanchor e -padx 3 -pady 5
+ update
+ lappend res [winfo geometry .pack.lf.f]
+ destroy .pack
+ return $res
+} -result {196x188+2+10 177x186+5+7}
+test grid-18.2 {test support for minreqsize} -body {
+ toplevel .pack
+ wm geometry .pack {}
+ frame .pack.l -width 150 -height 100
+ labelframe .pack.lf -labelwidget .pack.l
+ pack .pack.lf -fill both -expand 1
+ frame .pack.lf.f -width 20 -height 25
+ grid .pack.lf.f
+ update
+ set res [list [winfo geometry .pack.lf]]
+ .pack.lf configure -labelanchor ws
+ update
+ lappend res [winfo geometry .pack.lf]
+ destroy .pack
+ return $res
+} -result {162x127+0+0 172x112+0+0}
+
+test grid-19.1 {uniform realloc} -body {
+ # Use a lot of uniform groups to test the reallocation mechanism
+ for {set t 0} {$t < 100} {incr t 2} {
+ frame .fa$t -width 5 -height 20
+ frame .fb$t -width 6 -height 20
+ grid .fa$t .fb$t -row 0 -column $t -sticky news
+ grid columnconfigure . [list $t [expr {$t + 1}]] -uniform a$t
+ }
+ update
+ grid bbox .
+} -cleanup {
+ grid_reset 19.1
+} -result {0 0 600 20}
+
+test grid-20.1 {recalculate size after removal (destroy)} -body {
+ label .l1 -text l1
+ grid .l1 -row 2 -column 2
+ destroy .l1
+ label .l2 -text l2
+ grid .l2
+ grid size .
+} -cleanup {
+ grid_reset 20.1
+} -result {1 1}
+test grid-20.2 {recalculate size after removal (forget)} -body {
+ label .l1 -text l1
+ grid .l1 -row 2 -column 2
+ grid forget .l1
+ label .l2 -text l2
+ grid .l2
+ grid size .
+} -cleanup {
+ grid_reset 20.2
+} -result {1 1}
+
+test grid-21.1 {anchor} -body {
+ grid anchor . 1 xxx
+} -cleanup {
+ grid_reset 21.1
+} -returnCodes error -result {wrong # args: should be "grid anchor window ?anchor?"}
+test grid-21.2 {anchor} -body {
+ grid anchor .
+} -cleanup {
+ grid_reset 21.2
+} -result {nw}
+test grid-21.3 {anchor} -body {
+ grid anchor . se;grid anchor .
+} -cleanup {
+ grid_reset 21.3
+} -result {se}
+test grid-21.4 {anchor} -body {
+ grid anchor .x
+} -cleanup {
+ grid_reset 21.4
+} -returnCodes error -result {bad window path name ".x"}
+test grid-21.5 {anchor} -body {
+ grid anchor . x
+} -cleanup {
+ grid_reset 21.5
+} -returnCodes error -result {bad anchor "x": must be n, ne, e, se, s, sw, w, nw, or center}
+test grid-21.6 {anchor} -body {
+ foreach i {0 1 2} {
+ frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge
+ grid .$i -row $i -column $i -sticky nswe
+ }
+ grid propagate . 0
+ . configure -width 300 -height 250
+ set res {}
+ foreach a {n ne e se s sw w nw center} {
+ grid anchor . $a
+ update
+ lappend res [grid bbox .]
+ }
+ return $res
+} -cleanup {
+ grid_reset 21.6
+} -result [list {37 0 225 150} {75 0 225 150} {75 50 225 150} {75 100 225 150} \
+ {37 100 225 150} {0 100 225 150} {0 50 225 150} {0 0 225 150} \
+ {37 50 225 150}]
+test grid-21.7 {anchor} -body {
+ # Test with a non-symmetric internal border.
+ # This only tests vertically, there is currently no way to get
+ # it assymetric horizontally.
+ labelframe .f -bd 0
+ frame .f.x -width 20 -height 20
+ .f configure -labelwidget .f.x
+ pack .f -fill both -expand 1
+ foreach i {0 1 2} {
+ frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge
+ grid .$i -in .f -row $i -column $i -sticky nswe
+ }
+ pack propagate . 0
+ grid propagate .f 0
+ . configure -width 300 -height 250
+ set res {}
+ foreach a {n ne e se s sw w nw center} {
+ grid anchor .f $a
+ update
+ lappend res [grid bbox .f]
+ }
+ pack propagate . 1 ; wm geometry . {}
+ return $res
+} -cleanup {
+ grid_reset 21.7
+} -result [list {37 20 225 150} {75 20 225 150} {75 60 225 150} {75 100 225 150} \
+ {37 100 225 150} {0 100 225 150} {0 60 225 150} {0 20 225 150} \
+ {37 60 225 150}]
+
+test grid-22.1 {remove: basic argument checking} {
+ list [catch {grid remove foo} msg] $msg
+} {1 {bad window path name "foo"}}
+test grid-22.2 {remove} {
+ button .c
+ grid [button .b]
+ set a [grid slaves .]
+ grid remove .b .c
+ lappend a [grid slaves .]
+ return $a
+} {.b {}}
+grid_reset 22.2
+test grid-22.3 {remove} {
+ button .c
+ grid .c -row 2 -column 2 -rowspan 2 -columnspan 2 -padx 3 -pady 4 -sticky ns
+ grid remove .c
+ grid .c -row 0 -column 0
+ grid info .c
+} {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx 3 -pady 4 -sticky ns}
+grid_reset 22.3
+test grid-22.3.1 {remove} {
+ frame .a
+ button .c
+ grid .c -in .a -row 2 -column 2 -rowspan 2 -columnspan 2 -padx {3 5} -pady {4 7} -sticky ns
+ grid remove .c
+ grid .c -row 0 -column 0
+ grid info .c
+} {-in .a -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns}
+grid_reset 22.3.1
+test grid-22.4 {remove, calling Tk_UnmaintainGeometry} {
+ frame .f -bd 2 -relief raised
+ place .f -x 10 -y 20 -width 200 -height 100
+ frame .f2 -width 50 -height 30 -bg red
+ grid .f2 -in .f
+ update
+ set x [winfo ismapped .f2]
+ grid remove .f2
+ place .f -x 30
+ update
+ lappend x [winfo ismapped .f2]
+} {1 0}
+grid_reset 22.4
+test grid-22.5 {remove} {
+ frame .a
+ button .c
+ grid .c -in .a -row 2 -column 2 -rowspan 2 -columnspan 2 -padx {3 5} -pady {4 7} -sticky ns
+ grid remove .c
+ # If .a was destroyed while remembered by the removed .c, make sure it
+ # is ignored.
+ destroy .a
+ grid .c -row 0 -column 0
+ grid info .c
+} {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns}
+grid_reset 22.5
+
+# cleanup
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/image.test b/tk8.6/tests/image.test
new file mode 100644
index 0000000..3134ee8
--- /dev/null
+++ b/tk8.6/tests/image.test
@@ -0,0 +1,626 @@
+# This file is a Tcl script to test out the "image" command and the
+# other procedures in the file tkImage.c. It is organized in the
+# standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+imageInit
+
+# Canvas used in some tests in the whole file
+canvas .c -highlightthickness 2
+pack .c
+update
+
+
+test image-1.1 {Tk_ImageCmd procedure, "create" option} -body {
+ image
+} -returnCodes error -result {wrong # args: should be "image option ?args?"}
+test image-1.2 {Tk_ImageCmd procedure, "create" option} -body {
+ image gorp
+} -returnCodes error -result {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width}
+test image-1.3 {Tk_ImageCmd procedure, "create" option} -body {
+ image create
+} -returnCodes error -result {wrong # args: should be "image create type ?name? ?-option value ...?"}
+test image-1.4 {Tk_ImageCmd procedure, "create" option} -body {
+ image c bad_type
+} -returnCodes error -result {image type "bad_type" doesn't exist}
+test image-1.5 {Tk_ImageCmd procedure, "create" option} -constraints {
+ testImageType
+} -body {
+ list [image create test myimage] [imageNames]
+} -cleanup {
+ imageCleanup
+} -result {myimage myimage}
+test image-1.6 {Tk_ImageCmd procedure, "create" option} -constraints {
+ testImageType
+} -setup {
+ imageCleanup
+} -body {
+ scan [image create test] image%d first
+ image create test myimage
+ scan [image create test -variable x] image%d second
+ expr $second-$first
+} -cleanup {
+ imageCleanup
+} -result {1}
+
+test image-1.7 {Tk_ImageCmd procedure, "create" option} -constraints {
+ testImageType
+} -setup {
+ imageCleanup
+} -body {
+ image create test myimage -variable x
+ .c create image 100 50 -image myimage
+ .c create image 100 150 -image myimage
+ update
+ set x {}
+ image create test myimage -variable x
+ update
+ return $x
+} -cleanup {
+ imageCleanup
+} -result {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}}
+test image-1.8 {Tk_ImageCmd procedure, "create" option} -constraints {
+ testImageType
+} -setup {
+ .c delete all
+ imageCleanup
+} -body {
+ image create test myimage -variable x
+ .c create image 100 50 -image myimage
+ .c create image 100 150 -image myimage
+ image delete myimage
+ update
+ set x {}
+ image create test myimage -variable x
+ update
+ return $x
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}}
+test image-1.9 {Tk_ImageCmd procedure, "create" option} -constraints {
+ testImageType
+} -body {
+ image create test -badName foo
+} -returnCodes error -result {bad option name "-badName"}
+test image-1.10 {Tk_ImageCmd procedure, "create" option} -constraints {
+ testImageType
+} -body {
+ catch {image create test -badName foo}
+ imageNames
+} -result {}
+test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window} -body {
+ set code [loadTkCommand]
+ append code {
+ update
+ puts [list [catch {image create photo .} msg] $msg]
+ exit
+ }
+ set script [makeFile $code script]
+ exec [interpreter] <$script
+} -cleanup {
+ removeFile script
+} -result {1 {images may not be named the same as the main window}}
+test image-1.12 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} -body {
+ set code [loadTkCommand]
+ append code {
+ update
+ puts [list [catch {rename . foo;image create photo foo} msg] $msg]
+ exit
+ }
+ set script [makeFile $code script]
+ exec [interpreter] <$script
+} -cleanup {
+ removeFile script
+} -result {1 {images may not be named the same as the main window}}
+test image-1.13 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup {
+ .c delete all
+ imageCleanup
+} -body {
+ set i [image create bitmap]
+ regexp {^image(\d+)$} $i -> serial
+ incr serial
+ proc image$serial {} {return works}
+ set j [image create bitmap]
+
+ image$serial
+} -cleanup {
+ rename image$serial {}
+ image delete $i $j
+} -result works
+
+test image-2.1 {Tk_ImageCmd procedure, "delete" option} -body {
+ image delete
+} -result {}
+test image-2.2 {Tk_ImageCmd procedure, "delete" option} -constraints {
+ testImageType
+} -setup {
+ imageCleanup
+ set result {}
+} -body {
+ image create test myimage
+ image create test img2
+ lappend result [lsort [imageNames]]
+ image d myimage img2
+ lappend result [imageNames]
+} -cleanup {
+ imageCleanup
+} -result {{img2 myimage} {}}
+test image-2.3 {Tk_ImageCmd procedure, "delete" option} -constraints {
+ testImageType
+} -setup {
+ imageCleanup
+} -body {
+ image create test myimage
+ image create test img2
+ image delete myimage gorp img2
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result {image "gorp" doesn't exist}
+test image-2.4 {Tk_ImageCmd procedure, "delete" option} -constraints {
+ testImageType
+} -setup {
+ imageCleanup
+} -body {
+ image create test myimage
+ image create test img2
+ catch {image delete myimage gorp img2}
+ imageNames
+} -cleanup {
+ imageCleanup
+} -result {img2}
+
+
+test image-3.1 {Tk_ImageCmd procedure, "height" option} -body {
+ image height
+} -returnCodes error -result {wrong # args: should be "image height name"}
+test image-3.2 {Tk_ImageCmd procedure, "height" option} -body {
+ image height a b
+} -returnCodes error -result {wrong # args: should be "image height name"}
+test image-3.3 {Tk_ImageCmd procedure, "height" option} -body {
+ image height foo
+} -returnCodes error -result {image "foo" doesn't exist}
+test image-3.4 {Tk_ImageCmd procedure, "height" option} -constraints {
+ testImageType
+} -setup {
+ imageCleanup
+} -body {
+ image create test myimage
+ set x [image h myimage]
+ myimage changed 0 0 0 0 60 50
+ list $x [image height myimage]
+} -cleanup {
+ imageCleanup
+} -result {15 50}
+
+
+test image-4.1 {Tk_ImageCmd procedure, "names" option} -body {
+ image names x
+} -returnCodes error -result {wrong # args: should be "image names"}
+test image-4.2 {Tk_ImageCmd procedure, "names" option} -constraints {
+ testImageType
+} -setup {
+ catch {interp delete testinterp}
+} -body {
+ interp create testinterp
+ load {} Tk testinterp
+ interp eval testinterp {
+ image delete {*}[image names]
+ image create test myimage
+ image create test img2
+ image create test 24613
+ lsort [image names]
+ }
+} -cleanup {
+ interp delete testinterp
+} -result {24613 img2 myimage}
+test image-4.3 {Tk_ImageCmd procedure, "names" option} -setup {
+ catch {interp delete testinterp}
+} -body {
+ interp create testinterp
+ load {} Tk testinterp
+ interp eval testinterp {
+ image delete {*}[image names]
+ eval image delete [image names] [image names]
+ lsort [image names]
+ }
+} -cleanup {
+ interp delete testinterp
+} -result {}
+
+
+test image-5.1 {Tk_ImageCmd procedure, "type" option} -body {
+ image type
+} -returnCodes error -result {wrong # args: should be "image type name"}
+test image-5.2 {Tk_ImageCmd procedure, "type" option} -body {
+ image type a b
+} -returnCodes error -result {wrong # args: should be "image type name"}
+test image-5.3 {Tk_ImageCmd procedure, "type" option} -body {
+ image type foo
+} -returnCodes error -result {image "foo" doesn't exist}
+
+test image-5.4 {Tk_ImageCmd procedure, "type" option} -constraints {
+ testImageType
+} -setup {
+ imageCleanup
+} -body {
+ image create test myimage
+ image type myimage
+} -cleanup {
+ imageCleanup
+} -result {test}
+test image-5.5 {Tk_ImageCmd procedure, "type" option} -constraints {
+ testImageType
+} -setup {
+ imageCleanup
+} -body {
+ image create test myimage
+ .c create image 50 50 -image myimage
+ image delete myimage
+ image type myimage
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result {image "myimage" doesn't exist}
+test image-5.6 {Tk_ImageCmd procedure, "type" option} -constraints {
+ testOldImageType
+} -setup {
+ imageCleanup
+} -body {
+ image create oldtest myimage
+ image type myimage
+} -cleanup {
+ imageCleanup
+} -result {oldtest}
+test image-5.7 {Tk_ImageCmd procedure, "type" option} -constraints {
+ testOldImageType
+} -setup {
+ .c delete all
+ imageCleanup
+} -body {
+ image create oldtest myimage
+ .c create image 50 50 -image myimage
+ image delete myimage
+ image type myimage
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -returnCodes error -result {image "myimage" doesn't exist}
+
+
+test image-6.1 {Tk_ImageCmd procedure, "types" option} -body {
+ image types x
+} -returnCodes error -result {wrong # args: should be "image types"}
+test image-6.2 {Tk_ImageCmd procedure, "types" option} -constraints {
+ testImageType
+} -body {
+ lsort [image types]
+} -result {bitmap oldtest photo test}
+
+
+test image-7.1 {Tk_ImageCmd procedure, "width" option} -body {
+ image width
+} -returnCodes error -result {wrong # args: should be "image width name"}
+test image-7.2 {Tk_ImageCmd procedure, "width" option} -body {
+ image width a b
+} -returnCodes error -result {wrong # args: should be "image width name"}
+test image-7.3 {Tk_ImageCmd procedure, "width" option} -body {
+ image width foo
+} -returnCodes error -result {image "foo" doesn't exist}
+test image-7.4 {Tk_ImageCmd procedure, "width" option} -constraints {
+ testImageType
+} -setup {
+ imageCleanup
+} -body {
+ image create test myimage
+ set x [image w myimage]
+ myimage changed 0 0 0 0 60 50
+ list $x [image width myimage]
+} -cleanup {
+ imageCleanup
+} -result {30 60}
+
+
+test image-8.1 {Tk_ImageCmd procedure, "inuse" option} -constraints {
+ testImageType
+} -setup {
+ imageCleanup
+ set res {}
+ destroy .b
+} -body {
+ image create test myimage2
+ lappend res [image inuse myimage2]
+ button .b -image myimage2
+ lappend res [image inuse myimage2]
+} -cleanup {
+ imageCleanup
+ catch {destroy .b}
+} -result [list 0 1]
+
+
+test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup {
+ .c delete all
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ .c create image 50 50 -image foo
+ update
+ set x {}
+ foo changed 5 6 7 8 30 15
+ update
+ return $x
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {{foo display 5 6 7 8 30 30}}
+test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup {
+ .c delete all
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ .c create image 50 50 -image foo
+ .c create image 90 100 -image foo
+ update
+ set x {}
+ foo changed 5 6 7 8 30 15
+ update
+ return $x
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}}
+
+
+test image-10.1 {Tk_GetImage procedure} -setup {
+ imageCleanup
+} -body {
+ .c create image 100 10 -image bad_name
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result {image "bad_name" doesn't exist}
+test image-10.2 {Tk_GetImage procedure} -constraints testImageType -setup {
+ destroy .l
+ imageCleanup
+} -body {
+ image create test mytest
+ label .l -image mytest
+ image delete mytest
+ label .l2 -image mytest
+} -cleanup {
+ destroy .l
+ imageCleanup
+} -returnCodes error -result {image "mytest" doesn't exist}
+
+
+test image-11.1 {Tk_FreeImage procedure} -constraints testImageType -setup {
+ .c delete all
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ .c create image 50 50 -image foo -tags i1
+ .c create image 90 100 -image foo -tags i2
+ pack forget .c
+ update
+ set x {}
+ .c delete i1
+ pack .c
+ update
+ list [imageNames] $x
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {foo {{foo free} {foo display 0 0 30 15 103 121}}}
+test image-11.2 {Tk_FreeImage procedure} -constraints testImageType -setup {
+ .c delete all
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ .c create image 50 50 -image foo -tags i1
+ set names [imageNames]
+ image delete foo
+ update
+ set names2 [imageNames]
+ set x {}
+ .c delete i1
+ pack forget .c
+ pack .c
+ update
+ list $names $names2 [imageNames] $x
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {foo {} {} {}}
+
+
+# Non-portable, apparently due to differences in rounding:
+test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
+ testImageType nonPortable
+} -setup {
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ .c create image 50 60 -image foo -tags i1 -anchor nw
+ update
+ .c create rectangle 30 40 55 65 -width 0 -fill black -outline {}
+ set x {}
+ update
+ return $x
+} -cleanup {
+ imageCleanup
+} -result {{foo display 0 0 5 5 50 50}}
+test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
+ testImageType nonPortable
+} -setup {
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ .c create image 50 60 -image foo -tags i1 -anchor nw
+ update
+ .c create rectangle 60 40 100 65 -width 0 -fill black -outline {}
+ set x {}
+ update
+ return $x
+} -cleanup {
+ imageCleanup
+} -result {{foo display 10 0 20 5 30 50}}
+test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
+ testImageType nonPortable
+} -setup {
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ .c create image 50 60 -image foo -tags i1 -anchor nw
+ update
+ .c create rectangle 60 70 100 200 -width 0 -fill black -outline {}
+ set x {}
+ update
+ return $x
+} -cleanup {
+ imageCleanup
+} -result {{foo display 10 10 20 5 30 30}}
+test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
+ testImageType nonPortable
+} -setup {
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ .c create image 50 60 -image foo -tags i1 -anchor nw
+ update
+ .c create rectangle 30 70 55 200 -width 0 -fill black -outline {}
+ set x {}
+ update
+ return $x
+} -cleanup {
+ imageCleanup
+} -result {{foo display 0 10 5 5 50 30}}
+test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
+ testImageType nonPortable
+} -setup {
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ .c create image 50 60 -image foo -tags i1 -anchor nw
+ update
+ .c create rectangle 10 20 120 130 -width 0 -fill black -outline {}
+ set x {}
+ update
+ return $x
+} -cleanup {
+ imageCleanup
+} -result {{foo display 0 0 30 15 70 70}}
+test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
+ testImageType nonPortable
+} -setup {
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ .c create image 50 60 -image foo -tags i1 -anchor nw
+ update
+ .c create rectangle 55 65 75 70 -width 0 -fill black -outline {}
+ set x {}
+ update
+ return $x
+} -cleanup {
+ imageCleanup
+} -result {{foo display 5 5 20 5 30 30}}
+
+
+test image-13.1 {Tk_SizeOfImage procedure} -constraints testImageType -setup {
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ set result [list [image width foo] [image height foo]]
+ foo changed 0 0 0 0 85 60
+ lappend result [image width foo] [image height foo]
+} -cleanup {
+ imageCleanup
+} -result {30 15 85 60}
+
+test image-13.2 {DeleteImage procedure} -constraints testImageType -setup {
+ .c delete all
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ .c create image 50 50 -image foo -tags i1
+ .c create image 90 100 -image foo -tags i2
+ set x {}
+ image delete foo
+ lappend x | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] |
+} -cleanup {
+ imageCleanup
+} -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |}
+
+test image-13.3 {Tk_SizeOfImage procedure} -constraints testOldImageType -setup {
+ imageCleanup
+} -body {
+ image create oldtest foo -variable x
+ set result [list [image width foo] [image height foo]]
+ foo changed 0 0 0 0 85 60
+ lappend result [image width foo] [image height foo]
+} -cleanup {
+ imageCleanup
+} -result {30 15 85 60}
+
+test image-13.4 {DeleteImage procedure} -constraints testOldImageType -setup {
+ .c delete all
+ imageCleanup
+} -body {
+ image create oldtest foo -variable x
+ .c create image 50 50 -image foo -tags i1
+ .c create image 90 100 -image foo -tags i2
+ set x {}
+ image delete foo
+ lappend x | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] |
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |}
+
+test image-14.1 {image command vs hidden commands} -body {
+ catch {image delete hidden}
+ set l [imageNames]
+ set h [interp hidden]
+ image create photo hidden
+ interp hide {} hidden
+ image delete hidden
+ set res1 [list [imageNames] [interp hidden]]
+ set res2 [list $l $h]
+ expr {$res1 eq $res2}
+} -result 1
+
+test image-15.1 {deleting image does not make widgets forget about it} -setup {
+ .c delete all
+ imageCleanup
+} -body {
+ image create photo foo -width 10 -height 10
+ .c create image 10 10 -image foo -tags i1 -anchor nw
+ update
+ set x [.c bbox i1]
+ lappend x [imageNames]
+ image delete foo
+ lappend x [imageNames]
+ image create photo foo -width 20 -height 20
+ lappend x [.c bbox i1] [imageNames]
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {10 10 20 20 foo {} {10 10 30 30} foo}
+
+destroy .c
+imageFinish
+
+# cleanup
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/imgBmap.test b/tk8.6/tests/imgBmap.test
new file mode 100644
index 0000000..5ffd7c4
--- /dev/null
+++ b/tk8.6/tests/imgBmap.test
@@ -0,0 +1,519 @@
+# This file is a Tcl script to test out images of type "bitmap" (i.e.,
+# the procedures in the file tkImgBmap.c). It is organized in the
+# standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+imageInit
+
+set data1 {#define foo_width 16
+#define foo_height 16
+#define foo_x_hot 3
+#define foo_y_hot 3
+static unsigned char foo_bits[] = {
+ 0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81,
+ 0x81, 0x81, 0xff, 0xff, 0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81,
+ 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0xff, 0xff};
+}
+set data2 {
+ #define foo2_width 16
+ #define foo2_height 16
+ static char foo2_bits[] = {
+ 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0xff};
+}
+makeFile $data1 foo.bm
+makeFile $data2 foo2.bm
+
+imageCleanup
+#canvas .c
+#pack .c
+#update
+#image create bitmap i1
+#.c create image 200 100 -image i1
+update
+proc bgerror msg {
+ global errMsg
+ set errMsg $msg
+}
+
+test imageBmap-1.1 {options for bitmap images} -body {
+ image create bitmap i1 -background #123456
+ lindex [i1 configure -background] 4
+} -cleanup {
+ image delete i1
+} -result {#123456}
+test imageBmap-1.2 {options for bitmap images} -setup {
+ destroy .c
+ pack [canvas .c]
+ update
+} -body {
+ set errMsg {}
+ image create bitmap i1 -background lousy
+ .c create image 200 100 -image i1
+ update
+ list $errMsg $errorInfo
+} -cleanup {
+ image delete i1
+ destroy .c
+} -result {{unknown color name "lousy"} {unknown color name "lousy"
+ (while configuring image "i1")}}
+test imageBmap-1.3 {options for bitmap images} -body {
+ image create bitmap i1 -data $data1
+ lindex [i1 configure -data] 4
+} -result $data1
+test imageBmap-1.4 {options for bitmap images} -body {
+ image create bitmap i1 -data bogus
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-1.5 {options for bitmap images} -body {
+ image create bitmap i1 -file foo.bm
+ lindex [i1 configure -file] 4
+} -result foo.bm
+test imageBmap-1.6 {options for bitmap images} -body {
+ list [catch {image create bitmap i1 -file bogus} msg] [string tolower $msg]
+} -result {1 {couldn't read bitmap file "bogus": no such file or directory}}
+test imageBmap-1.7 {options for bitmap images} -body {
+ image create bitmap i1 -foreground #00ff00
+ lindex [i1 configure -foreground] 4
+} -cleanup {
+ image delete i1
+} -result {#00ff00}
+test imageBmap-1.8 {options for bitmap images} -setup {
+ destroy .c
+ pack [canvas .c]
+ update
+} -body {
+ set errMsg {}
+ image create bitmap i1 -foreground bad_color
+ .c create image 200 100 -image i1
+ update
+ list $errMsg $errorInfo
+} -cleanup {
+ destroy .c
+ image delete i1
+} -result {{unknown color name "bad_color"} {unknown color name "bad_color"
+ (while configuring image "i1")}}
+test imageBmap-1.9 {options for bitmap images} -body {
+ image create bitmap i1 -data $data1 -maskdata $data2
+ lindex [i1 configure -maskdata] 4
+} -result $data2
+test imageBmap-1.10 {options for bitmap images} -body {
+ image create bitmap i1 -data $data1 -maskdata bogus
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-1.11 {options for bitmap images} -body {
+ image create bitmap i1 -file foo.bm -maskfile foo2.bm
+ lindex [i1 configure -maskfile] 4
+} -result foo2.bm
+test imageBmap-1.12 {options for bitmap images} -body {
+ list [catch {image create bitmap i1 -data $data1 -maskfile bogus} msg] \
+ [string tolower $msg]
+} -result {1 {couldn't read bitmap file "bogus": no such file or directory}}
+rename bgerror {}
+
+
+test imageBmap-2.1 {ImgBmapCreate procedure} -setup {
+ imageCleanup
+} -body {
+ list [catch {image create bitmap -gorp dum} msg] $msg [imageNames]
+} -result {1 {unknown option "-gorp"} {}}
+test imageBmap-2.2 {ImgBmapCreate procedure} -setup {
+ imageCleanup
+} -body {
+ image create bitmap image1
+ list [info commands image1] [imageNames] \
+ [image width image1] [image height image1] \
+ [lindex [image1 configure -foreground] 4] \
+ [lindex [image1 configure -background] 4]
+} -cleanup {
+ image delete image1
+} -result {image1 image1 0 0 #000000 {}}
+
+
+test imageBmap-3.1 {ImgBmapConfigureMaster procedure, memory de-allocation} -body {
+ image create bitmap i1 -data $data1
+ i1 configure -data $data1
+} -cleanup {
+ image delete i1
+} -result {}
+test imageBmap-3.2 {ImgBmapConfigureMaster procedure} -body {
+ image create bitmap i1 -data $data1
+ list [catch {i1 configure -data bogus} msg] $msg [image width i1] \
+ [image height i1]
+} -result {1 {format error in bitmap data} 16 16}
+test imageBmap-3.3 {ImgBmapConfigureMaster procedure, memory de-allocation} -body {
+ image create bitmap i1 -data $data1 -maskdata $data2
+ i1 configure -maskdata $data2
+} -cleanup {
+ image delete i1
+} -result {}
+test imageBmap-3.4 {ImgBmapConfigureMaster procedure} -body {
+ image create bitmap i1
+ i1 configure -maskdata $data2
+} -returnCodes error -result {can't have mask without bitmap}
+test imageBmap-3.5 {ImgBmapConfigureMaster procedure} -body {
+ image create bitmap i1 -data $data1 -maskdata {
+ #define foo_width 8
+ #define foo_height 16
+ static char foo_bits[] = {
+ 0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81,
+ 0x81, 0x81, 0xff, 0xff, 0xff, 0xff, 0x81, 0x81};
+ }
+} -returnCodes error -result {bitmap and mask have different sizes}
+test imageBmap-3.6 {ImgBmapConfigureMaster procedure} -body {
+ image create bitmap i1 -data $data1 -maskdata {
+ #define foo_width 16
+ #define foo_height 8
+ static char foo_bits[] = {
+ 0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81,
+ 0x81, 0x81, 0xff, 0xff, 0xff, 0xff, 0x81, 0x81};
+ }
+} -returnCodes error -result {bitmap and mask have different sizes}
+test imageBmap-3.7 {ImgBmapConfigureMaster procedure} -setup {
+ destroy .c
+ pack [canvas .c]
+} -body {
+ image create bitmap i1 -data $data1
+ .c create image 100 100 -image i1 -tags i1.1 -anchor nw
+ .c create image 200 100 -image i1 -tags i1.2 -anchor nw
+ update
+ i1 configure -data {
+ #define foo2_height 14
+ #define foo2_width 15
+ static char foo2_bits[] = {
+ 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0xff};
+ }
+ update
+ list [image width i1] [image height i1] [.c bbox i1.1] [.c bbox i1.2]
+} -cleanup {
+ image delete i1
+ destroy .c
+} -result {15 14 {100 100 115 114} {200 100 215 114}}
+
+
+test imageBmap-4.1 {ImgBmapConfigureInstance procedure: check error handling} -setup {
+ destroy .c
+ pack [canvas .c]
+ update
+} -body {
+ proc bgerror args {}
+ image create bitmap i1 -file foo.bm
+ .c create image 100 100 -image i1
+ update
+ i1 configure -foreground bogus
+ update
+} -cleanup {
+ image delete i1
+ destroy .c
+} -result {}
+
+
+test imageBmap-5.1 {GetBitmapData procedure} -body {
+ list [catch {image create bitmap -file ~bad_user/a/b} msg] \
+ [string tolower $msg]
+} -result {1 {user "bad_user" doesn't exist}}
+test imageBmap-5.2 {GetBitmapData procedure} -body {
+ list [catch {image create bitmap -file bad_name} msg] [string tolower $msg]
+} -result {1 {couldn't read bitmap file "bad_name": no such file or directory}}
+test imageBmap-5.3 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap -data { }
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-5.4 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap -data "#define foo2_width"
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-5.5 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap -data "#define foo2_width gorp"
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-5.6 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap -data "#define foo2_width 1.4"
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-5.7 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap -data "#define foo2_height"
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-5.8 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap -data "#define foo2_height gorp"
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-5.9 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap -data "#define foo2_height 1.4"
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-5.10 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap i1 -data {
+ #define foo2_height 14
+ #define foo2_width 15 xx _widtg 18 xwidth 18 _heighz 18 xheight 18
+ static char foo2_bits[] = {
+ 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0xff};
+ }
+ list [image width i1] [image height i1]
+} -cleanup {
+ image delete i1
+} -result {15 14}
+test imageBmap-5.11 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap i1 -data {
+ _height 14 _width 15
+ char {
+ 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0xff}
+ }
+ list [image width i1] [image height i1]
+} -cleanup {
+ image delete i1
+} -result {15 14}
+test imageBmap-5.12 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap i1 -data {
+ #define foo2_height 14
+ #define foo2_width 15
+ static short foo2_bits[] = {
+ 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0xff};
+ }
+} -returnCodes error -result {format error in bitmap data; looks like it's an obsolete X10 bitmap file}
+test imageBmap-5.13 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap i1 -data {
+ #define foo2_height 16
+ #define foo2_width 16
+ static char foo2_bits[] =
+ 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0xff;
+ }
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-5.14 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap i1 -data {
+ #define foo2_width 16
+ static char foo2_bits[] = {
+ 0xff, 0xff, 0xff, }}
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-5.15 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap i1 -data {
+ #define foo2_height 16
+ static char foo2_bits[] = {
+ 0xff, 0xff, 0xff, }}
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-5.16 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap i1 -data {
+ #define foo2_height 16
+ #define foo2_width 16
+ static char foo2_bits[] = {
+ 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, foo};
+ }
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-5.17 {GetBitmapData procedure} -setup {imageCleanup} -body {
+ image create bitmap i1 -data "
+ #define foo2_height 16
+ #define foo2_width 16
+ static char foo2_bits[] = \{
+ 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81,
+ 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
+ 0xff
+ "
+} -returnCodes error -result {format error in bitmap data}
+
+
+test imageBmap-6.1 {NextBitmapWord procedure} -setup {imageCleanup} -body {
+ image create bitmap i1 -data {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890}
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-6.2 {NextBitmapWord procedure} -setup {imageCleanup} -body {
+ makeFile {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890} foo3.bm
+ image create bitmap i1 -file foo3.bm
+} -returnCodes error -result {format error in bitmap data}
+test imageBmap-6.3 {NextBitmapWord procedure} -setup {imageCleanup} -body {
+ makeFile { } foo3.bm
+ image create bitmap i1 -file foo3.bm
+} -returnCodes error -result {format error in bitmap data}
+removeFile foo3.bm
+
+
+imageCleanup
+# Image used in 7.* tests
+image create bitmap i1
+test imageBmap-7.1 {ImgBmapCmd procedure} -body {
+ i1
+} -returnCodes error -result {wrong # args: should be "i1 option ?arg ...?"}
+test imageBmap-7.2 {ImgBmapCmd procedure, "cget" option} -body {
+ i1 cget
+} -returnCodes error -result {wrong # args: should be "i1 cget option"}
+test imageBmap-7.3 {ImgBmapCmd procedure, "cget" option} -body {
+ i1 cget a b
+} -returnCodes error -result {wrong # args: should be "i1 cget option"}
+test imageBmap-7.4 {ImgBmapCmd procedure, "cget" option} -body {
+ i1 co -foreground #123456
+ i1 cget -foreground
+} -result {#123456}
+test imageBmap-7.5 {ImgBmapCmd procedure, "cget" option} -body {
+ i1 cget -stupid
+} -returnCodes error -result {unknown option "-stupid"}
+test imageBmap-7.6 {ImgBmapCmd procedure} -body {
+ llength [i1 configure]
+} -result {6}
+test imageBmap-7.7 {ImgBmapCmd procedure} -body {
+ i1 co -foreground #001122
+ i1 configure -foreground
+} -result {-foreground {} {} #000000 #001122}
+test imageBmap-7.8 {ImgBmapCmd procedure} -body {
+ i1 configure -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test imageBmap-7.9 {ImgBmapCmd procedure} -body {
+ i1 configure -foreground #221100 -background
+} -returnCodes error -result {value for "-background" missing}
+test imageBmap-7.10 {ImgBmapCmd procedure} -body {
+ i1 gorp
+} -returnCodes error -result {bad option "gorp": must be cget or configure}
+
+
+test imageBmap-8.1 {ImgBmapGet/Free procedures, shared instances} -setup {
+ destroy .c
+ pack [canvas .c]
+ update
+} -body {
+ image create bitmap i1 -data $data1
+ .c create image 50 100 -image i1 -tags i1.1
+ .c create image 150 100 -image i1 -tags i1.2
+ .c create image 250 100 -image i1 -tags i1.3
+ update
+ .c delete i1.1
+ i1 configure -background black
+ update
+ .c delete i1.2
+ i1 configure -background white
+ update
+ .c delete i1.3
+ i1 configure -background black
+ update
+ image delete i1
+} -cleanup {
+ destroy .c
+} -result {}
+
+
+test imageBmap-9.1 {ImgBmapDisplay procedure, nothing to display} -setup {
+ destroy .c
+ pack [canvas .c]
+ update
+} -body {
+ proc bgerror args {}
+ imageCleanup
+ image create bitmap i1 -data $data1
+ .c create image 50 100 -image i1 -tags i1.1
+ i1 configure -data {}
+ update
+} -cleanup {
+ image delete i1
+ destroy .c
+} -result {}
+test imageBmap-9.2 {ImgBmapDisplay procedure, nothing to display} -setup {
+ destroy .c
+ pack [canvas .c]
+ update
+} -body {
+ proc bgerror args {}
+ imageCleanup
+ .c delete all
+ image create bitmap i1 -data $data1
+ .c create image 50 100 -image i1 -tags i1.1
+ i1 configure -foreground bogus
+ update
+} -cleanup {
+ image delete i1
+ destroy .c
+} -result {}
+if {[info exists bgerror]} {
+ rename bgerror {}
+}
+
+
+test imageBmap-10.1 {ImgBmapFree procedure, resource freeing} -setup {
+ destroy .c
+ pack [canvas .c]
+ update
+} -body {
+ imageCleanup
+ image create bitmap i1 -data $data1 -maskdata $data2 -foreground #112233 \
+ -background #445566
+ .c create image 100 100 -image i1
+ update
+ .c delete all
+ image delete i1
+} -cleanup {
+ destroy .c
+} -result {}
+test imageBmap-10.2 {ImgBmapFree procedures, unlinking} -setup {
+ destroy .c
+ pack [canvas .c]
+ update
+} -body {
+ imageCleanup
+ image create bitmap i1 -data $data1 -maskdata $data2 -foreground #112233 \
+ -background #445566
+ .c create image 100 100 -image i1
+ button .b1 -image i1
+ button .b2 -image i1
+ button .b3 -image i1
+ pack .b1 .b2 .b3
+ update
+ destroy .b2
+ update
+ destroy .b3
+ update
+ destroy .b1
+ update
+ .c delete all
+} -cleanup {
+ image delete i1
+ deleteWindows
+} -result {}
+
+
+test imageBmap-11.1 {ImgBmapDelete procedure} -body {
+ image create bitmap i2 -file foo.bm -maskfile foo2.bm
+ image delete i2
+ info command i2
+} -result {}
+test imageBmap-11.2 {ImgBmapDelete procedure} -body {
+ image create bitmap i2 -file foo.bm -maskfile foo2.bm
+ rename i2 newi2
+ set x [list [info command i2] [info command new*] [newi2 cget -file]]
+ image delete i2
+ lappend x [info command new*]
+} -result {{} newi2 foo.bm {}}
+
+
+test imageBmap-12.1 {ImgBmapCmdDeletedProc procedure} -body {
+ image create bitmap i2 -file foo.bm -maskfile foo2.bm
+ rename i2 {}
+ list [lsearch -exact [imageNames] i2] [catch {i2 foo} msg] $msg
+} -result {-1 1 {invalid command name "i2"}}
+
+removeFile foo.bm
+removeFile foo2.bm
+imageFinish
+
+# cleanup
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/tk8.6/tests/imgPNG.test b/tk8.6/tests/imgPNG.test
new file mode 100644
index 0000000..0757411
--- /dev/null
+++ b/tk8.6/tests/imgPNG.test
@@ -0,0 +1,1116 @@
+# This file is a Tcl script to test out the code in tkImgFmtPNG.c, which reads
+# and write PNG-format image files for photo widgets. The files is organized
+# in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998 Willem van Schaik (images only)
+# Copyright (c) 2008 Donal K. Fellows
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+imageInit
+
+namespace eval png {
+ variable encoded
+ # Key names are from the names of the source images, which come from
+ # http://www.schaik.com/pngsuite/pngsuite.html
+ # The exception is "BadX", which is used to test handling badly compressed
+ # images.
+ array set encoded {
+ basn0g08 "iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAAAAABWESUoAAAABGdBTUEAAYag
+MeiWXwAAAEFJREFUeJxjZGAkABQIyLMMBQWMDwgp+PcfP2B5MBwUMMoRkGdkonlcDAYFjI/wyv7/z/
+iH5nExGBQwyuCVZWQEAFDl/nE14thZAAAAAElFTkSuQmCC"
+ basn2c08 "iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAIAAAD8GO2jAAAABGdBTUEAAYag
+MeiWXwAAAEhJREFUeJzt1cEJADAMAkCF7JH9t3ITO0Qr9KH4zuErtA0EO4AKFPgcoO3kfUx4QIECD0
+qHH8KEBxQo8KB0OCOpQIG7cHejwAGCsfleD0DPSwAAAABJRU5ErkJggg=="
+ basn3p08 "iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAAABGdBTUEAAYag
+MeiWXwAAAwBQTFRFIkQA9f/td/93y///EQoAOncAIiL//xH/EQAAIiIA/6xVZv9m/2Zm/wH/IhIA3P
+//zP+ZRET/AFVVIgAAy8v/REQAVf9Vy8sAMxoA/+zc7f//5P/L/9zcRP9EZmb/MwAARCIA7e3/ZmYA
+/6RE//+q7e0AAMvL/v///f/+//8BM/8zVSoAAQH/iIj/AKqqAQEARAAAiIgA/+TLulsAIv8iZjIA//
++Zqqr/VQAAqqoAy2MAEf8R1P+qdzoA/0RE3GsAZgAAAf8BiEIA7P/ca9wA/9y6ADMzAO0A7XMA//+I
+mUoAEf//dwAA/4MB/7q6/nsA//7/AMsA/5mZIv//iAAA//93AIiI/9z/GjMAAACqM///AJkAmQAAAA
+ABMmYA/7r/RP///6r/AHcAAP7+qgAASpkA//9m/yIiAACZi/8RVf///wEB/4j/AFUAABER///+//3+
+pP9EZv///2b/ADMA//9V/3d3AACI/0T/ABEAd///AGZm///tAAEA//XtERH///9E/yL//+3tEREAiP
+//AAB3k/8iANzcMzP//gD+urr/mf//MzMAY8sAuroArP9V///c//8ze/4A7QDtVVX/qv//3Nz/VVUA
+AABm3NwA3ADcg/8Bd3f//v7////L/1VVd3cA/v4AywDLAAD+AQIAAQAAEiIA//8iAEREm/8z/9SqAA
+BVmZn/mZkAugC6KlUA/8vLtP9m/5sz//+6qgCqQogAU6oA/6qqAADtALq6//8RAP4AAABEAJmZmQCZ
+/8yZugAAiACIANwA/5MiAADc/v/+qlMAdwB3AgEAywAAAAAz/+3/ALoA/zMz7f/t/8SIvP93AKoAZg
+BmACIi3AAA/8v/3P/c/4sRAADLAAEBVQBVAIgAAAAiAf//y//L7QAA/4iIRABEW7oA/7x3/5n/AGYA
+uv+6AHd3c+0A/gAAMwAzAAC6/3f/AEQAqv+q//7+AAARIgAixP+IAO3tmf+Z/1X/ACIA/7RmEQARCh
+EA/xER3P+6uv//iP+IAQAB/zP/uY7TYgAAAbFJREFUeJwNwQcACAQQAMBHqIxIZCs7Mwlla1hlZ+8V
+itCw9yoqNGiYDatsyt6jjIadlVkysve+u5jC9xTmV/qyl6bcJR7kAQZzg568xXmuE2lIyUNM5So7OM
+AFIhvp+YgGvEtFNnOKeJonSEvwP9NZzhHiOfLzBXPoxKP8yD6iPMXITjP+oTdfsp14lTJMJjGtOMFQ
+fiFe4wWK8BP7qUd31hBNqMos2tKYFbRnJdGGjTzPz2yjEA1ZSKymKCM5ylaWcJrZxCZK8jgfU4vc/M
+W3xE7K8RUvsZb3Wc/XxCEqk4v/qMQlFvMZcZIafMOnLKM13zGceJNqPMU4KnCQAqQgbrKHpXSgFK/Q
+n6REO9YxjWE8Sx2SMJD4jfl8wgzy0YgPuEeUJQcD6EoWWpCaHsQkHuY9RpGON/icK0RyrvE680jG22
+TlHaIbx6jLnySkF+M5QxzmD6pwkTsMoSAdidqsojipuMyHzOQ4sYgfyElpzjKGErQkqvMyC7jFv9xm
+BM2JuTzDRDLxN4l4jF1EZjIwmhfZzSOMpT4xiH70IQG/k5En2UKcowudycsG8jCBmtwHgRv+EIeWyO
+AAAAAASUVORK5CYII="
+ basn6a08 "iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABGdBTUEAAYag
+MeiWXwAAAG9JREFUeJzt1jEKgDAMRuEnZGhPofc/VQSPIcTdxUV4HVLoUCj8H00o2YoBMF57fpz/uj
+ODHXUFRwPKBqj5DVigB041HiJ9gFyCVOMbsEIPXNwuAHkgiJL/4qABNqB7QAeUPBAE2QAZUDZAfwEb
+8ABSIBqcFg+4TAAAAABJRU5ErkJggg=="
+
+ BadX "iVBORw0KGgoAAAANSUhEUgAAAAUAAAAFCAYAAACNbyblAAAABHNCSVQICAgIfAhk
+iAAAABN0RVh0U29mdHdhcmUAVGsgOC42YjEuMcrtT1oAAAAcSURBVHicYmBgYPjPgAr+ozP+o0uj68
+BUiWEmAAAA//8SozfjAAAAAElFTkSuQmCC"
+ MultiIDAT "iVBORw0KGgoAAAANSUhEUgAAAN8AAADUCAYAAAAcPvbvAAAAAXNSR0IArs4
+c6QAAAAZiS0dEAP8A/wD/oL2nkwAAAAlwSFlzAAALEwAACxMBAJqcGAAAAAd0SU1FB9oEGQQKMpLRO
+uoAACAASURBVHja7L158GbZWd/3ec45977bb+2e7p7pnu7ZNzFaRhJCwggjsHqUCgUhiWMSJymwUoV
+UlkumJChCHFWBywQQNqhYpFDB2Ljs2EWqiAmphMQVO2ATQMJCQsuMZrp7lt5++7ve9957lid/3Ptbu
+tWjGRAgZvo9XW//3vXe973nfM/zPN9nE1VlMf58RwHkgFMgJhDAQg0EAJQ+FuYekgVrCBope5YK6F3
+8Vw9UCdbvOnuBwbH2aDnBKy7rtkcA357PYHC0B0/t2xfjaz7M4hJ8jS+6fPnriqKqxLqG1IDTGINpP
+9vtds8bY85j5ABoYBAxX3ly5dbnW4wF+G7PoTcDpvnnYyDEeACYJOlgsozN3xMS71Fx7RQaFIOIbY6
+n5iaMpQX4/gIOt7gEf/7jyzFgQMFIAxODQSShmYXcgICmRr5F9dlwPH3XaFJw3LgMjFcsgiDtcZAG1
+HIEsArIAnwLybcA30urnQcPjSHr5GBNK7kSgpLq6h0XLz63fP36xjKYd4AlYUgYdF/t1MPJlVtJv8V
+YgO92vujmFmJQblAUFbWmfXPCZQaH4mezJ5/+wtM8//yLBJ+ePFQ7pQGdtjhTGkl49LiSFuBbgG8h+
+V5OJU0CAQVJJBQxIBqY7uw8+fyFS2xcvkooqycPxBzSqJU3MjcHE5yOAnAxFjbf7bzjyVG06Y07YWy
+ghEps3AUaMJpB7U8Ue8MnptvbpKSkyj9BTCewbMm+TccR6WdvBLoutM6F5FtIvpvuHFE7DaAaMRiCJ
+hKxnSUlFMW7r1+8ZIrNberhmPHWhsHIu20r16K2yE2HgL55khd+3QX4FuMWNh8KouDUoijG2saWA9B
+EPR6f37t8Fb+zTbW1wdVnn0GHu+eJFYaAMa0uc8MxzWKiF2rnYtys/+nNkjA1Dw4kIAaIiCYAmW3vv
+Pv6xUuc7uY4Z5ltXENC9W6siKKaNEEAK6ZVZxVEDjRbARC7uP4LybcY6WYNsbXVGuDpwStiFIJ//Wh
+r+/Tw6nXcdEI2m7B96Vn8aPc0qX49VIjEBls36pmAaX2A5gZ1dDEW4LvtheCNd1ppqPsATc39afHke
+GsLijlrKXDMKDoZUY92INZPQiASUEmo6OEBAJI2t1ucZzEW4Lttgbcv/W54UsEeqIsREWE2Gp7fvbZ
+BR4S7Bl1ODnosWaXY2wZfnBcCSiRoA8B9cuWQYJEF8BbgW4yviMZDbbMJsEYRUm+8s/fOzWtX6RmHK
+Ut0NiVMp1x5/iJpMn4n0LMI1jQ2nR7x56nqIfAWbr4F+BbjKxuDgrR2HwDvms7GnclwhBXDXXcc5/j
+qEsu9LnVRoMF3IL1LSXitSC3CVF5Kx12MBfhu0xGlSa2LBKDCUIH4AxdBSFABdcrpsgTT4jxXL3C3v
+8bXZZsMj09YX4k8sLfLGy9sYj//AuxMzqc4oxTLmEQtYKRJMxIR1OjNwZ6LsQDf7TteCge29QZYAxC
+Z7e6cH+/tYpLSzRyDwQDnGi9RWZawuwfz+Xln7a1z+F7JSRdjAb7b5aLv+/LM/hTI4ZNiGxUxA/D1u
+d3rVx/b29zAxJqBc2TWISJ0Oh2cs1DMoJw/ZpKegxpzk355g/q5AN8CfLe7xDMcDURpH7VPqECMYAH
+q8vxo8zrz4R5dha4xTQRM5ED61eMRTKcQ03nRwIGr70gcm+4ffzEW4Luth+4D0HBDzvlB1nozMY5Em
+k+fjJMxnbqmbw0dlH7Ww4khxkgxn7K7s0Xc3QEfnlyRDHcTpalH/y4AuADf7Q6+fQA2twaKKg0Zo4C
+zQArWj4bfJtMZfWDZGnoiZGJxJsN1crLMYjWRiikUs2+DZDNNByFl+ypnkhuBuBgL8C2YliM1WBJNU
+kIEnCSopm8rtjfXw2iPzNd0ETpJMcmRuR5Z3qXb79HJLTIvYTRap6ze5lLCHg1wOfJ34eZbgG8x4KD
+Y0X7mwWEiekSIUM7P+71dwniErSqcD1iUvhuQGUeISlGW1MWMajyC8QSinicq0sIs3ax7LsYCfLf3a
+GWQ3giK/SBrQUE9Ops+GcZj0nRGR5WOs0iM+DJRFDVBlYQS64o4HsHuLoTwZBNMLU1qX2qSbJsSobr
+A4AJ8t7vamb7M/jsqnCwKKa2HWfE2PxqSh0DXGHKxZFlGbvt08iUkyxFrsMYQZwVxcwf2Rm+j9uu0M
+Z37Np+9UQ4uxgJ8ty/f8mUA5KbEdu+/rdjdttPtHZxP9GyGMYYsy8ntgKwzQIxDrSOzllTMKba3YDS
+yhPBtaGyO1TKn5sDODIsJWIDv9h3xqPK3z3weAaABKOsnp7tDyuEIGyNWDClBQDBqMZIRsCQBay3UN
+Wk8g2IOSZ9EBYNytGqEFV0Yfwvw3e7gS4dB00cyGQ4iXxRiMTtfjsdQB3JjceIa+w4BzYjJUadETBB
+jRLwnFQVMphDj+abOpxwCW0FIB0TMYizAd9uqnfHmJ/SGx4/NJ9Nz1bRo7Lw2nAzjSEZAHT4mklpqj
+YS6JtWeOJ/D1jaU1TlCfOzgcAnQ2E72AnwL8N3Wki+2ki/emMPXOt6T9+dHe0PqYk4mBougqhjnMFm
+OkYwUmyBQwRBCgBShDky3d2E6AV+dv6FIRVKU2HoTF2MBvttY8qVbsjDN8N6fn02mVPOySQdKiZRS0
+6nIZs3bVZvHzrb2nGBIzGeTxu6r6/OKNhKzJXgWZQP/Yo1F9bI/T9C1iz/Spw9NQz4FejAlUlOzCp1
+sd/td/UtXcFtzenPBxBx1UKSaEC1djWQmI9VgnWsKdkahmxx6bQR/+Hm489S7TLXbKaypCrcK5Aw0x
+4XFrC8k3+180aWtLn1TcmvTaUjfWRVFz1c1GiOookkQNc0tQUqJGCMpNLcYAr6uqeYlVTEnDIcwnvS
+I+k5n7H7vzS8vJ78YC/DdbkP21U5p9M0YIwI4BI3x/GS3sfdSiKR0o7qoKRFCQFOCmNCgaB1IPhCqm
+nI+Z+vaBmzvQEznu8YtBN0CfIuxPxKHlfxAG3uulU5pXj052xsR5h4TFQJoBFFBkqBBCSkRQ0JTQkL
+CREGiIjGhdWCyNyRt7UDpn2wmObah24uxAN9C8jXgsxyEnhgEB6fDdP76+d4YrTwOi2jjXNckEA2xB
+u89IQRSSGhImKRYFSQKEiCVNeONbZjOX0/ktNOI1bb+52LGF+C77S/6fkiLE0S0aXEZw7vr4Uj8aIq
+UHptAVIkxIckiScAnfB3RoCSfSJUn1REJNFLRe0IZ2L56Hba2BR/f7ZKQyyKTfQG+xbhRBLZ/LKDz6
+vx8e0iazJEqYqOgEVLQJjtBHRrb/D9tX/OJWEeiT3gfqavAbDrl6vMvMrx6HWbz88S238OiR9hfqLG
+wxb9GmFONIK5pfpkClszovH63H02xRY2tIyYKISopAmohKkYdYiwiilElJYtGJSbFR8XHyHQ2Z4Qy2
+tpjbVa+m17f4DQhsWFOv+peKYs9eyH5/oKOl3Jmi0jr9G4c5sH7ZhIUqMMTroontp+/Qr03oRMgzit
+iHRFxzOcVVeUbuy8m6ipSzCrms5JyXlNUNUVVMatqyhjx3vO5T3+GsL17gpSeIDVBnokvZ1CPfu/91
+24sNX8TYXTkPTd/fuHIX0i+vzDgk1s41ywGS8LmFjRhswxierIajTCzCqkjztOQJ6ntdxkVrRMEJXR
+NWwLekKIwrz0xRqqYmMbAqC7Y8yXF5hbj3T2ORX0STX+AGoy1reRtgHZ0U9i/LQC0kHyvOsAd3fmP/
+r35BhFNjQM91XWDsKp6cu/aJmkypxPABcUkwbSFADUJMYKvE7WPhAAhQFlFJvOaYVGyPZuyM59RG2F
+rOOTChQtcfPYCeP8kIpRlgVd/ADhjDMaYryitF0BcSL5XpYr50he9bWiibYSnmGVieke5N6YTIasTJ
+iQ0RKIoUSAmg8QGp943sZ6+qqnnJfO6Yh49Y18zToFpmdiaTCh9xYULl3jrpHgHa6vLeZ5PklhU9Yb
+vt39/X53cB+TR3yiL8JiF5HtVECrtQr1ZnTskXJSjmeaQ3uWHw2y0tUU1miCVR+cBX3qqsmZeeXxM+
+AAxKAlH8IlyXjOrAkVITENi5Gt25gWX93YpgqesPBcuXOC5S5cy6vpdMTbnjDEeqJxHpbOINIm5Cwm
+4AN+rSeodVStvBtuXfS4F9jl/cRnU/j17W9vMRmPK0QSqQKw9ofZ4HwkpNfl7SQkRYoI6wLyqmc5Lp
+mXFuCzZLefszAtmGilCYFRMufDsRa5duwZJ35PlOYmm0vVR6bYfK3qzyvxSqvViLMD3qrL/jt72e+g
+RA8TIfDw+v7O13YSKKahP0AZNp5RIsZFWPgbqumY2K5jNCiazOZNpwd5kyt5sxrAoGFZzJlXF3mzGX
+jHl0vPP8cUvfpFrl198/7ycU6Wasizx3h+omfsbxa1s1sVY2HyvKgl4VPW81YKeT6agynhv7wlV/Ya
+969f/zQvPPTfU0fj1/WKe+yph6pqQwoHNl2IilR5becblDF/VFMWcopgz9XOmEijUU2lgHEpCo9zyw
+niHX//1X+daXXDPGx+v1s/c9Uf3nzr7h4PB4FMrKyu/NxgMPu2cwzl3S9fBwtb7MzRPbscdzlPSRFO
+aI38P1QCNbRl3A02nythkipvGZhqSYxBsW+jdtoX5AjAPje/cojjGOPbohhKmNWyPHg07o/Ofuv573
+7o3nn7zZ75waf36iyNOd0/zsDvDyT3D8V3F7pXEqqSQinIgTLPIuJ4xns+oqhK7u0WZAsN6zrYv2CO
+wZwK7WrMdPMMI0UEQRx2UGJU867O+ssbS0hIPn+rz0GOPcuaBezlx7vTeg48/9ltn7z/3/ywtLf1fn
+az7FFHJbQeNhgiI7Ta/jcbtkamSidzQ7OWw6xJH7NkbukQcGenI1ZYjStjLKWLpNaWw3Zbgq6jbhXM
+IQMNhuOWhbdZEoohpc89Nk3M3ItEhawsSgfcRUUfHWaxAVU2QuEcoNvCTjbcVm1e/a+u5y99++UuXH
+r/+4iYvzq+zNRrzhWcuU0yFJ+59gneefTPn/CprY5CdKZoC01QwEc/c1BSpYjgaMRmPSeWYOkUmqWY
+nzNlNnqEJ7BLYS0oBeAvBCDEJITaL3ZGRGYtJBYOOpb/SY+3EKg8/+iCPPPoADz14P/efPfu5+++5/
+zeOrR3/Nddf+X1sBlmHGou3FiHD4m6AzAHAUkA14lrSRm6IZTsKmHgL4L0cqNJrzlq6TcHnj8i8tk+
+QHpnQtp7KfqMRNTe2NDcpYo0AHsE3z6YAsznMZ8StF+4bbVz861svPvXXtq9deny4vcHu9h67uyOKW
+c0w9bi6tculywUuc7zjsb/EW8+9kfWxhetTBkGwBiZhxrCcUlASY2Syt8vuzg4TG6lJzJJnV0tGePb
+wTEiMUGY0SfLxoAeZgaStImpY7TqCr0kR+haODWCtC2dO9Xjg7N08cP+9PPzIYzz2xjd97tT9D/4LT
+p75p7jOJRBULOgpVJu+7yL7x20u3H5VNmk3twOJdnSZSbgFkF6p1HvtgO82tfluVnnayT2KMGsQOSx
+BFI/clpNAqoESZAr1FN3dZHb58neEjSt/Y/vZz3+n33qR6d5lUjFC5gXMSsxc6aqBaYbfKuiUcO7Yn
+Zxbu4s128ekmipFJnUAo5QamMaaedWoodW0REjsGcUnmAFjDEOUCcIMocYQ24bT+z9HJGEyg2gTvbJ
+X1ViFdQd3rcCprjBQZX06x12/wAubz+CvfJ7RC59+/OzDjz1+92Ov+7vH7773X9r1E/9Qlld+nbSMq
+B5tMAjGHdm72n6AB1scN25scjOAbk/ez92e0DMI6aVblB9ZC0nbGs/7QFTAz0Dn4PeIwxcZXr34vtE
+LF95fXn3hDW64Q9q6gp2PWKkndDVA9IwrD7PGRTAZlexsNsdblyVWgiXtzWAcyZNlWhZ4qSnwFMkzr
+ucUkwmhKhCUXQNVikzVM6RmTGRKokLwCMFkHJZpSqhCjG0omQHpOGyK9HJhJXesW+VkFjnWSwxSYm0
+1o6NTphvPcLHeZDp6jjvP3fudJ+8+951rJ05+llP242SdT5D3GgMXA9GRxCKmAxgS9gB+B3gT/hj23
+QJ8r02W6dDK+/IXbnYZxIATwVjXqqEK0yvocIPR1qXvn2xc+v5y44WzYesyDHeQ2YQVEwlaMI0zijI
+yKyF4MGLIxDH2iQgcy7ucXT/NcVlC9mrCzpxU1oToKaiYSs1Ua4ahZuQLEjUWx9B6ilgzoaYgMkWpM
+FTtlhL2u6NYB/ijafONHZsCSZuKZxmGnhGOLy9xetWRuznS9ayudxkc72P74OIOxcacYbmB7Ky/QWL
+28cHy2g/btVM/TW/tp2EA0sPQBTVoS0Dtb1iHXXJTWyb/FstO+YpzcWuyZgG+V92wuh9QbA/L+N2kg
+RpRNNU49U2ty5iI8wnFeEJ1+ffft7dx5YcmVy/eY4Zb9OsJy7MZqS4Ifs60mlJrzRSYOYPv9pDkSHN
+lOvW8MJxQAnf2V1npr9IjR7ynqiLldM48VhQ2sMuMnThjr55RSMCTSMzZTCVlrCgIrdUp1AgRQY1tf
+1DznTGmTZtoMtnFgBihK8rqYIn15S494zHGoM4QMsfa8SX6x3p0VnJsR+h3PaudwHo+Z9V1uT7890h
+YP7vM3f+AcOcH6Zz4cczxT+COgeSI2ltgK+z3TfryZfeytEO6hd23AN+rlGVKLdjsQUNKPaIeGQOWi
+EgNWkAsYLrH9Nrz37Fx5fJH0uan36LFBDcZ0asn5NMZZlpAVWI1kfX6zNVQzBOjOlImQ6kZ89ozmwa
+qXh8NJaY/oPbKbFzSKZt4zTIFtmdjZnlgK824Vo8Yqyc4YZ4ikzhjO84plZbqab51gAZ8GhBnm7DRl
+A515f3OtAoaFTHQdZa15WVWTc3yQFm/Y0BvOTK4w+JWLLan5B1YXepyrJuz5BLEGb1sE9KUqpjjdHy
+Pqacfl+78v4Hwo7j06yI9mgbW2WsSNAvwfTUjNRJBUZLIAQD3BWAiYuIMW4+h3Ibh1fuKjed/bHbtu
+e/WvW1s8RzG13RTSV8rnHiSDXgjRHGUoaJMileDOiEGZV6VVHVNSoGRF3LJGKwdww6W2B3P6UWBHK7
+MR2zHgpRnjHxkbGGKMEmBUgIlllFqgCcCLoOyVoxNaFSyrI+v64boNwZSQjGINmqvoOSZspxZus7Qz
+ZTVnqWbFVhJrK320Kyg03EsrfUYDPr084yutdi8C3kXK2NyF8nzHIwlxkis5m+xMvuXRsb/XNz6Dwv
+LlwyDFoCNA1/bPhN64Ae0yH4ZRb1xeg6y/EURMUfUzbQA36tb9DWz29DkcgMJZ1BsKrA6g2obf/2pD
+46e//xPVpvP5VIOOUbAxjEpVKR6TvB1E6isieQcRjIk1oSipJ6XWGdY63aRgbC7MWW4B0Nfs2oyKjX
+43DHLEluTMbP5jE07Z8fOSNFyfb7HOFbQ7zGtE8NQNYm1rcljLYS2sW2336GqPDE0Va7RdGDrNUlJr
+i1HL9RVhSeBRnKTWOrC8Z5yYiVyx3LN8vGM0A3YvMJZQ+YsttODTg42I3OGzAIyBzGIqREzJ8kUTXv
+fLXr8P0bWf1BY/5hhHRgg0kWTQxRS62o4dMLfWF9GzCthqhfge5WCzzZkgAZUTLs0E4aIY474PardF
+x6eXnnqY9X1Z99jhpfpVtvkYYyJFbaqqOuKOpTU0RNRojT0ukk16gPLWYbVxMx7dveG7OzCuICQQd9
+06Ls+UWCzmOKLis3xFrNQE9YMS3ece6q/tvTUkvpn8l7/uc7S8uU/evrpjd/77L//3Vrrg3CSKBAjd
+JY6fPO3fMuJc2fuXo0+3THaG5+ajEZ3b23u3Luzs/fQbDZ7tKrqR0MIxBhxNgOBmBI2h7X1LneuCHc
+szRnIlCUyEgmkQ6fTpbvSxXT6YHLAkuUDxLomKkHmiKkwpkB1SEo7aNjJxdzxM87e+R4IHwT5EmRNf
+bZWrVf0IKVK1dyU4vSKmJcF+F6dvgaDpoSmiDEBZxJCDWEGfkSx+dx7Z9ee/bnx5ae7rthg3VYsDyJ
+pVlHNh2SlI0aPpAhWiQplnYihRjxIEqRWxCsSG4d5tMokwmYJ8+Dp9hMboxEu2904duyO3zr3yFt+5
+/RD937y9EP3ffrYqfXi+PHjdJ2lm/eoysg//p//GV+4fIW92QzyDnjfBGarcseps3zHd/4n2+e/9V3
+bBrkgQDGZsru9x+bmNpevXOPixUv9C89eemJjY+Prr2xe+cZquPHNV7bGpy5kJWeWTnLfqRWOHV9ib
+bkGU2CyRNYdQLcPuYPctO1tFekstd6CACYh1mNsRZI56BzROaqepOY9Iu4zQvYBcL/UuCVsa52apn/
+EgU1oX0aqvbZUztsWfIojSUBMwJg2arHcJY2u4UdXPjG6/PT32XKXVbYxZoKppsx9Ab5ADaTUVBNTb
+cu4ix7s1knbiM9sQDIdirJmo665XldMctDj8ODxR/+/1z382P/+5te98TcffvCxT9197330T6xjVwf
+kq31cblnpdluvvqEeTukeW8esLLF+Yp2uXaGazyhGOzAe0ukf5/S5+7nn3gcwGknRI0mRRwUxOSkoe
++NJsbmx9e92h6N/90dPf+5nXrzwFNe++Om3msnVJ6cu/YdX5913dAtLbTJO33kS20vQyyBzIBaVCHl
+AugZxDjWpkX42gDGISVgCQoVSoalAdEiQvCti/ycj+vXG1O9D+kB2xIbTWwDLvOZVztsWfHPAiWlqW
+VJBtQd7zz1aXnv6l8vtS2/PptfpMselOeiUyk/xddXszXkHnxlCisRQQ1JcVLrR4MURbM64ipTGsVV
+HLk2Va2VOOvXIH77hG5/453edffh/eewvv/PCmROnOLZ8nMzmuF4fBpZKGrwFLfExkAXAC5Um8rVV7
+nrsIY7dcxab7mVvZ4MvffGP2KmewWTLiPRIgPeBbu7Q1BRRIkXE5Kyur7C8tsq5mPj6b3or0/GI7Su
+XPrV3+eKnys0X/l7Yu/rAeLr1nxbl9nfX4+xNK0lZ7hq6YsAl6CSkGyBXou01G45regY2RWEExGI0A
++2ACEkr0DFJLMmF77OM3yh0vxfufWq/M4U0RRPZDwpQFUQSt4MT/jUJvpeLV40iCIaUPKYcwfDFb68
+2nv0Vv/XsOpMXWLMVUo9JZUEIjVoaOzlRwUdIVommsfFcFKQ22EqoS6FMQpUN2IqWra4je+TRf/ime
+9/8j85+3Tf/9j0Pv50Tp45R5nss5V26ptfEkDZNhvCAp6YvOU4S2MYeTbZElvpkp44zOHsX9698E9e
+vPM/m9RE717fodI/h8iUUyPIOPswRgayTN61XmpK8GCBzlmExpjvocu9jb+Khx95ELArKve0L843LP
+1EPr/3E6NqX3jk1o++Jcfw3+n5GT2qyvIasBOMJrkNmsobxwYI6iFlbCrELKQOTY6xBxZNkiEpFJH8
+7uN+RdOa/NuJ+A5Ebgq8PokTV3kB/vlbTmm5Lybcfr+m9J4333ldtXft42r2GLXcZaImLM0hzjFYkj
+fgEPik+WRKCTwmDkIklw2A1EatELAJTn9A7jg3veuihn/26173548cee+u1/pk3YPp3NKU3gdwsE1E
+CYAViVDxNFGSHHEtTidq6DggY5+gsD+jfsU7v5B1kaRmbL4Prg+nT7awgJqMO4AQ6rnPg0E5AUI/Sq
+I8isNJfImGoGrlP3u/T651j6fg5mIw48+Djv11vf+m397Y/83cm1XPvD8Xsbw365VreqxDjUeNJhiY
+bXg0kBykH6YDpgGaNamkMxiTU1CQ8ikGRdav6vyXC+61kn3jpzVNf08B79YJvvwqD9e3yAchQ7SAJJ
+ArYCLZsJzEj0iGmhqdYtQEtrzLa/cxH6tFnf8RMn6ZXX6cfZ0gSfJ0obZ9pp0dpA9YnlufC2qhGxhU
+lV1HXpzJ9rqaMzbpDOThJ/4GHx71TD/3kfW96x0/nayeLwYk7sUsDkgMvTZKgQ8lxbZ/0ANpMglODi
+rRqZ02n1yrIyeJiYnloeHh4kjPXTrF5WgkZdPo5xIKODUg9o2MgaSK0PWj3SQyR5p7d5w6DHDpXjq7
+tDDi2SvI9smOnOH7u8WvzyfWPlNPNH9+bTr4/K/wPZo6V3ul/g8O0Lc48SAVmBq4HdkCswMgAMdrcp
+ImmbTx9guN3ENP9OKyfhGM/CisoPSIdVBwqTXaEIbZpW9I0isEiWJLsZ078yYApC/B9te6C/f/slxv
+j+2GbakEjSZp+JAo4Azq9wGx67aeqyZUP6XwHG0qESJSEswnNlTpUpKT0nMUqkDxBlV43Y7V3jp3xn
+J1xzYQeq2fu4aGH3vrROx/9hh+zZx4eki9DtgydHvsmTRZBTERECAJW0k0exsNhxZJISPIYDMEp3kQ
+K8RR4MitkxmBMw8tHX0NsAsWN2T9iOrg2+6CT/dOZfXLDHqRN7Wt5AuAskvdxA8Pyas7yfLmoJtt/b
+z7d+fl5Wfywq9Z+IDlwRKyNDetJajYTX2Ftv81yaG8KaERN2w5bPRoFMdMfQbIVcB9uokw7RBXMfgG
+q1haUtsOuIK8gFG0h+f5sh6V1lBug0+oqDXOmZr9ymG1CqVTa8KoKp03C53Dvkz/rp1sfCNMX6NSbd
+MIEazyaRbxJBOtxNtANHkJC50qswbgOMe+wOYRa+3ROrnLs9P3/6/GH3vjfZw++/nOcvB/cEtAjkLX
+2C809kWaVByXkiUQi22dJ9cbNoyEhEl4jmc0JTihsZCaeWRbpSEKMtv3VI1U9b8kfMPaw6bS0f00b4
+bKPdTWpfbW5hnqTOBDTgN9gIetBZuj0u8jy8tCWxQ/aNPsVpfi73k/+o8gYxwxjQTUQqXFm0Pye1Ep
+eEsZEwKMSkDRHqUjJIzZ9SIx0IP9bhlZl1X1Hu6EtGdyUtDiQ1LIA39eMUJF547DVjJuFh0pE2x0ds
+RhjMeIhjonVNn4+J3sJbgAAIABJREFU/NlUfOYDzIfk5R7dMKUrFUYitVWCicTocSZh1aNlRNWQXId
+5EPZmJTtylpN3n9u4/9HHf0Duf/SfcOpuyFaBjEnlMZ0ugYjRSKd16DdxlglEiSQEPSKb2kWv+w5m0
+6Y9WRQhWqU2kXmm1B2l20qPFGvQSDkbU/s5KQasNBn3rtmBjli5h6RiPKD19QCeHKE4BAiqaFSMCJn
+t4lxOvrKCWwmYSfY50vi76nj9vwrp6keTyCljSqwJGDJiDIh4DB6MYIySSFiNDfDjtJG2Mm/iZ0U/A
+A6kBWBsxbc1bXpuBGl8s41/cAG+ryFh0qhjIhxGRQtgpM1gO3zKCkANYZs4e+an5uPLH3DheVwqcDq
+lpw1IkiYSihdFxaC+Iq+bWibRdBipY6w5dZ5z7Bu+/Z8eP3P2b8vZe7dZPtYSDTlITt/mBG1URyMGQ
+0JpJFUjftJB5rfZ93UdyaK3R1RqJ225Bm0kurTEIqmGUKOxAgJlNaepyZluTS+puQXlZI58hxslbyO
+Vs0b9pAsonsi+NdntPAQ6Jo8r/4TY+z986v5MiLt/3eoca1oVX6vGpEw1ooLR/VqlCU1jjLUtW1pBi
+IB8ANOpMJ0Po71Gapo2/pNmbjD7W9YipehrNmK7Z7tDjvpAcqiYg8zzxtyKiB+ixYsf8ZMvfShNnqe
+fxmgscVpiUmx6HqREVEXFNZ2AEjgMErvsjj1b04yVux/jode9+f2Tx5/8RKe/3BAMCKlOmJSD67R9G
+A4MLwJKTSTRqJj7nq3GDjOHdSqO/pbUSC2TBJzgIvRsRs/aRnUOnhjqJspGhBBC6+iX/RZINyauSqu
+WS2Pv2S9LZk1HFDnTxp3LQV5e0ERKbeNq0za1dl3IeuSpv23Cyn9Zh+v/Noatj4c4otcFk+qmxIaax
+vYODqKgSUhujN23CdVCjCQVjMs+hMgYWf1RzKBlgATIDtzxr6Vws1en2vlSmdCt8RKOTJEPu6TJc+9
+jfPFHtHge569hIxAFm1rbMQWSCjZZjOSot5jYJ3rLtHSUrsvKubOfPfvGd75Xvu6tn6q7ZxDyFkSCZ
+IlcHfhIrCtsp7VDTaNm7meTpta+6rYK5Q3kkd78O2zj/EuJgeQcz/usZl160RKDPyiqiyg+xTYKxbS
+M4iGQ9i1D3Y/AwbTf/Oj5jtRY0YTRhtiQNpLHqGCMO/CnRwtGOohkYLs4WQGz/gnPyqdSuvpLyvANa
+iqgQJI2dnnqQuo0THQ+B8kgGdCMpAG0CfcTnf8I9uQm3PEJdBW0ByYjteqnvobaW79K2c7OgdUkN/U
+VkNausQYsM2J9/dt98cLHmT6HrTfpM8FUHVJSotQEqcFEUhKcZOTapyoFX+UMx0rJEicefOJXV5/4l
+u/hjvsKasF0+wcY8YBR25wvd1h3ZGGL4MQcQC0QGtuHnMOaMY1E0v2sb23ivg90Z4XMZKznfdZsn34
+URi3wQghoagKkkzSbUkwRZ83BJpUOKIvDQ+b70360sp+mG8GvjQFqjuLUt691laAGSQ5DjrErOFlG6
+HwqRvuOmMI/Smb2V50qIv5Q8pomtlNMTdKExPyAmVWzAzIlMsTK9ONodRmV34CcGDKikYbDIZG/1sB
+3tLDrrRybL9f26o/jEH25CJSXjVAxDqsJlYi0/jNSE6lvAavg8IhuPTqdXviVevw0Hb9BHqeIn4NfJ
+USP63ZJpmY+HZNj6CRHmM4JswHDMcSl05x93dv+fufhN3+YpbtAl6HfZ0X3yZ1WmphmXdZteUHVgJN
+G/TSAbdVKpzn4gHZa8kAEpKmNWbU5bM6AltB1NDaRb36fVpHZ7hBnB9SDQdNUM0aoSmK0iHUETZgYM
+GIx4g7jTTks/qRAaIkd00pc2S9Sqgl8aM7bBLG2z9/o4gkkjEgjuBKkYBBdRWwgz1JRFJP/zMTqp3y
+qPiQpkhEwWjUbjQkELTHSO5BgST2aiqaqmdlkVmzR78VfEbvyjcSVp6CLNU1MbqBC94k2ubWvT1/OH
+6GvbH3eqpnMV7O+bz6GO/rCX5QKxS/3HSQJxtiWSq9bQ1zaSAvIUkLDFuX04i+H0TPrprqG9buYUKK
+1hyAkLFNfoXlJNrD0Uo5MHTY5ikli9eR9LD/wlh/iwdf/BMfOkOwSUfqoQB4OzSkVmqrSbU55Aqy4w
+2jFqNgUW58jkFwjicy+2zkREWJLFhmg26XJWKjnzTMB6nJO9IGUEpkzDLo9+v1uQzKlRF2XWIROp9t
+8NsXGxhJFbNt3r2mNSSA/IPGlrYZtDDhjkI5raf023We/h98NpE2jQps2takJSHGIDIBj9HoPkEL3w
+7HubqFbP56kwEhoik6RwDbBAJKkFbgBbIExU8SCsVO8H6xnaf2Xxa6+w2oPHzKS9dibuiztO+5fMfD
++hOvvZuHzUs1Fb/X5l1rP7uY3vZI6ni91kldaA/Tl3vdy4LOpZTFl/2InEgHBYlSwcUQ5fv4Txe4X3
+h6nF+nGLWycoqEE39gW2IBPJZo8Wcfii0Q9KYhTh1s+zfI9r/ubPPaGX2DtLtT0KVu/nblpBxVpiB9
+7YJHs49K2722/6JEAfm0dx1E9QSMYiyUjxzblKzSBLyDMweYwnzOa7jGtZlCMkXyV2XREVZUQPcZ28
+VWJL+d0yKGqGollLc4KzjTpO40rXKlCxDmLaVVdrNnfxg4k+kFFQLtPc8QDTtSQHS73NhNdm8A5lFV
+EcqzrIaH/E1H6E5Gdn4ddMGPQEpXG79g0+GxYUCMek0rU1DjxBH8FwvG3590Tn8D03mdjF0mCtY2mc
+HQN3gy4l11fXyVpc6v2AEcfH+1S9cey+f44nUn/pJLyZSXby33pVhtCLJGGZDBGMaaCWMP88nvj+NL
+3yeh5OmGbrpnhYgU+NiUK4ghjPZkoSS2pFHb2avykS69zgpNf943fx+lHf5GlY2Ac03bh2YazBBdvs
+o9AVHF6hI61rSonN15lVZAUcAYy0UNLLHn8tKAeTxDvcbEexNnsLWUVX//czviR55979r4gHula+ks
+ZOzs1KZTgIDeJK5cuvPj7//Zfby0hV06vrV9a6fafXhks/RHdzh/QdTP6GS6zoIG8dxxIhNRE/9AWk
+lKagsLuyBc2R5z1+56drC2QpHJoUR4GrPWBHmgXMX2s7f4C2gkq+j8iHpGIamgiXlqXkW0rCxAbkid
+Tj4YRKV0hsf59puM+aczJXzLSBbIb1sefhbZ2Kwy8Ekwc7U71Sr7TV0243OrH/1mrrkY4Qih0G3cCC
+Sgg7T48Hz3zc2lygbzaoisVOYEUEj427B1phI1CRyHFLlUtlJMe3eX7OXnfN/5NHnvHL5Ktg+lRqCB
+isEdyA8qWUbStH1H22Yx4pPx5MgcZ59q+FFoZ3Q+xKfHgmwrXlCVhOGTvyvUnh1evvHu6ufmXs1S/d
+Xt7m0sbm3zu2i6f3Z4RTtxD7+RJlk2grqfU9RSKERvPX+VX/9k/vvu3fi2/u1f5J+4/eSf3nDjJfWf
+Ocufpuzh5+tSn7rr37v83O3Pq/2Z58JvIDKzBSeuwbsPUQsuGtl3jOdobQY644yW2Es82AFL2k2JzI
+jkSwNJBshyxFoL+Yki1A//zog7STlPZU2qMaTYEUgahf3DBslBR+WuUlaU/kJ9jIL+NnPwSVUI63a9
+q836lNt8fR7rdvCG8kk3B/XFVwj9NCfgn35oOJU5DrxsSFXUcYYvnPlbsPdXNi8t0w5CcAgioT8QQC
+Ah9U0MEVxl8mROrHl13huN3v/2HePibfoHeGdTk1NZisY2/jyYoWtQQJR7MYcQ0sfpiGpZyH22tmpm
+SIpaDpiqIgaKCvR2Kay8yvX71yXo0/Gv17u53za5vrs23tqEsMAaK7Q02r1zhwuVNNjTn1PG7yHOwL
+tEfZJw8tcbOtSXqnRFXLj7DKFQci5Bdu4ZdP4k+/yKbS0ssrQzeevyuE289fueJD/VW+sO1Bx75tWM
+nT/2L7Mzp32RlDYwF63DG4Iw9KPLHkQYy0jrkD2NEE6i2Vb1N6wDIGvZVW/85A8juAJ0hqfgFH+Ny0
+v6PO7fX2HmprasdXbMz+W5zXwIiAak3CbGkVNPtuqWPkS//B8T8K649Qf5U7L6vBg+vlKR0f5onOto
+W66vZmV7281oB3QM1LkkTMjWfbnwwbT/7nlC8QF5vYutJo4a2XiJVIRIQmWNqgxQd/NjQc6dYvvdtf
+597/tJP0HuAQrt4m2GBjERGQmJqYxWhk9mWRVQSBm8EPbKhxnbBWtXGPk2KpECal1RlSe+ZC4ONF59
+//+aFp98737j6qJsWZPM5bjpjuZiT+Rok0h9uszyZ0pmUKCVaFxSzEWa0RVVPIFWkOMeIkpnIshVWj
+GBnE2zWxboMZjPme5a94TbF1Rewzq25Zy587513n/3eex58+KnVc/f8EsdPfJyllRm9JXAGZ8CKaWy
+/g4Brc0TNrg9tWFw7n47U0r/Slg5tNJQMslWsnqIO+hPR908489SHNNaEUGJjxHiL+D7UDfhSmhFkQ
+qljqrhLVUbUr7ynt3L8g3TXPnYrhv6l7L8/TcB9JSLmK61ZERE9fENPmgMVr9jV8Oe1W7yikWqQHFV
+DbON3vff3TabDn6z3rrAUx0icIqGEOrZrRA4CSUJdYKocKTNc1aEzOP2rnH3zh1l/CFgi5IelBM1Bn
+ficI+Kuec3YFvjtxn1EUcuATJqQMMqaajRmtLGxMtkd/kD1yT/44Gjj6nKxcY1+PWcZGJQVrvBk85o
+uiUkxwQ3HdMuKbmqOlwOZgLWCMeB9RZgMkQRdJ3TEYuaBPIMlY1jPM1Z6A/KOJe900JiIoaS4fp1r4
+zGTzZ1Hj794+aMnH3jkI8fuf/BjnHAfpefGGHNY0u9A05BDt4Np07hkP5nWNoqpHrg3CandfCwgPch
+Wcd7ja/fhFPRcivVfTfUEao+pM1xtMFUO0VCUFTUTStnCG4iaKKcnOBUe/Mn8xH2/Dlz6arrkyks3C
+UhH1m9HRPbz1dZEZNZO8TERWQMuA7mqPqSqQVU3gHuBu4wxW+3xHgeSqu4A94vIOeAZ4F8BTzXcfDB
+9iaIk5tLk3giaFCeNgh9KxMQmUxPYMeGgO52haRuV7cdNaLsDxcP5kXaBHmiLDcF3JLjpkF1LNz2+l
+bY5dT2WrCEHuuUYW41h5+kf8xc/mevms6juMPVzbL/LbDRkdWUZrSMSPC4lOuEBtvdKtuou6w9+w2f
+v/Pr3fA8n7yfhCVlFB0enVaYEiEZucHd5tP3VYFKiiyG0wcwekKgsKZi6hs3r8NyzuMvPfdhcufTfh
+Ssvrg2KbU7UEHYnyLiiqxmxKvGxxvU6bO/uIcYy3J1TxUYF7HYGhAxkxeHSEK3HGFUGa2cotrcYT3M
+GuaUT5tRqCHUkD4HV6OnOazq1xznX9Fxfyumh2Osj4m5BcfH6sr3/0t9ZfeSRD3Dv6b/HXad+in6Xm
+TFEDF3pNo5t38xKMA3pYWj7zRMRIN/v856aKAfV1IRtsgRmmdQ9g5qa8rnf+p6Ujj8ymY3fsLm9waD
+XJTeGrRcvMBCHqQJhpiR/Apd3yQZLXJt+hs215/O3nH/+x6aD7/7PnTEYYzoGU7VOmxzVgaruNQSuv
+SdBGVLYxshZhzsJbHpiqsget41M34B4nyBnLGwJ0aZUvz4zRGLcc3C/GLmLFDeoqi4hfh1QlfnWrkl
+6j/PhjPH+ReY+ow4PoBIxnU0/nJ6oxA0KsbO57SRZXV9eO3MWZOkLFenasShBRHBN3TbuxfJXCOmhe
+lK8kCRdNJbjucNA/Bz4RMedoI7XmIyfO35icAqs06TPpCC1VXc3JgzB7aImQ+yAyLDhoLUDVC7UjY5
+oxGCzdFCcsa15KSJou9Ua85Uj153N0JiQELC2C+Od77hy4ep3b17axPmKoIlMG1KyLjsMQ6AsC7Lco
+GJIwTMsEv0Td3HnPQ+/l8FagVpM1m0Dec0BvX60n9GhVLOkFKk1YK29octcjtK1ApMZYeM64y899eT
+u5z/7P8Rrl5/ozEbEYooNNeoTqYqkOpJiatVnS/IROl08Qr6ySpzMmAOTqqCbIikFOp2MTsciLhHFo
+5LwyVPWkb4Gsu4ynW63KSPhGqlknSXLWqYwyxCbgRFCiISiwF/bZmazNR2OPnpHFf+L/K6T/+1gde0
+3yZoolBgb+87YW/Wbb6+SafuqmUZsitjW4dIGutqmH3zgdPH5L372vdvb258cj4eUxRT1gfloSCoq4
+rTCNoQoSQXJOkyqimMnT5Fl93z3I39lXnT6/UhmniPEjKRvwNqalPaoyvuAu3HuslFyF/zjpDTHmG1
+SOi11fVdP9Wq79k7XdUUK9V4KfjWG2sTgVVVDDHUmMYCGqD5YXzZpW6rKXrhOMZ3h56WapMdS5ZmOZ
+0wmU3zg3sIntouSwuSDux5+HW/8xm8ql1ZO/EZ/dfmjFvf7+6qTCz7hjA0YlqpUfevGePN1v//7v0t
+ZTCYrvdycOrYyyJOfGV9tHVvqn7xjbd3ygr9gjPFG3FkVc0Vs53nT6R0jH3Sw7vMELcGcwtprOHcRY
+9ZRtaj+ESIRl5/AmCtgLqHplAHBuc+Jyw1GTjIbb2Lci1hzByJdMM+3qFzHmFnecTVFaBLs5tPq4qe
+++JHf/de/zXTzixwbVOQyoyORfidnHxp1rDl2bA0xifFsgnTXeOz0o+/n3td/iv7xJv7QdJA2/lKOE
+A2N3RMPOtCikLB4E4kHCZ+JTBM2CTocM3rxMnuXLv703jNP/e3Js1+iu7vNegwMFOaxRH0T+WJtjg8
+BtRlJEsO6IACzsmQkym5o+ujWAqbTZHGrlKjU+FDgfYlYxWWCNYY86xCtEl3TOdCnSMdYTJaTd7qIQ
+rSdRiUxGc5ajOsgAdJuga+Umek/Yefyf7q77c+wsvL90usgInjTBGwfePn0JjNlP33qSHaFtBRNg8n
+/n7k3DbYsLet8f++whj2decw5a8ya54GiKCiGy9iIeJ3AFrBDxBuBjY3YHd1BBNGhtqKCVyIE2w4pR
+em4tnJF7QtGKyiFRQ1Q85BT5XTy5Dl55n32tNZ6p/thrX3yZIFfbDvo+lJVmZVZO9dez/s+z//5D4p
+IBhozr6L/7c1vP/rYsZ89eeLYZ7vbbYIpML1A5EtuQVTtc60tDdSsg5HxjKz7LMI98lOjo6M00hrOF
+igPSRQHEZzI+wNsnoVYRzcqITCmwBlLCOGg9x7rClpZb48QAZzH2BxnzLjzecnxtVZ4m0WuyEtjZGe
+UNwVFUewUHyLHGUev1xVb3R6Z92Qe1rt9lre7FHHKzOGr2XfkCq49fM3Rq/dd+btj6dgfEcQagK+el
+w5BeCfCcSnFr5iIv3Gp/Nhm1n7Hdx5/uLVw7CVaEiYT3WgF0ZhIE8YbDeZ1uD5NU5K0HmSkJ5SObkr
+qDRrNEeKkdkdpAy6dkpGK45hIxUYIpaWUQkrpXXOiLaUcr76iC0Jp4ijdoyK9JIS6gFRTUquaUPHzC
+FUg2AfqPEqdRspxW1OxQj0rVN30Fxd/+cRjL7H4/CL9rS3W2Mb0V1EyoIQkjlOEVOhYMz4lsd7QTR2
+33HnrH4/uv+VzNOdBjoBPL6PsDmPExM4iePi2lTsDGZdyl4KCgCfBorICujnrz710++rpU7+7dX7hT
+tobNK2hiaRlPEme47XG5AZvJcZKusbjRSAjsNrLaI6NsrzdZ90Flo0hB0KiQQaMzUvwxQ/Iiw4u2wQ
+PA2vZdgHhAgfmZhG1BNFMkTouS0BHFD7graMWSlqAlBod19H1BrLWRKkU52LUagfHKmrgPiJm8/vZM
+/MzshU/GYSgAJLqEBqCGyUN9PIkJMTuG7JESX0IZVczdgOHr8swf/vS55567rH77aB4r3BQBKhzyfJ
+iSJ9vRnV0UOQXJC88sQorf8xIs0WjlqKlItWKZpwKFTy+yBlrNEWqVZmQaw3B2WpPWyJIPlsr52YR8
+N4SfKmDFMKhgkW6HOEtwReltX1wRK40HPbekm4VZM5AYbBFRmYsfR8wSpEkCQeuvY4H3/mDxc33Pfj
+fmZz+JLXRRxEaslDupnQ5muko0riKmyhT/fjo7MTPvvEdb/qHgwenf+bbf//1I8ce/Rar58+i4xpFr
+cb68hL1rI1vtQjNhpC63ABlSYxptEjqtdLXMihFkEgZoYSOyn9WKBVJ35gcF1WYYgjsCUIhVQTIeR/
+EvPG+5CYq/XqPJARCQN4ohEBKGfKJpnCFfzdW011rs/jyacIGuC3F+nqXZnMECBTGImSMFQERSc4ub
+ZKZnMl7r7w4de29H5EHbgBXA1GHSFO4EiIXQ3uTcGmlcRmI5i79u8WW2y1vsReX6J84+xObzx/7/GB
+xUdPeoOYtaZ6T5gW6nyH7A/JIk2cOKSKciihSTRFFdDCsqR5nN7dYaW/TMZaztmANGODoFQOCy8t5W
+wyItNsR8jdHWjQD0O5ybnOdVDgSKSjqDaaSOjJOGEnqJErRiJt4qRAiBhUjiBBOIgpB7ANprFBtgwv
+bBC/u1JF+DDX+AVHXf6SE+se2r5ev0XaSoAShCuUU1crGOMWBa2/njle/iaeePfGR488//0YT8lkP9
+BDEOi5vcRWhnYS4UTF3HFknsH5umbZcpZ7GjNabjKQ1CiVJpCAm0FFtrJLESiC9QwZf3fCqnHllmyB
+FSQn0BQSLV6VjOcGQ5Z2y6ERFIJCOEALO5BhnmcwU/U4Hgiet1ZAqkDlDfW6ewzfczL1vffvTh2+/9
+z8zOfeHWNHbATiUqDSK5cGkh7YYttJXp1FtTc9M/tb0/a969PqDe3/xxcMH3/7M178ed86dI/WBuk6
+p56vUQ04jSKQD7y2R0NRUThISIh1jfSB4RRAaQlxaqcsYJSP6WwOElAhRra2FREiN9RLrPEJEOCHxT
+uACWI+wLuB9IIQgtluaYhDAxQiriLswJiap1SStmREGRRfjyodWBEXfFJjc0+5vMT41w76bH/jYnhv
+uW6M1j80kUuoStQwVMUVUKGfYDfVcGl3QQ1JvICIQY2Frg/bJY/9+7Ylnf9ktrZBsbJEUBZG3+O42R
+a9P6ktl+GDgsSjQMSaKWA+WC9ttzm6us7i5wUp/q1Qf1Jv0k5ioFtMaqaG1pNlImRyt0WsnjDajSnY
+OQQaS5gjWONCKdec5enGJJRkxGafsG5/k4Px+picmGScpleEyAZXiZYStDhgZFErFEJVkNz8wmI22R
+okvqMnWgbhV/5VhV7mDGsrvxRCRVcBJRT8rY5OQUtLXnlpS574HH+Dc2dNri+fOfuziRv6HzTSlk2U
+MQo4WEc0oKm+ioo8WnoZQ1KVkc6MDwVFPUtyIxSR9YgENJWhEGpWm5Q2HRxGIZCjzFSMNkSSvuTIqM
+Bh8MCjp0TgEFu8zorreIS2GapfssFgFRW5YMV36iWfLedZsh2xsgsNHjnDo3vv8/I23f3nP7Xd+kqj
+5eGa99zoi0RWKUIVjiZ22cxch1VftQUyKSMKje/bu/5fzb3nLT16/7+AHTzzx+K3nXzjG5vIyjZkx4
+jghisseXgtNLZLUIkkiA/3+JsILPBohI7xISmsHYUBHNAa2/IKkqiDsCCk11guMBYSlsJA7CM6DlwQ
+fsMZgrGN7JUfJFFdEmEJS5I5+v0fhCmScsr3ZpT3IcTomE9DJAoVw5D7mrlvv//M7HnzbFxpzh0HW8
+VEJBLwyoy9Q5thdgl7lkMS4o/FUeOI8I1tdYvvYS7+x+fSzHzWnz9Bs99HdjMg5grPkvT7O5uRa4YU
+k0zUGzrHZ67JuLBezgjOdLdbyHJOm7D1yN5PTU4xOTy7oVv3RIo2evlh0jy52239W1xJfdAi2TxpBs
+yYIkeZNb3nzHW978I2H6qgj3cWlW+3m5r356tr+fGWVfL3NxSzHdtps6YjECXRaI1UpkYiRKiFEETK
+pIdMaQSlEpCFKStex3BM6GUrrXxYqniDSv7CL6LlzKA278/LlEpdZQ4UQSo1HKMkIBsPcgTne+JY38
+OzTT3zhq1/563fnPnuXoVxTBGtAeyIHkbUEGYhI0DbDGEUaJ8Q6KWdY5xFSILRESolUIIJDCI+S1d5
+SuYqSKPBBE4IjeIFElmEwFXBmiSgGHZywWG+w3uBF6bmTmYIsy7gQOXwck8cJjE9w4IabueaBB5/Yd
+8sdnxNTc1+0spkNkLgoIqZW6ksDeOOJlKRSfJVLdgUkaCy2rHBvSaVG1kZ6RPXf3Xfn2FN7Zvf94qk
+Dz/7A0Wefl/n5fyh9J4MnDo7WUOLvLN4UNKMIHASh8SrCCYVBlR9CBlpxWXTOhfKGDKakJTuBM5X63
+AaC8eAFIiiEC4TC4KwhjQ1xlLDZ6dJez0DEOAKdXkbP9vCJpp05Qk2QIdiyYLSkMT7FHQ++/uNX3XQ
+bVicQJHJXhJz6Hq1UEENx6qXK7HiIBSTBItvbrL700m8vPvrYh83p00z0C2r9gribo205RQovGKiIL
+RzbRYctH7Pe73FqbZWVIseNjhIfPsid1x7h2ltufvi6W27+8+nZ2a/Wm/UX09E6XTPgO0ef5Utf+Qt
+st0NzrlHKdFxB0S/9XGZnZ5981WsffHJ+fIoUgW1vUWy2r+8sr7xl8cTJd507euI13fUt+kJy5uVNa
+i3DRJrScqArNb0TEqEjBiIQi4ASAa80SqqSydC3EHofZWY0RvBzO7jK7uy/nZtuF/F6SLnaxQ91BJI
+o5qZbb+Ud73gnR1889vGjZ868S2jQGrIccuOIiEijmKaskRZAL0fZhGYSM5Y0SQTEzpNqTUPHpBKiA
+FEoV0WR8MRaVvYWrvxgeUzwgeBceSPHlO+B92ALalGK9wWFFxgv8KqMW5PaoKKE9cMNNvoDRuf2cc+
+b3uyveNVr/oqpuU8SNx51suUMcUVEjMpLLQhSASKSVcb4TvGVT0xVaJSvAPbSc8OXfg210Uflodp7r
+mpNvmf6yE0fWnwqvuvCmTNsLS8zJkEnMSFclcyBAAAgAElEQVTLsL0+0gZM3qdZaxAlKbkXFMZhRAC
+VlL22KZBSo2QJa1hX0rAioYgSTadr0FJTjyIy68kLj7UWUxQUucGYrDQosim1KKaXOTJbYELACMHFr
+XVcFBO0ZBA8F/0WI40Jbnngnl+/6f67nk/qjYoU5odr9J3TCMA6uyNIdVTzZygTgbQqldwaT1jZYOm
+xp39j8fFHP+wvnGckK9D9Ab3VDUaiJqGXM8hy9GiTrrCc7G3S1YEzFxZZbm/QlZLpI1dz0wMPdG589
+X2fO3Dt9Q+Nzcy8mDSaCCUr4qgh8QkTUxOM1uvEiUb7jEYsqxcFigzStE69OUrcGsEai05T9NTsi/X
+DV744e/Mtn7pldeP6pbML71+/uPKhTfdY69zSRZYvXmB/HDEmFKmIUPWy+SJK6HqHDh4pBdp54qKag
+YKhaHc/HCdJQRL9wk7xKS6pJLh0Iw6LUEu98wNWSFLKApDUec39b+Q7jz/3/KmHfv/XpdIfa2d9lNB
+oH1OTCZFPCIUiISEmpk5M2veksWeknqJxJLmgJgOJD0R4arEm1WXBae/RIpRWi9ZTeEG9lmC9RcvAe
+KOOsz16nQFRBKY3KLkDwWOtY+B9+d4KSQgxq/UJrr/nJnfLPa9+bOzKI7/D2NQfE9eBhKIIECuScgt
+caktDxf99hSxGD+OCGQYoBlWuz+UwRSZCqABRPSOp/0FzbOrYdRNv+8XaiePvOP/iC9KtrjHIcoTto
+5IYKS2pLpEll5fCTSUjUp1gpMQNeUcyVK0u2ODYmenKFMeKKlQJVqUoX0atEM4TnMd7S5Zn9AeBTmY
+ZeEPH9en6LlEzpe8K2v1NehI26XBw39Xb9735Nb8yd/Veimo1IIYeyhVdYJiYIxW74qKjHacFKirbw
+HeJs4L+saP/fvU7T39UnlqikXXR+QDyjGa9xvb6Nk2RktZHOLvd4RR9ToQBR5dXaK+nXHPzDbz29a/
+tXH//q351/w03/Nb4/n19kTbKT1Be+JW7Q0A4i9aaWEMqBc2aJlGgnEFVB0KsYhCKzCt0VHYZKqpSe
+NM6amz8xX1zc7840+l+ws7v/8j5k6f/3eLL51rrW336W1tMeolIGihlGBlPCHGMiyK8kGUQSoCosJB
+bQipBqI8SRRvAr+y0nvry9WwQl9Y1lxGaK2ArVgJRi9k7fwWvuvd1PPf8sV958fixnwkuHXHWoq1Ai
+5iEGk2Z0hApTRXTKhyicCR9y0gtRgqHNAVaOVIRkXhB7MqbO9YSrQRxJAjBYYVHxR6hS82jMTndgUE
+Fg0wEUZqgRESn36FvHCaKsUAePGmzxfjEOG94948yv2fvX7b2H/oUrfFHEUnJPxIJtUgRnLwkLduxC
+AmXuHpVBZZYZZCXhh5BOShXg6YVpf+WlgJU5Ega/yDGrv+Bw+N73zsxc/j/Wj1+9J7OyVOqXywhVEQ
+kIA5lgQgf0D6UPpBClR6a3uOjMo65TPvxGFdasgt0RU0yeCkonMdYT+HBBI/Fl6RmKTAOCmPoG0dmD
+T1XMGDAIOTkHtqmz4Yt8HGM1hFH7rz+k69+06u3ZCuqhuuww2AZvhFDAEEisZVbyHC5LocKoQCxGTB
+YvPATq8+98MvF8ZcZ2dqm5gryojwxe6aMZu52MgwFy8Hz3OYqz9otsskmDzzwDu5+8LWfufuNr/1E4
+9D+DZIYh8IBxcCSpro8lHxVfKJ0ftaA8oY4glhZlLQlCQmIVUmKhhKy95XaQgZBrASRkjA+Rjw21o8
+nx3/lmmsOf6750sufWHz22Ic3Tl+gv7aKCZJ9I1dgjcdpXybOWtBG4rWqZjGHGOR4IZFS/TJJdA4p/
+qiyGi0d1v4xMnz1fOtyV0F6UKnmjjvu4DUvPbC1cPb8J8n5JYGn5iUTKmUkJNRDTCOuMZo2GJEGYww
+1nVKPEmSwWGfBC5SQKCkJwVZc3kp1HwTOB4x1GJmjQ4SKSx1oVhSlhSGObOBRaUxPeXpBkEkwKqI+O
+cGBI9ebuWuPPMLdD36GevPPiNLKHEpWORWVT6m8dPiEnUWx37WOkbuI1eEVJ1P1tg2Nd1xlShQA7z1
+NX0eON/5ktDZ1brQ18282GnPv2mqeIDt/ns2NDQpnGU01dR2TBo8xhtxYNIFIKbyUeAc2WGwozWFLj
+01QWmMHBdYV5CaQm0BmPcYHcmvJTY7XksJb+tYxcJ5BMGTSkGMx0tHOe3R8To7DC8HeK/Zv3XbvHZ+
+ePTDPoOgRx+muE9nvMqy87Ecr0VKl7fKgREA4T7yxdvu5p57+fOelo0xkBeNFwPZ6ZH6ASWNWum1at
+Ql6ec7KZo9zZsDLuSW96mrueevrn/uJd/yrj8wd2v81OTeBVYGezdE6IUJSS0rGX6hWil6UWsWyQzE
+IFzDBIGTJ4dSq7AZV8ERCElVroyFGVCUPwrC1doGiIUnSqY35RuPnJmZm//z8M8d/6+UnX7hpNeszZ
+sqViNIS6SKcDdjc4JQijkvGjM4KnChRarz9PLX4RSL95BB0eSU3MFQD4fDdU0LgnccF0EJAJLjimkO
+85jWv4qknHv30M99+8hdSGY2NpTXGRY16EVC5QQZLFElCocsxKYkujVBKIOME4qgiwEqc9DtKe+Md3
+nu8EMTelI4GMiBDgfWDkoMqAwNTYHNLoSOyWDHQmtbefVx9y+3M3H7HV9i3/zdpzT2KrjaRjtImvAo
+cDVXtuF2+POEVUpx0p+3cbQ8gLqFWvvryA1wW4iSlwPo6cZCGuPYwe656eGJ05ocm9h/68Mpzz9538
+djRqNfZIgSPEYLUlbptCUhX0sh6Rcn7FxXxWHqFcyWB1psCpUTZngaH8wYfwHmHcxbvCzo5dAcF2wN
+HpwgMgicXhlwYCixWOTwO6z3G5Ry58chnbr3j1r4Qcif55zIj2WFfOUQLRDXzivJze2dLNXjw2H6X9
+lPP/u7y49/WyZkF6gMHm1vYvAuxYLXYpi0lq2bAQAleLnqc2t5m9u7beN37fvT3rnvg3g/tmbnekyq
+8khg8Wqc7i+UhP3Z403qhEGiiSBGpsrgKv4mMLGlNksSQZUCRI60lGn53cpe6YvjHLOcKnIzJVSCdi
+EibI1+7amru1nR0/HOnXzrx0+fbm4zIQCPWNBp1IhlhAtjcErxAxxGJc5Dn5cEgUk2sfxe4i8qx0Iv
+wXQqPIRpTjoeGgEUqXa48coeoaw4d3suRa6/qXzh+4jNy4D5ed566dCS+XIYZk5ObjCIzJEmEEYHtr
+I93BbVU04g1XitCVD5bpQJBeIpQgHMopVBRTNPn5PkAby2I8rvVWuJLoxiKADaqU5uYYHb/oezALbd
+8s3HT7Z9hcuovEIJyviv/TEHLnRHJDf1x5OWrYf/dLQBDPchug/+y7dTDX+SrGVGidnk7ep1UDzUgE
+glx9Jek6epUEn1Uz068c+3kSQbrF+lurJMUBU0FKaXnii0yrBXlg5AKrUuU1BmPMRneFyRpnWA9prJ
+EF2HYJjokju2BKYsv92ROYISgCI6cghzDwGYYAkJJWqOj3HXXPZ+94vA1BASxqjGM4RBhF0S3CzuXF
+YtfVYZMerg07ndZO3f605uPP3WnWrhA2uliO33c5lZF/VJs9npsNxssZT1eOr/CSi/nyL2v5p0/9VM
+fvfOtb/hUfXYajMKJco4IojSgsN6g8gJFBDJCiPJWs0N9mhRILdBSIBOPrgmiNBApyAVIb5DOgC1n2
+FAFyVo8zjtE5Q0hdqhzGqtduejdO+73xbd90I42j144cfY3V7e7DLoKF2laYhQda6zz+OBA6PImDhY
+bAkoIVKTvJIk/jeTnv+vWC+VkP+w6Q/XeREpirUXqmCIYkiCZ37uH++66h1Pffv6z3cW1j7utLkJ4E
+hUTSY1UEVYIamlCVIsRkabwFm8NkRdVEI5ByUCkS/K7FKG8jV35AZRSYCTClN6sURwhYkXhDZ1+Tl8
+qXKNOc89B9t12O5O33/kVDh7+NPXWY2UvL3Gu7IZKFUcJxiBFNaeHXQYiofIdF99TKqB34Jfhzwu/Q
++AIuMrc1SJDQFYWc0bWKuMgURJ0nStULf6GPLD3GxNzY++Mplof3j5z6v7Nl0+lZn2VojBl22AcPli
+ULjmXIZSkYudc6RcpBFIFgrcI5/G2wJoM5xzBBbyxOFvQyx29PGdgAhaFkYo8WAahoOf69MkpkFgvO
+TS/9/evufrIktYxphgGOsqSElWZ+Ow8mF1tJ/7SjFdadDnaS4tvfv7bT3xk/OQZJnJHnBe47S6xD7j
+CsJF36eE4s7nBmcJyMu9z+PbbeOfPfvC9973pLV9U9WY5I8iKSSOGiKsnFpIo1mDkzm5ReHDK4LF4X
+4as6DiiPpqwvd0F4fABIgX1pARhcIY4jncZB5cvRrTL8kIZj44CQSr60oIP1OZazEZHPhWNjy6fee7
+4H2edPpsbW4ggaDabJejlAKGxwZQng1dY4VDKk+jwERq1r5LovxY7raffMQpmt++JVwgpKUwfqSTIF
+GOAEDE9MUci60uW2u8bb3+qplISUUNpiJKUen2M0bT8vSOp0FLiCKV8y/kK8fEEawlWoqPSXMuZQLA
+WZ6AXwAuNI+CERuuY7QIGkSKZnmLq6qsHk9de+3D9jrs+zd4DXyVOGSDpywiJZrxCAkP16vjd7bW4t
+JiSiFewpORlKlp9mUF/lZFty3sDWUZIVhbml2aj4a55KP9RKsYjiLVEJOKrrRuObDYb8c8nmh/Mzml
+YWydstQkGIjTaxWUmXV5QFAZrLCpExHFEpFO2tvsUhSUfZBRZjnEe4z3WOIwpyEwgN5aCgKXcFRYYM
+nIysp2Tp4+lXm9+IU1rdLa2GZ+eKjV41aPyQZWOmsN2c7cL1hCccq5k95qMtQsX/tNLzz3Nvett6kp
+hsgxX5CRpwtLWOgtbK/SmRljudTi+bZm/7Tp++EM//UN3v/ENX9Kt0UtpQOHybCKNJBaU7GF3yftly
+C0NovTlFFoRx5q4FiNUILcDnC/3YrUkRkVx5e1XHjKqaj3V8H/sPThPolKwDqcVSmuGQWvxbJ1xsfe
+Lzvhs7eTCn/UurjPo9kikRkW63I0pRW4zdBpXyU4KIwIukiSR+k8qkn8t1NB24pK4tZQeVc/WCIgkU
+qQYK9nu9Dl/6hwLR0/x2Fe+Nr292fs//cD/VEKdWNXASaxzyDQhrY8SD3rkgz4+BKJ6Sk3rcp8nNQ2
+tkMGhnCSSksiXgiMTFCE3YApMM8F5QzfLwDkSrTA6pjU3w6HbbqTxqvu/wp49n2Zs8nFURBtJLmsMg
+AwYt0NEvjrMhC9HJkLl0you8cu9vDT4+Uuo8PB7v2ypLIBkSBj8R+h7tpLaaGS5wwiyMrJN8LJZWGE
+f5oqZh5uzN75FLV38+Y1jJ1+zeezlmlvZQFnLjc+9TKgn9Gopg7SgW7Nli+kFsTF4Z1CFoDaIKPrQR
+9KNIja0YxtHMThJYQu8gjxWbHjDVihoY2hbT88DkSLoJt88efJvLvzHT37lvte+5aH7X/PGvzp0+Kp
+8vtVlz8wkcSoIhUV4Vy5dhMLLCEO1yxMgXcn9C+dO/cLZR/72ttb6ecZWF2jUWyxsroGucS5zbMcTL
+DTrHF/vcizXTF5zAz/y0z/33vvf8q4vqZExXCX2UwGyaGvHvzoiQdIsB/WozJgsDXAtEo0mRRpPLUh
+qaZ+QrNLoDEh7OSNyjCLvEEdj9PQMfRGTJgEhsqExYKW6jKpTNxqGV5QAVxWmOYTDPZBMpMzcePWXO
+iq8d00Uf2ysw8cFdRlKoKJf0GKblhwtV0kOokaDYiNHNPPbOHzgF5D8hiJAQ4Hw9Is+cT3FESjI6Xe
+atDsZy+sXWVg8x8mTJ/Y8//RTP3r06ed+cv302VvrxnPt9F4iI8m2+sQqoqU0jWCo5X0W4i5JBKMom
+jhaARpB0rSCNJLk3hBisMrhKBDOoPBEKhBLyfb2RWwcYeoRvVYTuX+e5jVX9mq33Pz3+vqbPuXHx/7
+WqKhSbSpqQtCoDhGFKPMy2C06lyXK+r3qRf4vMFDa6VLFrnt3F7qjdETUbH0t3au641H68716892Lz
+x9j6cwZzMwoubAYEZAioHND0R1grCcScRkSqSV5bOnnnn5e0CsyBtaSFzmFMRgcJihyZxmYnH7IyHA
+4IIkkPevwto/JnHrumWfesd3z71i+uMGhw1f9j/Hx+KGD++a+fOXB/b0D81PMTo6iRelPGyqvWudKe
+RpIWNsYefnFF//D+sJ5+hubbNqCXtZjzfTxhSFHs4Vkqb3Kqhuga01e++YHP3rXfXd+sTGSoqLyFho
+iH4KkojL4Sox8qW+RogJMqmyHshFO0aqGVnW0Aik3gT4+DEpARTmCLzA2J/aq8k8Rl+CWoC/np6piV
+2P03byeNIWrrrrqiyNxMrf88unf3G63CTpCpTUIhl6vQKkC4wP9Isd3+6XaIW+xZ6z5Hxhp/Gdq8fa
+QvSDjBlvdAaub6ywuLXHieMHyysWD5y8svGd9a/0nep3t6zeWl1lv9+j0DY2ojgoRtaRGXIuoW0Ejx
+DRkgio0iS/1mlJ6nHRkyNLzpdreogQhlLxMjUTrGOkNWEtuDIyM0LcFPQSN6Wmuvvte5m6/9a+Yn/t
+tRka/7aXaSdQQQlUd4P+85eA/S/Hp6mOo4QS9y/lYiHLnEfB4pQtZq32TvfPfbDQbbzicpv9GjzZfe
+/7JbzUGnQF+UFCTklrQKKvKwBEV2BoMMGi60tKWBd1gyK2HrJwdCxlwXhC0xIlAESwZbgd2zm354IW
+U6KRGXKvTrNeQItDe2HjT8RX1piePr1DXz39j79TIQ1cfPvClwwfm2wcO7GPPngamKjypyiX70umzH
+3vsG98cW3jpGHZ7i0VnYFDQVeC8xUURG3nBBdel0Jrr7rrx9970L/6PTx268RqsKOU2oZp7yvarhqx
+sisSQWLor7EUKv0OGEL7S/YUU6RsoL4hTQ5wURFFGnEJaEyhtCcEipdgxtRVVyAjD2WPn5MyGE8nO6
+R6ErhJgS5g8GZHM7pn+lOm1j6yY/k9ngwzXGyB8YIYWg1xQGMtmv8fWoMfmYJuQRiy018bueu39H5M
+y+fjK6hZbvYyVrU1OnllgYWn56jPnzr63Z/a+N7f5VYiI2vh+0pEcHxLWVzp4sYV1EYVVJHGd0Vqdt
+O9peEVLJtSKiHEUUkoSytnRKUmmAjJSeFmyFIQrXQucKhOelCj3N0EIVqRk7MBBZg7u783fcN3fNW6
+/7dfZv/fv0XGJhleO38Ojr5Ix7hAIwvez+Ia2eWJ3XJO4JMUJDHeDpd1eIj2Mth6OrrtmcMWe2c7Ku
+P/RlTMLbJ04i11t0xhYdAaiACMKullOHjm2hWdbFPQpysAOa4itwWqBEVCIQIEnrzxUdtmrVCOcwAw
+GeBIatYTZiQlGxiZoNG8g67Zpry0/cGqh88D62qnfP3ps6bHx8RN/MDU9/t8OHZhbG2ulzI/UaYZB4
+4knX/jX33z8SczqBZQ15L5yP9MxwQvyvMfi5hbLwJ6r9j/31h/7oQ9dcdMRgixDtSQO43IiNEpopCj
+DkeXueLBdaLMSnhBM1S4ObQk1wkUEG5PGhiQ2aF2QJFCvS5IIlHAVxStUFILSRPiyutu13S7/G7cjB
+g4IvBDoWIGFuBWz79DeDwlv7l04fuamTq9PGicsbbYRGx16eY/17gar3XWWtlbp+Iz0+Cgn2yv/ujU
+986tnL6z22n17w3Zm/+X6eu/HVVI/UJgR6hP7acjS38X5jPXVRVa3umxs9xg4S4ak188IqaKW1onzD
+JV7oqDRSjMWRdX2WiGjCBJJUIJcljtQiox6JEmiMhOjbzJcsIhIoiKNP7CHvXfewewdd36Z/Xs/Q6v
+xHYQEF7BSlmLNIeGimv3F7iFdfB+Lb+hfuds0dvcH8jtlGRG0xOOQRVFQTx4hnXlk5g33f7Z2auFjS
+XP0dZtPH20Mzq2QVC+OwxOkJJeBgXP0Q0HXZaXhrTHYYMgU9KyhXxT0RCDDVlkJ5YLZhdLuQMcxuSm
+t17c3N9jaWKeWJAzyjEbSojVVQ9oBSgac7d+ztNS559z51d959PGnnhodrf3heE3/Pw1RvPelxx9tP
+XdqCd3v4vMes2mEzQtGR0fBCzpZn5XMMLVnmrvf9taPvPrtb/PJ1Dg9a9C6thPWqVS0wzIqCfbye/T
+yHsiro6sA4urULW/NcoYboJRBi6LM5o1A6aFr9CvM/sTlXqdlJTZ3LZJ8dXQNvU9D5b8dEFFEPFb3j
+dGxj3gd/e1WzyB7jni9YHvQYWVzhdXeKhuDLdYGm3RdhktiXri42Jrad7C72S2WonR8fmRkDp1OMju
+zD9Bs2IQ8H9DpbLK5scy5c8c5f+YUnc4WUsB2aLM90BRhCpHUEap0IsidIE4EDSJcGHrrSNAR6IBxh
+pAbkgBaxeg4wYaCbihwUUx9coT65Hj30Nvf8HezV13xa+w/8E3SuFy1VWwuVBXeMgyX8t+DhKK+j8W
+3U/yvFJuKS21pDpgqe7VAIGOBkIZISKxoPdI4fMUv7Ze1drM2+p6t5gn6Z5cYrKzR6/UYCInxUBSGL
+DfkpsA7h8XgsPSFpBMK+nj6oQwo2Z3EQ+U5Yge9yrouZmnxHNZ4Zmb2MDmT4MfGaTVToliSpglWxRi
+ZYAK0B93b2oPt207b/qdD1qHbCfjpq+i2N+isr9KxA7quoNUuVzCZtwShefX9D37mwR/8sa+N7jlAo
+cvtaJlcDtFw82ov6QEvfWK96/AqsccgKsRZlsigji1RYlGJQyJIdFQaIklLEmuSeOguuptZcinJ1Q+
+PAOHB65KzuSNZlEBR2dh7HA6PR3uHiGvM7N/7tX7PfGZpZfPDLzz7EubiKpvtTTb7m+TC4FIQTU1ja
+hLVbFAfn6Q2MY5qRfON5gyNxgzOxOSZZ21thbX2NlvtDdbWl9jcWmZtbQGzdgGybXyw1HTM+HyT+nR
+CcI4iLlCRwQoFqSh9aaTYSRKVPiBdifIGF0jjlBAEnTxnIC22VWfk4BwHbr6G+cMH/zS+587foTXyF
+FqXaySlsKoE2iSXi6hF+F+XCPhPKr5hVK8YBi76sLN/kG4YKlruV4oqxDIiQmpVtYdNI0cbj6ZXjz4
+6Pzb72dG5/f924cnnX7f6zPPNjYXzmFDuzYrc43JbriUEmEgw8NDH0cfRw5GhyAjlMlqU/J7Z+Wmmp
+ma+luXm9ReX1xlkjvbmKu2NDc6efpnxkQ5jI03Gx8eZnZ1lZn6OWrNBiGNarRbpSJPcW/J8QNZtMzq
+1h/1X3sz6hUV67S3WF49iLq6w5gy2yHFopqenOodvv+8TM1deR89FeClLVkxF89A7ySRcXmhi11ch2
+GmgQ3XzhaEZr+4TdB90j0jFNGp10jhBS0sUlfYFWqvv8V0NjW5LHqPE4UPzslM0EHHJe82WDasOl1y
+jmoL6RPSJQnXff271ROv0C89TeEfaqtGaHqMxOUJrZoKxuRnikRGCroFISVyMtbC+tkKv41ld2uT8+
+UWK7jprG6usbyxBvlUC+DXB7IEx5qcmeM2tt27ftO+K/3cklw8tPXPi79r99rJ2zA7jybJQtsZKCax
+z+J5BKkEsA4oIGSS5s7hEE81NM3vtoe78bdd+ffbGa36N+Zl/IB2BuHzeXmg8ijx4nCvpj1oMxyouy
+6T436L4dkaUncK7/Ea0hSOOy+bUIHDBVQi3onCGhqpRmAKlJGrf3kfrU1P/cWZsdK072nx/fOocRx9
+7EhEGBDK8E1gvKKSgB/S1p+ctfSwZkOPISk/qHSLrvgP7/9t7fuzHf+Tw4StrR186+S+OHT/9/nNnl
+968cH5ZdvsZ7c4ZNhdzTp+D1tg4k1Oz1OojpCPjjE5PMTY9h0wSarUacdKildRIhMDbGlNTMHNoP4s
+LZ9lYW6O3vYG1GeP7Z3916vDVGzZOMdUtF1fPKSkRd0zXEzVk1eyZCnSRpXJiZzCLKwv24T7SIvFYB
+tjQQdJDSkkUxWitKUUHsiS+7xC69I7RbbjMkLFSk1f/qRue7jvDYIwkJs8z4qj0R+22l1i6cI7jx17
+ceHnp8V/rydO/NH/jDHEtZXJ2htHpKYyUFEJAHJMHgR0UbHc7FLlgdWmT5cU18oFje6PL+vomorOMk
+I6JkRozh+bZe2CaK686sH7zLdf92ZGrDj90xdz8tw7vu4LNl07z1e1ttpeWvyGK8MMiSKy0ZMZQRxA
+FhcsNIc9K4XMSQSzpmRw/EtPYO83+O2+0h+679b9G1x3+HKO1p0vLCE0QEuMcQVc5vUIi9K6iC7u44
+GL3QfXPh7jof2rTGYZxwzJclmwqBNQjtQN+yF18NUnZi3vjUaqBkx6LtKKePDF2+60fODI7/18G55b
++7WbhH1x8+oVmZ6tLxwuM1Kxsr+EixcBZOi6jR2VgFMr1glQRloAQnkMHr3jkne/6ASbGJgevfeDBP
++l2sz85dux0dPr0ubedOHnq/U8ce+btx4+fiBbPLrHR6bDRuQjGQ22E1vgUoxMztFqjjI9PMDM1C3G
+d7cJS03UipQlxwTWTY1xcvoB3BUoYrMkOfv2Rb9x2eunUUzfeeB1HrrmKvXvmqKsEbwzBOKJmCs4Tc
+JgwQAWPFgkylETzAMgoYmAlKI0SUVkMpoOQEuMKmmkEQmHMAKUkWkOcSGr1qPRWHapFUHgPWpdB1LJ
+KRaJ66XYsDytrA1kRkK0JBOdpdzdZWDzOiy8+rk+eePat65vn3+9s/917r4EknmNkbIxac4yB8XQ6A
+wqnybqWzfYaKxc3ubC4ysZam/Zmu7QkGBSopIbLB0zXNVdecxW33HLD8m133vQnt9554x8evmr/d5o
+jdSIt0dUYOj45xp5985xLjj4SJ+6H6yHFDzxWBApnsXlGZD31OCGSgqCgiBWmmbLntmt7+++8/m/nb
+7vuVzly+FtEYIUlyARdcUu0luyW2Yldxk2XuSMKf8lWAtBCfz+LT0OZsBwAACAASURBVO4C6OR3X8k
+Vy0eLS9KKy0pXVU7TSPLq98tljJyb+VYtTj/xwI//yPIL84984JmH/0Ff+PZ36Pc6yKRGUJCZHoUKZ
+Uiq8NhwSQ3lQ+nVUavVnoiiiFotIY5rjI6NMT42YW699dYvb21tf/l1qyfEyydPv/npp154/wsvHH3
+nyRPnaqvLq9Bfp2N7dJZPQdqg0RhhrDVGo9ZgtD7C9OQMzVqTYiynNdJgZn6MRiPFu5yLFxc+uLm98
+sH8+MbaqZef+dMn5qb/4ODeuUdvue56rjl8iInREZAZOEvh4lICJFRJYneXoGxvIdEjFH6AcwKtU6Q
+MxFGLOB1FiII0rSNVjoo0JbuvVHsMD0Yty1iXIcteCHBWY51ExhBH2U6RImUVVhLobm+y3d7g1Omj6
+cLiyXecWzj2gazYeHNaD+rA5BhC1ksdpWtQmIIts06/71la22Zpqc3S8hbrGz02ltfRSQOfG+j10El
+C1AwcuXqe+bm5hfvvvvu/XnPN1V+45rorn5+fn2Z0cgQdicpzRV6SBkQNmvVxmvHIE9guFBKdg0sCk
+VQI4bG2oGMLRCTQtQQ50eSmN93P3juv+0Lj0PxnmRp5lnjIolQ77BO5SyrmX7ETF2E3HdrvYMPhu0j
+S36dVw3fZSO/OFReXO36JV0C0QVyea7BjixIlPp6dfrIxOf3B21utz4/tm/93anz0nc889i3a5xdLG
+7gKXDGVM/LQor1UYghirZnfu+epVqtFHMc7XLE4UdSbMSOjNSbm6uGuG2/56psfeP1XT718nmeff+n
+BZ5958f3PPPfsu86cOTOy3RlAb5teb4neWrn3iZMmzeYIWseM7m0wOTnJ2HiLOJqjXo+ZnEgBSz2RU
+4TiQ93txQ+9uH6qvXr++S+9MD350L75mW9cd/XVzMzMYNIDpPX6DkkhVEz44QtgHChZYyj+Fq5OsC0
+a0Tyx6BPEFkJb0toE9foqOkqRsgyNNDsuARWNbXgQStCilL04u47SCikdLu+ytrXC8vK55vnFUz+wt
+r70gU5n6w29bItaU7N/dpLmSIPBYMDqxjqD7ja9osfLp86yeH6N7e2C9dWM9Y2MPJMEp6BnsEWAIie
+txdx5+w0vH7n6ii/ed++df3TjTTccn5o7zOzMVBnuWSVeWG8qdU5StpBCQZQwPbqXqdbsU73gifqO2
+GhMVAJDSil8GmGFIY8CphbwNcc9Nx2mcfdNn2a0dtxgCaJE5/WuOOxKo11BguzkMu20mrtjsnc17+H
+7XXy73S3DK6/of6QAd/9V+HKBLQQkHpy85MNTAF4GWlfs/9at81Mfj0brt6/3t/adv7hE3s/QaBxmJ
++bYV6o77yAIQZrUj05MTPWVkJVdXUnKds6XangEYyKFNGJyb4srpvdy1/W3fX3xgaWvv/jSS5w8ffy
++xx9/5H3PvPD0BxeXzmNMBh4Ku83G5jIIRS+vsbVcZ2SsxfbqNKNjLWq1mPGJBs36CM36CIn2mKw76
+oreB86eu/CBhQXbu7D0/F/MTE19ft+1b/ofY2MjjLeaxLpGpMZRjO1wu6X3BEcVTVbmkrh+naLXoL2
++jXAdlhZ7LC4atrZAKEGeS3xQpFGCD+Hy5z/EzN2AYDJULZB1lllcOjW2sPDSD62tnXp/P1u93/suQ
+lqmZmtMyZg4aaCUZqvdZXFxk6XlLfqDghdefpGzZ5dYXytv6iIHBiXpWuk6KkkYa7U4dPB6Xv/gA2u
+ve/C+qw7u38P8/DSjo02sGi3hpgB5btBaInVSuh8gLr2UacTY2Axjo9N9o7eOCt87EoVSHeO9x0ooE
+uhJWHV9VrbX6YQVbgldZurymiA5bquSqg13qu5SjyleEYR2ufHoP3bdhO/zzRfkZWyl3Q57Qrxi9fA
+9UCJZ/fIYiHfxTi1gfcmxyhWkrfTZycP7fj2ZGvm/iygwoKBGhA/msotWUjLbhZDU6/WjY2Nj5e0aP
+EKVLIgkKsvbq5I9P0w3kQHGR2PGxw9y7aGD9Af3PnL3rdc883v/5Xc++HebC2wYhxXVHR2AOCZb79B
+fg/5GnfbKMkktpjnaYHZ6nK2pcQ7sn2ZyrEE9UaSNFm5E0h+0G2tbF378/PLJH3/66GI+PTP+36++8
+tDnrzx09Vdnpw5aFfcp7QgCWmsICmvqmFxRdGFrpWD9fM75hSWeV4ssnF3h9Ol1Tp2FsdU2Dz/83Pv
+m5q//g9vvugPnHPVGRc4OWVV8A5xbY9Dbmt5eXfvhxYVT7zt16vm7tzrnSZOc0TFNrS6QKqI/6OGCo
+b9tWN/YZPFCxulTm7x8ZoWVi1t0Bz0626Wdu1YQm7KbSVSCkopmrcnYSJMH7r2Hn/5X75u64urDDXz
+RQ4nyMCuFHThf2l8oLXa+/1C9R7p6O3WrTjrSgISjVtojTnu8lmTK03OG9aLNUrbF6d4qS7ZLv6l5V
+96lr/wVEo+uIt7kUB1+WZHJaq96qcFUwxMwfPeF879F23k5ZeLy61hcsur/7gV89fdoqKOrwiSrC6k
+0862gOOMNuXf0XX5gc7DNZtEruZvSs5u5WAbUKowrJTfNZvPE3Mxs+QIPBY/Bl0bTrtzkxPjSrirVl
+z6jgyiF0doYN191xR2TiSYtchpF1Rqb8uVI8AgfkWOwnQFbnRyLI04jVhcuMjZWZ3VxhumpJiMjmun
+JJhNTNUbHRhmbaJQyKhuSbLD87hPHTr373KlH3MTI7Ffn5654aP+Bq/5ydn5PHpxCqEl0JBlsxZw7u
+f6+Yy+8+InzL69z8WKPMxcdFy4Etjuj+HyEtYuCL/3pNx5aXOp+4i1vPfWJt7ztwT+opSCUJ7BJ0W3
+vLfLVH93YPPuT2+2Lt1y4eA5vc0bHDXv2TVNLFcFl9Lpdup0+vU5gfX2b4ycv8sKLy5xbyNnahn4Gh
+amCeT3UY0FCSpABrWLiuNRopxq6G+t0NjcIzmOy4o4gwzdiFaMjTSgMMopKBLwM5qms7cMO8dsIqEV
+gmwI/IrBNfyKvDcBAB4P1sFJsc3Z7hVOdiyzQZgDEssF6dxN8OCC8Q8uojKCuXjkpL38fPfKy1zl8r
+/ui2qSpf+aNwz+t+Pylt19cdiL4S9zd6id38+GGp4by5pJLkKgwJlFZaAuB84ZUlgLefNDbu97eoJA
+Op6BT6XEqDyakkAQpwXmEkNRqjTPNZhMlSoUxIlSaMkmky3jHPvmO7AjKYEYtS8UB3rG6sHDT4OI6z
+aK0LweQKiV3noYcxU02Wd/cQKYpmTVsFz18rtjM+mytdVk4tcT4WDkH7t0/xtyeUabnxzh81X4mJkd
+I9AqtCVcJiQfKmrNvP39h6e0Xlr4DSv3Nddff9tDE+OEvx/qK7qmj+W8//a1zH37hmaOcO32WfrfN4
+oVxCFOMt2qMjyiMz1nfXOSr/9/Dh86eO/VQWnd33HTT4U/t2TPynnyw8hPd7YXrev8/e28eZFl213d
++zna3t+XLvaqylt6rW71Uq1d1awGEBwxjjywghmHMIDuMgcByGBs8eBx2yGMTMTM2HhxjkOzANjMsM
+RgBZgsQGgNSIwn13tXd1VXVtee+v/fyrffec878ce/LzKpuCUd4PN0KkREvKpeot9x7fuf8lu8yWKL
+bXWTQ32VqtpSKFwEuy2ltt1hd3GJ9tUOv63j55cv0hpJW27K5k7HdglEOKjBMNCocCef+OE3T9wdGE
+5mALB0yGgwZjQaMRiPae216bsTlSxdZW17h6InjD0Rx5fPjMsHIHGx+SD2ghCOoAmMzAtCOWEhs3eG
+aYCfsteFOn7yfsdTrs5cPWOu3WU53WKdLD8g1BFqxurQMg/SYiRQm8IxGGSqMsLqENLiDscHbnWbqM
+IjkluRTinfLyecPg+VvPr4p0RWHc+rxB1V5IYJUtENLJUc7jqjCghmpIE3Za7fmBqM+1WaNkRG0W32
+w5aknCx0RJwrOthCCIAiWwjBESllAj3A4Z0u2uEdqTZe05FJ5BJ5QF0aYWPC7exgv7mlGFU5OzpLuD
+Rn2U4QvEBAVl7CRS7Q3NKqTv6LC8H8cefs9Toq/vNtpnR72O0hl6e7t0dpJ2d7pcOkaRBU4crxOc6r
+BfSeGLCxMc+zoJNVKiJYBAkGajuin+TdfvvLcN19XN8gHF7l6znLp9T1uXFpjdWmJne01dtNTzM0cp
+RrXccozOVNlPj3O5evPcf3aDf7X/+1/+fif+3OPfvz9T72HxoRDqxZJPGB6VhKGEwzyFbrtAZubfTZ
+X+yxe3uXSG1tcuQQ7m5Bn0NqDYQZBBWanZ5icnfuPR46f+Ln5o0f+wx3Jfd2rVy//++Wlxe/a3d6i3
+RthhynSe2Kj6Q9HVGSITUfs7e1hrb/HAcMyTd0PPJsVR5E0Bal2DJaAEhdbKPlTBVdjKYtysnzE6uo
+2W3mbFbbZJScTGieL589bHXa3ttGOuUiWGFDn9/VUUqB2iAT7pzZRbmkminca24l565Por0JcuhV3M
+QhLzRLvUGMjEqVASJwQ5ELhbYFXbLf3pqYDhYwcw05BXbniCkJ4Xzr6mcPbLg0KNbOqyNddGLBrYoL
+CewiZF7o6Vhe7amwDjBKFjK/N8dLhhGIoc3zg2N1Zv23OpcwkhnDQxgQZg1GfAZJBugdpyAX6zB+7/
+eX7v+cjVzdC9RO91P7E6sVrxzbPX/3u/vrm965vrD60trfJVs+BNYgduL6UEqs2F051OHHMc9eddU4
+en2J2JmKmCRNVmG5W6bfg9bNXWFpc5Nqi4/zlHa5vbrLSWgfbh6CBVnWkrDNXn6GuYDKZZP7Ox9ncW
+eXcyy/xu5tfpOL2+IvfcTuzM22E7ZD3HNuX21zdqXJ9cYerVzdYXGlzY7HP4ir0BmCMIXOG6YVj9vT
+xE585fnzh3915x22/ffr03cOTp47RbNQRnYw/+n3xssr4rqgXY7KQCd8kiCzejNgx2+QRjPp7LC/dQ
+OX5bcpBRQBZjg+H44ofV64cAcTOEXtLb9CnUp0oHKNVHTVznFbl3PpVUtY3r/J74TJeAVagbIzwAmE
+1FZmBcOSjIRutralKs1kIZgRh4RBcME6h9AlRXw2mKfgvhyv7z0W4/Jf8kqJUf7IZWTZq2jxFSAhDi
+KpwNC8pJLlHSchGB7iOahRsBao4PeW+QdXhwtnhyjRHlSh+xFjavGjOxHF8LI5jdLVGDU9NaJwvZpF
+D59lZ7rGXRzx05sHz3/YX/iL5/DRDB7tLG8ujle2fXH7z0k8u3bg2e+76he+6tr32fVt7rcd2d3fp7
+XQYDoe8eQHWl7a4cWWL4wvTHJmvcmQu4MTRCeanpxB5he3tISsrPa5dGbC81KY9SBE+xlRrNJLbmGr
+OUw/qxIkhCD2GiDCcxVrDyaOW9uASb15a49q1GsNhl531RVavbLJ6o8XrK0O2tmBzq7CH9wLmZivMz
+N2ZTs+e/J0773rg380fOf67p06dyo8cOcL0VJPGRIUg0IUO6F7GiRM3zu8ud8jbHruXkfY1Uo8YCk8
+tqjKSRbMryzKstccO0ypECTR/W6apEERRVBiT5IIgKBoyu7vbW6urS+x0NshVCcn0viQdKxwZ1lncC
+IbDIaPRqOkK0We8EwcqUuLds87fkeC7iYh7uC1++O+iFN+xeRWbE0iBiTVS5xjdoO8yonzA0FqGXRj
+0YOSgEYh2oosdTpSOemNFMC0sFouUJVMAhRB2H4blhS/k8Kyb0UJidOEJUNUhQmkyGTD04NqSyiCnF
+iXXZiencI0ZUiRHGzNU7xb4xx5je3tz4/rm4k8v7Wz+9Hprq7m6vPodS1evf9/26ub7r1z9Mq1Wi5X
+ljNXlLaJgi4k6LByBhSMzVKMpdtYkmxsxi4tDNlspQyRBOMVko0mzcpJGtU4sFFoWAsJOCjRVjA6p1
+yTrO2u8dnaNuN6iVt1me7XD5jK0N2AYFUSA6emIqdnj/WPH7/7NE6fu/3cnTp7+7NTMgp87cpx6Y4p
+ms0kYjMm++T5KRmQB1Wr1mkDhnCP1tpDmS0f0bI8hPfbsCD/ssbi4yNbuzkxSqyKDoEAU7LfLvkKmp
+DXWOryXBKEmy4esbyy31zaW8GRUwyJzFbYAxAkh8V6TYbES8mxEno2qztqbrMtK3fp3TQC+K08+50G
+4IiMXzsZ4i5aeJNAEypJoqEpNQkiGI69Z0m7Ods9T07ZXlQ5TMun0GB3si7mOOkS88RSuQXCzB7tWq
+hFHAZVanQmhqMqCIJypEO0gPtKg09ZMJNU17Rx9NySXIYFUBRXMx8wmC0ydmOdeMoY22+22Oz+7sbz
++s1sra9XV1T//keXl5b9y9erVb1peucH29iK9vRXevJJz9compJuQV9BygV43AKoYAiJVoxbNUw2bR
+CpAuCHWZmQ+I88dLhe0O46dHY+zk+zs7PLFL95ASks1grn6BCdOzTBzx5H23Nz8rx+/7c6fO3Hizs/
+NHb2N5vQxKtVJtEkwYbzfKMvzDOsytCzk1kubNpKkumbxpM4zSlMyl+N8TppldO2AvWwAuWZzc5PRa
+NQQquzOGQ0+Rwh1kx/iPhrDg3dF098EApdBng4Y9Ns9QUoFqGpIbSFhIRghUUhVQOl8AMpbJC4uOuk
+HXvE36df/WfB9hZOxBB3afEQ2Ghg7GqCcxUhPJBXOD4gDRSg8TkJQiRANw+pOj4nAp5HICEgLFAxmn
+04gfCFbsd8A8qWr7FjcxxX/uiyPA22oV6rUECSZxXmJMSFGSAZ9x0Slxky10ZImIpGmWAAcKBQLrVB
+SFKYdQcRE0uDo1FHS2/vd0YBf6PeHv7C1sx2tr6/+hc3tpb+ysvbmt1y99LpcWrzGm69fZXsrx7k9Y
+JaECXTSIKomJGqSSmSItMDnpYU2MEhH9PYGbG0N2On0cDJmonqS6ckppudy7r3rju37Tz/66bmpkz8
+3vTD9J41Gg8bENFG1igkSZBABhsz5cfe/uHraoPCF0psohG+F0CSVWguhyF2hJGfTEdYPGdi0ICS5o
+tHVardJ0zQ+cK+9qZ94SxOvtChwbv9zCeGJEkVzKkk7kyF6NKIZF6OIXIIvx1VeOLwez3EzvHVGlCO
+C/fGC//+4Xfk1nXaOZxH+rQ0ai8NmKaNhT9pRH+1yYiWIPQhbOBNpmeEE1KOAOIiQ1jKZKBeSgstQt
+wJgvS3HDmX24YoxhBcl87vEYgkhVKACwiBA9wdQWn0hLFIWEnXGC5T1Q/ojbGSQiS4oVN4ThuqQXY/
+EOYdRGm0UQSOgWoEpBcdPzg/7w/f8Sub6v9If7OqVlWvftnzj+sf++A+/8Jd+97c+z5Vr24QIavUqj
+eYcYaVKGCdEwQCtDHme461gaHP2eh3ae3tsd9qMrMd7S6N5nA9+8CGeeOruR267febFo3OzNBuTiKC
++Lw6MAGc9zolCeFkKsnLxj2FXGlkqr/nSqVUQBNEwy3L6o5R2v0uWDnB2jx5tEClDn0FqabVaDNORy
+qxHK4/NHVp/FWUhIZFS7KujC5EzMVHlxPFZN1iu0VkfMV0R+FDhrMbnisw6BvmQkacAROQp3qbS2xz
+MAbZYiP8fuihfC8H31nDztzRdCtGhUEoXBkbFpjBc0i4nMuBkhpQeHUqaMWjl6RpHM1JSZanFu0ODf
+nnAxBjvu4eEcguq3QEQdao5aZuNCV3Pc+JhirICm4MzEVZqajM1er1dEl1IjRlbbCR5eYNH1hXS8hQ
+2yNJLcMVJJXJ3MGKRECYQqYTqRJLPzE3/5ul73/ObSdxMX33tqlld3aOWxDRqMfVaQlSto1WEFKsIn
+2BTT5p5+r09dtsb9Ifb9OwODk1gakxOz/PQg9+Yvu+pR16caAKqg9AO0gLQ7csY8FIU7lilvfOYh+i
+xBZy4hFspoUrfdUUQhIVIrfeFdLzR5EIXU4Ryqi100XARQlhT8ueULtJODgHy3a1dx3JDdi5HkhMGj
+lpDy0bDwBBy5fHCgpQ4KRiMUpwvMhohi9peFrnrLeNpf8tI/es47RRv94PwJfzOEQQBSSXKGpVE6Sz
+ADPv4HMIIrPAYA9XEUEs0djQicBmR8oH0+WAfn7evfFtKoXAg8SZ8aYBZOhX5EvVtgnCgg7AmS/dcJ
+TU6NIggJpUa1/fY1EKaR1j6lIZjY0NItY9qtkUjXch97wSMBF22GIVCCkXmLLm1COmI4oTmdHM5jM2
+pSlUzORkTKAkiQ3pXdGj9XuE/kEuGfUervUer0yL1O+Rsk+NoVCJmZhs0J2dX4rhgdWXCIRgVkhPuQ
+CO4PKCLsYsYa74ckspDgvM4Uaa5qSfPXNQbjhilOTkCYwKE0Phc7s/UpPeMRiPSNB1kuUUbhfPuEMD
+hoATz4mBDtNYihCqV8SxZ3sfZXhAmOdNTAm8F3ilsLsjSgiAsFEQKbChLIxmZqbdTzxbvnrNPviOv6
+r9CoScL9rtzrqjHrCXQauBdTiUMMEpST1Thg+EhCQXKpTRCzWQlYrZZZbZRqwibg1TkWRmA5UnjRKH
+FaG0ZeGIs++1w3iGEAiXxUrTjSo3cK4TUmDCiWmugg4ikUsO6Yh6mvZqgnxap5bDQUyn454VXRKG/6
+Q+5Ro5Bghn4FOdHeDKkLNgYRhZ2zWEcvrBwfBbr+vT7WzQahuZETCVJUELjc0E6yun19mh1dukN+gz
+SId2sS8aQZjPg+Kk6tYZAB/aFKC5eV8kAhy9ItJKbFJcFoJVEF0rB+9A959x+MEipca6QpVhdXptIR
+zn9NGOYpfSyEb10yJCUgS2A74M0p1avoLVuj2u+fIxsGm9+4hbWi/cHgectUnlq1Yjp6WplomEwxpM
+YT6QzarEj0hnVGOamJBM1qFc0jVqMkG5QKKEfBLgUEv8uOvnekeAT4qvnoUoqhJLk3uGc6zqXY7O8u
+BkelBKEBiItCRWE0hIrT6QELssaNktvfmI/dlySeGThOckBYxlf/L7gBSp0EG4KrZEmIEhqqCBBhTG
+mUiv+jWOQimFvME+vD6lHe3lI23Gs1ywOlK+4BeNa8ujEWOChtEpz1nH82MJvve99j3Dq1CzIPrnbw
++YDbJrS2W2TD0N63ZxWe5et1jrbvQ32GGBRGJmwsHCM6ZmYkycjji8Ev4UowCSisI3cP/GKE2osoJT
+DIaMAX/oXCiEK3Ut54P6Rjzzd7mA+yyzWwcg6Bnla2qod2EEbCXEYoaXaPLj3f4r+ni/YKO6QlqLSj
+iD0jSSBWg2qMVQDSEJHNYZaFep1zUTD0GzEVBJDGOiuKY++cfA53l1f8p16UfW2AG2/D/cRJTYzDMP
+dMAyRCoxUKAmqtKsKjcEoMMITKQiFJe3vTbs0KyDzohjmukMXP983Az1UCYiCjmRlaQRpgmVfmANgk
+mrhU65DVJQgggpBtYpUIb3e4BS7e+Vr6QMW9L7dZqnjViLn3RhLno/tV1RZcxaSgqE0GKWpJcH/ee/
+dJzdPnprC21263XWs7xIYTxgG5KMq3U5Gp9ein25jGaAJiMUkE/UjTDdnmJk0LCxI5uaHn1a6j6eHw
+CCo4USGF7cGXAHBE5Spsh+feGJfmGlcRWWDjN3N3VODQeGjMXIZgzzDygJDK8vucagVlUoFpdTy+Jo
+L+dWXnBfjgU+JzZWFGUwSi+l6TVFvQC1RVCqCJIZKpQi+Rl1Tr2uqNUO9GpGEwS5S3hTo/yWEb7/ma
+j75dk0XX8jcHZ63KW2o1+vbExMTyLRFYAO0A2MkJlZEgUD5jFB6QiGpGEVn1J8bDfrgCgHew3g8dQg
+Tvs9WFjdnw1ZIZBhfVXEFGUUYHRU6MmhMWMU5j6poVNJilNnTg96AOBf7SF0v3Fvhup6SWSHJAenDf
+VrW2BNCjmXbsUg/JFDDmePHEs4GHW4svki7NWSyYVFimtZOznZnk/ZgkwEtCvnYKlLH1KoRlcQwN6u
+Jky36o3O/VPXZfxMGM0AFn0uUtrfsfGOe9sGpJYXCy4PAs9bjfdFAGg1Strd3Tw/6I1Jryy1mHLqFC
+JHNc5RS1Ks1IhNcVWpcFY8Vlt9uEbj9X+43wZ1FSEtg/FycSORIk0rDaMg+CdkpUJEjt4VLUBQbtJH
+bX7nB92cNl6+Yerr9FghESWU9jivk0qB1EXxRpIliQxBZAm+JjSIS0EhC+riFbNgDm6O0vAkbWwR9X
+uIK2S84itpMlsEHYaV6oT45SbaxjcwsKgebK4hibOrQCVQbEzgdnEmHGXG5Y4jcj12kkftLeXy6Kmz
+J5RSl37uzkDtbaIcIifcjhN2j01784V73Oo8+ukCrfTv/z2fPs9u6QKeTUq0cZ9CpszfcwIkO3u/hh
+CUOKkw2a9x9ep57Toc8+LChUt1kdfmLfzGJ/Q9X6+ankRW0CN8m4yvO6XF+JoS6CUDsfclHkID09Dt
+ddrZ2zwwGRcNFK03qJNZ7LA4jZUGUDgImJyYIw/DCzXxU9zaoSsdbUlPAW4u1GUK6hTAQiAgSYVDag
+RdI47ACZCTJRoU6tQkEQrA+Fsa5yar6Jjfir9dRg//KfZiiVyhL8Vu1LJXC+nL2JFTR7NASLSyhURj
+h0DhiExBJfyrr7UE+hKBseZdiHbJEuAh/06xhv9O5byITRq82ZmZoL63A3gAVV3ApOB2Q+2JxRY0GA
+62fHHQHNEYpuAqoAmCe75/fHJLS8GV9JQ/SYO8Q5GglEMKSDzqMeivvWbzx4r+0bpWHH54jTB5mY2u
+RZ7/co9O6xGDUJc+n6bOOEF10YDEG4kgRVTOakzkPnJnjsccrpOkNdttX2N1q/kujJv4oTOLXURM33
+XaBKsEGB8FXSLvIg8ATrrB7do4sT1ldWWdna/vJ4XDIcDhEmgDlMvK8tx+xWkOtVmN+fp5qUnl17Mx
+0kx/0ftXjbi4DxaHupLd4lyOlO6WNgFAgrcUgC689U5zbBIqRKHC7URSitVweP2nJLHtXdTrfseArU
+i3PLcXXWy6Ml4IwjG/EcYVMBwQ+LAwy1Njt1JWdT1v40qmAQKq7RoMejEYQpQU73BYkTbGv+RCpogA
+AIABJREFU/hK+5UX3hfUEiEC/0JiaZhAn5L0RYRiRCY9TpkB6KEUQJ3T6g+M7Ozv3zXd655hrFt1ac
+3PDYjzu8OVRMtab8SWKR2kQwuLzPq2dRbbXz//aXmeRRn3EKN/C+WV00MPEcM/CJLXkGJ5prq/sEVY
+TGtOTTE+eJB8GrCxe5Prys7T27sIyT3MqLwSG2ssI3vy12SPVe4KKw7s5xs7AeHGoDzROMQ+QEM45l
+CpSRetS2u1drl+7dt/29u7x4TBlMBghRPG5rHcYrXEuIwoDZianOHbkKNVq9YXieR1Cy1tOO/n262O
+M7XUO7x1KiruiUOHSAG0NJvDoIECnKZn3OK0JpcUTUK0mhJG5wf4Gwj64gq/3Od9N2Na3QZqPZTaMC
+qhUKleq1SppFKFlisodWhYSgUIUkgtKgHSeQCtCqU7naVrkdM4f+Ao6QLmipym+yuRDgNRhL6rXnw+
+TyqNCddHaEErIlEFLCp86IRmMhrR2O9867HbPRbkFLYq/SV92zcvk2XNw/OKRWpT1ngORF/qYnW1WV
+678qxtXz949N2epVjwvvPIlXnn1DVp7cPwkfN//8N/z4P0f/kJ/aI699Orzp5zM0mMn71g5ceL+F1Y
+Xt5779P/9s5+4ce13o2dfuMLxk6d575nbqdciNtZ2SNOlu6v1o/8qCNUPeDFfSNU73gJq520RWMUFT
+NMh7c4ua2tr39rf65JlGWmaQiD3RzZKKWzmMCakXq8zOTn5fBRFPcqxhWYs3aBuOvXcIQsC5zjolZT
+mMkqp08YYfKiJCREl+yFNDakrRJVH5HgfkFQiVBheKe2a3irJ8vUcfKmEEIHIS2076UDZ8g0plJcYw
+Mkqo2T6YrBwEn/tZaqjPpNpiwSL0Ak2jOk5zcgIKgkEPqeRbZ+WS+cSrl3o89BxkJJeVNzqyIXoVJI
+GpVmjUCgUykOMA+eRzuJ9yiBUn8vvvv3RvSCm1e5SywRhmhMNU/biGdAJQS8jbw8/Mrix/s+j40dgr
+o7MLanyBCpkLP0yppBpVfyYihYBFYYDB5kkSTTLN85+54U3f/Ov1yfbRJMxV9Y2WVp3PP88rC/Ct//
+5v8wHHv/vvvO2k6d/tc0WJ2d2aeo+jfn3kMk72V44TRwOL/3Sp65/evH5F3lhokYQTnDi9pijJx071
+5/jytk/+OsPnTn9Wdn8xKeFq+NJCjsyDY52KT9skNSQGLJ8SKwt3o4QvkKNGV54eYXnFrsf2RIJ7Wy
+dIMgZDrdIyKkJR3fURaEZpJ6w2WTmtuOfs5FEkBMYRZ5l5Kbg8GknitvuKOaruksuhgyVIaSB0TGZ6
+5LLi0kwsXTa9S2IBayyRMZhzAjLHmGWY1QNX2nSiG9n5ugDZLJ20UvPINujYirlri7Ah++aTod8R1/
+9K7i+jAtkqSCO44tJkqSBidBBSBAnJElCHFcITIRSCi1VaREsMEqj8A+TDcCm+8+/70ki8v3BrvSH+
+y5iv9gXUUJSq362UqsT1yqEcYWwkhAkFUyc4AVESUJjahpp9Ad2O+376PZBCLQxhaTdeLrrfIkNdfv
+i3hLFKBuRJAFR4nn5xT8+8ual135+cqrB1NQM7c6Iy5fXef7ZC7R34cyZB3niqff965m56V81kSSKE
+oIgwhgDQYCJQyYmAm677bZffeyxx/51pVrn1Vff4E++9CJr67vgAyq1CWwOZ18/9/OrK+ePONoInY1
+RbuRekDmNJN6vWMc6OEIZEJLdrS6rq6v39fv9D0hZYFaF89TCGpGJEEJRD+pUq1WOHDnGfQ/cz9Tsz
+GeVUiVOU2CMKQcxvrgnkkNqYqqUOlL7521u+1g3elhIhwkNcRLSbNap1RIqlZg4DjGRIUkSqtUqQRy
+RJElqguCiQh1o+Yxr2ndR0feOBZ/jLXPwA4/NQ2lCEIVUqrVXTRjhhUIYgw6KoBOiMLwX3hagaTxae
+mzafcx2d2DUBj/c/5CeFFRhcy39W4f9Qgi8KNOhKP5MUq+2giRBVyJ0kmAqFVQU44xBVRLiRg2nNOu
+t3Y+12i2wviB5HkbtKwFGFWMUMYZshXib41yX5ZVzvHnl2U9nbjtqTlZxVvDa2at88ZlzPPvl4mmef
+vrDFx5/4skfaE7VIQSlo2KGOV5MqtCDWji5wJPve/oHzjz02IX19TbPPPM6L750nrX1PaK4Sa0xQ6c
+zjG6sPvfpwfAysE2WtwslOVFH+zoQo7wpEC9l17nQuRHcuHGDxcXrHxsNh8Um5cRYtIogCBBCUKvVm
+Zqa4vjx4zz00EOtWq32GUqWw1tXQH4YZV8uR40UukTXFGBt5wePKe2JYk1cjWlMVAoScawxYWFZHcY
+RSbWCMYYkSV6lvI/ysBOUeFeVfO9M8N0ceG9VvPbe77cegyCgVmu8bOK4sPnwpoRIFfWcQqBK5TMlP
+Eo6+r3WU53tVRhsAz0UQwrPpBy0f1uUjUCUQ93SGlZJdBT/uqlUEHGCqMSISgyVCFOt4sMQmSTIJKa
+f5z+42+kkfjjEubHmalnMloiCYi0U8zSbeeIoZHn5As8997v/aGSXn5qaMXT6O1y6tMTzz17m7MtF2
+frwmQ/x8KNPf3Rmdr5QeZJ5oaGBwjqKBexSnC/QJHfeeTcf+sZv/eip2+5nawv+5EvneOXlK/R7gnp
+9nonJOTZ3XnlqY+eVf+TcDYKgC+RID4E05MMD52gAlwtwmvZOl4sXriQrKys/2Nvr0u928d4ThiFKG
+YwJqVarVKtVpqdnOXZ8gRMnTvy6EALrCnn6/Xu7P4axRckhDy9Hg9536+1j/R6IwVPaeII4IIwNYQQ
+q8CgDKpSoQKEDgwkiTBChTfgy3iORCHeIuCvkn518b2lyeFl66ZTpjjroCUsTUWtOPp/UpsDEZMJgy
++6hlJIwMEShIdKa2BQP8vSDw84WpB2QA7QYIkixpAdpJrdsuuUfhBB4KcAE6Erll4N6nbBeR1Sq5FG
+MjRNUNUHEAUGzQW1uFhGEtZ1252+1W3vFmWdBOFHIse/DyYoOqMcirKPf3eHNN1/4wOLyy/9QBy1U0
+GNp6Qavnr3E66/32NmG0/few3/1rf/t37jzngfPCRPgpMOKHHyAkmGxoFVhDZX7YkzeaE7zwAOPnXv
+6qW/5G82JSV5/zfLl5y5y5foO3b6nUptFBzssLj/3D7d2X/uAEB1gSDYqHKZiU7x/l5fluAjJB5LrV
+ze4dOnq39rYWq912x12t3cQOOIwwmY5xhimp6ep1Ko0mhOcPHWKI0eP/vL4RCyCz92y6HJgdJDqeIM
+kLIW3MqANooNUow8GgSQIFTpQxXglcJgAwlgT1xJ0FKLCgEq9ThTFz+M91tt9rua7iEP7zgbfPp31r
+av/pmGrLzg6VOuNL9eaU4i4RiZD8nIZSykwRhEbXULNCumHJFRz2ajzKKM2uAGSERJHZn3hYeD9/g7
+8dpvCPus6jD4TNOrng2YDl0TkUUAWB+QSRBQS1+tUpyZRccz2TufH11bWJ7NuVliiydIkJs/BFZpcu
+lQv8S7jueeeSc6ff/bTQdwnqmQMRi02N7d5440lrl8FEygeevCDv3H/g0/+9ERzFq80QhgKGSANsrB
+GLi0A8SIvvA6ihOn5Uzz88Ad++s47HvmNzh68/tomr7x8haXVLlo3WVios7NzmVdf/6NPt/YuJLCHG
+kvLl5msliCFRiDZ3cp58+LS5OrK5o93u12ydIjEkUQxUVRIvhtjqNSqxHFMc2qKe++99/zMzNxntCl
+QB7mzZd13q0qmLaJ9vAK8RHpVBKVrg2s/qtVoLggVJtQIDVKN0JFHBA4dG6JqBWE0XhkmpqaJK7UvI
+03RUBPyJnzn133a+Xap55hrJzgAY1pbcLaS2sRLjekju2FtChdWEabAiokyzSx8yMtdVUISB+SjvW+
+huwODNti0kJPwGntoxufLhkgxEjiMrhmXH5qgVvs3wUQDWa2QxyGuEiNCg4wCbKBQcUhUrZJntra5s
+vGJ9cVV6HPgxVeqtY7TrOFoj6tXXuONc8//Yq+3OTs9WwGRce3aNS5evMHFiyOUgofPfGjz8ce/4Xs
+mp+bxSkPpI2cxxYkkA2wxiKOQTSzx+kJD0uT2Ox/iqff/199zzz13bW5uwzN//BovvXiRlfU9tNREs
+WJx+cLsl5/9zC9urJ9D6UHB6csOBtM2g34bLl1c49xr1z/RaQ9qaZqSjQbUKgnVOMYoQRzHRElIFEU
+0mk3uu+8+Hjjz8L8xUVgO7YtxwbjuEzd12Q7VfmPLMgfCD7D5Ls63v0UqSxBoTBCgAomOHHFFokKJD
+DVhNcHpAK80UzNHdnUUv8T+ehIH91r82cnHzR6yb9cFLY02ZdEKM9UGyeTM58PGNCJpIEODCCTSlLo
+issAcClU8jFHkw+632+4O9DowZjl4c0id/wBgLTw3nYSWwkfAKtBJ9ElTq+7JaoKoJahGlbhWxSQRO
+YJcSiq1Okkck/WGH99d2vimvNWHgTsUyQ68Jx3s0dnZ5oWXPv9Dw3T3IzOzdRqNGp12j5devsBzz2+
+wtAS33XYX3/hNf/67Hnn8ff1qfaJkXGhSK7EEKHWAQMHbW8FZ4AOmpk/w1NPf3H//+7/1u5QMeOlsh
+z959jyvnL3G8mKHuenjJJHm3Lkvf+SNi1/4oe7wGkL00QE4nwMw7Fk2VoZcPr/yTdcurX2830uxmaO
+7t0tgJFp5nLNUa0lhKprEzMzNct/979m7/c47PmmdY5QVxFkp5KG6j30FMz+OOH+wLIQHXA/vWnjX/
+XZBgROVRiINhJEkSgwmlOhQEyQJ6BBhYmoTU58vLOkk3vp9ZgnvQqDnO0MpOvzC/nCna7/KL3oVRpB
+lKeiA6WMLf2CDCn1ZqES7EuSL8OR5yjAbknkHWhHGAaGR7+vsrN5B3gPlwHqiMCoZE2IfMT+eOxzGE
+7r9YTv4QPaIzL8QSYiqxqhaQrVeK+pCDSYJCMOQSlQhRpHu7v3UztKqREjIIB/2S3MKz/rKMl/8/Of
+ufePCCz8TRpDUYhZvrPPqq1d5/rk2F87D9DQ8+eQ3/JMPfeM3f26i2SB3GbKkOykV4q0iyyDP80Ntd
+I8qxRIRAUiwTrKwcBdPvf/Pfe7+B5/6J87C+Yu7nDu3xPK1nL2OZmZqgUo14MrVl37mued/+17LKsg
+Web4L5HR2u3zhj5+XL714/qc67QFbGzsMBiNmmg2UsHibEoWKOA6IooBGo8bc3Bx3n77nX3T7/Z5Si
+sAEN3WTnbVFiedFybIo9eUOS5/LDG9b2HzrDmz3fbIo/pFaIQOBI8X6DBMaknoDKw1htc7CiTuJk8Y
+foCvgBEoeCMwqJf4s+N6263KLpEPhY1VeKKVBKWRS//1gYhIbVBAmAG0QsgBDS63QUYCMIrxRqEgSV
+iTCD7+TwW6B8xS+8PF0tyJa3P57uHXsaAFXQG3+qYyClkxCZBygAo2OA3QcoLRGh5o4jEh0RGDFA6O
+d7qdYb0N/hNYG8pyl61d57ewrvPHqq79WaWh0JOgPc65e3eDF56/z5oVC2Pf++x//0mNPPP0Pji4cJ
+apEqNLk0LuS/+1LnIy3SO9KnNqYpHUw4tABRLHh9jvv4f0f/PA/uOPOO7/UasHZ167z+tltttYE2kw
+yPTtL7tpcX37p164uPotnkzB27O3ucOHCm1y6cOVTm2ubDzgHRsfkuaNRj1HeEgaSiWYVoyXWpcwem
+eV973+qNTM/908r1fgQUcnvk1jlTbo64/csbzbWsT2gA77znUKMSsU0jdAKYWyBYAkUXhU247nXoBJ
+0Uiepzfz+fiGMRPh3K6fhHePz/SnIcun30ymhdLGz1Zvna3MLr/mkjgwiVBQhTFCkmkajkwqqGkOs0
+RVFpaaQYu+7/d4qpK2igD9kqeS/ygU5LHbliu5DR8fBT+g4QEQGHQiCikHFBh9IlNbEcUxiQoyF1ur
+G9y++eflvd9c3QSm6ey1efuVFXn311U922runZ+Ynsc5z7doGL7x0lddfg0EfTp48Mnr0sQ98x4NnH
+qZar+83J6z3+6lTAQworKIPZmf6kAit3BdFcQLmjy7wwQ99M08++Q3fYQI9unChxzOfv8jLL6+ytWG
+pV2eQWrKxdeX0y6/+wSevL72C911efP5P+OIzf/y311dXvr/X77KztclgMKCeNAi0Q4gUE0AlCanWI
+hYWjnLmzIM89sSjP1Ft1jtSqQPTSSkPLCmFKIx0PHg/DpJb2s++hXdbCL/73YIRSsgi+JRHBUX9V3R
+6NUIF5GicCgmixmsyqZ+HALzaDzzBuzPtfMf4fPJPAb0c7g1nAoKkxsT8wm+b+uX7ZRZjjEGZUiZAC
+YgMMg6KeVokiBLBQHXPDPpLH0hGG89QP47wk6W68a2v7/Z3X/E2aBupwXn5z8jU9/hMPGyVRUqFQjN
+yOVaUilxKYr2g096jPWz/5MZgd22O7i9d2bjGl5977qOt9vYPHpmfQZic1s6AS1fWuXhhh70unDjV5
+Mmnv/l7n3j6g6szc3NF3WVBaUNui8G92Mc95nhXdka8Lh7i0NUt5N+K/6cEx0+c4IPf8OHVa9evfu/
+nv/Af//2Fiy2a05cR2vHex26jWm/S6fW4eOmVHxwO/GePza3/2u//zsvfc/7szk9qMcug7+n2d4gCS
+Rw16HevUatG1OtVlPYEQch977mbBx564KXaRP2fjSea42iSZeA55woVcSnK2ytKROchfp8c4fMtvF/
+/AOye0SItwO5SgnI4leJQCKUJdIC3MQxDEBVUUPttZAzW7F+Tgs3gDwLcf90HnzvYCQ/ZiN1cB/r97
+NMKDWFEdXb+16szR35ctCvFridTvHPksjBK1IFChEULWiYjlMhwdvNjjJafwd4GagLBxAHO+u0CkJu
+tgsfq2VICyv69nPT3clkYbQohsSOPlQ4lix3e+eJ02lhbZ+X6+V9Mz4nhSnvtC0sbN35hfnaS2kSNl
+fWrLC1tc+3qDsvLYLTg/vuf+Nmnn/7GX3nve99LY6IGvrRrLv3UnbcF+MoP8aR4nxUB6kUxHxuTT8d
+plixqJ0dGGIa899En2Frf/pWlleWfffHl83/tjfNLCO2ZnJnixG1NZmccmxtv8MrZF3/hmY3X/87rr
++z8zMZSTmymiaMmlaROEifYzBJHiulmjVq9wmg0oN6scccdt3P02OzfQwq8z3He4w+deAV9aoxuyIr
+T2hUzVS98ybP04NpYv4n3Gx9DtNAqwypTsBtUjpBDRFZHSYEyMcNhSOYVQVAljCd+vWCsqFv6CYeyn
+a93ASXBf8LMRcp93SGLxCpDZWLq2cmjx18L4yZSRXhvEDpEGEOuFM4IZKSQiUVGGWEyQunWX/Xp+hH
+SNRAdlBx+hUH/oS5soXhcEoCKh5QSpdRnlFI/JQLwRuCMKCSzAl0Ag73H5ZZBv8/a2hpfevbL/Mbv/
+PavvvDaK2smjuLmzDTdQZ8r19c4+8plzr5+jdEA5o/c/uYjj7zv++99z/3UGtUy6Iqgwkmw43nViCj
+KQWSF6rPzZVEqbybll4tOiXKIo+DI/DEeefR9PPDg49/fmKq8ub414I0Lq7z6yhKbGylRNMH0zDxRF
+MXtdvtnOp0W2zsr7LYXcW4bE6YERhBFCadOHCWKNVk2YGp6gvc+8hAPnLnvp6qTE58Bh5ASIcUBRQl
+3wBmEcrCe3fSGiw2lB+zg/fYRz+5fFbKLNjkmKDCaQlukHqCUwUtF7iTD1JJmAh1WX4uixrNj256b7
+AfehQP2d0/D5dZUvBSv9YfYlQ6BrtaZXVj45Xp9FmUqeGHQQUgUVwiSCEKFiCUyBEyKruTESY7NNn+
+I4SbQRtD9yrZQb2dj7UuJBekJAk0chz8iQ/W8U55cOVSgMUmA1II0T+mXgXf1+jWuL96gN+hTnWgwe
+3QeGRqW1ld5881lzl24wd421KameOKJb/joo48/xbFjx0owcY7NC61Qm5VBpASFwdUAIR2erKz5xP4
+xvX+9nAPlcQwRWKTWIDVHjhzjQx/8Jt772JmPBqFme6vPSy9f5uyr19jc6DLRmOXY0ROcOnU78/OzR
+LECOcCLHsPhDtZlNJtT1KoxlSRkemqCM2ce5EMf+sDzx+6640fQemxyeGiCVwSeFKrIHjzF5xjX9GW
+e4clx9HC2g/OtH/K+hZJDjPFEJsAYhTYCFTqkVGXjRuK9wgQJjebML1eqjXK8I99md3V/Fnz7L/q2i
+IPy7Vi7/6fxWNYKCWFAY2LyF2vVCQITI5TGmJAwqRBEETowyFAVKhHaQiggBuv7H8+yTgIpvrBe/E8
+6mcddxfEJKLQkigOklj/gsLnDg1GYMEBoRZ7n9Ed9NjY3WV1dZZRlHDtxnDvuup24UmG31WJlbY2rV
+xdp7WYkzRoPn3n8bz7yyKOvnbztFLWJGqExCFnyFFWZQI0vSz7A00f68UlyCA10eOPQ5QjGF3WhFgp
+vLbVqg8cff5InnnjstZmZmb+ZpnDt2hoX3rjO1Wsr5JknjitEUcSxo0eZmm4wGLbYba2R2wFaKwIT0
+e12mJyc4MyZMzz5xGP5kbvu+AGUgnRQvE9nb5LoU0Lt19JZNhZtyt8y+3UuxbpBYl3/454hQuZIJRB
+aFcoFZtz8Vihl0CYkiGJqjQmmpqZ/ERUVPixfI1/qE5/4xDuQduoC5CoPuuPyUMXlpS5nb4XTQuA90
+oH1El9rtLZH6cMrvn+6l+wQz3YIKm0ikyN1FVwdTANbNaSVjGGlRx7lkVJyoG34jMCg9GzZeJGkXpB
+7gSu9rCUjsCOEzRAOpC9kY610DEXOUFl80lzt7PWupp32R6elRLRbdLdX6Yz2eG31Gp+/dI4L3T1qd
+9zO9Kk7IaySecHiyhoXr13jxpUbuB4cq8a/9ReefupHvvPDH+au+QUCpxEmJs0FmOKiCJ3jRQoix0t
+FZg2hW6fd2qNPjXpzChFmBPQKx1eZk7kBSkuMC9DESKsQowxlJBWl2DbrrG6tPLu4eP2R9ra/Z9AVB
+O4YWh0jrEwhKgqf9GgPltnY6uJHQ+aqUxxJJqjkOcGs476HTnPmqYeZvfv49+m6+kyqLGkg8TIAYVB
+eoZ1AO4l0IJwtJPyVpS/fRIoIKWr4AchUI6REuXOMss/9XSfOfptUu8W19xLPEKfaePZw3tExQ4gT+
+nmT1c0a1fojvzF37MlPWVtD6hCUR0hbnsLyJnFQ946ne++WtPMrAlzEWx5Syv3H5MyxfzsxPUcQVwr
+Le60h1BAqqBgINcqE6CBG6QStQqSUfxc/mMB3y/QtO9DUPFyUe1EQCUU5fxKy+N6LciAMLrdMTEz8w
+sTExN/PnCN3FhMVttHLa+vsDQYktTozs/M0mlMArK2s8vqrr3Pu7OtkHYgjmGpO/3AtblANq8ioCio
+Gq9AEaK8LZWerkFYjvEEREagqvp/hcomRIUJHjI0mfQb5yGF0AtbQ7aQwUoABk7C33eP8+Wu88OzrY
+KPJk8fv3IwjydraLq+ff50bS4t0ukOcVTQnj3LqztPMHq2jQkOGQ8aa6lSFhRPHufPuuzh1x51/v9J
+o/ELRryxgem8RpZVvxfAq6ngMzrGvbk2+TZ7vTuR28HeldwXGE4UUAVKZQk1NGBwKoysIDN4rJhpTN
+Kdm/q2RIYEOb6YQvTuX9zt78v3nBqMR8oJm8NE03ZzTskMlFqhIgTLFqo4kVBQyUUijQcUoUQ2lTBR
+CfhZ9tAQQKpwvRg/7IwZfCsp7WcwYhCpP6bHaceFHVAkDDOKZYbdba+/uPbW10+Liles8/+p51vf6J
+JNTzJ08gYlDOu1dFm9c5eqlC4xaXZAw15ylYap/TaUIMRIvuH6WiVxQSaoIr/alHIQXYBXeSlzuyXM
+QvR3a7T54TTWZQOoaiBghE6SICi09IRAuJEsFO+tdXn3pDZ555sv84R9+IXnu7Cs/trXa/rTI1ZN5m
+jPo9un1e2QuJfOWI8ePU7AeY/AR/Z6j2xkw0ZzkPQ/czwc//BR3v+fen4wnm/8A4XDC7WuPeu9Ronj
+/N/mSiLINLMFhEFQQXpeSiW2su0JuL//PgpVv8r6FwqK9QYgAUHjvcCWk3ooGo1FIrxdTb9x5dnb23
+h9RqsnhTqfYZ1DfjGzx76KQ1HwNfe3DwsIJqs1jnxz0Fj7p+tuIpA1iVHQnTApRDMaAUgXx1Osy4Wj
+/GM7/X7jd1xBJ2RGsFqcGY1V3PRauvAl5IUqiiwfCkh6jtSZM6j+aq1ZweWX94y9fvMz6Xp/a7BHmb
+jtFc2aenc4Gq6trXLt8lc5aIdwchwmJqiBSVdtd3v2JN8+++eNpK//U4tG1n5u/vn7u2G0niWt16hN
+VVFLcJSEEikKvBlUnlD2814g0hjwqNh4LaR9GGYxGltWVTa5cucaVNy+zdGPxvs3N7Y+1d1s/uL2b1
+ZYXt9DKksRVJpsjttsdLl++gTWS6YWTBGGM1k3mF+6hvSPYFpvUjk1zxyN3c/qhB/6PaKLxo2BJh0N
+UGCDL2b4U/q2LWx40zYpB02SR0guHND3IlshGV+53buXHtOrhshzhBF4U4xyEQhAgVYQS4PM6o1STp
+wGN2vwnA9Mgtx6txjYo4mtiPb/rg2+ffHl4+q0TRHX2U3Fz4X8aitXjqbJIYZHGISoCtCsq81JEUwi
+P9znQBj/6x7iNv4SsI0QB+C1GvxonwIlCAkK+jXWZRJUSCK50ZlRUGhNMHsn/pqhcS9u5+DtUatTmj
+lCbmQcTsrXTYWV5g531bcigUokIZUx/tw/ZgMnpGLuX1Vqr2z+2ubz7YxfPXXmmeXT+P1QnGr83N3/
+03Mz8DPWJBiaJkIFGakWc5vQ7HqSjZVJUp0V/aNnZ7bG2vsva+g6t3S5raxv3ra5sfGu/O/iItfYDo
+/6QdCRQgwq+a+i7AcoqlNAIB8M+7HWGfP7zz3Pv/Q9x2x13E9QSmscGzBw5zqMffD/3v/+xn5RR8qO
+FOJEniCtFs6QMd7CqAAAgAElEQVT0u9CH8JRe3Nxn3G8PZeWGpgfAOrm7zCi7+I+lWyIQe0hhSxn/g
+yGrUBpJBWSAyCdRKKJodrFanfkUhDhfKoB/FTiZe5dVffprIfBu/V4YAbJO1Fz43zO3+s/T0RCpIY4
+sVIKCkqSLG+d8wU4vArCPEIOP2HztexWjn8cUO6uiqCVUKS447m8qcauf+7g+yYqftEIoxeTRY8zfd
+vePNo4u/p1+PMHUseP4MGJ1c5tLl6+ydGOZdJgRmJiZyWm6OwMG3S7Ga/J+ytbKGoOtPVLg/2XvzYM
+sO8/zvt+3nO3uvffsCzBYBhgsFCASkLGQEjeTFBHGiu3EkURWYkk2VYq1REuKTiKpXLTlhFoiS1YiW
++WyltiyRFKiJHCTCHMndhDAYJkZzNbTMz293P2c823545zuGVByySXHBinNnbrV042pRve95z3f973
+v8/weF8X3TZ95/j6VZv9HZ6Z3dmZu9ovNbufJuJkdj7P0FZmo1eWW27q0vj5xNsg066SlpTeZ2uWtr
+enBi2sbN507t3pHWbg3gNxX5AYtNFprBlsDptMpURQxm87Sn1jGgy2SDLrtBluTCSvn15AbE5Jsns7
+MXmZ68yzsqkBX7aVlOruWflhuGza8QEiPFLLaKPgrssFw1QV/BaZYX3Rqu8E2AVZx/vR/L7j4kKSP8
+EUdRSbrrX+lqQv1GdyHiCJvAykzvf0f0tFcvT2OK+XL1WUe5NdMtfy14vtPXf2CAiETos6uD2X2uh+
+YDooDIk6hOQU5BeEIqkqt3RbXCukRopo8uXLlZ6Qo/1Co+DIyQ5IhRIwjqofC1cnB1rvPP/MILytOe
+WFgamDoecg1mix05+nML7K2scbZlQucOnWa8aW1ykyrNG5cko/6NEXMnrklds3OYCcTNjYGmCAoBBi
+lMcFz/rTcp5N4n4j0d6AlPlIIrZhpSfpbA0IQSBEzzQ0hVFuz8WgKKLyDWCcMBiNcaWikGd57GkmCx
+JPOzZConPPDdaTTzPYWyM0lJtMpTnhefvkkcaPLHXfeRdbusbm5yUtnVnny+dMPfdP1Bz4cAc5W/Jx
+GGgESuS0sCY6A2g4jqoFMcieQWwXwGIpiFWdPzXu3+jNajomEqYxG23lhMlRUOwHeawoH1mnGw4Qon
+T09M3PoQ9DBWomSMcFXvk4h/qNGy9eK7887421zG69+FHi0AJ3NELcPfDA3o1/yOiFEmxTlCmlTVTz
+MbV2fkFdScBEEf3lJePWz+O7fIXRBtBCigZJRxVgh4HZSCq5u2lUYCGQEQWI8DKaWC2uDxRdOr/z6W
+n/MwZsOcfbSKufPn+XUmdOMt7YAaDdbRD6nmOZEGpT3aGVxJmc8yMF40Amj6RSnFWNjKI3DSwVSUOB
+rcK8gEpWlKEubaB2Rj0sEEbGOsaWrAE5Bolst4nKCFIJunAKBNAXSQJY1SPUMG8Nz2NLhSkEr66Cyj
+OFoxHj9MmdOnWRufoHdew8jVINzF4d86jOP/fpc1ji0b8/CpUaiUehKsxlsdWiWsgZRXcl+qGmcr7r
+wbbHKZHIGY87/rJYbS42oQAtZAY6pi06Fyg6GxlhBWWqKUpOXTZJ07oNRuhto4J0mSqLqfy/kFV7rn
+yEx+3oqv6/Lbmf4c4AbRpZ18EmE1OmjaZK+y+F2lz5HJ2BFUTUplKgCSepmCaGCEikC+bi4zU3ERa1
+7jxKaVbdQRBWhWSqMLypVxrYaNzicKVBSQtCsbw7IWglnV4d87ON/8gfnLm1e3+jNMzGWV06fYXNzn
+ZdefJawtorINDONBF/kuKIktzlHDu5ld28OP5lUX3cGhKc922a9vw44bDBM7IjcjfHeErBYlzPOc7z
+b1t55nLEU5ZRQGlIliUWgGUlS5YiFYbYV02vFaEoSLO2ZQJYpApY4iplOCzbHA5IkIWs2MKHEllPG0
+yFSRczP72J+bi/exaxeHEb5ZOP1+w8d+bVWo3pNtRA7xlXqcE3na4Mz4JwlOEusJBqJMGucPPFlTp7
+83Pe68vyPtzJLIivDsVRRta2PAFnibI4NEqE7GNNiNIJO65sfW1q6/u+qaL4qvpAglaop15W5+lWzj
+Z0cm6qw5Z/KibhWfP/RDyfyajtJjBQx3olV5/3f9qIkqBIV+4rytb1qCV2lpgaJM6AxiKA598rGO9c
+v5B+bbe9dIZ0Fux1b7BDyivBabHfxts+AUqOShAtrOZ/74pMfeOHUue9WSRsRJWwNBpw9d5pnn3kce
++Yk2fIc33TbUdtOI9nfWGcyHTE/n9HOUqLgiQOkUYSOFIUv2Bz3afRa5C6nKKdsB1XmTMj9GOdLkqi
+B1hIlBTIE8JZYSBqRohEpEulItKedSNIIOg1Nu6HIYs9MNyHuGZqtGB1r4jSj2emxuGs3Nx69ietvO
+Ex/sG63xluSvGBaGoKP6XV30WwuMR0HJsXmgUbW8nt3Lz4SKXAF6EhW81E8Qmp88FgfUEgiJdFSIox
+lstnnpec/xdNPfuau0yce/4iSQ+a6GY0kRoc6FDMClIHIIWOFlwl5nlGaLkrN02nf9X1pY/4FZLc67
+4loZ6tZZQp+jVbpWvH9pw3Zr34GDJXaP0ZUw9cXvAg3BWFuFcqitEfWtDDhq+G4EJVI2TtJsGO21ic
+88aWXeeIrJ97gpum/2t3ba0TcrIp621ERLNZbvLeIUHVARQgMC804hy89/vS9X3r8q/96aqDZnmVSl
+pw6eYKXXniO0Ssvg4b77nv9//Tud7z1HbfdcuO4mSXfLIJPk5ai02wy0+yQKMV0PGaSjzHCY5Vnfdx
+naqdYTIXFl67GJAaUqpQ+Eg++xJkC6Q1ppGjEmkQHOs2UZqrptBMamaLR0MSJR2lPp9tAtRxRlpC1O
+xy64Sbe8Nfu58E3fxv3v/GBrdtfd9sHSjd5+3S0tbU53HqbMR7nI+Zm97Br6RBx1GaYb1JMyzcePHj
+9J+ba8iwVQOCqpJtKFKGlxDuLrPscfqvPKy+8zMN/9KuNrz7xxY9evnRqababsHd5gWYjQ2mFiBRog
+w85QTpElFCWGYN+incLNLN9v9Xu3fGPEC0QGT7E1d6kHtaHYOsZ6X9o5bti2b525vsLyXIqUuw2Nkm
+qFBV3fyKI+fcQJrHzplav1RSsUP2qQkiUCkhpuLxyjrMnz/Lo5y/fduY4v9ZSB/+bW9+0F+JK76bwe
+BxKVYRlXEBIBd6RO3j+5dPJ408d/+3cwszcEkFKRlt9Lq2cZ/2VExAJjt127GPvfPubf+6d3/YAzST
+6p3fedvRXXjx+/Eeee/GJH1h75Vx7cuEyRV7ghEc2EqSWmGLK+tYWnd4MqUyZDIYUZVHhGAIUdoqSA
+i0jtIyQIhCrmHYW0UpjYqVpJDFCBJKGJo4laTOrViY8ndku01jSm1mks7CPIze/joM3HRv2FhZ/Lmr
+onxnn/UHhBpTl9OcGg8mbz13aesfWxTVeeO5Z0nSR/ftvoNVa4OzKOo899uxvzzdvP7TQoSCAMwEVS
+4wx6KgC72LrzIyi5OWnnuWPH/44f/LHn/g164e37dqb4aaKcipxVkMSqrx6ESomqVA4FzMtUkrbJos
+Wy2Z64CdQHfAK79VOvLX31Cd1f1VfWn7Nue9qs9i1le8vtjIikFXYV71SgpB+S2CHAfc2ZwtUrUQRo
+U7iqVqkVe76tODZJ0/x9KNnefaxDS6c7t+CbbTnm72Pzy0uV99QB7xzaFXh87yv1Ca2tKyMNI898dX
+feunUudfPzC7SaHTZ2NjizOnTvPT8V5leXmHPgeWNd7/9Tfc99M63lTceOUirmTE7P1McveXoH1935
+Iafn59b3Gynrf1JnM4TJE5KchxDU2IiiU4TvLcYW6KVJGtkJEmMEoJOK6bTSul1mvQ6LWY6LeZmOsz
+MdOl1OzTbDeI0Jm6lxM2UxmyP9uwMrbkec3t2ceOtxzj2uru4/a7XH7/u1lv+cWt+5m/5KDwsElXIS
+NCd6SCC5MLKpd9bObf2PfmwyDaGEzyC2blZ4laP6WjC2oUL7WbauGl5cf7fxqpi7jgPKlIUhSE4R6R
+jmOacf/Y4n/jwR3n4dz/yT0+eOPc/SA+znSZzcx3mF7p0ZxrEDY9jjNAWYomQKca1MMU8kTpAu3njD
+8XNw3+EnK1VPDF10FI1NxShHg/5GsKlrr5oroqgE9eK7y9cfF7twFB97firXvDwJUJ4g7f+ei1kxUe
+q5f47CDnvGaxu8exTZ3j2sbNcPOMRZZP1C5N7NzfG+fWHDn+uPdeBJAZnCVIS0AQnUFoyHOT8yWMv/
+I8vvHz6R41TdGcWGY7GvPD8cZ7/6jNcfOEZFvct8+1vf9M7/+uH/voLNx05iFQBFwxxEpM1Wswu7jb
+79x38/NEjR3/xhsM3fXH3nr2mMz97KJuZSRuzPbxWjPKc4XCIVppGo0kkI6RUxHGCllNUcCgZSGNNF
+kfEUYXWi2JN0qhy41szM7QXF9h16BCHbr6R/TffxI233bZ1y7G7fnPfkaM/3ty96x/IVvZ5EmFKYdG
+xRmhBGmV0O3OMx2W5cn7t0fXB6Lt8XlBiSVsR3ZnraDWb9Dc2sNPp0dlOb2V2pv14hasJKF0Bg+M4g
+iBYefY4n/zwR/nCw5/80ZUTr/zD3OWkKqKRxbTbCfMLDRZ2tUg6npIBIrYEpTAhw5gekj000hv+KEu
+PfD9yHnyCJ6pOeK/yYzsk9kqP9c8svvB1U3zfkNvOba9RtbW0eCrrjJQRUrZ/QEbmKRVkiqvORUI6I
+MeZkqKYMuyXDDZzcDGzrSbCzDHZnPL0V57+4L//5CPDBzL5z5aOXYeKr6S4Si0opoETJ07f8NjTz/6
+KKT3d3jxFYTh75jwvPPcC506cJGq1efMD933wPe/665++55vuJFBgyylp1qjGym6KoEmWdWktN9i9s
+P/hY6+/9+Giv/m+l8+cfOvZyxfe/PzLxx84f/b0XZdXVis3gvWMB0OKyRiAVKxTFAYhFN1Wh05nhjR
+pk6VtskabKGvR7PaY372bzuwMy/v3Prr7wL7PNDrtTyS95sMMgAjKvCAIi0gEKha42ubjPCwu7eVb7
+n0jq6uDT5fuTz74/MmXfmwwuMjLLz1Bb/Eu9u9aYKY3z4WVSzz62FO/MtPJPnPocO9FpMCG6tyej8e
+ce/5lPv3hj/L5P3z47108dfqDDaGxYonEB9xUMt6y9LdGDEd9MqMgNRgc1gS8VcjQIUl25ane9QPIO
+fAdvKjyZUO4oneoqIRVAKl6tZ7mz9K6XSu+v/DjStRdNVCnCkmRaFDJizK034/J/x/vYvBxlbKDwTl
+DXkxYX+tz/txqDTXTjLYmQMxwY8inPv6pX/QN7IMN9SvzB5YQjQxEpZU8dfI0n/j4p36nYI5ms03Wb
+HBxdYPV1UusrKyAdbzh3ru/8sYH7//xG66/niSW+KCI45SAoMAQqRjrIUoqPguj6ndJZma4qXPs4Rv
+S2x++c+tuRqNBc7y+8U3Tzf6xyVb/xvFm/9B0NN5jjFmQ5enu1tYgCxY1N7vk5ueWpllzpt9sdNbSV
+u981uye6iwsvdBdXnoGpR8ji8ckUJZVYam0eudjmeA0WAwWg0Lhg0AnCTFw7NY7GQxKVi9v/vjFzbV
+v3ZwO7u4PLnH+/AVSpTiw3GNtbYXjx1/g+kPLv9Pp3njrzHxGaT0mzzn5wnE+9ZGP8bnf+4O/u3Hy9
+C/qSQEURCyjvEf6QLCKySRnc3OdxkJMM6vSi0zhCQ6ypEWazL4f2XsRm4KrzdL1TaJC2m/3VARfX6a
+hv4zFJ0bVNkLIeqOR1JniIEMKpL8aVHK3S7LvkaKLzc8TucvErsRcXOHlF5usXZhhOikwE0/iI5Zb8
+1Bq5DNDzpon//nZUUfPPfC6f6aP7IL5FpMLF/jov/k3v/DyK6dvKW+9hyiTXMo3OXHhZV448RQmv8x
+dd99sHnrr/e9554P3MtOJoazU/iDxEjQRpQOlxgQdY4QjtASxjiAofFlFac3Oz9Ob6405eOARoXjEe
+EthSnywBCEo8xGXXvwEXbPKof134GdvZ121CZGj6R0ZTbxImUYOKUs0AeUTdARWGMp4vLMB2+4Iylq
+LEomKFk2ISBPLHcf2c/ny/WxtbL7nsSefP7l2fjN6KvwuStxOt3eMqBd46ZUT/Pbv9W9RvOsX3nDbs
+e/X0zGnnnycL37sY3z1Tz7196YnT/xi25cktcjMxCfZ1ztIK8yRXkxxl2bIxwm5yZnBIwcSVRzCJm/
+ANe//51ty/69qoCk8Qk3xIdk566fR1czVqH7+6UWuDnO6Vnz/f/Q7r3yUyLoBI+p5uJARQqXfi0tvl
+7LxBmwDSQM73mI0sozWJ/jcEYqA8pJIJyQ6whlBpCRnT53kjz9R/uI4jNoPdL/1H/vJkM9+5o+//dH
+Pfun9QUnSvSMKr1lf2+DFp5/m0tlX6M51ef29d3/Xt77tW8/F7aSyOGl21BZSSKLtzreOqlVGCoLzO
+BcIrto/JVFc/3oxzlUgolgpoiitxyyeqUrIG7O0TYlo9FBZl4Zsg7JkOFQZoUQMosJNyKB3On4BUGT
+sRFTvkFJ9/WoGnDEQKZJGytLuDnfeeTtrG8NzIoq+6/Nf+Mpv9C+scKbVJA2eTMesnjvN+ePHyYx9f
++hvfSIui49+/pMf50uf+tSPDi6ufDDTEcoEQjBodJ0EBT4vmQ4dww3NsO+ZjGA4gaZuEiVddNr9otH
+x95Y7IyjJTpz1X4LHN+jKF+3YfMTVbs0aQ159KUHSfC/Sfl5GvRlnpvTHigsXc0aXxqhSk3gIWtOKu
+rSSjNJ5GklK2omY9vs8+9gTH7TCLAxE8cEvPv3Ub5z76suoJKHVeJlps8XJs6c5/eyzdLtt3vaWB3/
+tzW97428evGkJHWp5FGabXQciQYTqvuy8IkhR+d9UHaCJwgePs5YQqlQfESofm0ShZKXOMaUh012ya
+JaUAnQXaBELTUBXYMQ6CksLWXnnRI1FrM9ikUuuOA7E10roQEVxzaUQKA37D+zlgQfvpQzmN8+tnHn
+Ls8+Nvnv99Gm+cu4MmY5x+ZTpeJPpygrTc+d/Iwv+4MvPPPljq2dO/VALiVQagiAmodfuUGpDR7dIZ
+ULw4EeeyaZnMs7IywbNZAGd7tkkW3zvdljnzqolrhXfa92kfdXsZpvTXNlQxI4RNsjsuCB8J6r4vdK
+N2dySnD43ZXpxSlREZE6hgqalYxJAK0UrTVAV0ZXBpTVOPPPcDxWKH2rbmEPtBS5cvszpR75M3My4s
+HGZFMf933bnyb/x7ne879gdN1OGgFIei6nmTsLXQ34JIULUANyrcyIAgvD0tza4cOEi7XabLK2CHoM
+QqCih2UxRCiIZ4S3gEqRPwMYVp7L+1V8FDwrU7oCvmZK6qzg1r0qJuvLF4KocBqEVOpbs27/Esdtu4
+Olnrnvf5NLW/aurq4eLcoLF0yBmVqTYwYBnvvTlpsyna9pZZuMusbco70hURitNyOKUTtaiFzVpxU1
+E6hFFYHw5MB61COyBdA+kB74TZo9LYpQHvQPUlfxleXyDrnxy5/r62rs2VIGOMo7wZCjk7yPt9wUx/
+aXxtM36uqLlW4g0Im8HjNQkokumWuiGot1uU9qcsSkxhSMpPbGOSOM2Ytf17Ern+czzLzHsXyai4Na
+bb+ftf+1b3nPn0RvDbLcy4loqSJDHVnFhQtacegNOoCK90zlyziK8wzvHhdWzfOGLX0CrmE6nQ7vdJ
+Y4atDodFheWmZmZQydxNXP0dcu8XsLUTvHVPQexXX+vWjcq09TXXsDh1WqsKtG6ztRTgiTWCN3ghiM
+HuP++u8Pqky+9Z+PMqScTAomMEd4x32jTUAqz2SdyjkgrkiDQVpDphJlmk1QrvHXMp7M0UHRlglaCQ
+T6h7GtCuYyKb0Rle74Pln8fOgQv0dsKmlf9kNeK77WctO98CFff6eutlUfVsyCJlPyy0uWiihb/d8Q
+CXZWTxJY886BipE9IZEYjaRDHMT4ouiJha9yHYcm0HJN2uhxsL7A7mydTXY6fOsFYGL719ff84Dvuv
+fepvQtNxgZkHHA4rgAL6qP+dgC5EoRtbJ64kk+nooDUHmMnDEcbKO1pdxo0WpJWOyFOBEp7Yg2TwoE
+oa/ZlCcHipa6htG5nZ1A56AxBOISMaqW/qVwZf87rWsWu1ZOx4Ei14sCeZe6755tZf+LEU2unT/zg5
+tbW/9lSEutLVDFBCIW0JR3dQJgSgSMloqVTmjKhnTRIOhFLrR6xDbRUhYDXskXa2suu2WP0Zm79X6H
+3y5YGmgbCS6KrwMqvis29VnyvzZwvAG4HzhxePUmtJUc2VJKyBEGSLPxkp7n79m5733ui/BTTcYnMK
+6ye8IJYC9JEYcsxG/1N5udnaSmNDBJJRDMkxCEmNyWvO3iYxUaDsTR/eMvu3R9ajBOkhcQanA/oVNU
+6iiqa2AeB8PXXZKU/tNZWmQNa4pxFKsmufcvcfuctXLp0iV5vlsXFRXrdWZKkiVACE6Z4U+JlIOgcX
+F75F+WEIDv1lKtEygiEJghHwBBQtc3H4TEEPb6y5d3Zpm7fKGqynAJjApSOEDyCgHKOXpZx683Xs2/
+3wofsePTmRIW3K2IyKQhFTlckNGoXSUZEJ0lpRzGZjOkmDWa7PTpJRKI9LSkJ2jM7O8Oe6+5iz4G7f
+0cke34yJ8LVISq6ErOC8wQpEDWc+FX3i2/QM+A3ZPEFcTUtwFWev+Drs15FHAtU71nFAtEI1RLtZO5
+f9hqL72kkW1glsDqQZS2CV7SyKk+837fMdJtEKuBLQyNtEmuBH+fkY0PwgtKVHF5cxGbqY/RHnH3qW
+Q6Lo8TLXdARFGFHyOsFuCBqvkmVXamErnDqtdbCuoBQ0OvOcOOtRzlUXo+UVRc2jpNKEhckcZwQ6Yh
+BvglRgVAlaAPaEESoBOfCsY14qP6I6qMItY87YITZwdTInSK8khZkCk+UVt1VLXSF5Chyhpc3WD1zl
+ueee5rxpI/S7mPCh7drBJQez4RW3CYLklglZAjaMmY2bdJptGjoGDEpkcGTKEVa13u32WXv7uugd/h
+fYmJhIxHc9tAgVO8xwRIQVQMpfOMX3jds8W3T4bab5UpsJ5xUhx3rDEFERLIWljkBpQvjtdF9o7URc
+piTyJgkk0Rao6Um+JxBf4qSEik8ZZHTzFKEs0QiRiqFdxJPIDjLeLCJ9sn/Nb44/bZnPjv+wOba2lc
+PH7uR3vICemm+0iZGgjpMh6CrwBdb7wyTONqZtUVxmxAMFk+vt4y1ZRUGKarsh8pQrBBIXAjotCJDu
++BrIphgW1Zs8CQIgqiARdXaK/FB44WtBwox4NAEfI2d10rWoSugoqiiZVtPaQxmPOLC2Vf4yhc/xxO
+PPcpnPvGpW6ej6U+5snio+u4RGsGs7NKQkqj0zGUtmlLRkBEdFdMUikxKmlkDbQsaqSSRgSiOcJMJ0
+7MXyUb+PmLx+9ujuh3mSrAgPEJUcncp1Dd84X3jrnxXSV3kqyJN62y6SGO2GzEehHG49a3rB6tr7wt
+bY9IoxkkHSLSWFRHC1Yk6UkKIdy54WW8XvQuVodU5nHdgJGZsKHMesoP+Q3Yy/ZnR2uY/StrtrSPHb
+mHx4AHY16pWwClMhIeGpAafVabPegWvBOLxVSL8KgY6IPChXtmvijcugsUEgduGPHmJU3WAJhkhVNH
+RQUe1jSZCBoEXMRJwxDsCoUhYnC/xtqJIl8ZjvUZJjbWei+fP8/gXv8BnP/0Jnnr0i72L58/9hED9S
+JHnSOdRIiVSglQqUimJgYaSNISgFcV0opi5dptGHKGEJMYTR5JECaR0SFXtWszWiGxt8300s/9bxbz
+s1JVgk+09chAe93Xjxvur3HB5FRPr6r9fsZN4AgkCjBXDldV3bL5yRoitMVmkCVrVYKUauSPrTHexH
+aioELV41ztwweOExdeQCWs9zkFuDZMyZ7i++SPr5y59T9DRP1k7c+lDh4/eOLnujqM0980jZmKaXYm
+ThpySlGZdSPUY8KqObZAgRXTVKEDtQLy2bzzexRBiJA0QKXiNldRhKhLh69m+Ay8rUbivx3/oajIa3
+DbIWVdzSVmxPtMQGE1Lnnn2eZ588mmee/opnnv8scbLzz71D6bjwf+cSTrBKwSeGE0qNZmKaHhFS0U
+0hGK+3aCrU5pS0U5juo2YRpSAt4gAWaxJYk3AoyKJloJicwPOrwj27H5H4vj5oHZSxF41D/Ffh5kLf
+7W2nfV2Tb5Kx+d3znq2fpOEr+VdRZ5MVi8dzVcvzjXKnFhHV2BMoQqZ9FTbGikCvj4/BukrQhcgpEN
+XzVPiSID1eGvxJsdOppSTknJcdpyQP315de2HL54/9wunz7z4S/NHli4s3bjM0k2LpPMpUhYgFisWp
+VTgVXUnD7U/zV81+5NXwk/U1f0kkSCICV6D11VE2HbM2tUJRRK8kCh5BWQSqDSTwdSNqpBDKMGVbKx
+f5vS5C3zuK4/z5S8/xZcfe3zX5qXL3xem0+/35bCXAJGsUjcTUlpRSlvFZF7SEJqGUnRUxHK3R0trY
+g+JEMQyEElLEB4pBFF9RPBSEJREKUE56JOfOz2X3nLkqGx3kxhyBzUfpj4s/+VpdH5jr3zbBXhltZM
+7e7lqmxYqu633MBzvyS9ffC/9LbrOEym/U3zOORSeIEQNSAoVk0RUhelCteohAjKqCq8IlaNdElAhE
+EyVCe8nE4yHcZH3htOND5xefe4D/jHzL3oHm7929J4b/v3tf+0W9hxeBj0EkVRPFVORliNkqLDvOJB
+U2IsrAKkq09o7V3M2RW1UrVYCvTPkNGBrXikGIad1vrUGaYlCDqEHlOBGUPTxeZ+Lqys88vkv8IlHP
+sfnvvzMfZc2p989GJj3SXQ1La1faWsDs8S0dZNO0iAJksh5WlIzGzeYSVI6cUwnTolw6BCq11tWabp
+KKZSXlQFWK7yO8ALMaMBk5SzppfPvZfVX5S0AACAASURBVD79J5rohKcSpm+Ha1a3QXut+L4uDn3bs
+7N6K1J196qEHomsLsjphMml1b8/vnhZJnlBSnUnrjieAYUlyFDL1KphuNQRPkisr7EE3mNDdecOQlC
+OC6zJcQRwDucsRTGltFB6S+Es07UNpusD8qj/vt4wel/aPf/k0u6t3+o0Dv52b37hhFApRA3QTRAdK
+hZJC0hROgF0JZUL/qo9p0Xi0DTRuDpQ0lVFJRICFilzoGLcICZIOa32mEFCKMBPYHqeUAwxky3K8Tr
+DrTXOnDt93cvPf+5vPPf0U39r/TJ3GF9BsIO1FMESI4lJaTUa9CaBjmrQlQ0iD7H29OKUhaxFL0nRP
+pAoyOKYWAh0tN0cE2gNDdmgjAQiq3I1pIqQZU6xcQnOn5YcmP37JO0flFETJwTCKZTabqdpvr4AgH8
+Vi09ckU1eLV/3XOVUDuBG40OXzq0cmmxcVqmHjhB44eviq3LhJKCkrs93onZMCEQQeCGxwhCCw3tbU
+a2LHFeWWOkw1lGaCYU1dTRcQATLJN+iVH26PTiwO2PPLHckdvWO8aXJB2Xc/IJSyce0bj0sVPdRrWc
+QqodQMwjZAtWugjG3CcxCbOeVIbCEoIEcRQF+CmZYEfdUDnZcubxxYIe4coswzTHTkrwckTMkv3SKf
+NzHTvt3+aL/1vGo/4619fV7YnmB66+DzSms9WFaVq9xJGNSH6NkhHGKGRLaMqMlEiIZaOqI+VaTuax
+BpgQ6OGIpiIVAKo/Scmf11rEgFilWemSaISKNlBBLiZsMyVdOq3Sw/xANechHyakg9I5hlr80ZfcN3
+3DhyqD4yj70VYEYhEAxmswMNta/vRhPmBGCTCsmZVHTAB34ahsXCQg+YEPAW0+okxyFEFWR1zh0hyO
+SgpJtZF9OnueUxiB0hNAKpav7s04li4sN9u+aYdd8g3bmScSU8Xj1HimSe1Ctn5aic1HquUe0mvm8i
+kZfEar3hNbjSSAl7HBnFLrWVzlvMDatVl5bQD6EsMFA5IgoJ7Mjys0xzhsmfoNxvkq+tcVoa9jYGq/
+fOXabd6v+iXvLyfD+RNqlRuSZjIas90cEH9i9nHBwVGDPwKSoFsxEJ8QhQRMTxwkdH9PUGamISJWgE
+yf0Gm2acYz2hkxFaFnZo4K3SKXQuiKNy0jhS4/1vsL1I7CuMsD6PGe0uUY6Hny7K9o/RSucEuJKNPd
+2k+pa8b2WD2MhhlxAiSRBkriKk6sFFDEYB9p6wvrgR5PVTblsPc0ENtYuEssmWmucUlgnyEuPk55UR
+TSFrhiYoUCEymbqlKWILQOfM7QFZXtEbidELsKNHfHQ0kTTV5Zhq+RyvIndPWXXkZT2zU26Bxxzu9Z
+ZSjZoTQ39eBcwwoUBQqwsRVH0HVEUfUd1BvXoqHHcWY5L3XhJiuQV79S5INKLSiWXcaHvB+fHifXl0
+AY/GH1J+qDivAzNydR0TennN/qjJVO6vcPh6GC/3z9SFMVNwYubiqJgmo/Joo3qeAzEcYVfdLaN8Io
+ZmbBPXCSJA3MKhjlIMySLNFmakkQtjgymRJHEZBLbUESdmBCD9o45H9EKAu0VIY4pYgiRIsQRSipcg
+LxxHh81KLUHnyBKyYzz9LKI0eo67sQpqeaXflSF6G8aD6qeiygzpKEMQcxcK77XtNvCq+Bwr/pvzlX
+HQZfndxeDwUEzyVGlwTpLrOrcu51/X1mhvajOdYSAweFDRafWWqJCwBcG70oiAsPcMp1YnI8QcUzUi
+7DBYooBuR/S7Dhm9qUcuq7H4f0ddi/HtNsgoup7OlvNGEIAX+stfbB477HGMw7jm6zhJoGGEFOWjuC
+r2V1ZWkajAQ5BPrVMpiXWVVrWae4Zj3JWL22wtTmkMJY0TQHJeDzGW0eSJIzqOWMcQ9Z0RFFlYxJUO
+InDN+xjbsHS7m5x4sSEyxvgzSaNVoP2TBc/SBCNhFYzQzdisigmEwKpJGQJ1lXAXKkFiZIgBUorZL1
+6i5rPKWsBgQ+WMjiEFZTGs7W2Rm9r66BaMHdLGX0l1PmWqKhq54ZrK9/XQfFJoquHrpIqn0FV/UMzG
+e8era/f7qdTlDV4Z4iTiNhHBARlcHhV6S1FqMYT1nmCtjjrcd7jrcfZkmI6xJqCoATFBMpc4ZViag0
+jM2HoBozEJqprmNsVceONPY7c2GJpOWJ5JiNVAes8LkqQchvs6ncQGN56rDUYY3AuYMqqILyT5FNDW
+XrKwjKZTOn3DVJqxtOCrf6I0ggCMaNxyfrmiNGwaoQ6BwRTZaFTfe5cTltXwTFxQxFEio4CzhXo2NG
+KI8ZmSNJusetgB6dBvTJhPIRCXGZrWjBs7SdppzSaTVpRRCoVWgaiSCFaGYUtEUJUNi0CWqmK4amp9
+JkuqmRrQlb6XAU2VDkapZNML14kvXz59uae6W7VjCq7owAhNdvJD9eK77V6SMnVbZbt4gsCrNzWK3r
+Ga2vvH11YTcR0irKWYC1KS2IUxjmUr9DikoAXlb3HBl9hA4PHuJK8NBRFgTAObT2+CBRT8CLFxgljY
+DM4xqEgNAzz+yUHDkfcfH3MgWXIspxWFCFFggkxZdxGUNQz7QpDDwEfSgiO4F1lgK8s+bh6oBKswZc
+Wm+dMxwVSakzpqsDM0lGWnn5/ytZmrYuWCuccZbkdoSBxzpPngGojhKclIqJEIWyOcY4YRxSmBG1wj
+NDtlKX9TYglK+dG9DcLxqOCc/EScUMz18wq8bSUxInGKY8RDhFJSjzaByIX0Hhk3Sl2ArRUFXYfWcn
+5tMNLsKq6IRX9LdzaesJo8H6yzkeErAYMob5ko2vF91oWXz1Irgkp29sQLyungwSKwdZbBmfP3TK5e
+JFWnhN7hzMlLoC3Ed5XWQhBhtoB4XGumptZ65BCYrAVOdp5lKhyH2w+wQuNShOKNKYfpgy0gqzJzFL
+MwZuaXHdQcGBPi4UOCGmJtcNLQSk0RZRAUSJE7XBAgHdVBzPESF8NlqsbvAYX8IXDFxG28LhSoVSEt
+R7vQcoq3dWUpsL2SXBOsN535CWkicB5wXBY/ftmU7I5lOhI4aQgRCCUxQCZAl1OSJoZ1njiSNOamSF
+qesqwihF9ihzU3mWypT0ksgFbOcIJsjjCYZmUOTpRKAJBVnoUrxxSGVCKEBzGVTcUhScoj1cOpz1BB
+YT2MBliL12Ctcu30J17i4iyj1tZye5CrTu6Vnyv1aRBVFtOEXgVIc7tGEhtOllfv3WyeqEnhgNSZ0m
+EYFpN5gjegncIb1GiTo5zFu9KvAfrHUIoSu8oXMnIGArrGRclk7xk0jQcOXojSzfeyKqZcrp/ga18l
+UZzzNLhBnv2CbodTxoVKFmidEKpIpxUjDE0VMWl9EIQgq9XvmpvJYQmeA9BE7zEm4ApDDb3uFwRygQ
+tHCY4TOkoC8d0ahlPLc4qojhi0i8wFoyB0gacDeR5LcQTgThUWQrSQBgZgi4Rqlp5/DgQ+5LgFRkSF
+ac0eg2uu3mJG25t0m7NcfD6N7EUZYiVTTaffpH+2haRV7SkJpEVLkNIUUXZK4+PFD4WICwieGyo9sA
+imGq1jwKFMkhliBBEpac4fw7OnO6xuHgrWfQISufVHkFdm/O9ps1OKruJuMpAi9zmkVjsdGDGF1beV
+Vy6mMXjEYmzRK6swA6hEuiGYBCyyj8IziBsXkMgQSrJJC8YWcM4OPrOMDIGkaRksz0OHJnhW97xxsk
+db/q278yj+HOvbF566OS5F7/v8qWXblvulizMlmi9hVADhJrgJXilKo+csChtkdIjQhX15Zyt/RkOL
+yobUjXeU/hgcU5Q2kDwleazdKN6wCmZ5lNGY0NegHGK0kBpBSqJUXjGI0Npqu/lPAzHjpmWw0mYWMN
+0nCMiT5JVxyk3EcwkPdKsTaO9RNZeZKa7l11L13Po0M3sWt77dJku/ZK24cNbJ05/i86ifzV9/nTDr
+o+QhaMrU7A5XkjKSOAij0tBaon0DmUcQcfEVV5R1eiSDhdZgvJELhA5z3T1PMPTJ7L2dYfexVzn54h
+afM299lrxvRaPbSm1ugqZcKUX4zGDzXdN1y48aC9fJJ0OEYXHljnOF7gAxutKoBscwllwJaLIq3OVB
+BGnjMsJW4WhUBGjVDDUETNLiywfPOhe99++8SuHj97yAXbPfVIZx/7lI7+864YDv9zfuPXb26p433T
+txLspL2DDBugRjhFOGnTi8cEQ3CZeiKq7KSpIbPCh0piGgPMB7yUEh/GO0o4xzuKEx0vHNDfEUYpQC
+usm5CVYLymtYDg1GK/Y2CrIS4h0jBewNSgJARpZwsiMUV4QyhInAkkKMslIRAOIcWGG5d1HufnoHRz
+YfxOLi/uZm939ER01/4WzfHRU096iRvzvombW35yb/anp0y/dXZ5dV8F6lFdIGXBK4aJAiCTIil0jh
+SdKmkTeowk4GbDaU+pQB9EGdDBM+jl27SIM1h+kXH6XSOIPOxlfK77/7MXl/Z/yal39udv+wbczh23
+FENIK8umgM127+NbJ+TMlW+txIxhi4Sl8jjMFhfGUItDMGrjSMO5vIQXV3Cp4ptOS8WTM0AXGArZ8o
+C8FjX3L4egD94l7H3zwl9qvO/BvUfoRpEM1YiBCRglLy9lHpTUfbSZzh0Sx+d+Z6crfzPOVW0t3Cee
+28GWO0A4nN6rsOi2Q0gIFNpSE4BBS4pxBSMl0lNMfjzAYVKYwefWzTUswLlCUgdJLSge5CYwLz7QUD
+IYGJyRBCoa5pcirZoeOIoSOOb82ZHYWOp123cJXJI1FDh26gT37DnDkhps5fPgGDhy87qtJ1v5/Bfr
+XpUpPVYm3ZdXtl4K402bh6HWfnJ+fLYu9e75j89Hn3r/51RdDpr3oNloEkTOcrIN3NLpNhHcMR2NCL
+NFxghSC3E4oMZBUZ2CbF6iyYCZJmVw8y8zKqZIbD75Vm/jTOokHAXb0rl8bnPq1CcbXiu8vMkm46sX
+7s15I97V7fr3dALWosmiXq6u3i/WNWE2GaGdrf41B14JqG0kmZogtSlQsEc4zHo6Y2BLZyOgPpqxbw
+0peUrRbHLrrbr7lrW+/fMvd3/yb6cLCj+WZnlb709rxgK0HHhFCxUSd5ins4k/r9u6fju3lb7blxf/
+KuovvdHbjVhcmmNIRXKi9gdX80IWC0hUE6yjtlOA8uXFMnaAMIIJj6g3TYEE1MUimzpIbzdQqcgOlU
+1VSQaRwhaCwlkkRKG31OqooRWVtFnfB0tIudu/bz8L8IosLuzl4+DqOXH8TS7t2fzVOG7/f6XR/N0r
+TLztjKL0jkqC0IErjClAYAiZU57l4ef4RncRf8Yn2arH9t7eef3khH/TRBXQ7c2hpCEWOd45Ob4ZBE
+XDBUtbjBaVcpTgyHm8sOIsUloQcu7Ea67WV23XWaqdJGJTXAEr/5YrvP7Tx9Nt8zu0ZkKja8W5z64H
+R2bP3hI3LJOUE6as32ocqzVZLjUsCRZlTmAmp0EgpmDpDfzrFhkCZJAwJpHtmueWee7jrLW99/PDtd
+/zrZHb2Q15IjEpqnb1DBoMMtqZXVF4KG4A4RsRzaGa+rMPClzG7fhy7eRNu/Ja83P+msizvN/l0xro
+cR4FngrADSj/ChkphU4YRRmQ4keOFxzCmRGNCRlFaBhPHuFAUJmFqAqXXBBVTmDGGCJU16LZikrhJs
+91hbnaeTqfD/v372bVrD9ddd4R9ew9uzs8tP9Jo9T4dR8nHkRwX+so8VWpFJKqcQE+ODx5NE+XrAbm
+WeB3Bwuw0a2U/oPctvJLPZH9n8sKJ15VnV2g4T+ShsAU2SFSqifEEW2IpEJFHa4mzFudKpK0FByEnQ
+tNfOcns6b33iKXdD0Rp5zeCSq4V32s7Y6+REWGHJ1HZf6bTrt3YfK9ZuRBUf1MkZoqUUDrD1JYEL5B
+SMTUeGwwGgzUlUZRgIs1QwMZ4wpZWqKVFbn/g/vL+h959eu7WY9/thTw59o4ky7gSOqyQ+OoZLEJIA
+oqpZ8cAK4UkYRYRZaDnjhPM8TSLfj4tS0w2udPZ/PXel3dZM76jyIfHymIYb/XX8G6KFwOCGGBtXmk
+kozFejTBmgKEgzkpmdKA1oymdJIgUqRtMCk+StunNLDC/uMzi4i4WFhdZXFwue73eM1naezKJs0ezr
+PklrdUT28YQ52uHUllvFlQgikVt0rVVkIpwkBvQGi0jcIGJspRC4rIGan/yK91UfjLpZP9uqMSB0em
+V2E4CUZIi0Iy9JYlDZd4KHhUJNI6yLBHWIp3Ay4DHosgZXTpLdPZE6By9/b005j6m0H2uQXP/M44S/
+hz1rKzV1J4qLRZVZeeRT47ZjY0lsdkXyXhMUuecG0oKnyO8QlrJ0E8AsKLK5ekXlo1pzrq3jLOEeHk
+Xtz744Pib3vqWj8xdf+Qn0dELQick242eq54aXSMAq+6PoJKwuat6QdZDFDIIWW0RkhBBpHgigicQt
+bvV5YRQ3LAHe0Pw+eGiGO83xWRPwC3h3VxR5jOTyag13VrN+qNhVBovG62ez7KuCSqdKpWNdNrcTNL
+2ulDxxTjJzsdp64zW+qRQ6kWl1Itaa7RIdzbuvg4bCaFizWyT+XwA5331XoiaXk1U0cLVtsui9lK6q
+mliqsnrOF5cfKYR1Lua6H84TpJ3mwurzbKYYF1OYXJ0UeCFwUmLEJ5gHaK0RF4QaQW+pJQGrKeclBQ
+XVwRba0v0lo8pGX/W6/ha8b1WRRiEZ8chtsOr9NjJ9Nbi0tqxeDIls5YYg5DVaEHEAll6hAsYW2K9x
+3tBieLyeMK5rQF0Z5m74fpwz7veLQ7dfdf/0rvxpj9A6pdyG0h0VWy28MSJrIfE9bKLfBV4Vl1lbJJ
+chZp0QJB4VceX7+ji6k+iFAEvgnlReE+aGFJntznv4BxlWSCWVlhfX6c0gdm5RVqzC4AiyASRNCgmO
+UHUPjmtqpHFdhNLSiZTi1KKKBJXDOLbXBl5lY5BVr9QCBCCQso6pTdy9TIZQEbEWte58WAJKDTp7Ow
+L7dtv+d+6s70vb7z0ws9eevnFMNkohUPTnBY4THV6dwZlHdo6tIjRIqKQghJHMFOkMZSXV+Hs2WMsH
+rqVrPPZa9vO/8Jnv6sL0WOri03Usz0BFKY92uz/8PrZ8zSKksj8f+2deYxd1X3HP2e5975t/Gb1jMf
+GO/bYYBswBgMBgp0GXBkqIG2DQqqoahU1SEGqUrXqH5XaP6q2qVSlCKqqTdp/0gZFbYIapS1UJUogU
+kRD2Yyx8Ybt8Xj29S13O6d/nPvevJkxhQQCM9Yc6cqekWd83znnt/9+32+MTGJSz84PwgImTklkndh
+YapGhZgSJ79G1dRO9u/ey5cAtr+07dPffic7OJ/F9Ujw8PV9TzCkJhNlLqayZVC+IR62JkVI4DvcmY
+G72zyxYlSzoUBTY+c9nRJYJVWAD0C1zUp5rhsZKgqogIcTPd0LQ4cQlAWxAUMjPW7amwnLT4xII8u5
+9LWBMTGpcptXzPCwQRTFaa5T0nRIxztLYJKMY81OHxy1sw4ijwHFfpILUZvRnnWve9kr6a+1tKgkL8
+rft6bP76hOT+PUJIhJiU8fGMaQpOTQa6cotys2HRVGITRLmRi8z+tYxejbv+grl7m+igtlV4fsIhW5
+BBrTBrdMAP7IQ1asPzExOBBMjo+TDkDSsY6IakTDURUoUG2RdYKshdS/CCkW1HjOXWDo2bmH7gdsZu
+OuefyvdcMM36Oz6Ll6+OStO6p55sORaNhnugfUXwq1LiZQqQ45OsTbJujL8ZqiSMtNA03Q8Dg0uBwR
+WuQkFgUQK6XA3WzCirAVlNWEkqdddQd3HA6EyRGpJmmRVmAzHxS4a/4jTEGtTlJIZv7uLow11LBLfl
+xm7qyWNXWyttNtuN1GegM4m7RHExuLHGUW3BWkERkIoDcLXBFvWP7mxlBssFwu/OXLi9P2FmWGkgSS
+qYxLXbKCFRBhBkiSInHQOfBohjaEyOUH4zjk6J8YD1V95gKDtm6vC9zHFfIIqxiT4op0kAc8z0s4Mb
+UtffX7D9qkTeLODzMkKM4FApAG52EfUq4zXp5iws4xX11CVkqjcSXnnLq755Kemtn7i0E9yG7Z8oWb
+9GV/7CJM5gxJQCVbFJKSkJAS0z88zyXfbVk1DP4iFL49P5/v7/FkW12Hm2qb0TSd5/MIMXbWTlAIP0
+k5Cr43UM+i0ii8KrglLgSFGk1lo6XgkAtkSM1lwOJ4tDerWzusT1cgutwiwyTewrZu/xHhLUaQ94/j
+yrChgutq+J29a+8O2nTf+0+Dz6taRc+fak0vQqTyCoIZOK/jxKH5SpTZdJwk8ZizUdY6a9fCGh1Gv/
+M8GOjq2xR1dErRJjCEQHtpCGjokNGwK2pJgSRzKJxqBb7XzDBIgvzzu+YqkfHFWwfUnWgG1arU0Nnj
+5sdr0LPVqhSiqY5IQEYdYE1ELq0xVK1TSBOvnifwcaZCjf9sODh05OnT7PYef6OhZ+6hBTPg5fyFCj
+23dKpFhiHzMhyZla0dCE0RJNHBHPwTP44M81s670Y0/lVJJEAQTxWLx0YFbDj5xzcDAUKFvHUmxjbo
+fEHoBsQyIYoGnAmQsCKx0j4QorDJ86RwMX3jM1GslZWOkSR2AgQDlzHdDW2S6US694GLV8n2gFeAhh
+EeMa96tTc598fLp8+3x+BRerYaKaigiZAqVeoQ1PmngMx3GDE1OEXetY+CmG5NbPv3p6rqDt32Btf0
+/RQfjAq/ZKqpFa8CkmxZMLoMGJyll85Jn2ZCs/CGQQr4v4fpFhw3N92tZvu+jlBpTW7Z9bYPnvVDqK
+H979u2ThcqpN3U4WmeN9WkL1hDOzhDVq2jPR4kITynCNGb48hl6x8+167D+RR0EX5VCZDGBahj2pqK
+UGV43GTTW/++prArfksvxbu6nNpBKSSwEnqG3Mjq2Y+r0ed+bmCap10jSCGvqCCMRVlJJYMJqZoMct
+tDHtbffw8HDh/+j97bb/oZi8dkkjLG6gEETpZacEu5MRUvWQmoH374MhG9JHCzEPFvTMjm/xVaw0Qo
+mpSQWwXhu/aZn17d3PDLb3f07Fz19dFoopseGSecU2sbYNCGnPMKw5mYfpWVq5B3Mhbd8Oz2xg2KhV
+0o1bI0AqZro1q4yIskqUFhMJn6mOQe6Knzv8xCvKICRhJxwEVi1LiuDg/dHg4MEk9OYKKQe1wmjKsY
+oIlFiNIwYlYKe3ddx860HuO7wI38ddHb9I6X2/8XTGN8B8hlALaagaiQbLRngj1w2wpeZwWbiyeKGg
+OVH+f+/h3JoIoIb0yx3xCrASMi1dX2/uNUf2uDlzhS7er48/uorXDp2jK5iBzmr3VlUa5i4jhIxszM
+Vzrz+El0HL9zvl9f8EcUSQlhSFFa62qpqfHgrUYKFkxCrlu9D0PjksjpaQmVy+PHqhbO9ufExctU5S
+GNmowiLZC5MmQgrRJ39XHvzAa47/KlTG/fs+T7X7H7cUfBIUqFIgSjLSTZZbiVLEQvs8ooZhGhkZJZ
+Xx4fJYlApZdNFbgihEC5HaqxPJA1+oeOV0rbc46q4hkh6v1yzcvvEmTN4oaEeVYmNwCQGKRL8esLYq
+bcRZ071dmza8Dj5/B841kxL3CJbooXPT0iZEQeAEGa+7LMqfD9v0OOBNQjCHZVLZ/fXzr1JYXoEXZk
+iVhEzRpJIn1Brgu51XHvbXey5/+gbwXW7/xIveLoeC3KlwKYCIqCWuKJzE6buXYJzK+Y7XJZNzLc44
+fIRXK73ihmVUk0BXPwzUkpUAkJlfbBgY51H9m74/e4b9culrt6vXPjJj6+ffPMNpi6eI+fn8UyIjiN
+yQhGNRpw79jrbdu/aT3f3Dqw+CZDYFIxECYHXCvJpnABaTKZLzUIArVXh+xldTwtxGAnSuZ760Ok90
+cUTFGaHiecmmckZ5vw8w3Mp5a713HToaGX3ffedYWDnQ5QK5xFEAUFz6l0CBa3nU78mRUm1VPjE/AT
+Tsst2tuyPWAamWQhHKf2uMXt2hm6YClKh8b1SvdS/+Z/b2jtfzLWX//WY1lsvRNViPCVR4zGqWiOXK
+irTKZffeoupSxf2tG/a2EObfBuVs1JohMqSKylLqK6Xy9ktOMeV4mouiCEM5PzAzgy+87lLb7zUy9Q
+lVDzNXHWKyPcZsz7d19/KgQd/I9195OGvs3Pv5ymWT1nhRQjXFS9tk7C5WZVTGHzZ4ANwnHDuaSXj/
+OgSFo3Pv3gPkiSZF0AhIFMey43BZ/Fo2Pw7O/g/bSGXPa6fW0dJvu2U6lv/+X33/8rXdx05mkbrrmG
+yWGaqUGYoEkwJOHP6NC+//HIvlcrn0J6N0ihrS1hZa0W6nWkMyk/3MjV+pHb5ohUz4yKVMWkhYDQRd
+F9/k73urqN25x33fpn+Dc8QyMFQOrg8kaR4mWFTC7SjWagfRUOFZow6SOyyKDRcBUulWYlEo6xAGde
+iZiSkeBTKPa+qtra/2HHnPSeKa8pPHP/Bf4sTP/qBmJyN0RGcPHuR7teP213nLx5Zt37z3kAHr0WZE
+xBHDt7zSmGDWBW+D8EaarSZntk/cup0KRyfFCKOGDEp+S3buHbnXrYfeuCF7t23Pk3/5qfwJLMYlHB
+IZ0lcw5OLTqS1f2vJKdmMvNK0JMs+Xh0rRFbBWqGjNREpSkiUSDPUJgfJr1KXrTRKE1s1mF/b/9TWg
+0Xht5V/XZTa73zthR9x/q0TyHrIifPnxevHT5a6du/b73cV3tQ40g0dLHI5pSs3yOa3VhMuH8xX9kk
+qg6N3D588212drCBybei+NWy865fYfNd9/86Om/8UEbyQ2pSahVTLZiIl7+Xnhcs2BI+MlTIbArpCV
+lM2I4flcXgrmRK50UKkGi5oY8+zM5GAEAFWJMi2zievueHAq6We/j9Myj1HzsbfQQ5e5NTQCC+/ebx
+74M7xu9eXu//BWOnQBNRSwTPNLKhcViZwRbaXhcns/qnR4UdmHKb3TAAAAyxJREFUhsZJ04Dyjr1sP
+/qZoc1HP/MMu29+GL/0IkqDD1obRwNm4/lTb8Zyi6ydzWjCMuoxmz1iwbMqeB/80mVN5I0bqLJG2gy
+PlTh1uKbCB+ljc20vdm4deHjPoXuf+cSvPTpU3riJmvQ5fXGIS8Njj2D1fl8pTBS30PwaUtyzINGyj
+OKGlWj5vJnK2IOnjx+L49nQ37nrAAOH75xuv/XmP6Nv078YE9RkaEGnSBUCKRqBFj5e1o1ksxMQjYK
+elQuEsLUwK2m1kpmlVB+/8K1kAQxaNtBmjeMOl8LtcRzV8WQuG6FQGIQVWtbW79zz2L19Gx/uL5f+J
+P+fz5YHR8Z56aevxNt37n2wu7fnNd/TsfNaXBiRZiGDwKDRLbB3q8L3867y+MTlXdMTo8WBbbvi/Qf
+vGOLAvt+qrl37w3EIcxLag4x11laIRAWPAI8Ot/ExpH6jWC8yF2devkyLrInFgmeWh7OwRPBWGG+Wi
+F0jppWWRJBNHxikcD21XjFwUpk6AkatJEkC1orBclf73x564IHjhb7+v3/uv55fNz45VRy+fHlXd09
+PmSgZc0hPNhvYAruYN27V8n2gtXV8fOShnq5O9t+492kG9n2LQv65KWAaWAMUDPhEaG0oIFyOMgkhy
+YOaz2HKRVHc4lqQbf3LMisUrWjrl9XhhBCkwnWnNLiFDVCParR5BeeRJE47aungOASE1gueu+OTh76
+0dt3Gzx47dvzRUnHNQ8Cf2yQZE7mg+XtslqVWi5XocjlDu7K0pgS+dfbs2V8tFotPlUqlr+ZyuXNO+
+duFtaSrZF3pfCpiGjN2imToJJ39m6BjG1XZRwrkAI8YUKSZWlEZQDAIrNArHnyvpXtmM/B7wJeAbwO
+fBcxKuQMrzfLdBoz29fX9led5v6u1XnBJW7vnr/YlrXEoNo22LRYOYlxZ1S6rkOfDcLvPAY/hGmWC7
+H68uFI+x0oSPg2MAN/L5/M/vtqSED/T5cMu9J4Wf7HMGsB/4TEv/DFwe3Y/NPN57VXh+5BWApwFLlh
+r661tV1eju/ne8YJrkWtES0tmRe2VOviv2j2aBp5nHihiRaz/A4oCnsAsje/+AAAAAElFTkSuQmCC"
+ }
+
+# $encoded(basn0g08), $encoded(basn2c08), $encoded(basn3p08), $encoded(basn6a08)
+test imgPNG-1.1 {reading basic images; grayscale} -setup {
+ catch {rename foo ""}
+} -body {
+ image create photo foo -data $encoded(basn0g08)
+ list [image width foo] [image height foo]
+} -cleanup {
+ rename foo ""
+} -result {32 32}
+test imgPNG-1.2 {reading basic images; color} -setup {
+ catch {rename foo ""}
+} -body {
+ image create photo foo -data $encoded(basn2c08)
+ list [image width foo] [image height foo]
+} -cleanup {
+ rename foo ""
+} -result {32 32}
+test imgPNG-1.3 {reading basic images; color with palette} -setup {
+ catch {rename foo ""}
+} -body {
+ image create photo foo -data $encoded(basn3p08)
+ list [image width foo] [image height foo]
+} -cleanup {
+ rename foo ""
+} -result {32 32}
+test imgPNG-1.4 {reading basic images; alpha} -setup {
+ catch {rename foo ""}
+} -body {
+ image create photo foo -data $encoded(basn6a08)
+ list [image width foo] [image height foo]
+} -cleanup {
+ rename foo ""
+} -result {32 32}
+
+test imgPNG-2.1 {reading a bad image} -body {
+ image create photo -data $encoded(BadX)
+} -returnCodes error -result {unfinalized data stream in PNG data}
+test imgPNG-2.2 {reading a good image with multiple IDATs} -setup {
+ set i [image create photo]
+} -body {
+ $i put $encoded(MultiIDAT)
+ return [image width $i]x[image height $i]
+} -cleanup {
+ image delete $i
+} -result 223x212
+
+}
+namespace delete png
+imageFinish
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/tk8.6/tests/imgPPM.test b/tk8.6/tests/imgPPM.test
new file mode 100644
index 0000000..e3a738a
--- /dev/null
+++ b/tk8.6/tests/imgPPM.test
@@ -0,0 +1,239 @@
+# This file is a Tcl script to test out the code in tkImgFmtPPM.c,
+# which reads and write PPM-format image files for photo widgets.
+# The files is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+imageInit
+
+# Note that we do not use [tcltest::makeFile] because it is
+# only suitable for text files
+proc put {file data} {
+ set f [open $file w]
+ fconfigure $f -translation lf
+ puts -nonewline $f $data
+ close $f
+}
+
+test imgPPM-1.1 {FileReadPPM procedure} -body {
+ put test.ppm "P6\n0 256\n255\nabcdef"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
+test imgPPM-1.2 {FileReadPPM procedure} -body {
+ put test.ppm "P6\n-2 256\n255\nabcdef"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
+test imgPPM-1.3 {FileReadPPM procedure} -body {
+ put test.ppm "P6\n10 0\n255\nabcdef"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
+test imgPPM-1.4 {FileReadPPM procedure} -body {
+ put test.ppm "P6\n10 -2\n255\nabcdef"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
+test imgPPM-1.5 {FileReadPPM procedure} -body {
+ put test.ppm "P6\n10 20\n100000\nabcdef"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {PPM image file "test.ppm" has bad maximum intensity value 100000}
+test imgPPM-1.6 {FileReadPPM procedure} -body {
+ put test.ppm "P6\n10 20\n0\nabcdef"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {PPM image file "test.ppm" has bad maximum intensity value 0}
+test imgPPM-1.7 {FileReadPPM procedure} -body {
+ put test.ppm "P6\n10 10\n255\nabcdef"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {error reading PPM image file "test.ppm": not enough data}
+test imgPPM-1.8 {FileReadPPM procedure} -body {
+ put test.ppm "P6\n5 4\n255\n01234567890123456789012345678901234567890123456789012345678"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {error reading PPM image file "test.ppm": not enough data}
+test imgPPM-1.9 {FileReadPPM procedure} -body {
+ put test.ppm "P6\n5 4\n150\n012345678901234567890123456789012345678901234567890123456789"
+ list [image create photo p1 -file test.ppm] \
+ [image width p1] [image height p1]
+} -returnCodes ok -result {p1 5 4}
+
+
+test imgPPM-2.1 {FileWritePPM procedure} -setup {
+ catch {image delete p1}
+} -body {
+ put test.ppm "P6\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+ image create photo p1 -file test.ppm
+ list [catch {p1 write not_a_dir/bar/baz/gorp} msg] [string tolower $msg] \
+ [string tolower $errorCode]
+} -cleanup {
+ image delete p1
+} -result {1 {couldn't open "not_a_dir/bar/baz/gorp": no such file or directory} {posix enoent {no such file or directory}}}
+
+test imgPPM-2.2 {FileWritePPM procedure} -setup {
+ catch {image delete p1}
+ catch {unset data}
+} -body {
+ put test.ppm "P6\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+ image create photo p1 -file test.ppm
+ p1 write -format ppm test.ppm
+ set fd [open test.ppm]
+ set data [read $fd]
+ close $fd
+ set data
+} -cleanup {
+ image delete p1
+} -result {P6
+5 4
+255
+012345678901234567890123456789012345678901234567890123456789}
+
+
+test imgPPM-3.1 {ReadPPMFileHeader procedure} -body {
+ put test.ppm "# \n#\n#\nP6\n#\n##\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+ image create photo p1 -file test.ppm
+} -cleanup {
+ image delete p1
+} -returnCodes ok -result p1
+test imgPPM-3.2 {ReadPPMFileHeader procedure} -body {
+ put test.ppm "P6\n5\n 4 255\n012345678901234567890123456789012345678901234567890123456789"
+ image create photo p1 -file test.ppm
+} -cleanup {
+ image delete p1
+} -returnCodes ok -result p1
+test imgPPM-3.3 {ReadPPMFileHeader procedure} -body {
+ put test.ppm "P6\n# asdfasdf\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+ image create photo p1 -file test.ppm
+} -cleanup {
+ image delete p1
+} -returnCodes ok -result p1
+test imgPPM-3.4 {ReadPPMFileHeader procedure} -body {
+ put test.ppm "P6 \n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+ image create photo p1 -file test.ppm
+} -cleanup {
+ image delete p1
+} -returnCodes ok -result p1
+test imgPPM-3.5 {ReadPPMFileHeader procedure} -body {
+ put test.ppm "P5\n5 4\n255\n01234567890123456789"
+ image create photo p1 -file test.ppm
+} -cleanup {
+ image delete p1
+} -returnCodes ok -result p1
+test imgPPM-3.6 {ReadPPMFileHeader procedure} -body {
+ put test.ppm "P3\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.7 {ReadPPMFileHeader procedure} -body {
+ put test.ppm "P6x\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.8 {ReadPPMFileHeader procedure} -body {
+ put test.ppm "P6\nxy5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.9 {ReadPPMFileHeader procedure} -body {
+ put test.ppm "P6\n5\n255\n!012345678901234567890123456789012345678901234567890123456789"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.10 {ReadPPMFileHeader procedure} -body {
+ put test.ppm "P6\n5 4\nzz255\n012345678901234567890123456789012345678901234567890123456789"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.11 {ReadPPMFileHeader procedure, empty file} -body {
+ put test.ppm " "
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.12 {ReadPPMFileHeader procedure, file ends too soon} -body {
+ put test.ppm "P6\n566"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.13 {ReadPPMFileHeader procedure, file ends too soon} -body {
+ put test.ppm "P6\n566\n#asdf"
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+
+
+test imgPPM-4.1 {StringReadPPM procedure, data too short [Bug 1822391]} -body {
+ image create photo I -width 1103 -height 997
+ I put "P5\n1103 997\n255\n"
+} -cleanup {
+ image delete I
+} -returnCodes error -result {truncated PPM data}
+
+test imgPPM-5.1 {StringReadPPM procedure} -setup {
+ image create photo ppm
+} -body {
+ ppm put "P6\n0 256\n255\nabcdef"
+} -returnCodes error -cleanup {
+ image delete ppm
+} -result {PPM image data has dimension(s) <= 0}
+test imgPPM-5.2 {StringReadPPM procedure} -setup {
+ image create photo ppm
+} -body {
+ ppm put "P6\n-2 256\n255\nabcdef"
+} -returnCodes error -cleanup {
+ image delete ppm
+} -result {PPM image data has dimension(s) <= 0}
+test imgPPM-5.3 {StringReadPPM procedure} -setup {
+ image create photo ppm
+} -body {
+ ppm put "P6\n10 0\n255\nabcdef"
+} -returnCodes error -cleanup {
+ image delete ppm
+} -result {PPM image data has dimension(s) <= 0}
+test imgPPM-5.4 {StringReadPPM procedure} -setup {
+ image create photo ppm
+} -body {
+ ppm put "P6\n10 -2\n255\nabcdef"
+} -returnCodes error -cleanup {
+ image delete ppm
+} -result {PPM image data has dimension(s) <= 0}
+test imgPPM-5.5 {StringReadPPM procedure} -setup {
+ image create photo ppm
+} -body {
+ ppm put "P6\n10 20\n100000\nabcdef"
+} -returnCodes error -cleanup {
+ image delete ppm
+} -result {PPM image data has bad maximum intensity value 100000}
+test imgPPM-5.6 {StringReadPPM procedure} -setup {
+ image create photo ppm
+} -body {
+ ppm put "P6\n10 20\n0\nabcdef"
+} -returnCodes error -cleanup {
+ image delete ppm
+} -result {PPM image data has bad maximum intensity value 0}
+test imgPPM-5.7 {StringReadPPM procedure} -setup {
+ image create photo ppm
+} -body {
+ ppm put "P6\n10 10\n255\nabcdef"
+} -returnCodes error -cleanup {
+ image delete ppm
+} -result {truncated PPM data}
+test imgPPM-5.8 {StringReadPPM procedure} -setup {
+ image create photo ppm
+} -body {
+ ppm put "P6\n5 4\n255\n01234567890123456789012345678901234567890123456789012345678"
+} -returnCodes error -cleanup {
+ image delete ppm
+} -result {truncated PPM data}
+test imgPPM-5.9 {StringReadPPM procedure} -setup {
+ image create photo ppm
+} -body {
+ ppm put "P6\n5 4\n150\n012345678901234567890123456789012345678901234567890123456789"
+ list [image width ppm] [image height ppm]
+} -cleanup {
+ image delete ppm
+} -result {5 4}
+
+imageFinish
+
+# cleanup
+catch {file delete test.ppm}
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/imgPhoto.test b/tk8.6/tests/imgPhoto.test
new file mode 100644
index 0000000..e85f512
--- /dev/null
+++ b/tk8.6/tests/imgPhoto.test
@@ -0,0 +1,1169 @@
+# This file is a Tcl script to test out the "photo" image type and the other
+# procedures in the file tkImgPhoto.c. It is organized in the standard fashion
+# for Tcl tests.
+#
+# Copyright (c) 1994 The Australian National University
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2002-2008 Donal K. Fellows
+# All rights reserved.
+#
+# Author: Paul Mackerras (paulus@cs.anu.edu.au)
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+
+# Used for 4.65 - 4.73 tests
+# Now for some heftier testing, checking that setting and resetting of pixels'
+# transparency status doesn't "leak" with any one-off errors.
+proc foreachPixel {img xVar yVar script} {
+ upvar 1 $xVar x $yVar y
+ set width [image width $img]
+ set height [image height $img]
+ for {set x 0} {$x<$width} {incr x} {
+ for {set y 0} {$y<$height} {incr y} {
+ uplevel 1 $script
+ }
+ }
+}
+proc checkImgTrans {img} {
+ set result {}
+ foreachPixel $img x y {
+ if {[$img transparency get $x $y]} {
+ lappend result $x,$y
+ }
+ }
+ return $result
+}
+proc checkImgTransLoop {img script1 script2} {
+ set result {}
+ foreachPixel $img x y {
+ eval $script1
+ lappend result {*}[checkImgTrans $img]
+ append result :
+ eval $script2
+ lappend result {*}[checkImgTrans $img]
+ append result .
+ }
+ return $result
+}
+
+imageInit
+set README [makeFile {
+ README -- Tk test suite design document.
+} README-imgPhoto]
+
+# find the teapot.ppm file for use in these tests
+set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm]
+testConstraint hasTeapotPhoto [file exists $teapotPhotoFile]
+
+# ----------------------------------------------------------------------
+
+test imgPhoto-1.1 {options for photo images} -body {
+ image create photo photo1 -width 79 -height 83
+ list [photo1 cget -width] [photo1 cget -height] \
+ [image width photo1] [image height photo1]
+} -cleanup {
+ image delete photo1
+} -result {79 83 79 83}
+test imgPhoto-1.2 {options for photo images} -body {
+ list [catch {image create photo photo1 -file no.such.file} err] \
+ [string tolower $err]
+} -result {1 {couldn't open "no.such.file": no such file or directory}}
+test imgPhoto-1.3 {options for photo images} -constraints hasTeapotPhoto -body {
+ image create photo photo1 -file $teapotPhotoFile -format no.such.format
+} -returnCodes error -result {image file format "no.such.format" is not supported}
+test imgPhoto-1.4 {options for photo images} -constraints hasTeapotPhoto -body {
+ image create photo photo1 -file $teapotPhotoFile
+ list [image width photo1] [image height photo1]
+} -cleanup {
+ image delete photo1
+} -result {256 256}
+test imgPhoto-1.5 {options for photo images} -constraints hasTeapotPhoto -body {
+ image create photo photo1 -file $teapotPhotoFile \
+ -format ppm -width 79 -height 83
+ list [image width photo1] [image height photo1] [photo1 cget -file] [photo1 cget -format]
+} -cleanup {
+ image delete photo1
+} -result [list 79 83 $teapotPhotoFile ppm]
+test imgPhoto-1.6 {options for photo images} -body {
+ image create photo photo1 -palette 2/2/2 -gamma 2.2
+ list [format %.1f [photo1 cget -gamma]] [photo1 cget -palette]
+} -cleanup {
+ image delete photo1
+} -result {2.2 2/2/2}
+test imgPhoto-1.7 {options for photo images} -returnCodes error -body {
+ image create photo photo1 -file $README
+} -result [subst {couldn't recognize data in image file "$README"}]
+test imgPhoto-1.8 {options for photo images} -body {
+ image create photo -blah blah
+} -returnCodes error -result {unknown option "-blah"}
+test imgPhoto-1.9 {options for photo images - error case} -body {
+ image create photo -format
+} -returnCodes error -result {value for "-format" missing}
+test imgPhoto-1.10 {options for photo images - error case} -body {
+ image create photo -data
+} -returnCodes error -result {value for "-data" missing}
+test imgPhoto-1.11 {options for photo images - error case} -body {
+ image create photo photo1 -format
+} -returnCodes error -result {value for "-format" missing}
+
+test imgPhoto-2.1 {ImgPhotoCreate procedure} -setup {
+ imageCleanup
+} -body {
+ catch {image create photo -blah blah}
+ imageNames
+} -result {}
+test imgPhoto-2.2 {ImgPhotoCreate procedure} -setup {
+ imageCleanup
+} -body {
+ image create photo image1
+ list [info commands image1] [imageNames] \
+ [image width image1] [image height image1]
+} -cleanup {
+ image delete image1
+} -result {image1 image1 0 0}
+# test imgPhoto-2.3 {ImgPhotoCreate procedure: creation failure} {
+# image create photo photo1
+# image create photo photo2 -width 10 -height 10
+# catch {image create photo photo2 -file bogus.img} msg
+# photo1 copy photo2
+# set msg
+# } {couldn't open "bogus.img": no such file or directory}
+
+test imgPhoto-3.1 {ImgPhotoConfigureMaster procedure} -constraints {
+ hasTeapotPhoto
+} -body {
+ image create photo photo1 -file $teapotPhotoFile
+ photo1 configure -file $teapotPhotoFile
+} -cleanup {
+ image delete photo1
+} -result {}
+test imgPhoto-3.2 {ImgPhotoConfigureMaster procedure} -constraints {
+ hasTeapotPhoto
+} -body {
+ image create photo photo1 -file $teapotPhotoFile
+ list [catch {photo1 configure -file bogus} err] [string tolower $err] \
+ [image width photo1] [image height photo1]
+} -cleanup {
+ image delete photo1
+} -result {1 {couldn't open "bogus": no such file or directory} 256 256}
+test imgPhoto-3.3 {ImgPhotoConfigureMaster procedure} -constraints {
+ hasTeapotPhoto
+} -setup {
+ destroy .c
+ pack [canvas .c]
+ update
+} -body {
+ image create photo photo1
+ .c create image 10 10 -image photo1 -tags photo1.1 -anchor nw
+ .c create image 300 10 -image photo1 -tags photo1.2 -anchor nw
+ update
+ photo1 configure -file $teapotPhotoFile
+ update
+ list [image width photo1] [image height photo1] [.c bbox photo1.1] [.c bbox photo1.2]
+} -cleanup {
+ destroy .c
+ image delete photo1
+} -result {256 256 {10 10 266 266} {300 10 556 266}}
+
+test imgPhoto-4.1 {ImgPhotoCmd procedure} -setup {
+ image create photo photo1
+} -body {
+ photo1
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 option ?arg ...?"}
+test imgPhoto-4.2 {ImgPhotoCmd procedure} -setup {
+ image create photo photo1
+} -body {
+ photo1 blah
+} -returnCodes error -cleanup {
+ image delete photo1
+} -match glob -result {bad option "blah": must be *}
+test imgPhoto-4.3 {ImgPhotoCmd procedure: blank option} -setup {
+ image create photo photo1
+} -body {
+ photo1 blank
+ photo1 blank x
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {wrong # args: should be "photo1 blank"}
+test imgPhoto-4.4 {ImgPhotoCmd procedure: cget option} -setup {
+ image create photo photo1
+} -body {
+ photo1 cget
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {wrong # args: should be "photo1 cget option"}
+test imgPhoto-4.5 {ImgPhotoCmd procedure: cget option} -setup {
+ image create photo photo2 -width 25 -height 30
+} -body {
+ list [photo2 cget -width] [photo2 cget -height]
+} -cleanup {
+ image delete photo2
+} -result {25 30}
+test imgPhoto-4.6 {ImgPhotoCmd procedure: configure option} -setup {
+ image create photo photo1
+} -body {
+ llength [photo1 configure]
+} -cleanup {
+ image delete photo1
+} -result 7
+test imgPhoto-4.7 {ImgPhotoCmd procedure: configure option} -setup {
+ image create photo photo1
+} -body {
+ photo1 conf -palette 3/4/2
+ photo1 configure -palette
+} -cleanup {
+ image delete photo1
+} -result {-palette {} {} {} 3/4/2}
+test imgPhoto-4.8 {ImgPhotoCmd procedure: configure option} -setup {
+ image create photo photo1
+} -body {
+ photo1 configure -blah
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {unknown option "-blah"}
+test imgPhoto-4.9 {ImgPhotoCmd procedure: configure option} -setup {
+ image create photo photo1
+} -body {
+ photo1 configure -palette {} -gamma
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {value for "-gamma" missing}
+test imgPhoto-4.10 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -width 25 -height 30
+} -body {
+ image create photo photo2 -file $teapotPhotoFile
+ photo1 configure -width 0 -height 0 -palette {} -gamma 1
+ photo1 copy photo2
+ list [image width photo1] [image height photo1] [photo1 get 100 100]
+} -cleanup {
+ image delete photo1 photo2
+} -result {256 256 {169 117 90}}
+test imgPhoto-4.11 {ImgPhotoCmd procedure: copy option} -setup {
+ image create photo photo1
+} -body {
+ photo1 copy
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 copy source-image ?-compositingrule rule? ?-from x1 y1 x2 y2? ?-to x1 y1 x2 y2? ?-zoom x y? ?-subsample x y?"}
+test imgPhoto-4.12 {ImgPhotoCmd procedure: copy option} -setup {
+ image create photo photo1
+} -body {
+ photo1 copy blah
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {image "blah" doesn't exist or is not a photo image}
+test imgPhoto-4.13 {ImgPhotoCmd procedure: copy option} -setup {
+ image create photo photo1
+ image create photo photo2
+} -body {
+ photo1 copy photo2 -blah
+} -returnCodes error -cleanup {
+ image delete photo1 photo2
+} -result {unrecognized option "-blah": must be -compositingrule, -from, -shrink, -subsample, -to, or -zoom}
+test imgPhoto-4.14 {ImgPhotoCmd procedure: copy option} -setup {
+ image create photo photo1
+ image create photo photo2
+} -body {
+ photo1 copy photo2 -from -to
+} -returnCodes error -cleanup {
+ image delete photo1 photo2
+} -result {the "-from" option requires one to four integer values}
+test imgPhoto-4.15 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2
+ photo1 copy photo2 -from 0 70 60 120 -shrink
+ list [image width photo1] [image height photo1] [photo1 get 20 10]
+} -cleanup {
+ image delete photo1 photo2
+} -result {60 50 {215 154 120}}
+test imgPhoto-4.16 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2 -from 60 120 0 70 -to 20 50
+ list [image width photo1] [image height photo1] [photo1 get 40 80]
+} -cleanup {
+ image delete photo1 photo2
+} -result {80 100 {19 92 192}}
+test imgPhoto-4.17 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2 -from 0 120 60 70 -to 0 0 100 100
+ list [image width photo1] [image height photo1] [photo1 get 80 60]
+} -cleanup {
+ image delete photo1 photo2
+} -result {100 100 {215 154 120}}
+test imgPhoto-4.18 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2 -from 60 70 0 120 -zoom 2
+ list [image width photo1] [image height photo1] [photo1 get 100 50]
+} -cleanup {
+ image delete photo1 photo2
+} -result {120 100 {169 99 47}}
+test imgPhoto-4.19 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2 -from 0 70 60 120 -zoom 2
+ list [image width photo1] [image height photo1] [photo1 get 100 50]
+} -cleanup {
+ image delete photo1 photo2
+} -result {120 100 {169 99 47}}
+test imgPhoto-4.20 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2 -from 20 20 200 180 -subsample 2 -shrink
+ list [image width photo1] [image height photo1] [photo1 get 50 30]
+} -cleanup {
+ image delete photo1 photo2
+} -result {90 80 {207 146 112}}
+test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2
+ set result [list [image width photo1] [image height photo1]]
+ photo1 conf -width 49 -height 51
+ lappend result [image width photo1] [image height photo1]
+ photo1 copy photo2
+ lappend result [image width photo1] [image height photo1]
+ photo1 copy photo2 -from 0 0 10 10 -shrink
+ lappend result [image width photo1] [image height photo1]
+ photo1 conf -width 0
+ photo1 copy photo2 -from 0 0 10 10 -shrink
+ lappend result [image width photo1] [image height photo1]
+ photo1 conf -height 0
+ photo1 copy photo2 -from 0 0 10 10 -shrink
+ lappend result [image width photo1] [image height photo1]
+} -cleanup {
+ image delete photo1 photo2
+} -result {256 256 49 51 49 51 49 51 10 51 10 10}
+test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+} -body {
+ photo1 read $teapotPhotoFile
+ list [photo1 get 100 100] [photo1 get 150 100] [photo1 get 100 150]
+} -cleanup {
+ image delete photo1
+} -result {{169 117 90} {172 115 84} {35 35 35}}
+test imgPhoto-4.23 {ImgPhotoCmd procedure: get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 get 256 0
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {photo1 get: coordinates out of range}
+test imgPhoto-4.24 {ImgPhotoCmd procedure: get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 get 0 -1
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {photo1 get: coordinates out of range}
+test imgPhoto-4.25 {ImgPhotoCmd procedure: get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 get
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {wrong # args: should be "photo1 get x y"}
+test imgPhoto-4.26 {ImgPhotoCmd procedure: put option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 put data ?-option value ...?"}
+test imgPhoto-4.27 {ImgPhotoCmd procedure: put option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {{white} {white white}}
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {all elements of color list must have the same number of elements}
+test imgPhoto-4.28 {ImgPhotoCmd procedure: put option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {{blahgle}}
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {can't parse color "blahgle"}
+test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put -to 10 10 20 20 {{white}}
+ photo1 get 19 19
+} -cleanup {
+ image delete photo1
+} -result {255 255 255}
+test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} -setup {
+ image create photo photo1
+} -body {
+ photo1 read
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 read fileName ?-option value ...?"}
+test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+} -body {
+ photo1 read $teapotPhotoFile -zoom 2
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {unrecognized option "-zoom": must be -format, -from, -shrink, or -to}
+test imgPhoto-4.32 {ImgPhotoCmd procedure: read option} -setup {
+ image create photo photo1
+} -body {
+ list [catch {photo1 read bogus} err] [string tolower $err]
+} -cleanup {
+ image delete photo1
+} -result {1 {couldn't open "bogus": no such file or directory}}
+test imgPhoto-4.33 {ImgPhotoCmd procedure: read option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+} -body {
+ photo1 read $teapotPhotoFile -format bogus
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {image file format "bogus" is not supported}
+test imgPhoto-4.34 {ImgPhotoCmd procedure: read option} -setup {
+ image create photo photo1
+} -body {
+ photo1 read $README
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result [subst {couldn't recognize data in image file "$README"}]
+test imgPhoto-4.35 {ImgPhotoCmd procedure: read option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+} -body {
+ photo1 read $teapotPhotoFile
+ list [image width photo1] [image height photo1] [photo1 get 120 120]
+} -cleanup {
+ image delete photo1
+} -result {256 256 {161 109 82}}
+test imgPhoto-4.36 {ImgPhotoCmd procedure: read option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+} -body {
+ photo1 read $teapotPhotoFile -from 0 70 60 120 -to 10 10 -shrink
+ list [image width photo1] [image height photo1] [photo1 get 29 19]
+} -cleanup {
+ image delete photo1
+} -result {70 60 {244 180 144}}
+test imgPhoto-4.37 {ImgPhotoCmd procedure: redither option} -setup {
+ image create photo photo1
+} -body {
+ photo1 redither
+ photo1 redither x
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {wrong # args: should be "photo1 redither"}
+test imgPhoto-4.38 {ImgPhotoCmd procedure: write option} -setup {
+ image create photo photo1
+} -body {
+ photo1 write
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 write fileName ?-option value ...?"}
+test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} -setup {
+ image create photo photo1
+} -body {
+ photo1 write teapot.tmp -format bogus
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {image file format "bogus" is unknown}
+test imgPhoto-4.40 {ImgPhotoCmd procedure: transparency option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency option ?arg ...?"}
+test imgPhoto-4.41 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency get x y"}
+test imgPhoto-4.42 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency get x y"}
+test imgPhoto-4.43 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get 0 0 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency get x y"}
+test imgPhoto-4.44 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get bogus 0
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {expected integer but got "bogus"}
+test imgPhoto-4.45 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get 0 bogus
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {expected integer but got "bogus"}
+test imgPhoto-4.46 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white
+ photo1 transparency get 0 0
+} -cleanup {
+ image delete photo1
+} -result 0
+test imgPhoto-4.47 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get 1 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency get: coordinates out of range}
+test imgPhoto-4.48 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get -1 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency get: coordinates out of range}
+test imgPhoto-4.49 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get 0 1
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency get: coordinates out of range}
+test imgPhoto-4.50 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get 0 -1
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency get: coordinates out of range}
+test imgPhoto-4.51 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white
+ photo1 blank
+ photo1 transparency get 0 0
+} -cleanup {
+ image delete photo1
+} -result 1
+test imgPhoto-4.52 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency set x y boolean"}
+test imgPhoto-4.53 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency set x y boolean"}
+test imgPhoto-4.54 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency set x y boolean"}
+test imgPhoto-4.55 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0 0 0 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency set x y boolean"}
+test imgPhoto-4.56 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set bogus 0 0
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {expected integer but got "bogus"}
+test imgPhoto-4.57 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0 bogus 0
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {expected integer but got "bogus"}
+test imgPhoto-4.58 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0 0 bogus
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {expected boolean value but got "bogus"}
+test imgPhoto-4.59 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 1 0 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency set: coordinates out of range}
+test imgPhoto-4.60 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set -1 0 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency set: coordinates out of range}
+test imgPhoto-4.61 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0 1 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency set: coordinates out of range}
+test imgPhoto-4.62 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0 -1 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency set: coordinates out of range}
+test imgPhoto-4.63 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white
+ photo1 transparency set 0 0 false
+ photo1 transparency get 0 0
+} -cleanup {
+ image delete photo1
+} -result 0
+test imgPhoto-4.64 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white
+ photo1 transparency set 0 0 true
+ photo1 transparency get 0 0
+} -cleanup {
+ image delete photo1
+} -result 1
+# Now for some heftier testing, checking that setting and resetting of pixels'
+# transparency status doesn't "leak" with any one-off errors.
+test imgPhoto-4.65 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white -to 0 0 3 3
+ checkImgTrans photo1
+} -cleanup {
+ image delete photo1
+} -result {}
+test imgPhoto-4.66 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white -to 0 0 3 3
+ photo1 blank
+ checkImgTrans photo1
+} -result {0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2}
+test imgPhoto-4.67 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white -to 0 0 3 3
+ checkImgTransLoop photo1 {
+ photo1 put white -to 0 0 3 3
+ photo1 transparency set $x $y 1
+ } {
+ photo1 transparency set $x $y 0
+ }
+} -cleanup {
+ image delete photo1
+} -result {0,0:. 0,1:. 0,2:. 1,0:. 1,1:. 1,2:. 2,0:. 2,1:. 2,2:.}
+test imgPhoto-4.68 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white -to 0 0 3 3
+ checkImgTransLoop photo1 {
+ photo1 blank
+ photo1 transparency set $x $y 0
+ } {
+ photo1 transparency set $x $y 1
+ }
+} -cleanup {
+ image delete photo1
+} -result {0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,2 1,0 1,1 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 1,0 1,1 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,1 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,1 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,1 1,2 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2.}
+test imgPhoto-4.69 {ImgPhotoCmd procedure: copy with -compositingrule} -setup {
+ # Test the compositing rules for copying images
+ image create photo photo1 -width 3 -height 3
+ image create photo photo2 -width 2 -height 2
+} -body {
+ photo1 copy photo2 -to 1 1 -compositingrule
+} -cleanup {
+ image delete photo1 photo2
+} -returnCodes error -result {the "-compositingrule" option requires a value}
+test imgPhoto-4.70 {ImgPhotoCmd procedure: copy with -compositingrule} -setup {
+ # Test the compositing rules for copying images
+ image create photo photo1 -width 3 -height 3
+ image create photo photo2 -width 2 -height 2
+} -body {
+ photo1 copy photo2 -to 1 1 -compositingrule BAD
+} -returnCodes error -cleanup {
+ image delete photo1 photo2
+} -result {bad compositing rule "BAD": must be overlay or set}
+test imgPhoto-4.71 {ImgPhotoCmd procedure: copy with -compositingrule} -setup {
+ # Test the compositing rules for copying images
+ image create photo photo1 -width 3 -height 3
+ image create photo photo2 -width 2 -height 2
+} -body {
+ # Tests default compositing rule
+ photo1 blank
+ photo2 blank
+ photo1 put white -to 0 0 2 2
+ photo2 put white -to 0 0 2 2
+ photo2 transparency set 0 0 true
+ photo1 copy photo2 -to 1 1
+ checkImgTrans photo1
+} -cleanup {
+ image delete photo1 photo2
+} -result {0,2 2,0}
+test imgPhoto-4.72 {ImgPhotoCmd procedure: copy with -compositingrule} -setup {
+ # Test the compositing rules for copying images
+ image create photo photo1 -width 3 -height 3
+ image create photo photo2 -width 2 -height 2
+} -body {
+ photo1 blank
+ photo2 blank
+ photo1 put white -to 0 0 2 2
+ photo2 put white -to 0 0 2 2
+ photo2 transparency set 0 0 true
+ photo1 copy photo2 -to 1 1 -compositingrule overlay
+ checkImgTrans photo1
+} -cleanup {
+ image delete photo1 photo2
+} -result {0,2 2,0}
+test imgPhoto-4.73 {ImgPhotoCmd procedure: copy with -compositingrule} -setup {
+ # Test the compositing rules for copying images
+ image create photo photo1 -width 3 -height 3
+ image create photo photo2 -width 2 -height 2
+} -body {
+ photo1 blank
+ photo2 blank
+ photo1 put white -to 0 0 2 2
+ photo2 put white -to 0 0 2 2
+ photo2 transparency set 0 0 true
+ photo1 copy photo2 -to 1 1 -compositingrule set
+ checkImgTrans photo1
+} -cleanup {
+ image delete photo1 photo2
+} -result {0,2 1,1 2,0}
+
+test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -constraints {
+ hasTeapotPhoto
+} -setup {
+ destroy .c
+ pack [canvas .c]
+ imageCleanup
+} -body {
+ image create photo photo1 -file $teapotPhotoFile
+ .c create image 0 0 -image photo1 -tags photo1.1
+ .c create image 256 0 -image photo1 -tags photo1.2
+ .c create image 0 256 -image photo1 -tags photo1.3
+ update
+ .c delete i1.1
+ photo1 configure -width 1
+ update
+ .c delete i1.2
+ photo1 configure -height 1
+ update
+ image delete photo1
+} -cleanup {
+ destroy .c
+} -result {}
+
+test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} -setup {
+ destroy .c
+ pack [canvas .c]
+ imageCleanup
+} -body {
+ image create photo photo1 -width 10 -height 10
+ photo1 blank
+ .c create image 10 10 -image photo1
+ update
+} -cleanup {
+ destroy .c
+ image delete photo1
+} -result {}
+
+test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} -constraints {
+ hasTeapotPhoto
+} -setup {
+ destroy .c
+ pack [canvas .c]
+ imageCleanup
+} -body {
+ image create photo photo1 -file $teapotPhotoFile
+ .c create image 0 0 -image photo1 -anchor nw
+ update
+ .c delete all
+ image delete photo1
+} -cleanup {
+ destroy .c
+} -result {}
+test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} -constraints {
+ hasTeapotPhoto
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create photo photo1 -file $teapotPhotoFile
+ pack [canvas .c]
+ .c create image 10 10 -image photo1 -anchor nw
+ button .b1 -image photo1
+ button .b2 -image photo1
+ button .b3 -image photo1
+ pack .b1 .b2 .b3
+ update
+ destroy .b2
+ update
+ destroy .b3
+ update
+ destroy .b1
+ update
+ .c delete all
+} -cleanup {
+ destroy .c
+ image delete photo1
+} -result {}
+test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} -constraints {
+ hasTeapotPhoto
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create photo photo1 -file $teapotPhotoFile
+ button .b1 -image photo1
+ frame .f -visual best
+ button .f.b2 -image photo1
+ pack .f.b2
+ pack .b1 .f
+ update
+ destroy .b1
+ update
+ .f.b2 configure -image {}
+ update
+ destroy .f
+ image delete photo1
+} -result {}
+
+test imgPhoto-8.1 {ImgPhotoDelete procedure} -constraints hasTeapotPhoto -body {
+ image create photo photo2 -file $teapotPhotoFile
+ image delete photo2
+} -result {}
+test imgPhoto-8.2 {ImgPhotoDelete procedure} -constraints {
+ hasTeapotPhoto
+} -setup {
+ set x {}
+} -body {
+ image create photo photo2 -file $teapotPhotoFile
+ rename photo2 newphoto2
+ lappend x [info command photo2] [info command new*] [newphoto2 cget -file]
+ image delete photo2
+ lappend x [info command new*]
+} -result [list {} newphoto2 $teapotPhotoFile {}]
+test imgPhoto-8.3 {ImgPhotoDelete procedure, name cleanup} -body {
+ image create photo photo1
+ image create photo photo2 -width 10 -height 10
+ image delete photo2
+ photo1 copy photo2
+} -returnCodes error -cleanup {
+ imageCleanup
+} -result {image "photo2" doesn't exist or is not a photo image}
+
+test imgPhoto-9.1 {ImgPhotoCmdDeletedProc procedure} -constraints {
+ hasTeapotPhoto
+} -body {
+ image create photo photo2 -file $teapotPhotoFile
+ rename photo2 {}
+ list [lsearch -exact [imageNames] photo2] [catch {photo2 foo} msg] $msg
+} -result {-1 1 {invalid command name "photo2"}}
+
+test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} -setup {
+ imageCleanup
+} -body {
+ image create photo photo1
+ photo1 put "{#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000}" -to 0 0
+ photo1 put "{#00ff00 #00ff00}" -to 2 0
+ list [photo1 get 2 0] [photo1 get 3 0] [photo1 get 4 0]
+} -result {{0 255 0} {0 255 0} {255 0 0}}
+
+test imgPhoto-11.1 {Tk_FindPhoto} -setup {
+ imageCleanup
+} -body {
+ image create bitmap i1
+ image create photo photo1
+ photo1 copy i1
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result {image "i1" doesn't exist or is not a photo image}
+
+test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} -constraints hasTeapotPhoto -body {
+ image create photo p3 -file $teapotPhotoFile
+ set result [list [p3 get 50 50] [p3 get 100 100]]
+ p3 copy p3 -zoom 2
+ lappend result [image width p3] [image height p3] [p3 get 100 100]
+} -cleanup {
+ image delete p3
+} -result {{19 92 192} {169 117 90} 512 512 {19 92 192}}
+
+test imgPhoto-13.1 {check separation of images in different interpreters} -setup {
+ imageCleanup
+ set data {
+ R0lGODlhQgBkAPUAANbWxs7Wxs7OxsbOxsbGxsbGvb3Gvca9vcDAwL21vbW1vbW1tbWtta2t
+ ta2ltaWltaWlraWctaWcrZycrZyUrZSUrZSMrZSMpYyMrYyMpYyEpYSEpYR7pYR7nHp7pYRz
+ pYRynHtzpXtznHtrnHNrnHNjnGtjnGtjlGtalGNalGNSlGNSjFpSlFpKlFpKjFJKjFJCjFI5
+ jEo5jEo5hEoxhEIxhDkphDkhhAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAQgBkAAAG
+ /kCEcEgsGo/IpHLJbDqf0Kh0Sq1ar9isdsvter/gsHhMLpvP6LR6zW673/C4fE6v2+/4vH7P
+ 7/v/gIGCg4SFhoeIiYqLjI2Oj5CRkpOUlZaXmJmOBZxXnAQEnKIIBUQJCguoDKkIBgWhpUev
+ CA4TDwgEUpwKERUaHCIiJCQjIiEUQhwqKiwqLjDQMCwoIha3oUO5ESMuLSwtLSIMsU4Tzi4o
+ JBwWFA8ODQoMCkIMq6sNDQ4UFhwlzC4qSGhgkMvCsAoM6E0oAWMCOSUFGrgQcauAgAACSqGa
+ l6SAK1EaJXBA0SIDBw0KBiCg8EtEBgEWYCxoooAigFwIJGgQYQIF/goTAjk6sXhxAwwFnHRO
+ mEmAwoQAIUo8lCWhRgoOElJVkJBQFCwhCRqkYlUE1QMKHEywoBCrQaeIMCgQeOCi3AkYMmRI
+ S5EuxEkN7OApkGDhF4fDxoSVMAFUBAWkRxI0a+XghVAkBSqMsFCBwj4OI0igSKGCdLN0wYKd
+ zGDBwUYhn6YOKUCioQECGk7INpIArQgUKkr87TyhAYIDQxQgLkYsRIcQIDjcgi2Lw8RYKaAz
+ MXCgAs8UJrZGmOA5AkeQBlqRKsIpvYMQDx4S4NCCxIJSKJpFYMIgnPlSF2ygAQWuCUHAAp6x
+ E4EEE5BXQQUWYLABBySoAIMLHBSBWwso/jxwIAoyzMAWEw3AEEJCt6nUwAQagCDCYcCQwJcK
+ 6QD3DDQxwNDCCSg9NIAGKpwwgQAOtDADDBbsdkQDIPhkwosDPgDPAg1EAME++1jTnhAKdAnb
+ VAR04EIJFAhwwQs0sBDfE7cZwEAE++yU2joOtDcKE7GUcoIKH6RSmwwnQCZFKAo8cE2es7my
+ HnuxKTDgAA6owEEBjoL3wqRUNDBCCnyRYMFMRSDoWYPvyBPPA738lt1KKTxgpjolrDDiFAWU
+ cAMKE+CipAMRZMDTCSSUQMIJPQHLwWOcrDKBCBpokAIJgmYqQgosxIAOCS8iJEQD7HR2QbMh
+ WCCEK7Ck90Cz/oAFu+YVigpTwTsLyJOcBJ6N6plxRihA3E4cOKTkFCU6FMoAA7wiygAZgURA
+ ekYsEJYFGTSATRccQEMjti8eZsEFFuA7z2WkEJAAl7iEQekEhQHGzgQR4INUKLB8pYAFJaQA
+ KhleKdwAByEkFswHIoxQQn4AcYBvGRosisDICCjQAIMJGnZYBsUd4JEZBIhQwgPzKFwAwggL
+ IHbOQzCtxZ1NL0BlKmmhIOwwHGTg2YMUEBdtKzBfbQWlhMHoHIXBnvABBGE9UMKNMKhgQgnG
+ nNQO0wVQoI4FEohFyr9GzDIYaaPxxWy0rCjKQJUMQvxBaMOgNMQChcU4DAkZ6PoV/hIUoP4i
+ Z7g/YHZHIPXeyWyONgsaCi4AOoLjXP8uhAAvPpCQ2Akr38UpXW60Ij8yPkMmwwj8KAI8QWtQ
+ +eXSixEb37WhcHQBERz2rdZ8leCBBcXNY3XevQ8VG/6+F5CACDYgATlmYYD27aRmLngBNADC
+ GGxxQEAWUJDzqpcctc2DARN4kNRgtJxhnKAFV0kIEhYAJ34IQwUhqkENYFCCE5BmGf9wwWmA
+ 5UGgXAAVtfCFMIgRLMbFLQIPYFACcMI7TjQoH2eJQIs2poEMYMAp5XGAvFrBCYS9ImzQG1vT
+ arGTEQhIhE7QjLA+MKDOxClGwuoJtWi0uBIUIxjDSE2wQ4iHl7ywQDjGwZws/NcAlgBjaKQJ
+ JDVuoQBeUeACoFkMcFqgQL1IgxpRSsjsqHA/gy0tHvmAx2z2BxIupaJrnVxCEAAAOw==
+ }
+ interp create x1
+ interp create x2
+ x1 eval {load {} Tk}
+ x2 eval {load {} Tk}
+} -body {
+ x1 eval [list image create photo T1_data -data $data]
+ x2 eval [list image create photo T1_data -data $data]
+} -cleanup {
+ interp delete x1
+ interp delete x2
+} -result T1_data
+
+test imgPhoto-14.1 {GIF writes work correctly} -setup {
+ set data {
+ R0lGODlhYwA5APcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgAysnGy8hKzM
+ hASs3MTcjAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMDAwP8AAAD/
+ AP//AAAA//8A/wD//////ywAAAAAYwA5AAAI/wAZCBxIsKDBgwgTKlzIsKHD
+ hxAjSpxIsaLFixgzatzIsaPHjyBDihxJsqTJkyhTqlzJsqXLlzBjypxJs6bN
+ mzhz6tzJs6fPn0CDCh1KtKhRiwoSKEXAtGlTpUqPGkyagOmCq1edNsWalWkC
+ BUSXIuDqFepBqFWtZv3KU+zYrkrBSqT6dgECtjOTbu16NwFHvV3lshRLti/J
+ qlgRCE6ZuO9ik4Dt+k0ZVyZiyVIvXr77ODPEy5g9T4zMWfTEzXdNz1VbWvXn
+ uqldP1TAOrbshqBb314Y2W7n3Qdpv7UNPCHpycUVbv6dnODy5sqzQldIe8H0
+ hciva9/Ovbv37+BzBgEEADs=
+ }
+ set tmpfilename [makeFile {} imgPhoto-14.1.gif]
+ removeFile $tmpfilename
+} -body {
+ image create photo photo1 -data $data
+ photo1 write $tmpfilename -format gif
+ image create photo photo2 -file $tmpfilename
+ string equal [photo1 data] [photo2 data]
+} -cleanup {
+ catch {image delete photo1 photo2}
+ catch {file delete -force $tmpfilename}
+} -result 1
+test imgPhoto-14.2 {GIF -index handler buffer sizing} -setup {
+ set data {
+ R0lGODlhIAAgAKEAAPkOSQsi7////////yH/C05FVFNDQVBFMi4wAwEAAAAh
+ +QQJMgAAACwGAAYAFAAUAAACEYyPqcvtD6OctNqLs968+68VACH5BAkyAAEA
+ LAMAAwAaABoAAAI0jH+gq+gfmFzQzUsr3gBybn1gIm5kaUaoubbuC8fyTNel
+ Ohv1CSO533u8KrgbUfc5Ci/EAgA7
+ }
+} -body {
+ # Bug 1458234 makes this crash when trying to access buffers of the wrong
+ # size, caused when the initial frame is not the largest frame.
+ set i [image create photo]
+ $i configure -data $data -format {gif -index 2}
+} -cleanup {
+ image delete $i
+} -returnCodes error -result {no image data for this index}
+test imgPhoto-14.3 {GIF -index interleaving and small frames} -body {
+ # Interleaved GIFs used to crash us when a smaller subsequent frame was
+ # accessed.
+ set i [image create photo]
+ $i configure -format {GIF -index 1} -data {
+ R0lGODdhAQAFAPAAAP8AAAAAACwAAAAAAQAFAEACAoRdACwAAAAAAQAEAEACAoRRADs=
+ }
+} -cleanup {
+ image delete $i
+}
+test imgPhoto-14.4 {GIF buffer overflow} -setup {
+ set data {
+ R0lGODlhCgAKAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgMDAwP8AAAD/
+ AP//AAAA//8A/wD//////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAMwAAZgAAmQAAzAAA/wAzAAAzMwAzZgAzmQAzzAAz/wBmAABmMwBmZgBm
+ mQBmzABm/wCZAACZMwCZZgCZmQCZzACZ/wDMAADMMwDMZgDMmQDMzADM/wD/
+ AAD/MwD/ZgD/mQD/zAD//zMAADMAMzMAZjMAmTMAzDMA/zMzADMzMzMzZjMz
+ mTMzzDMz/zNmADNmMzNmZjNmmTNmzDNm/zOZADOZMzOZZjOZmTOZzDOZ/zPM
+ ADPMMzPMZjPMmTPMzDPM/zP/ADP/MzP/ZjP/mTP/zDP//2YAAGYAM2YAZmYA
+ mWYAzGYA/2YzAGYzM2YzZmYzmWYzzGYz/2ZmAGZmM2ZmZmZmmWZmzGZm/2aZ
+ AGaZM2aZZmaZmWaZzGaZ/2bMAGbMM2bMZmbMmWbMzGbM/2b/AGb/M2b/Zmb/
+ mWb/zGb//5kAAJkAM5kAZpkAmZkAzJkA/5kzAJkzM5kzZpkzmZkzzJkz/5lm
+ AJlmM5lmZplmmZlmzJlm/5mZAJmZM5mZZpmZmZmZzJmZ/5nMAJnMM5nMZpnM
+ mZnMzJnM/5n/AJn/M5n/Zpn/mZn/zJn//8wAAMwAM8wAZswAmcwAzMwA/8wz
+ AMwzM8wzZswzmcwzzMwz/8xmAMxmM8xmZsxmmcxmzMxm/8yZAMyZM8yZZsyZ
+ mcyZzMyZ/8zMAMzMM8zMZszMmczMzMzM/8z/AMz/M8z/Zsz/mcz/zMz///8A
+ AP8AM/8AZv8Amf8AzP8A//8zAP8zM/8zZv8zmf8zzP8z//9mAP9mM/9mZv9m
+ mf9mzP9m//+ZAP+ZM/+ZZv+Zmf+ZzP+Z///MAP/MM//MZv/Mmf/MzP/M////
+ AP//M///Zv//mf//zP///yH5BAEAABAALAAAAAAKAAoAABUSAAD/HEiwoMGD
+ CBMqXMiwYcKAADs=
+ }
+} -body {
+ # This crashes Tk up to 8.4.17 and 8.5.0
+ set i [image create photo]
+ $i configure -data $data
+} -cleanup {
+ image delete $i
+} -returnCodes error -result {malformed image}
+
+test imgPhoto-15.1 {photo images can fail to allocate memory gracefully} -constraints {
+ nonPortable
+} -body {
+ # This is not portable to very large machines with more than around 3GB of
+ # free memory available...
+ image create photo -width 32000 -height 32000
+} -returnCodes error -result {not enough free memory for image buffer}
+
+test imgPhoto-16.1 {copying to self doesn't access freed memory} -setup {
+ set i [image create photo]
+} -body {
+ # Bug 877950 makes this crash when trying to copy out of a deallocated
+ # area.
+ $i put red -to 0 0 1000 1000
+ $i copy $i -from 0 0 1000 1000 -to 500 0
+} -cleanup {
+ image delete $i
+} -result {}
+
+# Check that we can guess our supported output formats [Bug 2983824]
+test imgPhoto-17.1 {photo write: format guessing from filename} -setup {
+ set i [image create photo -width 3 -height 3]
+} -body {
+ set f [makeFile {} test.png]
+ $i write $f
+ set fd [open $f]
+ seek $fd 1
+ read $fd 3
+} -cleanup {
+ catch {close $fd}
+ image delete $i
+ catch {removeFile $f}
+} -result PNG
+test imgPhoto-17.2 {photo write: format guessing from filename} -setup {
+ set i [image create photo -width 3 -height 3]
+} -body {
+ set f [makeFile {} test.gif]
+ $i write $f
+ set fd [open $f]
+ read $fd 3
+} -cleanup {
+ catch {close $fd}
+ image delete $i
+ catch {removeFile $f}
+} -result GIF
+test imgPhoto-17.3 {photo write: format guessing from filename} -setup {
+ set i [image create photo -width 3 -height 3]
+} -body {
+ set f [makeFile {} test.ppm]
+ $i write $f
+ set fd [open $f]
+ read $fd 3
+} -cleanup {
+ catch {close $fd}
+ image delete $i
+ catch {removeFile $f}
+} -result "P6\n"
+
+# ----------------------------------------------------------------------
+
+catch {rename foreachPixel {}}
+catch {rename checkImgTrans {}}
+catch {rename checkImgTransLoop {}}
+imageFinish
+
+# cleanup
+removeFile README-imgPhoto
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/listbox.test b/tk8.6/tests/listbox.test
new file mode 100644
index 0000000..407420c
--- /dev/null
+++ b/tk8.6/tests/listbox.test
@@ -0,0 +1,3190 @@
+# This file is a Tcl script to test out the "listbox" command
+# of Tk. It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1993-1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+set fixed {Courier -12}
+
+proc record {name args} {
+ global log
+ lappend log [format {%s %.6g %.6g} $name {*}$args]
+}
+
+proc getsize w {
+ regexp {(^[^+-]*)} [wm geometry $w] foo x
+ return $x
+}
+
+proc resetGridInfo {} {
+ # Some window managers, such as mwm, don't reset gridding information
+ # unless the window is withdrawn and re-mapped. If this procedure
+ # isn't invoked, the window manager will stay in gridded mode, which
+ # can cause all sorts of problems. The "wm positionfrom" command is
+ # needed so that the window manager doesn't ask the user to
+ # manually position the window when it is re-mapped.
+
+ wm withdraw .
+ wm positionfrom . user
+ wm deiconify .
+}
+
+# Procedure that creates a second listbox for checking things related
+# to partially visible lines.
+
+proc mkPartial {{w .partial}} {
+ destroy $w
+ toplevel $w
+ wm geometry $w +0+0
+ listbox $w.l -width 30 -height 5
+ pack $w.l -expand 1 -fill both
+ $w.l insert end one two three four five six seven eight nine ten \
+ eleven twelve thirteen fourteen fifteen
+ update
+ scan [wm geometry $w] "%dx%d" width height
+ wm geometry $w ${width}x[expr $height-3]
+ update
+}
+
+# Create entries in the option database to be sure that geometry options
+# like border width have predictable values.
+
+option add *Listbox.borderWidth 2
+option add *Listbox.selectBorderWidth 1
+option add *Listbox.highlightThickness 2
+option add *Listbox.font {Helvetica -12 bold}
+
+# Listbox used in 3.* configuration options tests
+listbox .l
+pack .l
+update
+resetGridInfo
+test listbox-1.1 {configuration options} -body {
+ .l configure -activestyle under
+ list [lindex [.l configure -activestyle] 4] [.l cget -activestyle]
+} -cleanup {
+ .l configure -activestyle [lindex [.l configure -activestyle] 3]
+} -result {underline underline}
+test listbox-1.2 {configuration options} -body {
+ .l configure -activestyle foo
+} -returnCodes error -result {bad activestyle "foo": must be dotbox, none, or underline}
+test listbox-1.3 {configuration options} -body {
+ .l configure -background #ff0000
+ list [lindex [.l configure -background] 4] [.l cget -background]
+} -cleanup {
+ .l configure -background [lindex [.l configure -background] 3]
+} -result {{#ff0000} #ff0000}
+test listbox-1.4 {configuration options} -body {
+ .l configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test listbox-1.5 {configuration options} -body {
+ .l configure -bd 4
+ list [lindex [.l configure -bd] 4] [.l cget -bd]
+} -cleanup {
+ .l configure -bd [lindex [.l configure -bd] 3]
+} -result {4 4}
+test listbox-1.6 {configuration options} -body {
+ .l configure -bd badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test listbox-1.7 {configuration options} -body {
+ .l configure -bg #ff0000
+ list [lindex [.l configure -bg] 4] [.l cget -bg]
+} -cleanup {
+ .l configure -bg [lindex [.l configure -bg] 3]
+} -result {{#ff0000} #ff0000}
+test listbox-1.8 {configuration options} -body {
+ .l configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test listbox-1.9 {configuration options} -body {
+ .l configure -borderwidth 1.3
+ list [lindex [.l configure -borderwidth] 4] [.l cget -borderwidth]
+} -cleanup {
+ .l configure -borderwidth [lindex [.l configure -borderwidth] 3]
+} -result {1 1}
+test listbox-1.10 {configuration options} -body {
+ .l configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test listbox-1.11 {configuration options} -body {
+ .l configure -cursor arrow
+ list [lindex [.l configure -cursor] 4] [.l cget -cursor]
+} -cleanup {
+ .l configure -cursor [lindex [.l configure -cursor] 3]
+} -result {arrow arrow}
+test listbox-1.12 {configuration options} -body {
+ .l configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test listbox-1.13 {configuration options} -body {
+ .l configure -disabledforeground #110022
+ list [lindex [.l configure -disabledforeground] 4] [.l cget -disabledforeground]
+} -cleanup {
+ .l configure -disabledforeground [lindex [.l configure -disabledforeground] 3]
+} -result {{#110022} #110022}
+test listbox-1.14 {configuration options} -body {
+ .l configure -disabledforeground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-1.15 {configuration options} -body {
+ .l configure -exportselection yes
+ list [lindex [.l configure -exportselection] 4] [.l cget -exportselection]
+} -cleanup {
+ .l configure -exportselection [lindex [.l configure -exportselection] 3]
+} -result {1 1}
+test listbox-1.16 {configuration options} -body {
+ .l configure -exportselection xyzzy
+} -returnCodes error -result {expected boolean value but got "xyzzy"}
+test listbox-1.17 {configuration options} -body {
+ .l configure -fg #110022
+ list [lindex [.l configure -fg] 4] [.l cget -fg]
+} -cleanup {
+ .l configure -fg [lindex [.l configure -fg] 3]
+} -result {{#110022} #110022}
+test listbox-1.18 {configuration options} -body {
+ .l configure -fg bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-1.19 {configuration options} -body {
+ .l configure -font {Helvetica 12}
+ list [lindex [.l configure -font] 4] [.l cget -font]
+} -cleanup {
+ .l configure -font [lindex [.l configure -font] 3]
+} -result {{Helvetica 12} {Helvetica 12}}
+test listbox-1.21 {configuration options} -body {
+ .l configure -foreground #110022
+ list [lindex [.l configure -foreground] 4] [.l cget -foreground]
+} -cleanup {
+ .l configure -foreground [lindex [.l configure -foreground] 3]
+} -result {{#110022} #110022}
+test listbox-1.22 {configuration options} -body {
+ .l configure -foreground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-1.23 {configuration options} -body {
+ .l configure -height 30
+ list [lindex [.l configure -height] 4] [.l cget -height]
+} -cleanup {
+ .l configure -height [lindex [.l configure -height] 3]
+} -result {30 30}
+test listbox-1.24 {configuration options} -body {
+ .l configure -height 20p
+} -returnCodes error -result {expected integer but got "20p"}
+test listbox-1.25 {configuration options} -body {
+ .l configure -highlightbackground #112233
+ list [lindex [.l configure -highlightbackground] 4] [.l cget -highlightbackground]
+} -cleanup {
+ .l configure -highlightbackground [lindex [.l configure -highlightbackground] 3]
+} -result {{#112233} #112233}
+test listbox-1.26 {configuration options} -body {
+ .l configure -highlightbackground ugly
+} -returnCodes error -result {unknown color name "ugly"}
+test listbox-1.27 {configuration options} -body {
+ .l configure -highlightcolor #123456
+ list [lindex [.l configure -highlightcolor] 4] [.l cget -highlightcolor]
+} -cleanup {
+ .l configure -highlightcolor [lindex [.l configure -highlightcolor] 3]
+} -result {{#123456} #123456}
+test listbox-1.28 {configuration options} -body {
+ .l configure -highlightcolor bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-1.29 {configuration options} -body {
+ .l configure -highlightthickness 6
+ list [lindex [.l configure -highlightthickness] 4] [.l cget -highlightthickness]
+} -cleanup {
+ .l configure -highlightthickness [lindex [.l configure -highlightthickness] 3]
+} -result {6 6}
+test listbox-1.30 {configuration options} -body {
+ .l configure -highlightthickness bogus
+} -returnCodes error -result {bad screen distance "bogus"}
+test listbox-1.31 {configuration options} -body {
+ .l configure -highlightthickness -2
+ list [lindex [.l configure -highlightthickness] 4] [.l cget -highlightthickness]
+} -cleanup {
+ .l configure -highlightthickness [lindex [.l configure -highlightthickness] 3]
+} -result {0 0}
+test listbox-1.32.1 {configuration options} -setup {
+ set res {}
+} -body {
+ .l configure -justify left
+ set res [list [lindex [.l configure -justify] 4] [.l cget -justify]]
+ .l configure -justify center
+ lappend res [lindex [.l configure -justify] 4] [.l cget -justify]
+ .l configure -justify right
+ lappend res [lindex [.l configure -justify] 4] [.l cget -justify]
+} -cleanup {
+ .l configure -justify [lindex [.l configure -justify] 3]
+} -result {left left center center right right}
+test listbox-1.32.2 {configuration options} -body {
+ .l configure -justify bogus
+} -returnCodes error -result {bad justification "bogus": must be left, right, or center}
+test listbox-1.33 {configuration options} -body {
+ .l configure -relief groove
+ list [lindex [.l configure -relief] 4] [.l cget -relief]
+} -cleanup {
+ .l configure -relief [lindex [.l configure -relief] 3]
+} -result {groove groove}
+test listbox-1.34 {configuration options} -body {
+ .l configure -relief 1.5
+} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test listbox-1.35 {configuration options} -body {
+ .l configure -selectbackground #110022
+ list [lindex [.l configure -selectbackground] 4] [.l cget -selectbackground]
+} -cleanup {
+ .l configure -selectbackground [lindex [.l configure -selectbackground] 3]
+} -result {{#110022} #110022}
+test listbox-1.36 {configuration options} -body {
+ .l configure -selectbackground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-1.37 {configuration options} -body {
+ .l configure -selectborderwidth 1.3
+ list [lindex [.l configure -selectborderwidth] 4] [.l cget -selectborderwidth]
+} -cleanup {
+ .l configure -selectborderwidth [lindex [.l configure -selectborderwidth] 3]
+} -result {1 1}
+test listbox-1.38 {configuration options} -body {
+ .l configure -selectborderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test listbox-1.39 {configuration options} -body {
+ .l configure -selectforeground #654321
+ list [lindex [.l configure -selectforeground] 4] [.l cget -selectforeground]
+} -cleanup {
+ .l configure -selectforeground [lindex [.l configure -selectforeground] 3]
+} -result {{#654321} #654321}
+test listbox-1.40 {configuration options} -body {
+ .l configure -selectforeground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-1.41 {configuration options} -body {
+ .l configure -selectmode string
+ list [lindex [.l configure -selectmode] 4] [.l cget -selectmode]
+} -cleanup {
+ .l configure -selectmode [lindex [.l configure -selectmode] 3]
+} -result {string string}
+test listbox-1.43 {configuration options} -body {
+ .l configure -setgrid false
+ list [lindex [.l configure -setgrid] 4] [.l cget -setgrid]
+} -cleanup {
+ .l configure -setgrid [lindex [.l configure -setgrid] 3]
+} -result {0 0}
+test listbox-1.44 {configuration options} -body {
+ .l configure -setgrid lousy
+} -returnCodes error -result {expected boolean value but got "lousy"}
+test listbox-1.45 {configuration options} -body {
+ .l configure -state disabled
+ list [lindex [.l configure -state] 4] [.l cget -state]
+} -cleanup {
+ .l configure -state [lindex [.l configure -state] 3]
+} -result {disabled disabled}
+test listbox-1.46 {configuration options} -body {
+ .l configure -state foo
+} -returnCodes error -result {bad state "foo": must be disabled or normal}
+test listbox-1.47 {configuration options} -body {
+ .l configure -takefocus {any string}
+ list [lindex [.l configure -takefocus] 4] [.l cget -takefocus]
+} -cleanup {
+ .l configure -takefocus [lindex [.l configure -takefocus] 3]
+} -result {{any string} {any string}}
+test listbox-1.49 {configuration options} -body {
+ .l configure -width 45
+ list [lindex [.l configure -width] 4] [.l cget -width]
+} -cleanup {
+ .l configure -width [lindex [.l configure -width] 3]
+} -result {45 45}
+test listbox-1.50 {configuration options} -body {
+ .l configure -width 3p
+} -returnCodes error -result {expected integer but got "3p"}
+test listbox-1.51 {configuration options} -body {
+ .l configure -xscrollcommand {Some command}
+ list [lindex [.l configure -xscrollcommand] 4] [.l cget -xscrollcommand]
+} -cleanup {
+ .l configure -xscrollcommand [lindex [.l configure -xscrollcommand] 3]
+} -result {{Some command} {Some command}}
+test listbox-1.53 {configuration options} -body {
+ .l configure -yscrollcommand {Another command}
+ list [lindex [.l configure -yscrollcommand] 4] [.l cget -yscrollcommand]
+} -cleanup {
+ .l configure -yscrollcommand [lindex [.l configure -yscrollcommand] 3]
+} -result {{Another command} {Another command}}
+test listbox-1.55 {configuration options} -body {
+ .l configure -listvar testVariable
+ list [lindex [.l configure -listvar] 4] [.l cget -listvar]
+} -cleanup {
+ .l configure -listvar [lindex [.l configure -listvar] 3]
+} -result {testVariable testVariable}
+
+
+test listbox-2.1 {Tk_ListboxCmd procedure} -body {
+ listbox
+} -returnCodes error -result {wrong # args: should be "listbox pathName ?-option value ...?"}
+test listbox-2.2 {Tk_ListboxCmd procedure} -body {
+ listbox gorp
+} -returnCodes error -result {bad window path name "gorp"}
+test listbox-2.3 {Tk_ListboxCmd procedure} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ list [winfo exists .l] [winfo class .l] [info commands .l]
+} -result {1 Listbox .l}
+test listbox-2.4 {Tk_ListboxCmd procedure} -setup {
+ destroy .l
+} -body {
+ listbox .l -gorp foo
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {unknown option "-gorp"}
+test listbox-2.4.1 {Tk_ListboxCmd procedure} -setup {
+ destroy .l
+} -body {
+ catch {listbox .l -gorp foo}
+ list [winfo exists .l] [info commands .l]
+} -cleanup {
+ destroy .l
+} -result {0 {}}
+test listbox-2.5 {Tk_ListboxCmd procedure} -setup {
+ destroy .l
+} -body {
+ listbox .l
+} -cleanup {
+ destroy .l
+} -result {.l}
+
+
+# Listbox used in 3.1 -3.115 tests
+destroy .l
+listbox .l -width 20 -height 5 -bd 4 -highlightthickness 1 -selectborderwidth 2
+pack .l
+.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 el12 el13 el14 \
+ el15 el16 el17
+update
+test listbox-3.1 {ListboxWidgetCmd procedure} -body {
+ .l
+} -returnCodes error -result {wrong # args: should be ".l option ?arg ...?"}
+test listbox-3.2 {ListboxWidgetCmd procedure, "activate" option} -body {
+ .l activate
+} -returnCodes error -result {wrong # args: should be ".l activate index"}
+test listbox-3.3 {ListboxWidgetCmd procedure, "activate" option} -body {
+ .l activate a b
+} -returnCodes error -result {wrong # args: should be ".l activate index"}
+test listbox-3.4 {ListboxWidgetCmd procedure, "activate" option} -body {
+ .l activate fooey
+} -returnCodes error -result {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number}
+test listbox-3.5 {ListboxWidgetCmd procedure, "activate" option} -body {
+ .l activate 3
+ .l index active
+} -result 3
+test listbox-3.6 {ListboxWidgetCmd procedure, "activate" option} -body {
+ .l activate -1
+ .l index active
+} -result {0}
+test listbox-3.7 {ListboxWidgetCmd procedure, "activate" option} -body {
+ .l activate 30
+ .l index active
+} -result {17}
+test listbox-3.8 {ListboxWidgetCmd procedure, "activate" option} -body {
+ .l activate end
+ .l index active
+} -result {17}
+test listbox-3.9 {ListboxWidgetCmd procedure, "bbox" option} -body {
+ .l bbox
+} -returnCodes error -result {wrong # args: should be ".l bbox index"}
+test listbox-3.10 {ListboxWidgetCmd procedure, "bbox" option} -body {
+ .l bbox a b
+} -returnCodes error -result {wrong # args: should be ".l bbox index"}
+test listbox-3.11 {ListboxWidgetCmd procedure, "bbox" option} -body {
+ .l bbox fooey
+} -returnCodes error -result {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number}
+test listbox-3.12 {ListboxWidgetCmd procedure, "bbox" option} -body {
+ .l yview 3
+ update
+ list [.l bbox 2] [.l bbox 8]
+} -result {{} {}}
+test listbox-3.13 {ListboxWidgetCmd procedure, "bbox" option} -cleanup {
+ destroy .l2
+} -body {
+ # Used to generate a core dump before a bug was fixed (the last
+ # element would be on-screen if it existed, but it doesn't exist).
+
+ listbox .l2
+ pack .l2 -side top
+ tkwait visibility .l2
+ set x [.l2 bbox 0]
+ destroy .l2
+ set x
+} -cleanup {
+ destroy .l2
+} -result {}
+test listbox-3.14 {ListboxWidgetCmd procedure, "bbox" option} -constraints {
+ fonts
+} -body {
+ .l yview 3
+ update
+ list [.l bbox 3] [.l bbox 4]
+} -result {{7 7 17 14} {7 26 17 14}}
+test listbox-3.15 {ListboxWidgetCmd procedure, "bbox" option} -constraints {
+ fonts
+} -body {
+ .l yview 0
+ update
+ list [.l bbox -1] [.l bbox 0]
+} -result {{} {7 7 17 14}}
+test listbox-3.16 {ListboxWidgetCmd procedure, "bbox" option} -constraints {
+ fonts
+} -body {
+ .l yview end
+ update
+ list [.l bbox 17] [.l bbox end] [.l bbox 18]
+} -result {{7 83 24 14} {7 83 24 14} {}}
+test listbox-3.17 {ListboxWidgetCmd procedure, "bbox" option} -constraints {
+ fonts
+} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm geom .t +0+0
+ listbox .t.l -width 10 -height 5
+ .t.l insert 0 "Short" "Somewhat longer" "Really, quite a whole lot longer than can possibly fit on the screen" "Short"
+ pack .t.l
+ update
+ .t.l xview moveto .2
+ .t.l bbox 2
+} -cleanup {
+ destroy .t
+} -result {-72 39 393 14}
+test listbox-3.18 {ListboxWidgetCmd procedure, "bbox" option, partial last line} -constraints {
+ fonts
+} -body {
+ mkPartial
+ list [.partial.l bbox 3] [.partial.l bbox 4]
+} -result {{5 56 24 14} {5 73 23 14}}
+test listbox-3.18a {ListboxWidgetCmd procedure, "bbox" option, justified} -constraints {
+ fonts
+} -setup {
+ destroy .top.l .top
+ unset -nocomplain res
+} -body {
+ toplevel .top
+ listbox .top.l -justify left
+ .top.l insert end Item1 LongerItem2 MuchLongerItem3
+ pack .top.l
+ update
+ lappend res [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2]
+ .top.l configure -justify center
+ lappend res [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2]
+ .top.l configure -justify right
+ lappend res [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2]
+} -cleanup {
+ destroy .top.l .top
+ unset -nocomplain res
+} -result [list \
+ {5 5 34 14} {5 22 74 14} {5 39 106 14} \
+ {58 5 34 14} {38 22 74 14} {22 39 106 14} \
+ {111 5 34 14} {71 22 74 14} {39 39 106 14} \
+]
+test listbox-3.18b {ListboxWidgetCmd procedure, "bbox" option, justified, non-default borderwidth} -setup {
+ destroy .top.l .top
+ unset -nocomplain lres res
+} -body {
+ # This test checks whether all "x" values from bbox for different size
+ # items with different justification settings are all positive or zero
+ # This checks a bit the calculation of this x value with non-default
+ # borders widths of the listbox
+ toplevel .top
+ listbox .top.l -justify left -borderwidth 17 -highlightthickness 19 -selectborderwidth 22
+ .top.l insert end Item1 LongerItem2 MuchLongerItem3
+ .top.l selection set 1
+ pack .top.l
+ update
+ lappend lres [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2]
+ .top.l configure -justify center
+ lappend lres [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2]
+ .top.l configure -justify right
+ lappend lres [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2]
+ set res 1
+ for {set i 0} {$i < [llength $lres]} {incr i 4} {
+ set res [expr {$res * [expr {[lindex $lres $i] >= 0}] }]
+ }
+ set res
+} -cleanup {
+ destroy .top.l .top
+ unset -nocomplain lres res
+} -result {1}
+test listbox-3.19 {ListboxWidgetCmd procedure, "cget" option} -body {
+ .l cget
+} -returnCodes error -result {wrong # args: should be ".l cget option"}
+test listbox-3.20 {ListboxWidgetCmd procedure, "cget" option} -body {
+ .l cget a b
+} -returnCodes error -result {wrong # args: should be ".l cget option"}
+test listbox-3.21 {ListboxWidgetCmd procedure, "cget" option} -body {
+ .l cget -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test listbox-3.22 {ListboxWidgetCmd procedure, "cget" option} -body {
+ .l cget -setgrid
+} -result {0}
+test listbox-3.23 {ListboxWidgetCmd procedure, "configure" option} -body {
+ llength [.l configure]
+} -result {28}
+test listbox-3.24 {ListboxWidgetCmd procedure, "configure" option} -body {
+ .l configure -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test listbox-3.25 {ListboxWidgetCmd procedure, "configure" option} -body {
+ .l configure -setgrid
+} -result {-setgrid setGrid SetGrid 0 0}
+test listbox-3.26 {ListboxWidgetCmd procedure, "configure" option} -body {
+ .l configure -gorp is_messy
+} -returnCodes error -result {unknown option "-gorp"}
+test listbox-3.27 {ListboxWidgetCmd procedure, "configure" option} -body {
+ set oldbd [.l cget -bd]
+ set oldht [.l cget -highlightthickness]
+ .l configure -bd 3 -highlightthickness 0
+ set x "[.l cget -bd] [.l cget -highlightthickness]"
+ .l configure -bd $oldbd -highlightthickness $oldht
+ set x
+} -result {3 0}
+test listbox-3.28 {ListboxWidgetCmd procedure, "curselection" option} -body {
+ .l curselection a
+} -returnCodes error -result {wrong # args: should be ".l curselection"}
+test listbox-3.29 {ListboxWidgetCmd procedure, "curselection" option} -body {
+ .l selection clear 0 end
+ .l selection set 3 6
+ .l selection set 9
+ .l curselection
+} -result {3 4 5 6 9}
+test listbox-3.30 {ListboxWidgetCmd procedure, "delete" option} -body {
+ .l delete
+} -returnCodes error -result {wrong # args: should be ".l delete firstIndex ?lastIndex?"}
+test listbox-3.31 {ListboxWidgetCmd procedure, "delete" option} -body {
+ .l delete a b c
+} -returnCodes error -result {wrong # args: should be ".l delete firstIndex ?lastIndex?"}
+test listbox-3.32 {ListboxWidgetCmd procedure, "delete" option} -body {
+ .l delete badIndex
+} -returnCodes error -result {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number}
+test listbox-3.33 {ListboxWidgetCmd procedure, "delete" option} -body {
+ .l delete 2 123ab
+} -returnCodes error -result {bad listbox index "123ab": must be active, anchor, end, @x,y, or a number}
+test listbox-3.34 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
+ .l2 delete 3
+ list [.l2 get 2] [.l2 get 3] [.l2 index end]
+} -cleanup {
+ destroy .l2
+} -result {el2 el4 7}
+test listbox-3.35 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
+ .l2 delete 2 4
+ list [.l2 get 1] [.l2 get 2] [.l2 index end]
+} -cleanup {
+ destroy .l2
+} -result {el1 el5 5}
+test listbox-3.36 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
+ .l2 delete -3 2
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result {el3 el4 el5 el6 el7}
+test listbox-3.37 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
+ .l2 delete -3 -1
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result {el0 el1 el2 el3 el4 el5 el6 el7}
+test listbox-3.38 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
+ .l2 delete 2 end
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result {el0 el1}
+test listbox-3.39 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
+ .l2 delete 5 20
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result {el0 el1 el2 el3 el4}
+test listbox-3.40 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
+ .l2 delete end 20
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result {el0 el1 el2 el3 el4 el5 el6}
+test listbox-3.41 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
+ .l2 delete 8 20
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result {el0 el1 el2 el3 el4 el5 el6 el7}
+test listbox-3.42 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get
+} -returnCodes error -result {wrong # args: should be ".l get firstIndex ?lastIndex?"}
+test listbox-3.43 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get a b c
+} -returnCodes error -result {wrong # args: should be ".l get firstIndex ?lastIndex?"}
+test listbox-3.44 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get 2.4
+} -returnCodes error -result {bad listbox index "2.4": must be active, anchor, end, @x,y, or a number}
+test listbox-3.45 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get end bogus
+} -returnCodes error -result {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number}
+test listbox-3.46 {ListboxWidgetCmd procedure, "get" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
+ list [.l2 get 0] [.l2 get 3] [.l2 get end]
+} -cleanup {
+ destroy .l2
+} -result {el0 el3 el7}
+test listbox-3.47 {ListboxWidgetCmd procedure, "get" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ list [.l2 get 0] [.l2 get end]
+} -cleanup {
+ destroy .l2
+} -result {{} {}}
+test listbox-3.48 {ListboxWidgetCmd procedure, "get" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert 0 el0 el1 el2 "two words" el4 el5 el6 el7
+ .l2 get 3 end
+} -cleanup {
+ destroy .l2
+} -result {{two words} el4 el5 el6 el7}
+test listbox-3.49 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get -1
+} -result {}
+test listbox-3.50 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get -2 -1
+} -result {}
+test listbox-3.51 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get -2 3
+} -result {el0 el1 el2 el3}
+test listbox-3.52 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get 12 end
+} -result {el12 el13 el14 el15 el16 el17}
+test listbox-3.53 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get 12 20
+} -result {el12 el13 el14 el15 el16 el17}
+test listbox-3.54 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get end
+} -result {el17}
+test listbox-3.55 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get 30
+} -result {}
+test listbox-3.56 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get 30 35
+} -result {}
+test listbox-3.57 {ListboxWidgetCmd procedure, "index" option} -body {
+ .l index
+} -returnCodes error -result {wrong # args: should be ".l index index"}
+test listbox-3.58 {ListboxWidgetCmd procedure, "index" option} -body {
+ .l index a b
+} -returnCodes error -result {wrong # args: should be ".l index index"}
+test listbox-3.59 {ListboxWidgetCmd procedure, "index" option} -body {
+ .l index @
+} -returnCodes error -result {bad listbox index "@": must be active, anchor, end, @x,y, or a number}
+test listbox-3.60 {ListboxWidgetCmd procedure, "index" option} -body {
+ .l index 2
+} -result 2
+test listbox-3.61 {ListboxWidgetCmd procedure, "index" option} -body {
+ .l index -1
+} -result {-1}
+test listbox-3.62 {ListboxWidgetCmd procedure, "index" option} -body {
+ .l index end
+} -result 18
+test listbox-3.63 {ListboxWidgetCmd procedure, "index" option} -body {
+ .l index 34
+} -result 34
+test listbox-3.64 {ListboxWidgetCmd procedure, "insert" option} -body {
+ .l insert
+} -returnCodes error -result {wrong # args: should be ".l insert index ?element ...?"}
+test listbox-3.65 {ListboxWidgetCmd procedure, "insert" option} -body {
+ .l insert badIndex
+} -returnCodes error -result {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number}
+test listbox-3.66 {ListboxWidgetCmd procedure, "insert" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert end a b c d e
+ .l2 insert 3 x y z
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result {a b c x y z d e}
+test listbox-3.67 {ListboxWidgetCmd procedure, "insert" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert end a b c
+ .l2 insert -1 x
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result {x a b c}
+test listbox-3.68 {ListboxWidgetCmd procedure, "insert" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert end a b c
+ .l2 insert end x
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result {a b c x}
+test listbox-3.69 {ListboxWidgetCmd procedure, "insert" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert end a b c
+ .l2 insert 43 x
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result {a b c x}
+test listbox-3.70 {ListboxWidgetCmd procedure, "nearest" option} -body {
+ .l nearest
+} -returnCodes error -result {wrong # args: should be ".l nearest y"}
+test listbox-3.71 {ListboxWidgetCmd procedure, "nearest" option} -body {
+ .l nearest a b
+} -returnCodes error -result {wrong # args: should be ".l nearest y"}
+test listbox-3.72 {ListboxWidgetCmd procedure, "nearest" option} -body {
+ .l nearest 20p
+} -returnCodes error -result {expected integer but got "20p"}
+test listbox-3.73 {ListboxWidgetCmd procedure, "nearest" option} -body {
+ .l yview 3
+ .l nearest 1000
+} -result {7}
+test listbox-3.74 {ListboxWidgetCmd procedure, "scan" option} -body {
+ .l scan a b
+} -returnCodes error -result {wrong # args: should be ".l scan mark|dragto x y"}
+test listbox-3.75 {ListboxWidgetCmd procedure, "scan" option} -body {
+ .l scan a b c d
+} -returnCodes error -result {wrong # args: should be ".l scan mark|dragto x y"}
+test listbox-3.76 {ListboxWidgetCmd procedure, "scan" option} -body {
+ .l scan foo bogus 2
+} -returnCodes error -result {expected integer but got "bogus"}
+test listbox-3.77 {ListboxWidgetCmd procedure, "scan" option} -body {
+ .l scan foo 2 2.3
+} -returnCodes error -result {expected integer but got "2.3"}
+test listbox-3.78 {ListboxWidgetCmd procedure, "scan" option} -constraints {
+ fonts
+} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm geom .t +0+0
+ listbox .t.l -width 10 -height 5
+ .t.l insert 0 "Short" "Somewhat longer" "Really, quite a whole lot longer than can possibly fit on the screen" "Short" a b c d e f g h i j
+ pack .t.l
+ update
+ .t.l scan mark 100 140
+ .t.l scan dragto 90 137
+ update
+ list [format {%.6g %.6g} {*}[.t.l xview]] [format {%.6g %.6g} {*}[.t.l yview]]
+} -cleanup {
+ destroy .t
+} -result {{0.249364 0.427481} {0.0714286 0.428571}}
+test listbox-3.79 {ListboxWidgetCmd procedure, "scan" option} -body {
+ .l scan foo 2 4
+} -returnCodes error -result {bad option "foo": must be mark or dragto}
+test listbox-3.80 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l see
+} -returnCodes error -result {wrong # args: should be ".l see index"}
+test listbox-3.81 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l see a b
+} -returnCodes error -result {wrong # args: should be ".l see index"}
+test listbox-3.82 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l see gorp
+} -returnCodes error -result {bad listbox index "gorp": must be active, anchor, end, @x,y, or a number}
+test listbox-3.83 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l yview 7
+ .l see 7
+ .l index @0,0
+} -result {7}
+test listbox-3.84 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l yview 7
+ .l see 11
+ .l index @0,0
+} -result {7}
+test listbox-3.85 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l yview 7
+ .l see 6
+ .l index @0,0
+} -result {6}
+test listbox-3.86 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l yview 7
+ .l see 5
+ .l index @0,0
+} -result {3}
+test listbox-3.87 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l yview 7
+ .l see 12
+ .l index @0,0
+} -result {8}
+test listbox-3.88 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l yview 7
+ .l see 13
+ .l index @0,0
+} -result {11}
+test listbox-3.89 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l yview 7
+ .l see -1
+ .l index @0,0
+} -result {0}
+test listbox-3.90 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l yview 7
+ .l see end
+ .l index @0,0
+} -result {13}
+test listbox-3.91 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l yview 7
+ .l see 322
+ .l index @0,0
+} -result {13}
+test listbox-3.92 {ListboxWidgetCmd procedure, "see" option, partial last line} -body {
+ mkPartial
+ .partial.l see 4
+ .partial.l index @0,0
+} -result {1}
+test listbox-3.93 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l select a
+} -returnCodes error -result {wrong # args: should be ".l selection option index ?index?"}
+test listbox-3.94 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l select a b c d
+} -returnCodes error -result {wrong # args: should be ".l selection option index ?index?"}
+test listbox-3.95 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection a bogus
+} -returnCodes error -result {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number}
+test listbox-3.96 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection a 0 lousy
+} -returnCodes error -result {bad listbox index "lousy": must be active, anchor, end, @x,y, or a number}
+test listbox-3.97 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection anchor 0 0
+} -returnCodes error -result {wrong # args: should be ".l selection anchor index"}
+test listbox-3.98 {ListboxWidgetCmd procedure, "selection" option} -body {
+ list [.l selection anchor 5; .l index anchor] \
+ [.l selection anchor 0; .l index anchor]
+} -result {5 0}
+test listbox-3.99 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection anchor -1
+ .l index anchor
+} -result {0}
+test listbox-3.100 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection anchor end
+ .l index anchor
+} -result {17}
+test listbox-3.101 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection anchor 44
+ .l index anchor
+} -result {17}
+test listbox-3.102 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection clear 0 end
+ .l selection set 2 8
+ .l selection clear 3 4
+ .l curselection
+} -result {2 5 6 7 8}
+test listbox-3.103 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection includes 0 0
+} -returnCodes error -result {wrong # args: should be ".l selection includes index"}
+test listbox-3.104 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection clear 0 end
+ .l selection set 2 8
+ .l selection clear 4
+ list [.l selection includes 3] [.l selection includes 4] \
+ [.l selection includes 5]
+} -result {1 0 1}
+test listbox-3.105 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection set 0 end
+ .l selection includes -1
+} -result {0}
+test listbox-3.106 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection clear 0 end
+ .l selection set end
+ .l selection includes end
+} -result {1}
+test listbox-3.107 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection set 0 end
+ .l selection includes 44
+} -result {0}
+test listbox-3.108 {ListboxWidgetCmd procedure, "selection" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 selection includes 0
+} -cleanup {
+ destroy .l2
+} -result {0}
+test listbox-3.109 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection clear 0 end
+ .l selection set 2
+ .l selection set 5 7
+ .l curselection
+} -result {2 5 6 7}
+test listbox-3.110 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection clear 0 end
+ .l selection set 2
+ .l selection set 5 7
+ .l selection set 5 7
+ .l curselection
+} -result {2 5 6 7}
+test listbox-3.111 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection badOption 0 0
+} -returnCodes error -result {bad option "badOption": must be anchor, clear, includes, or set}
+test listbox-3.112 {ListboxWidgetCmd procedure, "size" option} -body {
+ .l size a
+} -returnCodes error -result {wrong # args: should be ".l size"}
+test listbox-3.113 {ListboxWidgetCmd procedure, "size" option} -body {
+ .l size
+} -result {18}
+test listbox-3.114 {ListboxWidgetCmd procedure, "xview" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ update
+ format {%.6g %.6g} {*}[.l2 xview]
+} -cleanup {
+ destroy .l2
+} -result {0 1}
+test listbox-3.115 {ListboxWidgetCmd procedure, "xview" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2 -width 10 -height 5 -font $fixed
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ pack .l2
+ update
+ format {%.6g %.6g} {*}[.l2 xview]
+} -cleanup {
+ destroy .l2
+} -result {0 1}
+
+test listbox-3.116 {ListboxWidgetCmd procedure, "xview" option} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789"
+ .l2 xview 4
+ format {%.6g %.6g} {*}[.l2 xview]
+} -cleanup {
+ destroy .l2
+} -result {0.08 0.28}
+test listbox-3.117 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l xview foo
+} -returnCodes error -result {expected integer but got "foo"}
+test listbox-3.118 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l xview zoom a b
+} -returnCodes error -result {unknown option "zoom": must be moveto or scroll}
+test listbox-3.119 {ListboxWidgetCmd procedure, "xview" option} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789"
+ .l xview 0
+ .l2 xview moveto .4
+ update
+ format {%.6g %.6g} {*}[.l2 xview]
+} -cleanup {
+ destroy .l2
+} -result {0.4 0.6}
+test listbox-3.120 {ListboxWidgetCmd procedure, "xview" option} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789"
+ .l2 xview 0
+ .l2 xview scroll 2 units
+ update
+ format {%.6g %.6g} {*}[.l2 xview]
+} -cleanup {
+ destroy .l2
+} -result {0.04 0.24}
+test listbox-3.121 {ListboxWidgetCmd procedure, "xview" option} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789"
+ .l2 xview 30
+ .l2 xview scroll -1 pages
+ update
+ format {%.6g %.6g} {*}[.l2 xview]
+} -cleanup {
+ destroy .l2
+} -result {0.44 0.64}
+test listbox-3.122 {ListboxWidgetCmd procedure, "xview" option} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789"
+ .l2 configure -width 1
+ update
+ .l2 xview 30
+ .l2 xview scroll -4 pages
+ update
+ format {%.6g %.6g} {*}[.l2 xview]
+} -cleanup {
+ destroy .l2
+} -result {0.52 0.54}
+test listbox-3.123 {ListboxWidgetCmd procedure, "yview" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ pack .l2
+ update
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0 1}
+test listbox-3.124 {ListboxWidgetCmd procedure, "yview" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert 0 el1
+ pack .l2
+ update
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0 1}
+
+test listbox-3.125 {ListboxWidgetCmd procedure, "yview" option} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 yview 4
+ update
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0.2 0.45}
+test listbox-3.126 {ListboxWidgetCmd procedure, "yview" option, partial last line} -setup {
+ destroy .l
+ listbox .l -width 10 -height 5 -font $fixed
+ pack .l
+ update
+} -body {
+ .l insert 0 a b c d e f g h i j k l m n o p q r s t
+ mkPartial
+ format {%.6g %.6g} {*}[.partial.l yview]
+} -cleanup {
+ destroy .l
+} -result {0 0.266667}
+
+# Listbox used in 3.127 -3.137 tests
+destroy .l
+listbox .l -width 20 -height 5 -bd 4 -highlightthickness 1 -selectborderwidth 2
+pack .l
+.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 el12 el13 el14 \
+ el15 el16 el17
+update
+test listbox-3.127 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l yview foo
+} -returnCodes error -result {bad listbox index "foo": must be active, anchor, end, @x,y, or a number}
+test listbox-3.128 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l yview foo a b
+} -returnCodes error -result {unknown option "foo": must be moveto or scroll}
+test listbox-3.129 {ListboxWidgetCmd procedure, "xview" option} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 yview 0
+ .l2 yview moveto .31
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0.3 0.55}
+test listbox-3.130 {ListboxWidgetCmd procedure, "xview" option} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 yview 2
+ .l2 yview scroll 2 pages
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0.4 0.65}
+test listbox-3.131 {ListboxWidgetCmd procedure, "xview" option} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 yview 10
+ .l2 yview scroll -3 units
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0.35 0.6}
+test listbox-3.132 {ListboxWidgetCmd procedure, "xview" option} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 configure -height 2
+ update
+ .l2 yview 15
+ .l2 yview scroll -4 pages
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0.55 0.65}
+test listbox-3.133 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l whoknows
+} -returnCodes error -result {bad option "whoknows": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}
+test listbox-3.134 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l c
+} -returnCodes error -result {ambiguous option "c": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}
+test listbox-3.135 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l in
+} -returnCodes error -result {ambiguous option "in": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}
+test listbox-3.136 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l s
+} -returnCodes error -result {ambiguous option "s": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}
+test listbox-3.137 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l se
+} -returnCodes error -result {ambiguous option "se": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}
+
+# No tests for DestroyListbox: I can't come up with anything to test
+# in this procedure.
+
+
+test listbox-4.1 {ConfigureListbox procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+ destroy .l
+ listbox .l -setgrid 1 -width 25 -height 15
+ pack .l
+ update
+} -body {
+ set x [getsize .]
+ .l configure -setgrid 0
+ update
+ list $x [getsize .]
+} -cleanup {
+ deleteWindows
+} -result {25x15 185x263}
+resetGridInfo
+test listbox-4.2 {ConfigureListbox procedure} -setup {
+ deleteWindows
+ destroy .l
+ listbox .l -setgrid 1 -width 25 -height 15
+ pack .l
+ update
+} -body {
+ .l configure -highlightthickness -3
+ .l cget -highlightthickness
+} -cleanup {
+ deleteWindows
+} -result {0}
+test listbox-4.3 {ConfigureListbox procedure} -setup {
+ deleteWindows
+ destroy .l
+ listbox .l -setgrid 1 -width 25 -height 15
+ pack .l
+ update
+} -body {
+ .l configure -exportselection 0
+ .l delete 0 end
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8
+ .l selection set 3 5
+ .l configure -exportselection 1
+ selection get
+} -cleanup {
+ deleteWindows
+} -result {el3
+el4
+el5}
+test listbox-4.4 {ConfigureListbox procedure} -setup {
+ deleteWindows
+ listbox .l -setgrid 1 -width 25 -height 15
+ pack .l
+ update
+} -body {
+ entry .e
+ .e insert 0 abc
+ .e select from 0
+ .e select to 2
+ .l configure -exportselection 0
+ .l delete 0 end
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8
+ .l selection set 3 5
+ .l selection clear 3 5
+ .l configure -exportselection 1
+ list [selection own] [selection get]
+} -cleanup {
+ deleteWindows
+} -result {.e ab}
+test listbox-4.5 {-exportselection option} -setup {
+ deleteWindows
+ listbox .l -setgrid 1 -width 25 -height 15
+ pack .l
+ update
+} -body {
+ selection clear .
+ .l configure -exportselection 1
+ .l delete 0 end
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8
+ .l selection set 1 1
+ set x {}
+ lappend x [catch {selection get} msg] $msg [.l curselection]
+ .l config -exportselection 0
+ lappend x [catch {selection get} msg] $msg [.l curselection]
+ .l selection clear 0 end
+ lappend x [catch {selection get} msg] $msg [.l curselection]
+ .l selection set 1 3
+ lappend x [catch {selection get} msg] $msg [.l curselection]
+ .l config -exportselection 1
+ lappend x [catch {selection get} msg] $msg [.l curselection]
+} -cleanup {
+ deleteWindows
+} -result {0 el1 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {1 2 3} 0 {el1
+el2
+el3} {1 2 3}}
+test listbox-4.6 {ConfigureListbox procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+
+ # The following code (reset geometry, withdraw, etc.) is necessary
+ # to reset the state of some window managers like olvwm under
+ # SunOS 4.1.3.
+
+ wm geom . 300x300
+ update
+ wm geom . {}
+ wm withdraw .
+ listbox .l2 -font $fixed -width 15 -height 20
+ pack .l2
+ update
+ wm deiconify .
+ set x [getsize .]
+ .l2 configure -setgrid 1
+ update
+ list $x [getsize .]
+} -cleanup {
+ deleteWindows
+} -result {115x328 15x20}
+test listbox-4.7 {ConfigureListbox procedure} -setup {
+ deleteWindows
+} -body {
+ wm withdraw .
+ listbox .l2 -font $fixed -width 30 -height 20 -setgrid 1
+ wm geom . +25+25
+ pack .l2
+ update
+ wm deiconify .
+ set result [getsize .]
+ wm geom . 26x15
+ update
+ lappend result [getsize .]
+ .l2 configure -setgrid 1
+ update
+ lappend result [getsize .]
+} -cleanup {
+ deleteWindows
+ wm geom . {}
+} -result {30x20 26x15 26x15}
+
+resetGridInfo
+test listbox-4.8 {ConfigureListbox procedure} -setup {
+ destroy .l2
+} -body {
+ listbox .l2 -width 15 -height 20 -xscrollcommand "record x" \
+ -yscrollcommand "record y"
+ pack .l2
+ update
+ .l2 configure -fg black
+ set log {}
+ update
+ set log
+} -cleanup {
+ destroy .l2
+} -result {{y 0 1} {x 0 1}}
+test listbox-4.9 {ConfigureListbox procedure, -listvar} -setup {
+ destroy .l2
+} -body {
+ set x [list a b c d]
+ listbox .l2 -listvar x
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result [list a b c d]
+test listbox-4.10 {ConfigureListbox, no listvar -> existing listvar} -setup {
+ destroy .l2
+} -body {
+ set x [list a b c d]
+ listbox .l2
+ .l2 insert end 1 2 3 4
+ .l2 configure -listvar x
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result [list a b c d]
+test listbox-4.11 {ConfigureListbox procedure, listvar -> no listvar} -setup {
+ destroy .l2
+} -body {
+ set x [list a b c d]
+ listbox .l2 -listvar x
+ .l2 configure -listvar {}
+ .l2 insert end 1 2 3 4
+ list $x [.l2 get 0 end]
+} -cleanup {
+ destroy .l2
+} -result [list [list a b c d] [list a b c d 1 2 3 4]]
+test listbox-4.12 {ConfigureListbox procedure, listvar -> different listvar} -setup {
+ destroy .l2
+} -body {
+ set x [list a b c d]
+ set y [list 1 2 3 4]
+ listbox .l2
+ .l2 configure -listvar x
+ .l2 configure -listvar y
+ .l2 insert end 5 6 7 8
+ list $x $y
+} -cleanup {
+ destroy .l2
+} -result [list [list a b c d] [list 1 2 3 4 5 6 7 8]]
+test listbox-4.13 {ConfigureListbox, no listvar -> non-existant listvar} -setup {
+ destroy .l2
+} -body {
+ catch {unset x}
+ listbox .l2
+ .l2 insert end a b c d
+ .l2 configure -listvar x
+ set x
+} -cleanup {
+ destroy .l2
+} -result [list a b c d]
+test listbox-4.14 {ConfigureListbox, non-existant listvar} -setup {
+ destroy .l2
+} -body {
+ catch {unset x}
+ listbox .l2 -listvar x
+ list [info exists x] $x
+} -cleanup {
+ destroy .l2
+} -result [list 1 {}]
+test listbox-4.15 {ConfigureListbox, listvar -> non-existant listvar} -setup {
+ destroy .l2
+} -body {
+ catch {unset y}
+ set x [list a b c d]
+ listbox .l2 -listvar x
+ .l2 configure -listvar y
+ list [info exists y] $y
+} -cleanup {
+ destroy .l2
+} -result [list 1 [list a b c d]]
+test listbox-4.16 {ConfigureListbox, listvar -> same listvar} -setup {
+ destroy .l2
+} -body {
+ set x [list a b c d]
+ listbox .l2 -listvar x
+ .l2 configure -listvar x
+ set x
+} -cleanup {
+ destroy .l2
+} -result [list a b c d]
+test listbox-4.17 {ConfigureListbox, no listvar -> no listvar} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert end a b c d
+ .l2 configure -listvar {}
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result [list a b c d]
+test listbox-4.18 {ConfigureListbox, no listvar -> bad listvar} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert end a b c d
+ set x "this is a \" bad list"
+ catch {.l2 configure -listvar x} result
+ list [.l2 get 0 end] [.l2 cget -listvar] $result
+} -cleanup {
+ destroy .l2
+} -result [list [list a b c d] {} \
+ "unmatched open quote in list: invalid -listvariable value"]
+test listbox-4.19 {ConfigureListbox, no listvar -> bad non-existent listvar} -setup {
+ destroy .l2
+} -body {
+ unset -nocomplain ::foo
+ listbox .l2 -listvar foo
+ .l2 insert end a b c d
+ catch {.l2 configure -listvar ::zoo::bar::foo} result
+ list [.l2 get 0 end] [.l2 cget -listvar] $foo $result
+} -cleanup {
+ destroy .l2
+} -result [list [list a b c d] foo [list a b c d] \
+ {can't set "::zoo::bar::foo": parent namespace doesn't exist}]
+
+
+# No tests for DisplayListbox: I don't know how to test this procedure.
+
+test listbox-5.1 {ListboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
+ listbox .l -font $fixed -width 15 -height 20
+ pack .l
+ list [winfo reqwidth .l] [winfo reqheight .l]
+} -result {115 328}
+test listbox-5.2 {ListboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
+ listbox .l -font $fixed -width 0 -height 10
+ pack .l
+ update
+ list [winfo reqwidth .l] [winfo reqheight .l]
+} -result {17 168}
+test listbox-5.3 {ListboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
+ listbox .l -font $fixed -width 0 -height 10 -bd 3
+ .l insert 0 Short "Really much longer" Longer
+ pack .l
+ update
+ list [winfo reqwidth .l] [winfo reqheight .l]
+} -result {138 170}
+test listbox-5.4 {ListboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
+ listbox .l -font $fixed -width 10 -height 0
+ pack .l
+ update
+ list [winfo reqwidth .l] [winfo reqheight .l]
+} -result {80 24}
+test listbox-5.5 {ListboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
+ listbox .l -font $fixed -width 10 -height 0 -highlightthickness 0
+ .l insert 0 Short "Really much longer" Longer
+ pack .l
+ update
+ list [winfo reqwidth .l] [winfo reqheight .l]
+} -result {76 52}
+test listbox-5.6 {ListboxComputeGeometry procedure} -setup {
+ destroy .l
+} -body {
+ # If "0" in selected font had 0 width, caused divide-by-zero error.
+
+ pack [listbox .l -font {{open look glyph}}]
+ update
+} -cleanup {
+ destroy .l
+} -result {}
+
+
+# Listbox used in 6.*, 7.* tests
+destroy .l
+listbox .l -height 2 -xscrollcommand "record x" -yscrollcommand "record y"
+pack .l
+update
+test listbox-6.1 {InsertEls procedure} -body {
+ .l delete 0 end
+ .l insert end a b c d
+ .l insert 5 x y z
+ .l insert 2 A
+ .l insert 0 q r s
+ .l get 0 end
+} -result {q r s a b A c d x y z}
+test listbox-6.2 {InsertEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l selection anchor 2
+ .l insert 2 A B
+ .l index anchor
+} -result {4}
+test listbox-6.3 {InsertEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l selection anchor 2
+ .l insert 3 A B
+ .l index anchor
+} -result {2}
+test listbox-6.4 {InsertEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l yview 3
+ update
+ .l insert 2 A B
+ .l index @0,0
+} -result {5}
+test listbox-6.5 {InsertEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l yview 3
+ update
+ .l insert 3 A B
+ .l index @0,0
+} -result {3}
+test listbox-6.6 {InsertEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l activate 5
+ .l insert 5 A B
+ .l index active
+} -result {7}
+test listbox-6.7 {InsertEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l activate 5
+ .l insert 6 A B
+ .l index active
+} -result {5}
+test listbox-6.8 {InsertEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c
+ .l index active
+} -result {2}
+test listbox-6.9 {InsertEls procedure} -body {
+ .l delete 0 end
+ .l insert 0
+ .l index active
+} -result {0}
+test listbox-6.10 {InsertEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b "two words" c d e f g h i j
+ update
+ set log {}
+ .l insert 0 word
+ update
+ set log
+} -result {{y 0 0.166667}}
+test listbox-6.11 {InsertEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b "two words" c d e f g h i j
+ update
+ set log {}
+ .l insert 0 "much longer entry"
+ update
+ set log
+} -result {{y 0 0.166667} {x 0 1}}
+test listbox-6.12 {InsertEls procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+} -body {
+ listbox .l2 -width 0 -height 0
+ pack .l2 -side top
+ .l2 insert 0 a b "two words" c d
+ set x {}
+ lappend x [winfo reqwidth .l2] [winfo reqheight .l2]
+ .l2 insert 0 "much longer entry"
+ lappend x [winfo reqwidth .l2] [winfo reqheight .l2]
+} -cleanup {
+ destroy .l2
+} -result {80 93 122 110}
+test listbox-6.13 {InsertEls procedure, check -listvar update} -setup {
+ destroy .l2
+} -body {
+ set x [list a b c d]
+ listbox .l2 -listvar x
+ .l2 insert 0 1 2 3 4
+ set x
+} -cleanup {
+ destroy .l2
+} -result [list 1 2 3 4 a b c d]
+test listbox-6.14 {InsertEls procedure, check selection update} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert 0 0 1 2 3 4
+ .l2 selection set 2 4
+ .l2 insert 0 a
+ .l2 curselection
+} -cleanup {
+ destroy .l2
+} -result [list 3 4 5]
+test listbox-6.15 {InsertEls procedure, lost namespaced listvar} -body {
+ destroy .l2
+ namespace eval test { variable foo {a b} }
+ listbox .l2 -listvar ::test::foo
+ namespace delete test
+ .l2 insert end c d
+ .l2 delete end
+ .l2 insert end e f
+ catch {set ::test::foo} result
+ list [.l2 get 0 end] [.l2 cget -listvar] $result
+} -cleanup {
+ destroy .l2
+} -result [list [list a b c e f] ::test::foo \
+ {can't read "::test::foo": no such variable}]
+
+
+test listbox-7.1 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l selection set 1 6
+ .l delete 4 3
+ list [.l size] [selection get]
+} -result {10 {b
+c
+d
+e
+f
+g}}
+test listbox-7.2 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l selection set 3 6
+ .l delete 4 4
+ list [.l size] [.l get 4] [.l curselection]
+} -result {9 f {3 4 5}}
+test listbox-7.3 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l delete 0 3
+ list [.l size] [.l get 0] [.l get 1]
+} -result {6 e f}
+test listbox-7.4 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l delete 8 1000
+ list [.l size] [.l get 7]
+} -result {8 h}
+test listbox-7.5 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l selection anchor 2
+ .l delete 0 1
+ .l index anchor
+} -result {0}
+test listbox-7.6 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l selection anchor 2
+ .l delete 2
+ .l index anchor
+} -result {2}
+test listbox-7.7 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l selection anchor 4
+ .l delete 2 5
+ .l index anchor
+} -result {2}
+test listbox-7.8 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l selection anchor 3
+ .l delete 4 5
+ .l index anchor
+} -result {3}
+test listbox-7.9 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l yview 3
+ update
+ .l delete 1 2
+ .l index @0,0
+} -result {1}
+test listbox-7.10 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l yview 3
+ update
+ .l delete 3 4
+ .l index @0,0
+} -result {3}
+test listbox-7.11 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l yview 3
+ update
+ .l delete 4 6
+ .l index @0,0
+} -result {3}
+test listbox-7.12 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l yview 3
+ update
+ .l delete 3 end
+ .l index @0,0
+} -result {1}
+test listbox-7.13 {DeleteEls procedure, updating view with partial last line} -body {
+ mkPartial
+ .partial.l yview 8
+ update
+ .partial.l delete 10 13
+ .partial.l index @0,0
+} -result {7}
+test listbox-7.14 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l activate 6
+ .l delete 3 4
+ .l index active
+} -result {4}
+test listbox-7.15 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l activate 6
+ .l delete 5 7
+ .l index active
+} -result {5}
+test listbox-7.16 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l activate 6
+ .l delete 5 end
+ .l index active
+} -result {4}
+test listbox-7.17 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j
+ .l activate 6
+ .l delete 0 end
+ .l index active
+} -result {0}
+test listbox-7.18 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c "two words" d e f g h i j
+ update
+ set log {}
+ .l delete 4 6
+ update
+ set log
+} -result {{y 0 0.25}}
+test listbox-7.19 {DeleteEls procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c "two words" d e f g h i j
+ update
+ set log {}
+ .l delete 3
+ update
+ set log
+} -result {{y 0 0.2} {x 0 1}}
+test listbox-7.20 {DeleteEls procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+} -body {
+ listbox .l2 -width 0 -height 0
+ pack .l2 -side top
+ .l2 insert 0 a b "two words" c d e f g
+ set x {}
+ lappend x [winfo reqwidth .l2] [winfo reqheight .l2]
+ .l2 delete 2 4
+ lappend x [winfo reqwidth .l2] [winfo reqheight .l2]
+} -result {80 144 17 93}
+test listbox-7.21 {DeleteEls procedure, check -listvar update} -setup {
+ destroy .l2
+} -body {
+ set x [list a b c d]
+ listbox .l2 -listvar x
+ .l2 delete 0 1
+ set x
+} -result [list c d]
+
+
+test listbox-8.1 {ListboxEventProc procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
+ listbox .l -setgrid 1
+ pack .l
+ update
+ set x [getsize .]
+ destroy .l
+ list $x [getsize .] [winfo exists .l] [info command .l]
+} -cleanup {
+ destroy .l
+} -result {20x10 150x178 0 {}}
+resetGridInfo
+test listbox-8.2 {ListboxEventProc procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
+ listbox .l -height 5 -width 10
+ .l insert 0 a b c "A string that is very very long" d e f g h i j k
+ pack .l
+ update
+ place .l -width 50 -height 80
+ update
+ list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]
+} -cleanup {
+ destroy .l
+} -result {{0 0.222222} {0 0.333333}}
+test listbox-8.3 {ListboxEventProc procedure} -setup {
+ deleteWindows
+} -body {
+ listbox .l1 -bg #543210
+ rename .l1 .l2
+ set x {}
+ lappend x [winfo children .]
+ lappend x [.l2 cget -bg]
+ destroy .l1
+ lappend x [info command .l*] [winfo children .]
+} -cleanup {
+ deleteWindows
+} -result {.l1 #543210 {} {}}
+
+
+test listbox-9.1 {ListboxCmdDeletedProc procedure} -setup {
+ deleteWindows
+} -body {
+ listbox .l1
+ rename .l1 {}
+ list [info command .l*] [winfo children .]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test listbox-9.2 {ListboxCmdDeletedProc procedure, disabling -setgrid} -constraints {
+ fonts
+} -setup {
+ destroy .top
+} -body {
+ toplevel .top
+ wm geom .top +0+0
+ listbox .top.l -setgrid 1 -width 20 -height 10
+ pack .top.l
+ update
+ set x [getsize .top]
+ rename .top.l {}
+ update
+ lappend x [getsize .top]
+} -cleanup {
+ destroy .top
+} -result {20x10 150x178}
+
+
+# Listbox used in 10.* tests
+destroy .l
+test listbox-10.1 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ .l activate 3
+ update
+ list [.l activate 3; .l index active] [.l activate 6; .l index active]
+} -cleanup {
+ destroy .l
+} -result {3 6}
+test listbox-10.2 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ .l selection anchor 2
+ update
+ .l index anchor
+} -cleanup {
+ destroy .l
+} -result 2
+test listbox-10.3 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ .l insert end A B C D E
+ .l selection anchor end
+ update
+ .l delete 12 end
+ list [.l index anchor] [.l index end]
+} -cleanup {
+ destroy .l
+} -result {12 12}
+test listbox-10.4 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index a
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "a": must be active, anchor, end, @x,y, or a number}
+test listbox-10.5 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index end
+} -cleanup {
+ destroy .l
+} -result {12}
+test listbox-10.6 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l get end
+} -cleanup {
+ destroy .l
+} -result {el11}
+test listbox-10.7 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ .l delete 0 end
+ update
+ .l index end
+} -cleanup {
+ destroy .l
+} -result 0
+test listbox-10.8 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index @
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "@": must be active, anchor, end, @x,y, or a number}
+test listbox-10.9 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index @foo
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "@foo": must be active, anchor, end, @x,y, or a number}
+test listbox-10.10 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index @1x3
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "@1x3": must be active, anchor, end, @x,y, or a number}
+test listbox-10.11 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index @1,
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "@1,": must be active, anchor, end, @x,y, or a number}
+test listbox-10.12 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index @1,foo
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "@1,foo": must be active, anchor, end, @x,y, or a number}
+test listbox-10.13 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index @1,2x
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "@1,2x": must be active, anchor, end, @x,y, or a number}
+test listbox-10.14 {GetListboxIndex procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ list [.l index @5,57] [.l index @5,58]
+} -cleanup {
+ .l delete 0 end
+} -cleanup {
+ destroy .l
+} -result {3 3}
+test listbox-10.15 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index 1xy
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "1xy": must be active, anchor, end, @x,y, or a number}
+test listbox-10.16 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index 3
+} -cleanup {
+ destroy .l
+} -result {3}
+test listbox-10.17 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index 20
+} -cleanup {
+ destroy .l
+} -result {20}
+test listbox-10.18 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l get 20
+} -cleanup {
+ destroy .l
+} -result {}
+test listbox-10.19 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index -2
+} -cleanup {
+ destroy .l
+} -result -2
+test listbox-10.20 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ .l delete 0 end
+ update
+ .l index 1
+} -cleanup {
+ destroy .l
+} -result 1
+
+
+test listbox-11.1 {ChangeListboxView procedure, boundary conditions for index} -setup {
+ destroy .l
+} -body {
+ listbox .l -height 5
+ pack .l
+ .l insert 0 a b c d e f g h i j
+ .l yview 3
+ update
+ set x [.l index @0,0]
+ .l yview -1
+ update
+ lappend x [.l index @0,0]
+} -cleanup {
+ destroy .l
+} -result {3 0}
+test listbox-11.2 {ChangeListboxView procedure, boundary conditions for index} -setup {
+ destroy .l
+} -body {
+ listbox .l -height 5
+ pack .l
+ .l insert 0 a b c d e f g h i j
+ .l yview 3
+ update
+ set x [.l index @0,0]
+ .l yview 20
+ update
+ lappend x [.l index @0,0]
+} -cleanup {
+ destroy .l
+} -result {3 5}
+test listbox-11.3 {ChangeListboxView procedure} -setup {
+ destroy .l
+} -body {
+ listbox .l -height 5 -yscrollcommand "record y"
+ pack .l
+ .l insert 0 a b c d e f g h i j
+ update
+ set log {}
+ .l yview 2
+ update
+ list [format {%.6g %.6g} {*}[.l yview]] $log
+} -cleanup {
+ destroy .l
+} -result {{0.2 0.7} {{y 0.2 0.7}}}
+test listbox-11.4 {ChangeListboxView procedure} -setup {
+ destroy .l
+} -body {
+ listbox .l -height 5 -yscrollcommand "record y"
+ pack .l
+ .l insert 0 a b c d e f g h i j
+ update
+ set log {}
+ .l yview 8
+ update
+ list [format {%.6g %.6g} {*}[.l yview]] $log
+} -cleanup {
+ destroy .l
+} -result {{0.5 1} {{y 0.5 1}}}
+test listbox-11.5 {ChangeListboxView procedure} -setup {
+ destroy .l
+} -body {
+ listbox .l -height 5 -yscrollcommand "record y"
+ pack .l
+ .l insert 0 a b c d e f g h i j
+ .l yview 3
+ update
+ set log {}
+ .l yview 3
+ update
+ list [format {%.6g %.6g} {*}[.l yview]] $log
+} -cleanup {
+ destroy .l
+} -result {{0.3 0.8} {}}
+test listbox-11.6 {ChangeListboxView procedure, partial last line} -body {
+ mkPartial
+ .partial.l yview 13
+ .partial.l index @0,0
+} -cleanup {
+ destroy .l
+} -result {11}
+
+
+# Listbox used in 12.* tests
+destroy .l
+listbox .l -font $fixed -xscrollcommand "record x" -width 10
+.l insert 0 0123456789a123456789b123456789c123456789d123456789e123456789f123456789g123456789h123456789i123456789
+pack .l
+update
+test listbox-12.1 {ChangeListboxOffset procedure} -constraints {
+ fonts
+} -body {
+ set log {}
+ .l xview 99
+ update
+ list [format {%.6g %.6g} {*}[.l xview]] $log
+} -result {{0.9 1} {{x 0.9 1}}}
+test listbox-12.2 {ChangeListboxOffset procedure} -constraints {
+ fonts
+} -body {
+ set log {}
+ .l xview 99
+ .l xview moveto -.25
+ update
+ list [format {%.6g %.6g} {*}[.l xview]] $log
+} -result {{0 0.1} {{x 0 0.1}}}
+test listbox-12.3 {ChangeListboxOffset procedure} -constraints {
+ fonts
+} -body {
+ .l xview 10
+ update
+ set log {}
+ .l xview 10
+ update
+ list [format {%.6g %.6g} {*}[.l xview]] $log
+} -result {{0.1 0.2} {}}
+
+
+# Listbox used in 13.* tests
+destroy .l
+listbox .l -font $fixed -width 10 -height 5
+pack .l
+.l insert 0 a bb c d e f g h i j k l m n o p q r s
+.l insert 0 0123456789a123456789b123456789c123456789d123456789
+update
+set width [expr [lindex [.l bbox 2] 2] - [lindex [.l bbox 1] 2]]
+set height [expr [lindex [.l bbox 2] 1] - [lindex [.l bbox 1] 1]]
+test listbox-13.1 {ListboxScanTo procedure} -constraints {
+ fonts
+} -body {
+ .l yview 0
+ .l xview 0
+ .l scan mark 10 20
+ .l scan dragto [expr 10-$width] [expr 20-$height]
+ update
+ list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]
+} -result {{0.2 0.4} {0.5 0.75}}
+test listbox-13.2 {ListboxScanTo procedure} -constraints {
+ fonts
+} -body {
+ .l yview 5
+ .l xview 10
+ .l scan mark 10 20
+ .l scan dragto 20 40
+ update
+ set x [list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]]
+ .l scan dragto [expr 20-$width] [expr 40-$height]
+ update
+ lappend x [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]
+} -result {{0 0.2} {0 0.25} {0.2 0.4} {0.5 0.75}}
+test listbox-13.3 {ListboxScanTo procedure} -constraints {
+ fonts
+} -body {
+ .l yview moveto 1.0
+ .l xview moveto 1.0
+ .l scan mark 10 20
+ .l scan dragto 5 10
+ update
+ set x [list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]]
+ .l scan dragto [expr 5+$width] [expr 10+$height]
+ update
+ lappend x [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]
+} -result {{0.8 1} {0.75 1} {0.64 0.84} {0.25 0.5}}
+
+
+test listbox-14.1 {NearestListboxElement procedure, partial last line} -body {
+ mkPartial
+ .partial.l nearest [winfo height .partial.l]
+} -result {4}
+# Listbox used in 14.* tests
+destroy .l
+listbox .l -font $fixed -width 20 -height 10
+.l insert 0 a b c d e f g h i j k l m n o p q r s t
+.l yview 4
+pack .l
+update
+test listbox-14.2 {NearestListboxElement procedure} -constraints {
+ fonts
+} -body {
+ .l index @50,0
+} -result {4}
+test listbox-14.3 {NearestListboxElement procedure} -constraints {
+ fonts
+} -body {
+ list [.l index @50,35] [.l index @50,36]
+} -result {5 6}
+test listbox-14.4 {NearestListboxElement procedure} -constraints {
+ fonts
+} -body {
+ .l index @50,200
+} -result {13}
+
+
+# Listbox used in 15.* 16.* and 17.* tests
+destroy .l
+listbox .l -font $fixed -width 20 -height 10
+pack .l
+update
+test listbox-15.1 {ListboxSelect procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j k l m n o p
+ .l select set 2 4
+ .l select set 7 12
+ .l select clear 4 7
+ .l curselection
+} -result {2 3 8 9 10 11 12}
+test listbox-15.2 {ListboxSelect procedure} -setup {
+ destroy .e
+} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f g h i j k l m n o p
+ entry .e
+ .e insert 0 "This is some text"
+ .e select from 0
+ .e select to 7
+ .l selection clear 2 4
+ set x [selection own]
+ .l selection set 3
+ list $x [selection own] [selection get]
+} -cleanup {
+ destroy .e
+} -result {.e .l d}
+test listbox-15.3 {ListboxSelect procedure} -body {
+ .l delete 0 end
+ .l selection clear 0 end
+ .l select set 0 end
+ .l curselection
+} -result {}
+test listbox-15.4 {ListboxSelect procedure, boundary conditions for indices} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f
+ .l select clear 0 end
+ .l select set -2 -1
+ .l curselection
+} -result {}
+test listbox-15.5 {ListboxSelect procedure, boundary conditions for indices} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f
+ .l select clear 0 end
+ .l select set -1 3
+ .l curselection
+} -result {0 1 2 3}
+test listbox-15.6 {ListboxSelect procedure, boundary conditions for indices} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f
+ .l select clear 0 end
+ .l select set 2 4
+ .l curselection
+} -result {2 3 4}
+test listbox-15.7 {ListboxSelect procedure, boundary conditions for indices} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f
+ .l select clear 0 end
+ .l select set 4 end
+ .l curselection
+} -result {4 5}
+test listbox-15.8 {ListboxSelect procedure, boundary conditions for indices} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f
+ .l select clear 0 end
+ .l select set 4 30
+ .l curselection
+} -result {4 5}
+test listbox-15.9 {ListboxSelect procedure, boundary conditions for indices} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f
+ .l select clear 0 end
+ .l select set end 30
+ .l curselection
+} -result {5}
+test listbox-15.10 {ListboxSelect procedure, boundary conditions for indices} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e f
+ .l select clear 0 end
+ .l select set 20 25
+ .l curselection
+} -result {}
+
+
+test listbox-16.1 {ListboxFetchSelection procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c "two words" e f g h i \\ k l m n o p
+ .l selection set 2 4
+ .l selection set 9
+ .l selection set 11 12
+ selection get
+} -result "c\ntwo words\ne\n\\\nl\nm"
+test listbox-16.2 {ListboxFetchSelection procedure} -body {
+ .l delete 0 end
+ .l insert 0 a b c "two words" e f g h i \\ k l m n o p
+ .l selection set 3
+ selection get
+} -result "two words"
+test listbox-16.3 {ListboxFetchSelection procedure, retrieve in several parts} -body {
+ set long "This is quite a long string\n"
+ append long $long $long $long $long
+ append long $long $long $long $long
+ append long $long $long
+ .l delete 0 end
+ .l insert 0 1$long 2$long 3$long 4$long 5$long
+ .l selection set 0 end
+ set sel [selection get]
+ string compare 1$long\n2$long\n3$long\n4$long\n5$long $sel
+} -cleanup {
+ catch {unset long sel}
+} -result {0}
+
+
+test listbox-17.1 {ListboxLostSelection procedure} -setup {
+ destroy .e
+} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e
+ .l select set 0 end
+ entry .e
+ .e insert 0 "This is some text"
+ .e select from 0
+ .e select to 5
+ .l curselection
+} -cleanup {
+ destroy .e
+} -result {}
+test listbox-17.2 {ListboxLostSelection procedure} -setup {
+ destroy .e
+} -body {
+ .l delete 0 end
+ .l insert 0 a b c d e
+ .l select set 0 end
+ .l configure -exportselection 0
+ entry .e
+ .e insert 0 "This is some text"
+ .e select from 0
+ .e select to 5
+ .l curselection
+} -cleanup {
+ destroy .e
+} -result {0 1 2 3 4}
+
+
+# Listbox used in 18.* tests
+destroy .l
+listbox .l -font $fixed -width 10 -height 5
+pack .l
+update
+test listbox-18.1 {ListboxUpdateVScrollbar procedure} -body {
+ .l configure -yscrollcommand "record y"
+ set log {}
+ .l insert 0 a b c
+ update
+ .l insert end d e f g h
+ update
+ .l delete 0 end
+ update
+ set log
+} -result {{y 0 1} {y 0 0.625} {y 0 1}}
+test listbox-18.2 {ListboxUpdateVScrollbar procedure, partial last line} -body {
+ mkPartial
+ .partial.l configure -yscrollcommand "record y"
+ set log {}
+ .partial.l yview 3
+ update
+ set log
+} -result {{y 0.2 0.466667}}
+test listbox-18.3 {ListboxUpdateVScrollbar procedure} -body {
+ proc bgerror args {
+ global x errorInfo
+ set x [list $args $errorInfo]
+ }
+ .l configure -yscrollcommand gorp
+ .l insert 0 foo
+ update
+ set x
+} -cleanup {
+ rename bgerror {}
+} -result {{{invalid command name "gorp"}} {invalid command name "gorp"
+ while executing
+"gorp 0.0 1.0"
+ (vertical scrolling command executed by listbox)}}
+
+
+# Listbox used in 19.* tests
+destroy .l
+listbox .l -font $fixed -width 10 -height 5
+pack .l
+update
+test listbox-19.1 {ListboxUpdateVScrollbar procedure} -constraints {
+ fonts
+} -body {
+ .l configure -xscrollcommand "record x"
+ set log {}
+ .l insert 0 abc
+ update
+ .l insert 0 "This is a much longer string..."
+ update
+ .l delete 0 end
+ update
+ set log
+} -result {{x 0 1} {x 0 0.322581} {x 0 1}}
+test listbox-19.2 {ListboxUpdateVScrollbar procedure} -body {
+ proc bgerror args {
+ global x errorInfo
+ set x [list $args $errorInfo]
+ }
+ .l configure -xscrollcommand bogus
+ .l insert 0 foo
+ update
+ set x
+} -result {{{invalid command name "bogus"}} {invalid command name "bogus"
+ while executing
+"bogus 0.0 1.0"
+ (horizontal scrolling command executed by listbox)}}
+
+
+test listbox-20.1 {listbox vs hidden commands} -setup {
+ deleteWindows
+} -body {
+ set l [interp hidden]
+ listbox .l
+ interp hide {} .l
+ destroy .l
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 eq $res2}
+} -result 1
+
+
+# tests for ListboxListVarProc
+test listbox-21.1 {ListboxListVarProc} -setup {
+ destroy .l
+} -body {
+ catch {unset x}
+ listbox .l -listvar x
+ set x [list a b c d]
+ .l get 0 end
+} -cleanup {
+ destroy .l
+} -result [list a b c d]
+test listbox-21.2 {ListboxListVarProc} -setup {
+ destroy .l
+} -body {
+ set x [list a b c d]
+ listbox .l -listvar x
+ unset x
+ set x
+} -cleanup {
+ destroy .l
+} -result [list a b c d]
+test listbox-21.3 {ListboxListVarProc} -setup {
+ destroy .l
+} -body {
+ set x [list a b c d]
+ listbox .l -listvar x
+ .l configure -listvar {}
+ unset x
+ info exists x
+} -cleanup {
+ destroy .l
+} -result 0
+test listbox-21.4 {ListboxListVarProc} -setup {
+ destroy .l
+} -body {
+ set x [list a b c d]
+ listbox .l -listvar x
+ lappend x e f g
+ .l size
+} -cleanup {
+ destroy .l
+} -result 7
+test listbox-21.5 {ListboxListVarProc, test selection after listvar mod} -setup {
+ destroy .l
+} -body {
+ set x [list a b c d e f g]
+ listbox .l -listvar x
+ .l selection set end
+ set x [list a b c d]
+ set x [list 0 1 2 3 4 5 6]
+ .l curselection
+} -cleanup {
+ destroy .l
+} -result {}
+test listbox-21.6 {ListboxListVarProc, test selection after listvar mod} -setup {
+ destroy .l
+} -body {
+ set x [list a b c d]
+ listbox .l -listvar x
+ .l selection set 3
+ lappend x e f g
+ .l curselection
+} -cleanup {
+ destroy .l
+} -result 3
+test listbox-21.7 {ListboxListVarProc, test selection after listvar mod} -setup {
+ destroy .l
+} -body {
+ set x [list a b c d]
+ listbox .l -listvar x
+ .l selection set 0
+ set x [linsert $x 0 1 2 3 4]
+ .l curselection
+} -cleanup {
+ destroy .l
+} -result 0
+test listbox-21.8 {ListboxListVarProc, test selection after listvar mod} -setup {
+ destroy .l
+} -body {
+ set x [list a b c d]
+ listbox .l -listvar x
+ .l selection set 2
+ set x [list a b c]
+ .l curselection
+} -cleanup {
+ destroy .l
+} -result 2
+test listbox-21.9 {ListboxListVarProc, test hscrollbar after listvar mod} -setup {
+ destroy .l
+} -body {
+ catch {unset x}
+ set log {}
+ listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x
+ pack .l
+ update
+ lappend x "0000000000"
+ update
+ lappend x "00000000000000000000"
+ update
+ set log
+} -cleanup {
+ destroy .l
+} -result [list {x 0 1} {x 0 1} {x 0 0.5}]
+test listbox-21.10 {ListboxListVarProc, test hscrollbar after listvar mod} -setup {
+ destroy .l
+} -body {
+ catch {unset x}
+ set log {}
+ listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x
+ pack .l
+ update
+ lappend x "0000000000"
+ update
+ lappend x "00000000000000000000"
+ update
+ set x [list "0000000000"]
+ update
+ set log
+} -cleanup {
+ destroy .l
+} -result [list {x 0 1} {x 0 1} {x 0 0.5} {x 0 1}]
+test listbox-21.11 {ListboxListVarProc, bad list} -setup {
+ destroy .l
+} -body {
+ catch {unset x}
+ listbox .l -listvar x
+ set x [list a b c d]
+ catch {set x "this is a \" bad list"} result
+ set result
+} -cleanup {
+ destroy .l
+} -result {can't set "x": invalid listvar value}
+test listbox-21.12 {ListboxListVarProc, cleanup item attributes} -setup {
+ destroy .l
+} -body {
+ set x [list a b c d e f g]
+ listbox .l -listvar x
+ .l itemconfigure end -fg red
+ set x [list a b c d]
+ set x [list 0 1 2 3 4 5 6]
+ .l itemcget end -fg
+} -cleanup {
+ destroy .l
+} -result {}
+test listbox-21.12a {ListboxListVarProc, cleanup item attributes} -setup {
+ destroy .l
+} -body {
+ set x [list a b c d e f g]
+ listbox .l -listvar x
+ .l itemconfigure end -fg red
+ set x [list a b c d]
+ set x [list 0 1 2 3 4 5 6]
+ .l itemcget end -fg
+} -cleanup {
+ destroy .l
+} -result {}
+test listbox-21.13 {listbox item configurations and listvar based deletions} -setup {
+ destroy .l
+} -body {
+ catch {unset x}
+ listbox .l -listvar x
+ .l insert end a b c
+ .l itemconfigure 1 -fg red
+ set x [list b c]
+ .l itemcget 1 -fg
+} -cleanup {
+ destroy .l
+} -result red
+test listbox-21.14 {listbox item configurations and listvar based inserts} -setup {
+ destroy .l
+} -body {
+ catch {unset x}
+ listbox .l -listvar x
+ .l insert end a b c
+ .l itemconfigure 0 -fg red
+ set x [list 1 2 3 4 a b c]
+ .l itemcget 0 -fg
+} -cleanup {
+ destroy .l
+} -result red
+test listbox-21.15 {ListboxListVarProc, update vertical scrollbar} -setup {
+ destroy .l
+} -body {
+ catch {unset x}
+ set log {}
+ listbox .l -listvar x -yscrollcommand "record y" -font fixed -height 3
+ pack .l
+ update
+ lappend x a b c d e f
+ update
+ set log
+} -cleanup {
+ destroy .l
+} -result [list {y 0 1} {y 0 0.5}]
+test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} -setup {
+ destroy .l
+} -body {
+ catch {unset x}
+ listbox .l -listvar x -height 3
+ pack .l
+ update
+ set x [list 0 1 2 3 4 5]
+ .l yview scroll 3 units
+ update
+ set result {}
+ lappend result [format {%.6g %.6g} {*}[.l yview]]
+ set x [lreplace $x 3 3]
+ set x [lreplace $x 3 3]
+ set x [lreplace $x 3 3]
+ update
+ lappend result [format {%.6g %.6g} {*}[.l yview]]
+ set result
+} -cleanup {
+ destroy .l
+} -result [list {0.5 1} {0 1}]
+
+
+# UpdateHScrollbar
+test listbox-22.1 {UpdateHScrollbar} -setup {
+ destroy .l
+} -body {
+ set log {}
+ listbox .l -font $fixed -width 10 -xscrollcommand "record x"
+ pack .l
+ update
+ .l insert end "0000000000"
+ update
+ .l insert end "00000000000000000000"
+ update
+ set log
+} -cleanup {
+ destroy .l
+} -result [list {x 0 1} {x 0 1} {x 0 0.5}]
+
+
+# ConfigureListboxItem
+test listbox-23.1 {ConfigureListboxItem} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ catch {.l itemconfigure 0} result
+ set result
+} -cleanup {
+ destroy .l
+} -result {item number "0" out of range}
+test listbox-23.2 {ConfigureListboxItem} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a b c d
+ .l itemconfigure 0
+} -cleanup {
+ destroy .l
+} -result [list {-background background Background {} {}} \
+ {-bg -background} \
+ {-fg -foreground} \
+ {-foreground foreground Foreground {} {}} \
+ {-selectbackground selectBackground Foreground {} {}} \
+ {-selectforeground selectForeground Background {} {}}]
+test listbox-23.3 {ConfigureListboxItem, itemco shortcut} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a b c d
+ .l itemco 0 -background
+} -cleanup {
+ destroy .l
+} -result {-background background Background {} {}}
+test listbox-23.4 {ConfigureListboxItem, wrong num args} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a
+ catch {.l itemco} result
+ set result
+} -cleanup {
+ destroy .l
+} -result {wrong # args: should be ".l itemconfigure index ?-option? ?value? ?-option value ...?"}
+test listbox-23.5 {ConfigureListboxItem, multiple calls} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ set i 0
+ foreach color {red orange yellow green blue white violet} {
+ .l insert end $color
+ .l itemconfigure $i -bg $color
+ incr i
+ }
+ pack .l
+ update
+ list [.l itemcget 0 -bg] [.l itemcget 1 -bg] [.l itemcget 2 -bg] \
+ [.l itemcget 3 -bg] [.l itemcget 4 -bg] [.l itemcget 5 -bg] \
+ [.l itemcget 6 -bg]
+} -cleanup {
+ destroy .l
+} -result {red orange yellow green blue white violet}
+
+# Listbox used in 23.6 -23.17 tests
+destroy .l
+listbox .l
+.l insert end a b c d
+test listbox-23.6 {configuration options} -body {
+ .l itemconfigure 0 -background #ff0000
+ list [lindex [.l itemconfigure 0 -background] 4] [.l itemcget 0 -background]
+} -cleanup {
+ .l configure -background #ffffff
+} -result {{#ff0000} #ff0000}
+test listbox-23.7 {configuration options} -body {
+ .l configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test listbox-23.8 {configuration options} -body {
+ .l itemconfigure 0 -bg #ff0000
+ list [lindex [.l itemconfigure 0 -bg] 4] [.l itemcget 0 -bg]
+} -cleanup {
+ .l configure -bg #ffffff
+} -result {{#ff0000} #ff0000}
+test listbox-23.9 {configuration options} -body {
+ .l configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test listbox-23.10 {configuration options} -body {
+ .l itemconfigure 0 -fg #110022
+ list [lindex [.l itemconfigure 0 -fg] 4] [.l itemcget 0 -fg]
+} -cleanup {
+ .l configure -fg #000000
+} -result {{#110022} #110022}
+test listbox-23.11 {configuration options} -body {
+ .l configure -fg bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-23.12 {configuration options} -body {
+ .l itemconfigure 0 -foreground #110022
+ list [lindex [.l itemconfigure 0 -foreground] 4] [.l itemcget 0 -foreground]
+} -cleanup {
+ .l configure -foreground #000000
+} -result {{#110022} #110022}
+test listbox-23.13 {configuration options} -body {
+ .l configure -foreground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-23.14 {configuration options} -body {
+ .l itemconfigure 0 -selectbackground #110022
+ list [lindex [.l itemconfigure 0 -selectbackground] 4] [.l itemcget 0 -selectbackground]
+} -cleanup {
+ .l configure -selectbackground #c3c3c3
+} -result {{#110022} #110022}
+test listbox-23.15 {configuration options} -body {
+ .l configure -selectbackground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-23.16 {configuration options} -body {
+ .l itemconfigure 0 -selectforeground #654321
+ list [lindex [.l itemconfigure 0 -selectforeground] 4] [.l itemcget 0 -selectforeground]
+} -cleanup {
+ .l configure -selectforeground #000000
+} -result {{#654321} #654321}
+test listbox-23.17 {configuration options} -body {
+ .l configure -selectforeground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+
+
+# ListboxWidgetObjCmd, itemcget
+test listbox-24.1 {itemcget} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a b c d
+ .l itemcget 0 -fg
+} -cleanup {
+ destroy .l
+} -result {}
+test listbox-24.2 {itemcget} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a b c d
+ .l itemconfigure 0 -fg red
+ .l itemcget 0 -fg
+} -cleanup {
+ destroy .l
+} -result red
+test listbox-24.3 {itemcget} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a b c d
+ catch {.l itemcget 0} result
+ set result
+} -cleanup {
+ destroy .l
+} -result {wrong # args: should be ".l itemcget index option"}
+test listbox-24.4 {itemcget, itemcg shortcut} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a b c d
+ catch {.l itemcg 0} result
+ set result
+} -cleanup {
+ destroy .l
+} -result {wrong # args: should be ".l itemcget index option"}
+
+
+# General item configuration issues
+test listbox-25.1 {listbox item configurations and widget based deletions} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a
+ .l itemconfigure 0 -fg red
+ .l delete 0 end
+ .l insert end a
+ .l itemcget 0 -fg
+} -cleanup {
+ destroy .l
+} -result {}
+test listbox-25.2 {listbox item configurations and widget based inserts} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a b c
+ .l itemconfigure 0 -fg red
+ .l insert 0 1 2 3 4
+ list [.l itemcget 0 -fg] [.l itemcget 4 -fg]
+} -cleanup {
+ destroy .l
+} -result {{} red}
+
+
+# state issues
+test listbox-26.1 {listbox disabled state disallows inserts} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a b c
+ .l configure -state disabled
+ .l insert end d e f
+ .l get 0 end
+} -cleanup {
+ destroy .l
+} -result [list a b c]
+test listbox-26.2 {listbox disabled state disallows deletions} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a b c
+ .l configure -state disabled
+ .l delete 0 end
+ .l get 0 end
+} -cleanup {
+ destroy .l
+} -result [list a b c]
+test listbox-26.3 {listbox disabled state disallows selection modification} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a b c
+ .l selection set 0
+ .l selection set 2
+ .l configure -state disabled
+ .l selection clear 0 end
+ .l selection set 1
+ .l curselection
+} -cleanup {
+ destroy .l
+} -result [list 0 2]
+test listbox-26.4 {listbox disabled state disallows anchor modification} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a b c
+ .l selection anchor 0
+ .l configure -state disabled
+ .l selection anchor 2
+ .l index anchor
+} -cleanup {
+ destroy .l
+} -result 0
+test listbox-26.5 {listbox disabled state disallows active modification} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end a b c
+ .l activate 0
+ .l configure -state disabled
+ .l activate 2
+ .l index active
+} -cleanup {
+ destroy .l
+} -result 0
+
+
+test listbox-27.1 {widget deletion while active} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ update
+ .l configure -cursor xterm -xscrollcommand { destroy .l }
+ update idle
+ winfo exists .l
+} -cleanup {
+ destroy .l
+} -result 0
+
+
+test listbox-28.1 {listbox -activestyle} -setup {
+ destroy .l
+} -body {
+ listbox .l -activ non
+ .l cget -activestyle
+} -cleanup {
+ destroy .l
+} -result none
+test listbox-28.2 {listbox -activestyle} -constraints {
+ nonwin
+} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l cget -activestyle
+} -cleanup {
+ destroy .l
+} -result dotbox
+test listbox-28.3 {listbox -activestyle} -constraints {
+ win
+} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l cget -activestyle
+} -cleanup {
+ destroy .l
+} -result underline
+test listbox-28.4 {listbox -activestyle} -setup {
+ destroy .l
+} -body {
+ listbox .l -activestyle und
+ .l cget -activestyle
+} -cleanup {
+ destroy .l
+} -result underline
+
+
+test listbox-29.1 {listbox selection behavior, -state disabled} -setup {
+ destroy .l
+} -body {
+ listbox .l
+ .l insert end 1 2 3
+ .l selection set 2
+ set out [.l selection includes 2]
+ .l configure -state disabled
+ # still return 1 when disabled, because 'selection get' will work,
+ # but selection cannot be changed (new behavior since 8.4)
+ .l selection set 3
+ lappend out [.l selection includes 2] [.l curselection]
+} -cleanup {
+ destroy .l
+} -result {1 1 2}
+
+test listbox-30.1 {Bug 3607326} -setup {
+ destroy .l
+ unset -nocomplain a
+} -body {
+ array set a {}
+ listbox .l -listvariable a
+} -cleanup {
+ destroy .l
+ unset -nocomplain a
+} -result * -match glob -returnCodes error
+
+test listbox-31.1 {<<ListboxSelect>> event} -setup {
+ destroy .l
+ unset -nocomplain res
+} -body {
+ pack [listbox .l -state normal]
+ update
+ bind .l <<ListboxSelect>> {lappend res [%W curselection]}
+ .l insert end a b c
+ focus -force .l
+ event generate .l <1> -x 5 -y 5 ; # <<ListboxSelect>> fires
+ .l configure -state disabled
+ focus -force .l
+ event generate .l <Control-Home> ; # <<ListboxSelect>> does NOT fire
+ .l configure -state normal
+ focus -force .l
+ event generate .l <Control-End> ; # <<ListboxSelect>> fires
+ .l selection clear 0 end ; # <<ListboxSelect>> does NOT fire
+ .l selection set 1 1 ; # <<ListboxSelect>> does NOT fire
+ lappend res [.l curselection]
+} -cleanup {
+ destroy .l
+ unset -nocomplain res
+} -result {0 2 1}
+
+test listbox-31.2 {<<ListboxSelect>> event on lost selection} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l -exportselection true]
+ update
+ bind .l <<ListboxSelect>> {lappend res [list [selection own] [%W curselection]]}
+ .l insert end a b c
+ focus -force .l
+ event generate .l <1> -x 5 -y 5 ; # <<ListboxSelect>> fires
+ selection clear ; # <<ListboxSelect>> fires again
+ update
+ set res
+} -cleanup {
+ destroy .l
+} -result {{.l 0} {{} {}}}
+
+resetGridInfo
+deleteWindows
+option clear
+
+# cleanup
+cleanupTests
+return
+
+
+
+
+
diff --git a/tk8.6/tests/main.test b/tk8.6/tests/main.test
new file mode 100644
index 0000000..7ab624f
--- /dev/null
+++ b/tk8.6/tests/main.test
@@ -0,0 +1,120 @@
+# This file contains tests for the tkMain.c file.
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1997 by Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test main-1.1 {StdinProc} -constraints stdio -setup {
+ set script [makeFile {close stdin; exit} script]
+} -body {
+ exec [interpreter] <$script
+} -cleanup {
+ removeFile script
+} -returnCodes ok
+
+test main-2.1 {Tk_MainEx: -encoding option} -constraints stdio -setup {
+ set script [makeFile {} script]
+ file delete $script
+ set f [open $script w]
+ fconfigure $f -encoding utf-8
+ puts $f {puts [list $argv0 $argv $tcl_interactive]}
+ puts -nonewline $f {puts [string equal \u20ac }
+ puts $f "\u20ac]; exit"
+ close $f
+ catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]}
+} -body {
+ read $f
+} -cleanup {
+ close $f
+ removeFile script
+} -result "script {} 0\n1\n"
+
+test main-2.2 {Tk_MainEx: -encoding option} -constraints stdio -setup {
+ set script [makeFile {} script]
+ file delete $script
+ set f [open $script w]
+ fconfigure $f -encoding utf-8
+ puts $f {puts [list $argv0 $argv $tcl_interactive]}
+ puts -nonewline $f {puts [string equal \u20ac }
+ puts $f "\u20ac]; exit"
+ close $f
+ catch {set f [open "|[list [interpreter] -encoding ascii script]" r]}
+} -body {
+ read $f
+} -cleanup {
+ close $f
+ removeFile script
+} -result "script {} 0\n0\n"
+
+ # Procedure to simulate interactive typing of commands, line by line,
+ # for test 2.3
+ proc type {chan script} {
+ foreach line [split $script \n] {
+ if {[catch {
+ puts $chan $line
+ flush $chan
+ }]} {
+ return
+ }
+ # Grrr... Behavior depends on this value.
+ after 1000
+ }
+ }
+
+test main-2.3 {Tk_MainEx: -encoding option} -constraints stdio -setup {
+ set script [makeFile {} script]
+ file delete $script
+ set f [open $script w]
+ fconfigure $f -encoding utf-8
+ puts $f {puts [list $argv0 $argv $tcl_interactive]}
+ puts -nonewline $f {puts [string equal \u20ac }
+ puts $f "\u20ac]"
+ close $f
+ catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]}
+} -body {
+ type $f {
+ puts $argv
+ exit
+ }
+ gets $f
+} -cleanup {
+ close $f
+ removeFile script
+} -returnCodes ok -result {-enc utf-8 script}
+
+test main-3.1 {Tk_ParseArgv: -help option} -constraints unix -body {
+ # Run only on unix as Win32 pops up native dialog
+ exec [interpreter] -help
+} -returnCodes error -match glob -result {% application-specific initialization failed: Command-specific options:*}
+
+test main-3.2 {Tk_ParseArgv: -help option} -setup {
+ set maininterp [interp create]
+} -body {
+ $maininterp eval { set argc 1 ; set argv -help }
+ load {} Tk $maininterp
+} -cleanup {
+ interp delete $maininterp
+} -returnCodes error -match glob -result {Command-specific options:*}
+
+test main-3.3 {Tk_ParseArgv: -help option} -setup {
+ set maininterp [interp create]
+} -body {
+ # Repeat of 3.2 to catch cleanup, eg Bug 1927135
+ $maininterp eval { set argc 1 ; set argv -help }
+ load {} Tk $maininterp
+} -cleanup {
+ interp delete $maininterp
+} -returnCodes error -match glob -result {Command-specific options:*}
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/menu.test b/tk8.6/tests/menu.test
new file mode 100644
index 0000000..aaadc86
--- /dev/null
+++ b/tk8.6/tests/menu.test
@@ -0,0 +1,3890 @@
+# This file is a Tcl script to test menus in Tk. It is
+# organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1995-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+imageInit
+
+# find the earth.gif file for use in these tests (tests 2.*)
+set earthPhotoFile [file join [file dirname [info script]] earth.gif]
+testConstraint hasEarthPhoto [file exists $earthPhotoFile]
+
+test menu-1.1 {Tk_MenuCmd procedure} -body {
+ menu
+} -returnCodes error -result {wrong # args: should be "menu pathName ?-option value ...?"}
+test menu-1.2 {Tk_MenuCmd procedure} -body {
+ menu bogus
+} -returnCodes error -result {bad window path name "bogus"}
+test menu-1.3 {Tk_MenuCmd procedure} -body {
+ destroy .m1
+ menu .m1 foo
+} -returnCodes error -result {unknown option "foo"}
+test menu-1.4 {Tk_MenuCmd procedure} -body {
+ destroy .m1
+ menu .m1
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+test menu-1.5 {Tk_MenuCmd - creating menubar} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label Test -menu ""
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-1.6 {Tk_MenuCmd procedure menu ref no cascade} -setup {
+ deleteWindows
+} -body {
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ menu .m1
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+test menu-1.7 {Tk_MenuCmd procedure one clone cascade} -setup {
+ deleteWindows
+} -body {
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ menu .m1
+ .m1 add cascade -menu .m2
+ menu .m2
+} -cleanup {
+ deleteWindows
+} -result {.m2}
+test menu-1.8 {Tk_MenuCmd procedure two clone cascades} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m2
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ toplevel .t3 -menu .m1
+ wm geometry .t3 +0+0
+ menu .m2
+} -cleanup {
+ deleteWindows
+} -result {.m2}
+test menu-1.9 {Tk_MenuCmd procedure two clone cascades different order} -setup {
+ deleteWindows
+} -body {
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ menu .m1
+ .m1 add cascade -menu .m2
+ toplevel .t3 -menu .m1
+ wm geometry .t3 +0+0
+ list [menu .m2]
+} -cleanup {
+ deleteWindows
+} -result {.m2}
+test menu-1.10 {Tk_MenuCmd procedure two clone cascades menus last} -setup {
+ deleteWindows
+} -body {
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ toplevel .t3 -menu .m1
+ wm geometry .t3 +0+0
+ menu .m1
+ .m1 add cascade -menu .m2
+ list [menu .m2]
+} -cleanup {
+ deleteWindows
+} -result {.m2}
+test menu-1.11 {Tk_MenuCmd procedure three clones cascades} -setup {
+ deleteWindows
+} -body {
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ toplevel .t3 -menu .m1
+ wm geometry .t3 +0+0
+ toplevel .t4 -menu .m1
+ wm geometry .t4 +0+0
+ menu .m1
+ .m1 add cascade -menu .m2
+ list [menu .m2]
+} -cleanup {
+ deleteWindows
+} -result {.m2}
+test menu-1.12 {Tk_MenuCmd procedure} -setup {
+ deleteWindows
+} -body {
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ list [menu .m1]
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+test menu-1.13 {Tk_MenuCmd procedure} -setup {
+ deleteWindows
+} -body {
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ toplevel .t3 -menu .m1
+ wm geometry .t3 +0+0
+ list [menu .m1]
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+test menu-1.14 {Tk_MenuCmd procedure} -setup {
+ deleteWindows
+} -body {
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ toplevel .t3 -menu .m1
+ wm geometry .t3 +0+0
+ toplevel .t4 -menu .m1
+ wm geometry .t4 +0+0
+ list [menu .m1]
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+
+# Used for 2.1 - 2.30 tests
+destroy .m1
+menu .m1
+test menu-2.1 {configuration options -activebackground #012345} -body {
+ .m1 configure -activebackground #012345
+ .m1 cget -activebackground
+} -result {#012345}
+test menu-2.2 {configuration options -activebackground non-existent} -body {
+ .m1 configure -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.3 {configuration options -activeborderwidth 1.3} -body {
+ .m1 configure -activeborderwidth 1.3
+ .m1 cget -activeborderwidth
+} -result {1.3}
+test menu-2.4 {configuration options -activeborderwidth badValue} -body {
+ .m1 configure -activeborderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+
+test menu-2.5 {configuration options -activeforeground #ff0000} -body {
+ .m1 configure -activeforeground #ff0000
+ .m1 cget -activeforeground
+} -result {#ff0000}
+test menu-2.6 {configuration options -activeforeground non-existent} -body {
+ .m1 configure -activeforeground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.7 {configuration options -background #ff0000} -body {
+ .m1 configure -background #ff0000
+ .m1 cget -background
+} -result {#ff0000}
+test menu-2.8 {configuration options -background non-existent} -body {
+ .m1 configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.9 {configuration options -bg #110022} -body {
+ .m1 configure -bg #110022
+ .m1 cget -bg
+} -result {#110022}
+test menu-2.10 {configuration options -bg bogus} -body {
+ .m1 configure -bg bogus
+} -returnCodes error -result {unknown color name "bogus"}
+
+test menu-2.11 {configuration options -borderwidth 1.3} -body {
+ .m1 configure -borderwidth 1.3
+ .m1 cget -borderwidth
+} -result {1.3}
+test menu-2.12 {configuration options -borderwidth badValue} -body {
+ .m1 configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+
+test menu-2.13 {configuration options -cursor arrow} -body {
+ .m1 configure -cursor arrow
+ .m1 cget -cursor
+} -result {arrow}
+test menu-2.14 {configuration options -cursor badValue} -body {
+ .m1 configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+
+test menu-2.15 {configuration options -disabledforeground #00ff00} -body {
+ .m1 configure -disabledforeground #00ff00
+ .m1 cget -disabledforeground
+} -result {#00ff00}
+test menu-2.16 {configuration options -disabledforeground xyzzy} -body {
+ .m1 configure -disabledforeground xyzzy
+} -returnCodes error -result {unknown color name "xyzzy"}
+
+test menu-2.17 {configuration options -fg #110022} -body {
+ .m1 configure -fg #110022
+ .m1 cget -fg
+} -result {#110022}
+test menu-2.18 {configuration options -fg bogus} -body {
+ .m1 configure -fg bogus
+} -returnCodes error -result {unknown color name "bogus"}
+
+test menu-2.19 {configuration options -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*} -body {
+ .m1 configure -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+ .m1 cget -font
+} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*}
+test menu-2.20 {configuration options -foreground #110022} -body {
+ .m1 configure -foreground #110022
+ .m1 cget -foreground
+} -result {#110022}
+test menu-2.21 {configuration options -foreground bogus} -body {
+ .m1 configure -foreground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+
+test menu-2.22 {configuration options -postcommand {any old string}} -body {
+ .m1 configure -postcommand {any old string}
+ .m1 cget -postcommand
+} -result {any old string}
+test menu-2.23 {configuration options -relief groove} -body {
+ .m1 configure -relief groove
+ .m1 cget -relief
+} -result {groove}
+test menu-2.24 {configuration options -relief 1.5} -body {
+ .m1 configure -relief 1.5
+} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+
+test menu-2.25 {configuration options -selectcolor #110022} -body {
+ .m1 configure -selectcolor #110022
+ .m1 cget -selectcolor
+} -result {#110022}
+test menu-2.26 {configuration options -selectcolor bogus} -body {
+ .m1 configure -selectcolor bogus
+} -returnCodes error -result {unknown color name "bogus"}
+
+test menu-2.27 {configuration options -takefocus {any string}} -body {
+ .m1 configure -takefocus {any string}
+ .m1 cget -takefocus
+} -result {any string}
+test menu-2.28 {configuration options -tearoff 0} -body {
+ .m1 configure -tearoff 0
+ .m1 cget -tearoff
+} -result {0}
+test menu-2.29 {configuration options -tearoff 1} -body {
+ .m1 configure -tearoff 1
+ .m1 cget -tearoff
+} -result {1}
+test menu-2.30 {configuration options -tearoffcommand {any old string}} -body {
+ .m1 configure -tearoffcommand {any old string}
+ .m1 cget -tearoffcommand
+} -result {any old string}
+destroy .m1
+
+# We need to test all of the options with all of the different types of
+# menu entries. The following code sets up .m1 with 6 items. It then
+# runs through the 2.31 - 2.228 tests below
+# index 0 is tearoff, 1 command, 2 cascade, 3 separator, 4 checkbutton,
+# 5 radiobutton
+deleteWindows
+menu .m1
+.m1 add command -label "command"
+menu .m2
+.m2 add command -label "test"
+.m1 add cascade -label "cascade" -menu .m2
+.m1 add separator
+.m1 add checkbutton -label "checkbutton" -variable check -onvalue on -offvalue off
+.m1 add radiobutton -label "radiobutton" -variable radio
+
+if {[testConstraint hasEarthPhoto]} {
+ image create photo image1 -file $earthPhotoFile
+}
+
+test menu-2.31 {entry configuration options 0 -activebackground #012345 tearoff} -body {
+ .m1 entryconfigure 0 -activebackground #012345
+} -returnCodes error -result {unknown option "-activebackground"}
+
+test menu-2.32 {entry configuration options 1 -activebackground #012345 command} -body {
+ .m1 entryconfigure 1 -activebackground #012345
+ lindex [.m1 entryconfigure 1 -activebackground] 4
+} -result {#012345}
+
+test menu-2.33 {entry configuration options 2 -activebackground #012345 cascade} -body {
+ .m1 entryconfigure 2 -activebackground #012345
+ lindex [.m1 entryconfigure 2 -activebackground] 4
+} -result {#012345}
+
+test menu-2.34 {entry configuration options 3 -activebackground #012345 separator} -body {
+ .m1 entryconfigure 3 -activebackground #012345
+} -returnCodes error -result {unknown option "-activebackground"}
+
+test menu-2.35 {entry configuration options 4 -activebackground #012345 checkbutton} -body {
+ .m1 entryconfigure 4 -activebackground #012345
+ lindex [.m1 entryconfigure 4 -activebackground] 4
+} -result {#012345}
+
+test menu-2.36 {entry configuration options 5 -activebackground #012345 radiobutton} -body {
+ .m1 entryconfigure 5 -activebackground #012345
+ lindex [.m1 entryconfigure 5 -activebackground] 4
+} -result {#012345}
+
+test menu-2.37 {entry configuration options 0 -activebackground non-existent tearoff} -body {
+ .m1 entryconfigure 0 -activebackground non-existent
+} -returnCodes error -result {unknown option "-activebackground"}
+
+test menu-2.38 {entry configuration options 1 -activebackground non-existent command} -body {
+ .m1 entryconfigure 1 -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.39 {entry configuration options 2 -activebackground non-existent cascade} -body {
+ .m1 entryconfigure 2 -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.40 {entry configuration options 3 -activebackground non-existent separator} -body {
+ .m1 entryconfigure 3 -activebackground non-existent
+} -returnCodes error -result {unknown option "-activebackground"}
+
+test menu-2.41 {entry configuration options 4 -activebackground non-existent checkbutton} -body {
+ .m1 entryconfigure 4 -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.42 {entry configuration options 5 -activebackground non-existent radiobutton} -body {
+ .m1 entryconfigure 5 -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.43 {entry configuration options 0 -activeforeground #ff0000 tearoff} -body {
+ .m1 entryconfigure 0 -activeforeground #ff0000
+} -returnCodes error -result {unknown option "-activeforeground"}
+
+test menu-2.44 {entry configuration options 1 -activeforeground #ff0000 command} -body {
+ .m1 entryconfigure 1 -activeforeground #ff0000
+ lindex [.m1 entryconfigure 1 -activeforeground] 4
+} -result {#ff0000}
+
+test menu-2.45 {entry configuration options 2 -activeforeground #ff0000 cascade} -body {
+ .m1 entryconfigure 2 -activeforeground #ff0000
+ lindex [.m1 entryconfigure 2 -activeforeground] 4
+} -result {#ff0000}
+
+test menu-2.46 {entry configuration options 3 -activeforeground #ff0000 separator} -body {
+ .m1 entryconfigure 3 -activeforeground #ff0000
+} -returnCodes error -result {unknown option "-activeforeground"}
+
+test menu-2.47 {entry configuration options 4 -activeforeground #ff0000 checkbutton} -body {
+ .m1 entryconfigure 4 -activeforeground #ff0000
+ lindex [.m1 entryconfigure 4 -activeforeground] 4
+} -result {#ff0000}
+
+test menu-2.48 {entry configuration options 5 -activeforeground #ff0000 radiobutton} -body {
+ .m1 entryconfigure 5 -activeforeground #ff0000
+ lindex [.m1 entryconfigure 5 -activeforeground] 4
+} -result {#ff0000}
+
+test menu-2.49 {entry configuration options 0 -activeforeground non-existent tearoff} -body {
+ .m1 entryconfigure 0 -activeforeground non-existent
+} -returnCodes error -result {unknown option "-activeforeground"}
+
+test menu-2.50 {entry configuration options 1 -activeforeground non-existent command} -body {
+ .m1 entryconfigure 1 -activeforeground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.51 {entry configuration options 2 -activeforeground non-existent cascade} -body {
+ .m1 entryconfigure 2 -activeforeground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.52 {entry configuration options 3 -activeforeground non-existent separator} -body {
+ .m1 entryconfigure 3 -activeforeground non-existent
+} -returnCodes error -result {unknown option "-activeforeground"}
+
+test menu-2.53 {entry configuration options 4 -activeforeground non-existent checkbutton} -body {
+ .m1 entryconfigure 4 -activeforeground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.54 {entry configuration options 5 -activeforeground non-existent radiobutton} -body {
+ .m1 entryconfigure 5 -activeforeground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.55 {entry configuration options 0 -accelerator Ctrl+S tearoff} -body {
+ .m1 entryconfigure 0 -accelerator Ctrl+S
+} -returnCodes error -result {unknown option "-accelerator"}
+
+test menu-2.56 {entry configuration options 1 -accelerator Ctrl+S command} -body {
+ .m1 entryconfigure 1 -accelerator Ctrl+S
+ lindex [.m1 entryconfigure 1 -accelerator] 4
+} -result {Ctrl+S}
+
+test menu-2.57 {entry configuration options 2 -accelerator Ctrl+S cascade} -body {
+ .m1 entryconfigure 2 -accelerator Ctrl+S
+ lindex [.m1 entryconfigure 2 -accelerator] 4
+} -result {Ctrl+S}
+
+test menu-2.58 {entry configuration options 3 -accelerator Ctrl+S separator} -body {
+ .m1 entryconfigure 3 -accelerator Ctrl+S
+} -returnCodes error -result {unknown option "-accelerator"}
+
+test menu-2.59 {entry configuration options 4 -accelerator Ctrl+S checkbutton} -body {
+ .m1 entryconfigure 4 -accelerator Ctrl+S
+ lindex [.m1 entryconfigure 4 -accelerator] 4
+} -result {Ctrl+S}
+
+test menu-2.60 {entry configuration options 5 -accelerator Ctrl+S radiobutton} -body {
+ .m1 entryconfigure 5 -accelerator Ctrl+S
+ lindex [.m1 entryconfigure 5 -accelerator] 4
+} -result {Ctrl+S}
+
+test menu-2.61 {entry configuration options 0 -background #ff0000 tearoff} -body {
+ .m1 entryconfigure 0 -background #ff0000
+ lindex [.m1 entryconfigure 0 -background] 4
+} -result {#ff0000}
+
+test menu-2.62 {entry configuration options 1 -background #ff0000 command} -body {
+ .m1 entryconfigure 1 -background #ff0000
+ lindex [.m1 entryconfigure 1 -background] 4
+} -result {#ff0000}
+
+test menu-2.63 {entry configuration options 2 -background #ff0000 cascade} -body {
+ .m1 entryconfigure 2 -background #ff0000
+ lindex [.m1 entryconfigure 2 -background] 4
+} -result {#ff0000}
+
+test menu-2.64 {entry configuration options 3 -background #ff0000 separator} -body {
+ .m1 entryconfigure 3 -background #ff0000
+ lindex [.m1 entryconfigure 3 -background] 4
+} -result {#ff0000}
+
+test menu-2.65 {entry configuration options 4 -background #ff0000 checkbutton} -body {
+ .m1 entryconfigure 4 -background #ff0000
+ lindex [.m1 entryconfigure 4 -background] 4
+} -result {#ff0000}
+
+test menu-2.66 {entry configuration options 5 -background #ff0000 radiobutton} -body {
+ .m1 entryconfigure 5 -background #ff0000
+ lindex [.m1 entryconfigure 5 -background] 4
+} -result {#ff0000}
+
+test menu-2.67 {entry configuration options 0 -background non-existent tearoff} -body {
+ .m1 entryconfigure 0 -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.68 {entry configuration options 1 -background non-existent command} -body {
+ .m1 entryconfigure 1 -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.69 {entry configuration options 2 -background non-existent cascade} -body {
+ .m1 entryconfigure 2 -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.70 {entry configuration options 3 -background non-existent separator} -body {
+ .m1 entryconfigure 3 -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.71 {entry configuration options 4 -background non-existent checkbutton} -body {
+ .m1 entryconfigure 4 -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.72 {entry configuration options 5 -background non-existent radiobutton} -body {
+ .m1 entryconfigure 5 -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.73 {entry configuration options 0 -bitmap questhead tearoff} -body {
+ .m1 entryconfigure 0 -bitmap questhead
+} -returnCodes error -result {unknown option "-bitmap"}
+
+test menu-2.74 {entry configuration options 1 -bitmap questhead command} -body {
+ .m1 entryconfigure 1 -bitmap questhead
+ lindex [.m1 entryconfigure 1 -bitmap] 4
+} -result {questhead}
+
+test menu-2.75 {entry configuration options 2 -bitmap questhead cascade} -body {
+ .m1 entryconfigure 2 -bitmap questhead
+ lindex [.m1 entryconfigure 2 -bitmap] 4
+} -result {questhead}
+
+test menu-2.76 {entry configuration options 3 -bitmap questhead separator} -body {
+ .m1 entryconfigure 3 -bitmap questhead
+} -returnCodes error -result {unknown option "-bitmap"}
+
+test menu-2.77 {entry configuration options 4 -bitmap questhead checkbutton} -body {
+ .m1 entryconfigure 4 -bitmap questhead
+ lindex [.m1 entryconfigure 4 -bitmap] 4
+} -result {questhead}
+
+test menu-2.78 {entry configuration options 5 -bitmap questhead radiobutton} -body {
+ .m1 entryconfigure 5 -bitmap questhead
+ lindex [.m1 entryconfigure 5 -bitmap] 4
+} -result {questhead}
+
+test menu-2.79 {entry configuration options 0 -bitmap badValue tearoff} -body {
+ .m1 entryconfigure 0 -bitmap badValue
+} -returnCodes error -result {unknown option "-bitmap"}
+
+test menu-2.80 {entry configuration options 1 -bitmap badValue command} -body {
+ .m1 entryconfigure 1 -bitmap badValue
+} -returnCodes error -result {bitmap "badValue" not defined}
+
+test menu-2.81 {entry configuration options 2 -bitmap badValue cascade} -body {
+ .m1 entryconfigure 2 -bitmap badValue
+} -returnCodes error -result {bitmap "badValue" not defined}
+
+test menu-2.82 {entry configuration options 3 -bitmap badValue separator} -body {
+ .m1 entryconfigure 3 -bitmap badValue
+} -returnCodes error -result {unknown option "-bitmap"}
+
+test menu-2.83 {entry configuration options 4 -bitmap badValue checkbutton} -body {
+ .m1 entryconfigure 4 -bitmap badValue
+} -returnCodes error -result {bitmap "badValue" not defined}
+
+test menu-2.84 {entry configuration options 5 -bitmap badValue radiobutton} -body {
+ .m1 entryconfigure 5 -bitmap badValue
+} -returnCodes error -result {bitmap "badValue" not defined}
+
+test menu-2.85 {entry configuration options 0 -columnbreak 1 tearoff} -body {
+ .m1 entryconfigure 0 -columnbreak 1
+} -returnCodes error -result {unknown option "-columnbreak"}
+
+test menu-2.86 {entry configuration options 1 -columnbreak 1 command} -body {
+ .m1 entryconfigure 1 -columnbreak 1
+ lindex [.m1 entryconfigure 1 -columnbreak] 4
+} -result {1}
+
+test menu-2.87 {entry configuration options 2 -columnbreak 1 cascade} -body {
+ .m1 entryconfigure 2 -columnbreak 1
+ lindex [.m1 entryconfigure 2 -columnbreak] 4
+} -result {1}
+
+test menu-2.88 {entry configuration options 3 -columnbreak 1 separator} -body {
+ .m1 entryconfigure 3 -columnbreak 1
+} -returnCodes error -result {unknown option "-columnbreak"}
+
+test menu-2.89 {entry configuration options 4 -columnbreak 1 checkbutton} -body {
+ .m1 entryconfigure 4 -columnbreak 1
+ lindex [.m1 entryconfigure 4 -columnbreak] 4
+} -result {1}
+
+test menu-2.90 {entry configuration options 5 -columnbreak 1 radiobutton} -body {
+ .m1 entryconfigure 5 -columnbreak 1
+ lindex [.m1 entryconfigure 5 -columnbreak] 4
+} -result {1}
+
+test menu-2.91 {entry configuration options 0 -command beep tearoff} -body {
+ .m1 entryconfigure 0 -command beep
+} -returnCodes error -result {unknown option "-command"}
+
+test menu-2.92 {entry configuration options 1 -command beep command} -body {
+ .m1 entryconfigure 1 -command beep
+ lindex [.m1 entryconfigure 1 -command] 4
+} -result {beep}
+
+test menu-2.93 {entry configuration options 2 -command beep cascade} -body {
+ .m1 entryconfigure 2 -command beep
+ lindex [.m1 entryconfigure 2 -command] 4
+} -result {beep}
+
+test menu-2.94 {entry configuration options 3 -command beep separator} -body {
+ .m1 entryconfigure 3 -command beep
+} -returnCodes error -result {unknown option "-command"}
+
+test menu-2.95 {entry configuration options 4 -command beep checkbutton} -body {
+ .m1 entryconfigure 4 -command beep
+ lindex [.m1 entryconfigure 4 -command] 4
+} -result {beep}
+
+test menu-2.96 {entry configuration options 5 -command beep radiobutton} -body {
+ .m1 entryconfigure 5 -command beep
+ lindex [.m1 entryconfigure 5 -command] 4
+} -result {beep}
+
+test menu-2.97 {entry configuration options 0 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* tearoff} -body {
+ .m1 entryconfigure 0 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+} -returnCodes error -result {unknown option "-font"}
+
+test menu-2.98 {entry configuration options 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* command} -body {
+ .m1 entryconfigure 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+ lindex [.m1 entryconfigure 1 -font] 4
+} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*}
+
+test menu-2.99 {entry configuration options 2 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* cascade} -body {
+ .m1 entryconfigure 2 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+ lindex [.m1 entryconfigure 2 -font] 4
+} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*}
+
+test menu-2.100 {entry configuration options 3 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* separator} -body {
+ .m1 entryconfigure 3 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+} -returnCodes error -result {unknown option "-font"}
+
+test menu-2.101 {entry configuration options 4 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* checkbutton} -body {
+ .m1 entryconfigure 4 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+ lindex [.m1 entryconfigure 4 -font] 4
+} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*}
+
+test menu-2.102 {entry configuration options 5 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* radiobutton} -body {
+ .m1 entryconfigure 5 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+ lindex [.m1 entryconfigure 5 -font] 4
+} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*}
+
+test menu-2.103 {entry configuration options 0 -font {kill rock stars} tearoff} -body {
+ .m1 entryconfigure 0 -font {kill rock stars}
+} -returnCodes error -result {unknown option "-font"}
+
+test menu-2.104 {entry configuration options 1 -font {kill rock stars} command} -body {
+ .m1 entryconfigure 1 -font {kill rock stars}
+} -returnCodes error -result {expected integer but got "rock"}
+
+test menu-2.105 {entry configuration options 2 -font {kill rock stars} cascade} -body {
+ .m1 entryconfigure 2 -font {kill rock stars}
+} -returnCodes error -result {expected integer but got "rock"}
+
+test menu-2.106 {entry configuration options 3 -font {kill rock stars} separator} -body {
+ .m1 entryconfigure 3 -font {kill rock stars}
+} -returnCodes error -result {unknown option "-font"}
+
+test menu-2.107 {entry configuration options 4 -font {kill rock stars} checkbutton} -body {
+ .m1 entryconfigure 4 -font {kill rock stars}
+} -returnCodes error -result {expected integer but got "rock"}
+
+test menu-2.108 {entry configuration options 5 -font {kill rock stars} radiobutton} -body {
+ .m1 entryconfigure 5 -font {kill rock stars}
+} -returnCodes error -result {expected integer but got "rock"}
+
+test menu-2.109 {entry configuration options 0 -foreground #110022 tearoff} -body {
+ .m1 entryconfigure 0 -foreground #110022
+} -returnCodes error -result {unknown option "-foreground"}
+
+test menu-2.110 {entry configuration options 1 -foreground #110022 command} -body {
+ .m1 entryconfigure 1 -foreground #110022
+ lindex [.m1 entryconfigure 1 -foreground] 4
+} -result {#110022}
+
+test menu-2.111 {entry configuration options 2 -foreground #110022 cascade} -body {
+ .m1 entryconfigure 2 -foreground #110022
+ lindex [.m1 entryconfigure 2 -foreground] 4
+} -result {#110022}
+
+test menu-2.112 {entry configuration options 3 -foreground #110022 separator} -body {
+ .m1 entryconfigure 3 -foreground #110022
+} -returnCodes error -result {unknown option "-foreground"}
+
+test menu-2.113 {entry configuration options 4 -foreground #110022 checkbutton} -body {
+ .m1 entryconfigure 4 -foreground #110022
+ lindex [.m1 entryconfigure 4 -foreground] 4
+} -result {#110022}
+
+test menu-2.114 {entry configuration options 5 -foreground #110022 radiobutton} -body {
+ .m1 entryconfigure 5 -foreground #110022
+ lindex [.m1 entryconfigure 5 -foreground] 4
+} -result {#110022}
+
+test menu-2.115 {entry configuration options 0 -foreground non-existent tearoff} -body {
+ .m1 entryconfigure 0 -foreground non-existent
+} -returnCodes error -result {unknown option "-foreground"}
+
+test menu-2.116 {entry configuration options 1 -foreground non-existent command} -body {
+ .m1 entryconfigure 1 -foreground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.117 {entry configuration options 2 -foreground non-existent cascade} -body {
+ .m1 entryconfigure 2 -foreground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.118 {entry configuration options 3 -foreground non-existent separator} -body {
+ .m1 entryconfigure 3 -foreground non-existent
+} -returnCodes error -result {unknown option "-foreground"}
+
+test menu-2.119 {entry configuration options 4 -foreground non-existent checkbutton} -body {
+ .m1 entryconfigure 4 -foreground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.120 {entry configuration options 5 -foreground non-existent radiobutton} -body {
+ .m1 entryconfigure 5 -foreground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.121 {entry configuration options 0 -image image1 tearoff} -constraints {
+ hasEarthPhoto
+} -body {
+ .m1 entryconfigure 0 -image image1
+} -returnCodes error -result {unknown option "-image"}
+
+test menu-2.122 {entry configuration options 1 -image image1 command} -constraints {
+ hasEarthPhoto
+} -setup {
+ .m1 entryconfigure 1 -image {}
+} -body {
+ .m1 entryconfigure 1 -image image1
+ lindex [.m1 entryconfigure 1 -image] 4
+} -cleanup {
+ .m1 entryconfigure 1 -image {}
+} -result {image1}
+
+test menu-2.123 {entry configuration options 2 -image image1 cascade} -constraints {
+ hasEarthPhoto
+} -setup {
+ .m1 entryconfigure 2 -image {}
+} -body {
+ .m1 entryconfigure 2 -image image1
+ lindex [.m1 entryconfigure 2 -image] 4
+} -cleanup {
+ .m1 entryconfigure 2 -image {}
+} -result {image1}
+
+test menu-2.124 {entry configuration options 3 -image image1 separator} -constraints {
+ hasEarthPhoto
+} -body {
+ .m1 entryconfigure 3 -image image1
+} -returnCodes error -result {unknown option "-image"}
+
+test menu-2.125 {entry configuration options 4 -image image1 checkbutton} -constraints {
+ hasEarthPhoto
+} -setup {
+ .m1 entryconfigure 4 -image {}
+} -body {
+ .m1 entryconfigure 4 -image image1
+ lindex [.m1 entryconfigure 4 -image] 4
+} -cleanup {
+ .m1 entryconfigure 4 -image {}
+} -result {image1}
+
+test menu-2.126 {entry configuration options 5 -image image1 radiobutton} -constraints {
+ hasEarthPhoto
+} -setup {
+ .m1 entryconfigure 5 -image {}
+} -body {
+ .m1 entryconfigure 5 -image image1
+ lindex [.m1 entryconfigure 5 -image] 4
+} -cleanup {
+ .m1 entryconfigure 5 -image {}
+} -result {image1}
+
+test menu-2.127 {entry configuration options 0 -image bogus tearoff} -body {
+ .m1 entryconfigure 0 -image bogus
+} -returnCodes error -result {unknown option "-image"}
+
+test menu-2.128 {entry configuration options 1 -image bogus command} -body {
+ .m1 entryconfigure 1 -image bogus
+} -returnCodes error -result {image "bogus" doesn't exist}
+
+test menu-2.129 {entry configuration options 2 -image bogus cascade} -body {
+ .m1 entryconfigure 2 -image bogus
+} -returnCodes error -result {image "bogus" doesn't exist}
+
+test menu-2.130 {entry configuration options 3 -image bogus separator} -body {
+ .m1 entryconfigure 3 -image bogus
+} -returnCodes error -result {unknown option "-image"}
+
+test menu-2.131 {entry configuration options 4 -image bogus checkbutton} -body {
+ .m1 entryconfigure 4 -image bogus
+} -returnCodes error -result {image "bogus" doesn't exist}
+
+test menu-2.132 {entry configuration options 5 -image bogus radiobutton} -body {
+ .m1 entryconfigure 5 -image bogus
+} -returnCodes error -result {image "bogus" doesn't exist}
+
+test menu-2.133 {entry configuration options 0 -image {} tearoff} -body {
+ .m1 entryconfigure 0 -image
+} -returnCodes error -result {unknown option "-image"}
+
+test menu-2.134 {entry configuration options 1 -image {} command} -setup {
+ .m1 entryconfigure 1 -image {}
+} -body {
+ .m1 entryconfigure 1 -image
+ lindex [.m1 entryconfigure 1 -image] 4
+} -result {}
+
+test menu-2.135 {entry configuration options 2 -image {} cascade} -setup {
+ .m1 entryconfigure 2 -image {}
+} -body {
+ .m1 entryconfigure 2 -image
+ lindex [.m1 entryconfigure 2 -image] 4
+} -result {}
+
+test menu-2.136 {entry configuration options 3 -image {} separator} -body {
+ .m1 entryconfigure 3 -image
+} -returnCodes error -result {unknown option "-image"}
+
+test menu-2.137 {entry configuration options 4 -image {} checkbutton} -body {
+ .m1 entryconfigure 4 -image
+ lindex [.m1 entryconfigure 4 -image] 4
+} -result {}
+
+test menu-2.138 {entry configuration options 5 -image {} radiobutton} -body {
+ .m1 entryconfigure 5 -image
+ lindex [.m1 entryconfigure 5 -image] 4
+} -result {}
+
+test menu-2.139 {entry configuration options 0 -indicatoron 1 tearoff} -body {
+ .m1 entryconfigure 0 -indicatoron 1
+} -returnCodes error -result {unknown option "-indicatoron"}
+
+test menu-2.140 {entry configuration options 1 -indicatoron 1 command} -body {
+ .m1 entryconfigure 1 -indicatoron 1
+} -returnCodes error -result {unknown option "-indicatoron"}
+
+test menu-2.141 {entry configuration options 2 -indicatoron 1 cascade} -body {
+ .m1 entryconfigure 2 -indicatoron 1
+} -returnCodes error -result {unknown option "-indicatoron"}
+
+test menu-2.142 {entry configuration options 3 -indicatoron 1 separator} -body {
+ .m1 entryconfigure 3 -indicatoron 1
+} -returnCodes error -result {unknown option "-indicatoron"}
+
+test menu-2.143 {entry configuration options 4 -indicatoron 1 checkbutton} -body {
+ .m1 entryconfigure 4 -indicatoron 1
+ lindex [.m1 entryconfigure 4 -indicatoron] 4
+} -result {1}
+
+test menu-2.144 {entry configuration options 5 -indicatoron 1 radiobutton} -body {
+ .m1 entryconfigure 5 -indicatoron 1
+ lindex [.m1 entryconfigure 5 -indicatoron] 4
+} -result {1}
+
+test menu-2.145 {entry configuration options 0 -label test tearoff} -body {
+ .m1 entryconfigure 0 -label test
+} -returnCodes error -result {unknown option "-label"}
+
+test menu-2.146 {entry configuration options 1 -label test command} -body {
+ .m1 entryconfigure 1 -label test
+ lindex [.m1 entryconfigure 1 -label] 4
+} -result {test}
+
+test menu-2.147 {entry configuration options 2 -label test cascade} -body {
+ .m1 entryconfigure 2 -label test
+ lindex [.m1 entryconfigure 2 -label] 4
+} -result {test}
+
+test menu-2.148 {entry configuration options 3 -label test separator} -body {
+ .m1 entryconfigure 3 -label test
+} -returnCodes error -result {unknown option "-label"}
+
+test menu-2.149 {entry configuration options 4 -label test checkbutton} -body {
+ .m1 entryconfigure 4 -label test
+ lindex [.m1 entryconfigure 4 -label] 4
+} -result {test}
+
+test menu-2.150 {entry configuration options 5 -label test radiobutton} -body {
+ .m1 entryconfigure 5 -label test
+ lindex [.m1 entryconfigure 5 -label] 4
+} -result {test}
+
+test menu-2.151 {entry configuration options 0 -menu .m2 tearoff} -body {
+ .m1 entryconfigure 0 -menu .m2
+} -returnCodes error -result {unknown option "-menu"}
+
+test menu-2.152 {entry configuration options 1 -menu .m2 command} -body {
+ .m1 entryconfigure 1 -menu .m2
+} -returnCodes error -result {unknown option "-menu"}
+
+test menu-2.153 {entry configuration options 2 -menu .m2 cascade} -body {
+ .m1 entryconfigure 2 -menu .m2
+ lindex [.m1 entryconfigure 2 -menu] 4
+} -result {.m2}
+
+test menu-2.154 {entry configuration options 3 -menu .m2 separator} -body {
+ .m1 entryconfigure 3 -menu .m2
+} -returnCodes error -result {unknown option "-menu"}
+
+test menu-2.155 {entry configuration options 4 -menu .m2 checkbutton} -body {
+ .m1 entryconfigure 4 -menu .m2
+} -returnCodes error -result {unknown option "-menu"}
+
+test menu-2.156 {entry configuration options 5 -menu .m2 radiobutton} -body {
+ .m1 entryconfigure 5 -menu .m2
+} -returnCodes error -result {unknown option "-menu"}
+
+test menu-2.157 {entry configuration options 0 -offvalue off tearoff} -body {
+ .m1 entryconfigure 0 -offvalue off
+} -returnCodes error -result {unknown option "-offvalue"}
+
+test menu-2.158 {entry configuration options 1 -offvalue off command} -body {
+ .m1 entryconfigure 1 -offvalue off
+} -returnCodes error -result {unknown option "-offvalue"}
+
+test menu-2.159 {entry configuration options 2 -offvalue off cascade} -body {
+ .m1 entryconfigure 2 -offvalue off
+} -returnCodes error -result {unknown option "-offvalue"}
+
+test menu-2.160 {entry configuration options 3 -offvalue off separator} -body {
+ .m1 entryconfigure 3 -offvalue off
+} -returnCodes error -result {unknown option "-offvalue"}
+
+test menu-2.161 {entry configuration options 4 -offvalue off checkbutton} -body {
+ .m1 entryconfigure 4 -offvalue off
+ lindex [.m1 entryconfigure 4 -offvalue] 4
+} -result {off}
+
+test menu-2.162 {entry configuration options 5 -offvalue off radiobutton} -body {
+ .m1 entryconfigure 5 -offvalue off
+} -returnCodes error -result {unknown option "-offvalue"}
+
+test menu-2.163 {entry configuration options 0 -onvalue on tearoff} -body {
+ .m1 entryconfigure 0 -onvalue on
+} -returnCodes error -result {unknown option "-onvalue"}
+
+test menu-2.164 {entry configuration options 1 -onvalue on command} -body {
+ .m1 entryconfigure 1 -onvalue on
+} -returnCodes error -result {unknown option "-onvalue"}
+
+test menu-2.165 {entry configuration options 2 -onvalue on cascade} -body {
+ .m1 entryconfigure 2 -onvalue on
+} -returnCodes error -result {unknown option "-onvalue"}
+
+test menu-2.166 {entry configuration options 3 -onvalue on separator} -body {
+ .m1 entryconfigure 3 -onvalue on
+} -returnCodes error -result {unknown option "-onvalue"}
+
+test menu-2.167 {entry configuration options 4 -onvalue on checkbutton} -body {
+ .m1 entryconfigure 4 -onvalue on
+ lindex [.m1 entryconfigure 4 -onvalue] 4
+} -result {on}
+
+test menu-2.168 {entry configuration options 5 -onvalue on radiobutton} -body {
+ .m1 entryconfigure 5 -onvalue on
+} -returnCodes error -result {unknown option "-onvalue"}
+
+test menu-2.169 {entry configuration options 0 -selectcolor #110022 tearoff} -body {
+ .m1 entryconfigure 0 -selectcolor #110022
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.170 {entry configuration options 1 -selectcolor #110022 command} -body {
+ .m1 entryconfigure 1 -selectcolor #110022
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.171 {entry configuration options 2 -selectcolor #110022 cascade} -body {
+ .m1 entryconfigure 2 -selectcolor #110022
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.172 {entry configuration options 3 -selectcolor #110022 separator} -body {
+ .m1 entryconfigure 3 -selectcolor #110022
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.173 {entry configuration options 4 -selectcolor #110022 checkbutton} -body {
+ .m1 entryconfigure 4 -selectcolor #110022
+ lindex [.m1 entryconfigure 4 -selectcolor] 4
+} -result {#110022}
+
+test menu-2.174 {entry configuration options 5 -selectcolor #110022 radiobutton} -body {
+ .m1 entryconfigure 5 -selectcolor #110022
+ lindex [.m1 entryconfigure 5 -selectcolor] 4
+} -result {#110022}
+
+test menu-2.175 {entry configuration options 0 -selectcolor non-existent tearoff} -body {
+ .m1 entryconfigure 0 -selectcolor non-existent
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.176 {entry configuration options 1 -selectcolor non-existent command} -body {
+ .m1 entryconfigure 1 -selectcolor non-existent
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.177 {entry configuration options 2 -selectcolor non-existent cascade} -body {
+ .m1 entryconfigure 2 -selectcolor non-existent
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.178 {entry configuration options 3 -selectcolor non-existent separator} -body {
+ .m1 entryconfigure 3 -selectcolor non-existent
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.179 {entry configuration options 4 -selectcolor non-existent checkbutton} -body {
+ .m1 entryconfigure 4 -selectcolor non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.180 {entry configuration options 5 -selectcolor non-existent radiobutton} -body {
+ .m1 entryconfigure 5 -selectcolor non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.181 {entry configuration options 0 -selectimage image1 tearoff} -constraints {
+ hasEarthPhoto
+} -body {
+ .m1 entryconfigure 0 -selectimage image1
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.182 {entry configuration options 1 -selectimage image1 command} -constraints {
+ hasEarthPhoto
+} -body {
+ .m1 entryconfigure 1 -selectimage image1
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.183 {entry configuration options 2 -selectimage image1 cascade} -constraints {
+ hasEarthPhoto
+} -body {
+ .m1 entryconfigure 2 -selectimage image1
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.184 {entry configuration options 3 -selectimage image1 separator} -constraints {
+ hasEarthPhoto
+} -body {
+ .m1 entryconfigure 3 -selectimage image1
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.185 {entry configuration options 4 -selectimage image1 checkbutton} -constraints {
+ hasEarthPhoto
+} -setup {
+ .m1 entryconfigure 4 -selectimage {}
+} -body {
+ .m1 entryconfigure 4 -selectimage image1
+ lindex [.m1 entryconfigure 4 -selectimage] 4
+} -cleanup {
+ .m1 entryconfigure 4 -selectimage {}
+} -result {image1}
+
+test menu-2.186 {entry configuration options 5 -selectimage image1 radiobutton} -constraints {
+ hasEarthPhoto
+} -setup {
+ .m1 entryconfigure 5 -selectimage {}
+} -body {
+ .m1 entryconfigure 5 -selectimage image1
+ lindex [.m1 entryconfigure 5 -selectimage] 4
+} -cleanup {
+ .m1 entryconfigure 5 -selectimage {}
+} -result {image1}
+
+test menu-2.187 {entry configuration options 0 -selectimage bogus tearoff} -body {
+ .m1 entryconfigure 0 -selectimage bogus
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.188 {entry configuration options 1 -selectimage bogus command} -body {
+ .m1 entryconfigure 1 -selectimage bogus
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.189 {entry configuration options 2 -selectimage bogus cascade} -body {
+ .m1 entryconfigure 2 -selectimage bogus
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.190 {entry configuration options 3 -selectimage bogus separator} -body {
+ .m1 entryconfigure 3 -selectimage bogus
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.191 {entry configuration options 4 -selectimage bogus checkbutton} -body {
+ .m1 entryconfigure 4 -selectimage bogus
+} -returnCodes error -result {image "bogus" doesn't exist}
+
+test menu-2.192 {entry configuration options 5 -selectimage bogus radiobutton} -body {
+ .m1 entryconfigure 5 -selectimage bogus
+} -returnCodes error -result {image "bogus" doesn't exist}
+
+test menu-2.193 {entry configuration options 0 -selectimage {} tearoff} -body {
+ .m1 entryconfigure 0 -selectimage
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.194 {entry configuration options 1 -selectimage {} command} -body {
+ .m1 entryconfigure 1 -selectimage
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.195 {entry configuration options 2 -selectimage {} cascade} -body {
+ .m1 entryconfigure 2 -selectimage
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.196 {entry configuration options 3 -selectimage {} separator} -body {
+ .m1 entryconfigure 3 -selectimage
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.197 {entry configuration options 4 -selectimage {} checkbutton} -body {
+ .m1 entryconfigure 4 -selectimage
+ lindex [.m1 entryconfigure 4 -selectimage] 4
+} -result {}
+
+test menu-2.198 {entry configuration options 5 -selectimage {} radiobutton} -body {
+ .m1 entryconfigure 5 -selectimage
+ lindex [.m1 entryconfigure 5 -selectimage] 4
+} -result {}
+
+test menu-2.199 {entry configuration options 0 -state normal tearoff} -body {
+ .m1 entryconfigure 0 -state normal
+ lindex [.m1 entryconfigure 0 -state] 4
+} -result {normal}
+
+test menu-2.200 {entry configuration options 1 -state normal command} -body {
+ .m1 entryconfigure 1 -state normal
+ lindex [.m1 entryconfigure 1 -state] 4
+} -result {normal}
+
+test menu-2.201 {entry configuration options 2 -state normal cascade} -body {
+ .m1 entryconfigure 2 -state normal
+ lindex [.m1 entryconfigure 2 -state] 4
+} -result {normal}
+
+test menu-2.202 {entry configuration options 3 -state normal separator} -body {
+ .m1 entryconfigure 3 -state normal
+} -returnCodes error -result {unknown option "-state"}
+
+test menu-2.203 {entry configuration options 4 -state normal checkbutton} -body {
+ .m1 entryconfigure 4 -state normal
+ lindex [.m1 entryconfigure 4 -state] 4
+} -result {normal}
+
+test menu-2.204 {entry configuration options 5 -state normal radiobutton} -body {
+ .m1 entryconfigure 5 -state normal
+ lindex [.m1 entryconfigure 5 -state] 4
+} -result {normal}
+
+test menu-2.205 {entry configuration options 0 -value {any string} tearoff} -body {
+ .m1 entryconfigure 0 -value {any string}
+} -returnCodes error -result {unknown option "-value"}
+
+test menu-2.206 {entry configuration options 1 -value {any string} command} -body {
+ .m1 entryconfigure 1 -value {any string}
+} -returnCodes error -result {unknown option "-value"}
+
+test menu-2.207 {entry configuration options 2 -value {any string} cascade} -body {
+ .m1 entryconfigure 2 -value {any string}
+} -returnCodes error -result {unknown option "-value"}
+
+test menu-2.208 {entry configuration options 3 -value {any string} separator} -body {
+ .m1 entryconfigure 3 -value {any string}
+} -returnCodes error -result {unknown option "-value"}
+
+test menu-2.209 {entry configuration options 4 -value {any string} checkbutton} -body {
+ .m1 entryconfigure 4 -value {any string}
+} -returnCodes error -result {unknown option "-value"}
+
+test menu-2.210 {entry configuration options 5 -value {any string} radiobutton} -body {
+ .m1 entryconfigure 5 -value {any string}
+ lindex [.m1 entryconfigure 5 -value] 4
+} -result {any string}
+
+test menu-2.211 {entry configuration options 0 -variable {any string} tearoff} -body {
+ .m1 entryconfigure 0 -variable {any string}
+} -returnCodes error -result {unknown option "-variable"}
+
+test menu-2.212 {entry configuration options 1 -variable {any string} command} -body {
+ .m1 entryconfigure 1 -variable {any string}
+} -returnCodes error -result {unknown option "-variable"}
+
+test menu-2.213 {entry configuration options 2 -variable {any string} cascade} -body {
+ .m1 entryconfigure 2 -variable {any string}
+} -returnCodes error -result {unknown option "-variable"}
+
+test menu-2.214 {entry configuration options 3 -variable {any string} separator} -body {
+ .m1 entryconfigure 3 -variable {any string}
+} -returnCodes error -result {unknown option "-variable"}
+
+test menu-2.215 {entry configuration options 4 -variable {any string} checkbutton} -body {
+ .m1 entryconfigure 4 -variable {any string}
+ lindex [.m1 entryconfigure 4 -variable] 4
+} -result {any string}
+
+test menu-2.216 {entry configuration options 5 -variable {any string} radiobutton} -body {
+ .m1 entryconfigure 5 -variable {any string}
+ lindex [.m1 entryconfigure 5 -variable] 4
+} -result {any string}
+
+test menu-2.217 {entry configuration options 0 -underline 0 tearoff} -body {
+ .m1 entryconfigure 0 -underline 0
+} -returnCodes error -result {unknown option "-underline"}
+
+test menu-2.218 {entry configuration options 1 -underline 0 command} -body {
+ .m1 entryconfigure 1 -underline 0
+ lindex [.m1 entryconfigure 1 -underline] 4
+} -result {0}
+
+test menu-2.219 {entry configuration options 2 -underline 0 cascade} -body {
+ .m1 entryconfigure 2 -underline 0
+ lindex [.m1 entryconfigure 2 -underline] 4
+} -result {0}
+
+test menu-2.220 {entry configuration options 3 -underline 0 separator} -body {
+ .m1 entryconfigure 3 -underline 0
+} -returnCodes error -result {unknown option "-underline"}
+
+test menu-2.221 {entry configuration options 4 -underline 0 checkbutton} -body {
+ .m1 entryconfigure 4 -underline 0
+ lindex [.m1 entryconfigure 4 -underline] 4
+} -result {0}
+
+test menu-2.222 {entry configuration options 5 -underline 0 radiobutton} -body {
+ .m1 entryconfigure 5 -underline 0
+ lindex [.m1 entryconfigure 5 -underline] 4
+} -result {0}
+
+test menu-2.223 {entry configuration options 0 -underline 3p tearoff} -body {
+ .m1 entryconfigure 0 -underline 3p
+} -returnCodes error -result {unknown option "-underline"}
+
+test menu-2.224 {entry configuration options 1 -underline 3p command} -body {
+ .m1 entryconfigure 1 -underline 3p
+} -returnCodes error -result {expected integer but got "3p"}
+
+test menu-2.225 {entry configuration options 2 -underline 3p cascade} -body {
+ .m1 entryconfigure 2 -underline 3p
+} -returnCodes error -result {expected integer but got "3p"}
+
+test menu-2.226 {entry configuration options 3 -underline 3p separator} -body {
+ .m1 entryconfigure 3 -underline 3p
+} -returnCodes error -result {unknown option "-underline"}
+
+test menu-2.227 {entry configuration options 4 -underline 3p checkbutton} -body {
+ .m1 entryconfigure 4 -underline 3p
+} -returnCodes error -result {expected integer but got "3p"}
+
+test menu-2.228 {entry configuration options 5 -underline 3p radiobutton} -body {
+ .m1 entryconfigure 5 -underline 3p
+} -returnCodes error -result {expected integer but got "3p"}
+
+deleteWindows
+if {[testConstraint hasEarthPhoto]} {
+ image delete image1
+}
+
+
+
+test menu-3.1 {MenuWidgetCmd procedure} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 option ?arg ...?"}
+test menu-3.2 {MenuWidgetCmd, Tcl_Preserve and Tcl_Release} -constraints {
+ nonUnixUserInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -postcommand "destroy .m1"
+ .m1 add command -label "menu-3.2: Hit Escape"
+ .m1 post 40 40
+} -cleanup {
+ destroy .m1
+} -returnCodes ok -result {}
+test menu-3.3 {MenuWidgetCmd procedure, "activate" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 activate
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 activate index"}
+test menu-3.4 {MenuWidgetCmd procedure, "activate" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 activate "foo"
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.5 {MenuWidgetCmd procedure, "activate" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 add separator
+ .m1 activate 2
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.6 {MenuWidgetCmd procedure, "activate" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 entryconfigure 1 -state disabled
+ .m1 activate 1
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.7 {MenuWidgetCmd procedure, "activate" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 activate 1
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.8 {MenuWidgetCmd procedure, "add" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 add type ?-option value ...?"}
+test menu-3.9 {MenuWidgetCmd procedure, "add" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add foo
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {bad menu entry type "foo": must be cascade, checkbutton, command, radiobutton, or separator}
+test menu-3.10 {MenuWidgetCmd procedure, "add" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add separator
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.11 {MenuWidgetCmd procedure, "cget" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 cget
+} -returnCodes error -result {wrong # args: should be ".m1 cget option"}
+test menu-3.12 {MenuWidgetCmd procedure, "cget" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 cget -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test menu-3.13 {MenuWidgetCmd procedure, "cget" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 configure -postcommand "Some string"
+ .m1 cget -postcommand
+} -cleanup {
+ destroy .m1
+} -result {Some string}
+test menu-3.14 {MenuWidgetCmd procedure, "clone" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 clone
+} -returnCodes error -result {wrong # args: should be ".m1 clone newMenuName ?menuType?"}
+test menu-3.15 {MenuWidgetCmd procedure, "clone" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 clone a b c d
+} -returnCodes error -result {wrong # args: should be ".m1 clone newMenuName ?menuType?"}
+test menu-3.16 {MenuWidgetCmd procedure, "clone" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 clone .m1.clone1
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.17 {MenuWidgetCmd procedure, "clone" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 clone .m1.clone1 tearoff
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.18 {MenuWidgetCmd procedure, "configure" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ llength [.m1 configure]
+} -cleanup {
+ destroy .m1
+} -result {20}
+test menu-3.19 {MenuWidgetCmd procedure, "configure" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 configure -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test menu-3.20 {MenuWidgetCmd procedure, "configure" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 configure -postcommand "A random String"
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.21 {MenuWidgetCmd procedure, "configure" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 configure -postcommand "Another string"
+ lindex [.m1 configure -postcommand] 4
+} -cleanup {
+ destroy .m1
+} -result {Another string}
+test menu-3.22 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 delete
+} -returnCodes error -result {wrong # args: should be ".m1 delete first ?last?"}
+test menu-3.23 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 delete foo
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.24 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 delete 0 "foo"
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.25 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 delete 0
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.26 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "foo"
+ .m1 delete 1 0
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.27 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "1"
+ .m1 add command -label "2"
+ .m1 add command -label "3"
+ .m1 delete 1 3
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.28 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "1"
+ .m1 add command -label "2"
+ .m1 add command -label "3"
+ .m1 activate 2
+ .m1 delete 1 3
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.29 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "1"
+ .m1 add command -label "2"
+ .m1 add command -label "3"
+ .m1 activate 3
+ .m1 delete 1
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.29+1 {MenuWidgetCmd, "delete", Bug 220950} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "bogus"
+ .m1 add command -label "ok"
+ .m1 delete 10 20
+ .m1 entrycget last -label
+} -cleanup {
+ destroy .m1
+} -result ok
+test menu-3.30 {MenuWidgetCmd procedure, "entrycget" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 entrycget
+} -returnCodes error -result {wrong # args: should be ".m1 entrycget index option"}
+test menu-3.31 {MenuWidgetCmd procedure, "entrycget" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 entrycget index option foo
+} -returnCodes error -result {wrong # args: should be ".m1 entrycget index option"}
+test menu-3.32 {MenuWidgetCmd procedure, "entrycget" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 entrycget foo -label
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.33 {MenuWidgetCmd procedure, "entrycget" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 entrycget 1 -label
+} -cleanup {
+ destroy .m1
+} -result {test}
+test menu-3.34 {MenuWidgetCmd procedure, "entryconfigure" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 entryconfigure
+} -returnCodes error -result {wrong # args: should be ".m1 entryconfigure index ?-option value ...?"}
+test menu-3.35 {MenuWidgetCmd procedure, "entryconfigure" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 entryconfigure foo
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.36 {MenuWidgetCmd procedure, "entryconfigure" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ llength [.m1 entryconfigure 1]
+} -cleanup {
+ destroy .m1
+} -result {15}
+test menu-3.37 {MenuWidgetCmd procedure, "entryconfigure" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ lindex [.m1 entryconfigure 1 -label] 4
+} -cleanup {
+ destroy .m1
+} -result {test}
+test menu-3.38 {MenuWidgetCmd procedure, "entryconfigure" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 entryconfigure 1 -label "changed"
+ lindex [.m1 entryconfigure 1 -label] 4
+} -cleanup {
+ destroy .m1
+} -result {changed}
+test menu-3.39 {MenuWidgetCmd procedure, "index" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 index
+} -returnCodes error -result {wrong # args: should be ".m1 index string"}
+test menu-3.40 {MenuWidgetCmd procedure, "index" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 index foo
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.41 {MenuWidgetCmd procedure, "index" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 add command -label "3"
+ .m1 add command -label "another label"
+ .m1 add command -label "end"
+ .m1 add command -label "3a"
+ .m1 add command -label "final entry"
+ list [.m1 index "test"] [.m1 index "3"] [.m1 index "3a"] [.m1 index "end"]
+} -cleanup {
+ destroy .m1
+} -result {1 3 5 6}
+test menu-3.42 {MenuWidgetCmd procedure, "insert" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 insert
+} -returnCodes error -result {wrong # args: should be ".m1 insert index type ?-option value ...?"}
+test menu-3.43 {MenuWidgetCmd procedure, "insert" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 insert 1 command -label "test"
+ .m1 entrycget 1 -label
+} -cleanup {
+ destroy .m1
+} -result {test}
+test menu-3.44 {MenuWidgetCmd procedure, "invoke" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 invoke
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 invoke index"}
+test menu-3.45 {MenuWidgetCmd procedure, "invoke" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 invoke foo
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.46 {MenuWidgetCmd procedure, "invoke" option} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ .m1 add command -label "set foo" -command "set foo hello"
+ list [.m1 invoke 1] [set foo] [unset foo]
+} -cleanup {
+ destroy .m1
+} -returnCodes ok -result {hello hello {}}
+test menu-3.47 {MenuWidgetCmd procedure, "post" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "On Windows, hit Escape to get this menu to go away"
+ .m1 post
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 post x y"}
+test menu-3.48 {MenuWidgetCmd procedure, "post" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 post foo 40
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {expected integer but got "foo"}
+test menu-3.49 {MenuWidgetCmd procedure, "post" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 post 40 bar
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {expected integer but got "bar"}
+test menu-3.50 {MenuWidgetCmd procedure, "post" option} -constraints {
+ nonUnixUserInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "menu-3.53: hit Escape" -command "puts hello"
+ .m1 post 40 40
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.51 {MenuWidgetCmd procedure, "postcascade" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 postcascade
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 postcascade index"}
+test menu-3.52 {MenuWidgetCmd procedure, "postcascade" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 postcascade foo
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.53 {MenuWidgetCmd procedure, "postcascade" option} -constraints {
+ nonUnixUserInteraction
+} -setup {
+ destroy .m1 .m2
+} -body {
+ menu .m1
+ .m1 add command -label "menu-3.56 - hit Escape"
+ menu .m2
+ .m1 post 40 40
+ .m1 add cascade -menu .m2
+ .m1 postcascade 1
+} -cleanup {
+ destroy .m1 .m2
+} -result {}
+test menu-3.54 {MenuWidgetCmd procedure, "postcascade" option} -setup {
+ destroy .m1 .m2
+} -body {
+ menu .m1
+ menu .m2
+ .m1 add cascade -menu .m2 -label "menu-3.57 - hit Escape"
+ .m1 postcascade 1
+ .m1 postcascade none
+} -cleanup {
+ destroy .m1 .m2
+} -result {}
+test menu-3.55 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 type
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 type index"}
+test menu-3.56 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 type foo
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.57 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 type 1
+} -cleanup {
+ destroy .m1
+} -result {command}
+test menu-3.58 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add separator
+ .m1 type 1
+} -cleanup {
+ destroy .m1
+} -result {separator}
+test menu-3.59 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label "test"
+ .m1 type 1
+} -cleanup {
+ destroy .m1
+} -result {checkbutton}
+test menu-3.60 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add radiobutton -label "test"
+ .m1 type 1
+} -cleanup {
+ destroy .m1
+} -result {radiobutton}
+test menu-3.61 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label "test"
+ .m1 type 1
+} -cleanup {
+ destroy .m1
+} -result {cascade}
+test menu-3.62 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 type 0
+} -cleanup {
+ destroy .m1
+} -result {tearoff}
+test menu-3.63 {MenuWidgetCmd procedure, "unpost" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 unpost foo
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 unpost"}
+test menu-3.64 {MenuWidgetCmd procedure, "unpost" option} -constraints {
+ nonUnixUserInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "menu-3.68 - hit Escape"
+ .m1 post 40 40
+ .m1 unpost
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.65 {MenuWidgetCmd procedure, "yposition" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 yposition
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 yposition index"}
+test menu-3.66 {MenuWidgetCmd procedure, "yposition" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 yposition 1
+} -cleanup {
+ destroy .m1
+} -result {1}
+test menu-3.67 {MenuWidgetCmd procedure, bad option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 foo
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, xposition, or yposition}
+test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} -setup {
+ deleteWindows
+} -body {
+ set t .t
+ set m1 .t.m1
+ set c1 .t.c1
+ set c2 .t.c2
+ toplevel .t
+ menu $m1 -tearoff 1
+ menu $c1 -tearoff 1
+ $c1 add command -label c1
+ menu $c2 -tearoff 1
+ $c2 add command -label c2
+ $m1 add cascade -label c1 -menu $c1
+ $t configure -menu $m1
+ $m1 entryconfigure 1 -menu $c2 -label c2
+ $t configure -menu ""
+ list [winfo exists $c1] [winfo exists $c2]
+} -cleanup {
+ deleteWindows
+} -result {1 1}
+test menu-3.69 {MenuWidgetCmd procedure, "xposition" option} -setup {
+ destroy .m1
+ menu .m1
+} -body {
+ .m1 xposition
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 xposition index"}
+test menu-3.70 {MenuWidgetCmd procedure, "xposition" option} -setup {
+ destroy .m1
+ menu .m1
+} -body {
+ .m1 xposition 1
+ subst {} ;# just checking that the xposition does not produce an error...
+} -cleanup {
+ destroy .m1
+} -result {}
+
+
+test menu-4.1 {TkInvokeMenu: disabled} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off \
+ -state disabled
+ list [catch {.m1 invoke 1} msg] $foo
+} -cleanup {
+ destroy .m1
+} -result {0 off}
+test menu-4.2 {TkInvokeMenu: tearoff} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ catch {.m1 invoke 0}
+} -cleanup {
+ deleteWindows
+} -result {0}
+test menu-4.3 {TkInvokeMenu: checkbutton -on} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off
+ list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 \
+ [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 on 0 {}}
+test menu-4.4 {TkInvokeMenu: checkbutton -off} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off
+ .m1 invoke 1
+ list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 off 0 {}}
+test menu-4.5 {TkInvokeMenu: checkbutton array element} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ .m1 add checkbutton -label "test" -variable foo(1) -onvalue on
+ list [catch {.m1 invoke 1} msg] $msg [catch {set foo(1)} msg2] $msg2 [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 on 0 {}}
+test menu-4.6 {TkInvokeMenu: radiobutton} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ .m1 add radiobutton -label "1" -variable foo -value one
+ .m1 add radiobutton -label "2" -variable foo -value two
+ .m1 add radiobutton -label "3" -variable foo -value three
+ list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 one 0 {}}
+test menu-4.7 {TkInvokeMenu: radiobutton} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ .m1 add radiobutton -label "1" -variable foo -value one
+ .m1 add radiobutton -label "2" -variable foo -value two
+ .m1 add radiobutton -label "3" -variable foo -value three
+ list [catch {.m1 invoke 2} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 two 0 {}}
+test menu-4.8 {TkInvokeMenu: radiobutton} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ .m1 add radiobutton -label "1" -variable foo -value one
+ .m1 add radiobutton -label "2" -variable foo -value two
+ .m1 add radiobutton -label "3" -variable foo -value three
+ list [catch {.m1 invoke 3} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 three 0 {}}
+test menu-4.9 {TkInvokeMenu: radiobutton array element} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ .m1 add radiobutton -label "1" -variable foo(2) -value one
+ .m1 add radiobutton -label "2" -variable foo(2) -value two
+ .m1 add radiobutton -label "3" -variable foo(2) -value three
+ list [catch {.m1 invoke 3} msg] $msg [catch {set foo(2)} msg2] $msg2 [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 three 0 {}}
+test menu-4.10 {TkInvokeMenu} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ .m1 add command -label "test" -command "set menu_test menu-4.8"
+ list [catch {.m1 invoke 1} msg] $msg [catch {set menu_test} msg2] $msg2 [catch {unset menu_test} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 menu-4.8 0 menu-4.8 0 {}}
+test menu-4.11 {TkInvokeMenu} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label "test" -menu .m1.m2
+ list [catch {.m1 invoke 1} msg] $msg
+} -cleanup {
+ destroy .m1
+} -result {0 {}}
+test menu-4.12 {TkInvokeMenu} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test" -command ".m1 delete 1"
+ list [catch {.m1 invoke 1} msg] $msg [catch {.m1 type "test"} msg2] $msg2
+} -cleanup {
+ destroy .m1
+} -result {0 {} 1 {bad menu entry index "test"}}
+
+test menu-5.1 {DestroyMenuInstance} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ destroy .m1
+} -returnCodes ok
+test menu-5.2 {DestroyMenuInstance - cascade menu} -setup {
+ destroy .m1 .m2
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m2
+ menu .m2
+ destroy .m1 .m2
+} -returnCodes ok
+test menu-5.3 {DestroyMenuInstance - multiple cascade parents} -setup {
+ destroy .m1 .m2 .m3
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m3
+ menu .m2
+ .m2 add cascade -menu .m3
+ menu .m3
+ list [destroy .m3] [destroy .m1 .m2]
+} -returnCodes ok -result {{} {}}
+test menu-5.4 {DestroyMenuInstance - multiple cascade parents} -setup {
+ destroy .m1 .m2 .m3 .m4
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m4
+ menu .m2
+ .m2 add cascade -menu .m4
+ menu .m3
+ .m3 add cascade -menu .m4
+ menu .m4
+ list [destroy .m4] [destroy .m1 .m2 .m3]
+} -returnCodes ok -result {{} {}}
+test menu-5.5 {DestroyMenuInstance - cascades of cloned menus} -setup {
+ destroy .m1 .m2
+} -body {
+ menu .m1
+ menu .m2
+ .m1 add cascade -menu .m2
+ . configure -menu .m1
+ list [destroy .m2] [.m1 entrycget 1 -menu] [. configure -menu ""] [destroy .m1]
+} -returnCodes ok -result {{} .m2 {} {}}
+test menu-5.6 {DestroyMenuInstance - cascades of cloned menus} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m2
+ menu .m2
+ . configure -menu .m1
+ toplevel .t2
+ wm geometry .t2 +0+0
+ .t2 configure -menu .m1
+ list [destroy .m2] [. configure -menu ""] [destroy .t2 .m1]
+} -returnCodes ok -result {{} {} {}}
+test menu-5.7 {DestroyMenuInstance - basic clones} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ set tearoff [tk::TearOffMenu .m1]
+ list [destroy $tearoff] [destroy .m1]
+} -result {{} {}}
+test menu-5.8 {DestroyMenuInstance - multiple clones} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ set tearoff1 [tk::TearOffMenu .m1]
+ set tearoff2 [tk::TearOffMenu .m1]
+ list [destroy $tearoff1] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test menu-5.9 {DestroyMenuInstace - master menu} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ tk::TearOffMenu .m1
+ destroy .m1
+} -returnCodes ok
+test menu-5.10 {DestroyMenuInstance - freeing entries} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "foo"
+ destroy .m1
+} -returnCodes ok
+test menu-5.11 {DestroyMenuInstace - no entries} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 configure -tearoff 0
+ destroy .m1
+} -returnCodes ok
+test menu-5.12 {DestroyMenuInstance - platform data} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ destroy .m1
+} -returnCodes ok
+test menu-5.13 {DestroyMenuInstance - clones when mismatched tearoffs} -setup {
+ destroy .m1 .m2
+} -body {
+ menu .m1
+ menu .m2
+ .m1 add cascade -menu .m2
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [destroy .m2] [destroy .m1]
+} -result {{} {}}
+
+
+test menu-6.1 {TkDestroyMenu} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ destroy .m1
+} -returnCodes ok
+test menu-6.2 {TkDestroyMenu - reentrancy} -setup {
+ destroy .m1 .m2
+} -body {
+ menu .m1
+ bind .m1 <Destroy> {destroy .m1}
+ menu .m2
+ bind .m2 <Destroy> {destroy .m2}
+ list [destroy .m1] [destroy .m2]
+} -returnCodes ok -result {{} {}}
+test menu-6.3 {TkDestroyMenu - reentrancy} -setup {
+ destroy .m1 .m2 .m3
+} -body {
+ menu .m1
+ bind .m1 <Destroy> {destroy .m2}
+ .m1 clone .m2
+ .m1 clone .m3
+ list [destroy .m1] [winfo exists .m2]
+} -returnCodes ok -result {{} 0}
+test menu-6.4 {TkDestroyMenu - reentrancy - clones} -setup {
+ destroy .m1 .m2
+} -body {
+ menu .m1
+ .m1 clone .m2
+ .m1 clone .m1.m3
+ destroy .m1
+} -cleanup {
+ deleteWindows
+} -returnCodes ok
+test menu-6.5 {TkDestroyMenu} -setup {
+ destroy .m1 .m2
+} -body {
+ menu .m1
+ .m1 clone .m2
+ destroy .m1
+ winfo exists .m2
+} -result {0}
+test menu-6.6 {TkDestroyMenu} -setup {
+ destroy .m1 .m2
+} -body {
+ menu .m1
+ .m1 clone .m2 tearoff
+ destroy .m1
+} -result {}
+test menu-6.7 {TkDestroyMenu} -setup {
+ destroy .m1 .m2
+} -body {
+ menu .m1
+ .m1 clone .m2
+ destroy .m2
+ destroy .m1
+} -returnCodes ok -result {}
+test menu-6.8 {TkDestroyMenu} -setup {
+ destroy .m1 .m2 .m3
+} -body {
+ menu .m1
+ .m1 clone .m2
+ .m1 clone .m3
+ destroy .m1
+ list [winfo exists .m2] [winfo exists .m3]
+} -result {0 0}
+test menu-6.9 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+ .m1 clone .m3
+ list [destroy .m2] [destroy .m3] [destroy .m1]
+} -returnCodes ok -result {{} {} {}}
+test menu-6.10 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+ .m1 clone .m3
+ list [destroy .m3] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test menu-6.11 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+ .m1 clone .m3
+ .m1 clone .m4
+ list [destroy .m2] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test menu-6.12 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+ .m1 clone .m3
+ .m1 clone .m4
+ list [destroy .m3] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test menu-6.13 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+ .m1 clone .m3
+ .m1 clone .m4
+ list [destroy .m4] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test menu-6.14 {TkDestroyMenu} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ . configure -menu .m1
+ list [destroy .m1] [. configure -menu ""]
+} -returnCodes ok -result {{} {}}
+test menu-6.15 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ toplevel .t2
+ wm geometry .t2 +0+0
+ . configure -menu .m1
+ .t2 configure -menu .m1
+ list [destroy .m1] [destroy .t2] [. configure -menu ""]
+} -result {{} {} {}}
+test menu-6.16 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ toplevel .t2
+ wm geometry .t2 +0+0
+ toplevel .t3
+ wm geometry .t3 +0+0
+ . configure -menu .m1
+ .t2 configure -menu .m1
+ .t3 configure -menu .m1
+ list [destroy .m1] [destroy .t2] [destroy .t3] [. configure -menu ""]
+} -result {{} {} {} {}}
+
+test menu-7.1 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ destroy .m1
+} -returnCodes ok
+test menu-7.2 {UnhookCascadeEntry} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m2
+ destroy .m1
+} -returnCodes ok
+test menu-7.3 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .m2
+ .m2 add cascade -menu .cascade
+ .m1 add cascade -menu .cascade
+ list [destroy .m1] [destroy .m2]
+} -returnCodes ok -result {{} {}}
+test menu-7.4 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .m2
+ .m1 add cascade -menu .cascade
+ .m2 add cascade -menu .cascade
+ list [destroy .m1] [destroy .m2]
+} -returnCodes ok -result {{} {}}
+test menu-7.5 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .m2
+ menu .m3
+ .m1 add cascade -menu .cascade
+ .m2 add cascade -menu .cascade
+ .m3 add cascade -menu .cascade
+ list [destroy .m1] [destroy .m2 .m3]
+} -returnCodes ok -result {{} {}}
+test menu-7.6 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .m2
+ menu .m3
+ .m1 add cascade -menu .cascade
+ .m2 add cascade -menu .cascade
+ .m3 add cascade -menu .cascade
+ list [destroy .m2] [destroy .m1 .m3]
+} -returnCodes ok -result {{} {}}
+test menu-7.7 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .m2
+ menu .m3
+ .m1 add cascade -menu .cascade
+ .m2 add cascade -menu .cascade
+ .m3 add cascade -menu .cascade
+ list [destroy .m3] [destroy .m1 .m2]
+} -returnCodes ok -result {{} {}}
+test menu-7.8 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .m2
+ .m1 add cascade -menu .m2
+ list [destroy .m1] [destroy .m2]
+} -returnCodes ok -result {{} {}}
+test menu-7.9 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .m2
+ .m1 add cascade -menu .m2
+ destroy .m1
+ destroy .m2
+} -returnCodes ok
+
+test menu-8.1 {DestroyMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .m2
+ .m1 add cascade -menu .m2
+ list [.m1 delete 1] [destroy .m1 .m2]
+} -result {{} {}}
+test menu-8.2 {DestroyMenuEntry} -constraints hasEarthPhoto -setup {
+ deleteWindows
+ catch {image delete image1a}
+} -body {
+ image create photo image1a -file $earthPhotoFile
+ menu .m1
+ .m1 add command -image image1a
+ list [.m1 delete 1] [destroy .m1] [image delete image1a]
+} -result {{} {} {}}
+test menu-8.3 {DestroyMenuEntry} -constraints testImageType -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create test image1
+ image create test image2
+ menu .m1
+ .m1 add checkbutton -image image1 -selectimage image2
+ .m1 invoke 1
+ list [.m1 delete 1] [destroy .m1]
+} -cleanup {
+ imageCleanup
+ deleteWindows
+} -result {{} {}}
+test menu-8.4 {DestroyMenuEntry} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -variable foo
+ list [.m1 delete 1] [destroy .m1]
+} -result {{} {}}
+test menu-8.5 {DestroyMenuEntry} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ list [.m1 delete 1] [destroy .m1]
+} -result {{} {}}
+test menu-8.6 {DestroyMenuEntry} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "one"
+ .m1 add command -label "two"
+ list [.m1 delete 1] [.m1 entrycget 1 -label] [destroy .m1]
+} -result {{} two {}}
+test menu-8.7 {DestroyMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "one"
+ .m1 clone .m2 tearoff
+ list [.m2 delete 1] [destroy .m1]
+} -result {{} {}}
+
+
+# test menu-9 - Can only change when fonts change on system, which cannot
+# be done from tcl.
+test menu-9.1 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [.m1 configure -postcommand "beep"] [.m1 cget -postcommand]
+} -cleanup {
+ deleteWindows
+} -result {{} beep}
+test menu-9.2 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ list [.m1 configure -tearoff 0] [.m1 entrycget 1 -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test}
+test menu-9.3 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [.m1 configure -postcommand "beep"] [.m1 cget -postcommand]
+} -cleanup {
+ deleteWindows
+} -result {{} beep}
+test menu-9.4 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 configure -fg red
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-9.5 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 add command -label "two"
+ .m1 configure -fg red
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-9.6 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 add command -label "two"
+ .m1 add command -label "three"
+ .m1 configure -fg red
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-9.7 {ConfigureMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2 tearoff
+ list [.m1 configure -fg red] [.m2 cget -fg]
+} -cleanup {
+ deleteWindows
+} -result {{} red}
+test menu-9.8 {ConfigureMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2 tearoff
+ list [.m2 configure -fg red] [.m1 cget -fg]
+} -cleanup {
+ deleteWindows
+} -result {{} red}
+test menu-9.9 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+
+
+test menu-10.1 {PostProcessEntry: array variable} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ set foo(1) on
+ .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense"
+ set foo(1)
+} -cleanup {
+ deleteWindows
+} -result {on}
+test menu-10.2 {PostProcessEntry: array variable} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense"
+ set foo(1)
+} -cleanup {
+ deleteWindows
+} -result {off}
+
+
+test menu-11.1 {ConfigureMenuEntry} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ .m1 add checkbutton -variable foo -onvalue on -offvalue off -label "Nonsense"
+ list [.m1 entryconfigure 1 -variable bar] [.m1 entrycget 1 -variable]
+} -cleanup {
+ deleteWindows
+} -result {{} bar}
+test menu-11.2 {ConfigureMenuEntry} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ list [.m1 entryconfigure 1 -label ""] [.m1 entrycget 1 -label]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-11.3 {ConfigureMenuEntry} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command
+ list [.m1 entryconfigure 1 -label "test"] [.m1 entrycget 1 -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test}
+test menu-11.4 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command
+ list [.m1 entryconfigure 1 -accel "S"] [.m1 entrycget 1 -accel]
+} -cleanup {
+ deleteWindows
+} -result {{} S}
+test menu-11.5 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command
+ list [.m1 entryconfigure 1 -label "test"] [.m1 entrycget 1 -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test}
+test menu-11.6 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command
+ .m1 entryconfigure 1 -label "test"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.7 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m2
+ menu .m1
+ .m1 add cascade
+ .m1 entryconfigure 1 -label "test" -menu .m2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.8 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade
+ .m1 entryconfigure 1 -label "test" -menu .m2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.9 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m3
+ .m1 entryconfigure 1 -label "test" -menu .m2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.10 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade
+ .m1 entryconfigure 1 -label "test" -menu .m2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.11 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m2
+ .m1 entryconfigure 1 -label "test" -menu .m2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.12 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .m2
+ .m2 add cascade -menu .m1
+ menu .m3
+ .m3 add cascade -menu .m1
+ menu .m4
+ .m4 add cascade -menu .m1
+ menu .m5
+ .m5 add cascade
+ .m5 entryconfigure 1 -label "test" -menu .m1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.13 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .m2
+ .m2 add cascade -menu .m1
+ menu .m3
+ .m3 add cascade -menu .m1
+ menu .m4
+ .m4 add cascade -menu .m1
+ .m3 entryconfigure 1 -label "test" -menu .m1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.14 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add checkbutton
+ list [.m1 entryconfigure 1 -variable "test"] [.m1 entrycget 1 -variable]
+} -cleanup {
+ deleteWindows
+} -result {{} test}
+test menu-11.15 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ list [.m1 add checkbutton -label "test"] [.m1 entrycget 1 -variable]
+} -cleanup {
+ deleteWindows
+} -result {{} test}
+test menu-11.16 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add radiobutton -label "test"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.17 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add checkbutton
+ list [.m1 entryconfigure 1 -onvalue "test"] [.m1 entrycget 1 -onvalue]
+} -cleanup {
+ deleteWindows
+} -result {{} test}
+test menu-11.18 {ConfigureMenuEntry} -constraints testImageType -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ menu .m1
+ .m1 add command
+ image create test image1
+ .m1 entryconfigure 1 -image image1
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {}
+test menu-11.19 {ConfigureMenuEntry} -constraints {
+ testImageType hasEarthPhoto
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create test image1
+ image create photo image2 -file $earthPhotoFile
+ menu .m1
+ .m1 add command -image image1
+ .m1 entryconfigure 1 -image image2
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {}
+test menu-11.20 {ConfigureMenuEntry} -constraints {
+ testImageType hasEarthPhoto
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create photo image1 -file $earthPhotoFile
+ image create test image2
+ menu .m1
+ .m1 add checkbutton -image image1
+ .m1 entryconfigure 1 -selectimage image2
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {}
+test menu-11.21 {ConfigureMenuEntry} -constraints {
+ testImageType hasEarthPhoto
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create photo image1 -file $earthPhotoFile
+ image create test image2
+ image create test image3
+ menu .m1
+ .m1 add checkbutton -image image1 -selectimage image2
+ .m1 entryconfigure 1 -selectimage image3
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {}
+
+
+test menu-12.1 {ConfigureMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+ .m2 configure -tearoff 0
+ .m1 clone .m3
+ .m1 add command -label "test"
+ .m1 add command -label "test2"
+ .m1 entryconfigure 1 -gork "foo"
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown option "-gork"}
+test menu-12.2 {ConfigureMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+ menu .m3
+ .m1 add cascade -menu .m3
+ menu .m4
+ .m1 entryconfigure 1 -menu .m4
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-12.3 {ConfigureMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+ .m1 add cascade -label dummy
+ .m1 entryconfigure dummy -menu .m3
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-12.4 {ConfigureMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -label File -menu .m1.foo
+ menu .m1.foo
+ .m1.foo add command -label bar
+ .m1 clone .m2
+ .m1 entryconfigure File -state disabled
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test menu-13.1 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "active"
+ .m1 add command -label "test2"
+ .m1 add command -label "test3"
+ .m1 activate 2
+ .m1 entrycget active -label
+} -cleanup {
+ deleteWindows
+} -result {test2}
+test menu-13.2 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "last"
+ .m1 add command -label "test2"
+ .m1 add command -label "test3"
+ .m1 activate 2
+ .m1 entrycget last -label
+} -cleanup {
+ deleteWindows
+} -result {test3}
+test menu-13.3 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "last"
+ .m1 add command -label "test2"
+ .m1 add command -label "test3"
+ .m1 activate 2
+ .m1 entrycget end -label
+} -cleanup {
+ deleteWindows
+} -result {test3}
+test menu-13.4 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ list [.m1 insert last command -label "test2"] [.m1 entrycget last -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test2}
+test menu-13.5 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ list [.m1 insert end command -label "test2"] [.m1 entrycget end -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test2}
+test menu-13.6 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "active"
+ .m1 add command -label "test2"
+ .m1 add command -label "test3"
+ .m1 activate 2
+ .m1 entrycget none -label
+} -cleanup {
+ deleteWindows
+} -result {}
+#test menu-13.7 - Need to add @test here.
+test menu-13.7 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "active"
+ .m1 add command -label "test2"
+ .m1 add command -label "test3"
+ .m1 entrycget 1 -label
+} -cleanup {
+ deleteWindows
+} -result {active}
+test menu-13.8 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "active"
+ .m1 entrycget -1 -label
+} -returnCodes error -result {bad menu entry index "-1"}
+test menu-13.9 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 add command -label "test2"
+ .m1 entrycget 999 -label
+} -cleanup {
+ deleteWindows
+} -result {test2}
+test menu-13.10 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 insert 999 command -label "test"
+ .m1 entrycget 1 -label
+} -cleanup {
+ deleteWindows
+} -result {test}
+test menu-13.11 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "1test"
+ .m1 entrycget 1test -label
+} -cleanup {
+ deleteWindows
+} -result {1test}
+test menu-13.12 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 add command -label "test2" -command "beep"
+ .m1 add command -label "test3"
+ .m1 entrycget test2 -command
+} -cleanup {
+ deleteWindows
+} -result {beep}
+
+test menu-14.1 {MenuCmdDeletedProc} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ destroy .m1
+} -cleanup {
+ deleteWindows
+} -returnCodes ok
+test menu-14.2 {MenuCmdDeletedProc} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+ destroy .m1
+} -cleanup {
+ deleteWindows
+} -returnCodes ok
+
+test menu-15.1 {MenuNewEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-15.2 {MenuNewEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 add command -label "test3"
+ .m1 insert 2 command -label "test2"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-15.3 {MenuNewEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 add command -label "test2"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-15.4 {MenuNewEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+} -cleanup {
+ deleteWindows
+} -result {}
+
+test menu-16.1 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 insert foo command -label "test"
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-16.2 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 insert test command -label "foo"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.3 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 insert -1 command -label "test"
+} -returnCodes error -result {bad menu entry index "-1"}
+test menu-16.4 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 insert 0 command -label "test2"
+ .m1 entrycget 1 -label
+} -cleanup {
+ deleteWindows
+} -result {test2}
+test menu-16.5 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.6 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add checkbutton
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.7 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.8 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add radiobutton
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.9 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add separator
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.10 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add blork
+} -returnCodes error -result {bad menu entry type "blork": must be cascade, checkbutton, command, radiobutton, or separator}
+test menu-16.11 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.12 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+ .m2 clone .m3
+ list [.m2 add command -label "test"] [.m1 entrycget 1 -label] [.m3 entrycget 1 -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test test}
+test menu-16.13 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+ .m2 clone .m3
+ list [.m3 add command -label "test"] [.m1 entrycget 1 -label] [.m2 entrycget 1 -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test test}
+test menu-16.14 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -blork
+} -returnCodes error -result {unknown option "-blork"}
+test menu-16.15 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "File"
+ menu .container
+ . configure -menu .container
+ list [.container add cascade -label "File" -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-16.16 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .m2
+ set tearoff [tk::TearOffMenu .m2]
+ list [.m2 add cascade -menu .m1] [$tearoff unpost]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-16.17 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .container
+ . configure -menu .container
+ set tearoff [tk::TearOffMenu .container]
+ list [.container add cascade -label "File" -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-16.18 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .container
+ .container add cascade -menu .m1
+ . configure -menu .container
+ list [.container add cascade -label "File" -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} -setup {
+ deleteWindows
+} -body {
+ menu .menubar
+ menu .menubar.test -tearoff 0
+ .menubar add cascade -label Test -underline 0 -menu .menubar.test
+ menu .menubar.test.cascade -tearoff 0
+ .menubar.test.cascade add command -label SubItem -command "puts SubItemSelected"
+ . configure -menu .menubar
+ list [catch {.menubar.test add cascade -label SubMenu \
+ -menu .menubar.test.cascade}] \
+ [info commands .\#menubar.\#menubar\#test.\#menubar\#test\#cascade] \
+ [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {0 .#menubar.#menubar#test.#menubar#test#cascade {}}
+
+
+test menu-17.1 {MenuVarProc} -setup {
+ deleteWindows
+} -body {
+ catch {unset foo}
+ menu .m1
+ set foo "hello"
+ list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \
+ [unset foo]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+# menu-17.2 - Don't know how to generate the flags in the if
+test menu-17.2 {MenuVarProc} -setup {
+ deleteWindows
+} -body {
+ catch {unset foo}
+ menu .m1
+ list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \
+ [set foo ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-17.3 {MenuVarProc} -setup {
+ deleteWindows
+} -body {
+ catch {unset foo}
+ menu .m1
+ set foo "hello"
+ list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \
+ [set foo "hello"] [unset foo]
+} -cleanup {
+ deleteWindows
+} -result {{} hello {}}
+test menu-17.4 {MenuVarProc} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ set foo "goodbye"
+ list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \
+ [set foo "hello"] [unset foo]
+} -cleanup {
+ deleteWindows
+} -result {{} hello {}}
+test menu-17.5 {MenuVarProc} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ set foo "hello"
+ list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \
+ [set foo "goodbye"] [unset foo]
+} -cleanup {
+ deleteWindows
+} -result {{} goodbye {}}
+
+
+test menu-18.1 {TkActivateMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 activate 1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-18.2 {TkActivateMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 activate 0
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-18.3 {TkActivateMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 add command -label "test2"
+ .m1 activate 1
+ .m1 activate 2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-18.4 {TkActivateMenuEntry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 add command -label "test2"
+ .m1 activate 1
+ .m1 activate 1
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test menu-19.1 {TkPostCommand} -constraints nonUnixUserInteraction -setup {
+ deleteWindows
+} -body {
+ menu .m1 -postcommand "set menu_test menu-19.1"
+ .m1 add command -label "menu-19.1 - hit Escape"
+ list [.m1 post 40 40] [.m1 unpost] [set menu_test]
+} -cleanup {
+ deleteWindows
+} -result {menu-19.1 {} menu-19.1}
+test menu-19.2 {TkPostCommand} -constraints nonUnixUserInteraction -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "menu-19.2 - hit Escape"
+ list [.m1 post 40 40] [.m1 unpost]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+
+test menu-20.1 {CloneMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2]
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.2 {CloneMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2 normal
+ deleteWindows
+} -result {}
+test menu-20.3 {CloneMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2 tearoff
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.4 {CloneMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2 menubar
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.5 {CloneMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2 foo
+} -returnCodes error -result {bad menu type "foo": must be normal, tearoff, or menubar}
+test menu-20.6 {CloneMenu - hooking up bookeeping ptrs} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+ .m1 clone .m3
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.8 {CloneMenu - cascade entries} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m2
+ .m1 clone .foo
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.9 {CloneMenu - cascades entries} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m2
+ menu .m2
+ .m1 clone .foo
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.10 {CloneMenu - tearoff fields} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ list [.m1 clone .m2 normal] [.m2 cget -tearoff]
+} -cleanup {
+ deleteWindows
+} -result {{} 1}
+test menu-20.11 {CloneMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .m2
+ .m1 clone .m2
+} -returnCodes error -result {window name "m2" already exists in parent}
+
+test menu-21.1 {MenuDoYPosition} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 yposition glorp
+} -returnCodes error -result {bad menu entry index "glorp"}
+test menu-21.2 {MenuDoYPosition} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "Test"
+ .m1 yposition 1
+} -cleanup {
+ deleteWindows
+} -returnCodes ok -match glob -result {*}
+
+test menu-22.1 {GetIndexFromCoords} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 configure -tearoff 0
+ .m1 index @5
+} -cleanup {
+ deleteWindows
+} -result {0}
+test menu-22.2 {GetIndexFromCoords} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 configure -tearoff 0
+ .m1 index @5,5
+} -cleanup {
+ deleteWindows
+} -result {0}
+test menu-22.3 {GetIndexFromCoords: mapped window, y only} -setup {
+ deleteWindows
+} -constraints {unix} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 configure -tearoff 0
+ tk_popup .m1 0 0
+ tkwait visibility .m1
+ .m1 index @5
+} -cleanup {
+ deleteWindows
+} -result {0}
+test menu-22.4 {GetIndexFromCoords: mapped window x,y} -setup {
+ deleteWindows
+} -constraints {unix} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 configure -tearoff 0
+ tk_popup .m1 0 0
+ tkwait visibility .m1
+ update
+ set x [expr {[winfo width .m1] - [.m1 cget -borderwidth] - 1}]
+ .m1 index @$x,5
+} -cleanup {
+ deleteWindows
+} -result {0}
+test menu-22.5 {GetIndexFromCoords: mapped wide window} -setup {
+ deleteWindows
+} -constraints {unix} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 configure -tearoff 0
+ tk_popup .m1 0 0
+ tkwait visibility .m1
+ wm geometry .m1 200x100
+ update
+ set x [expr {[winfo width .m1] - [.m1 cget -borderwidth] - 1}]
+ .m1 index @$x,5
+} -cleanup {
+ deleteWindows
+} -result {0}
+
+test menu-23.1 {RecursivelyDeleteMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ . configure -menu .m1
+ . configure -menu ""
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-23.2 {RecursivelyDeleteMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m2
+ .m2 add command -label "test2"
+ menu .m1
+ .m1 add cascade -label "test1" -menu .m2
+ . configure -menu .m1
+ . configure -menu ""
+} -cleanup {
+ deleteWindows
+} -result {}
+
+test menu-24.1 {TkNewMenuName} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-24.2 {TkNewMenuName} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ menu .m1\#0
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-24.3 {TkNewMenuName} -setup {
+ deleteWindows
+} -body {
+ menu .#m
+ rename .#m hideme
+ list [catch {. configure -menu [menu .m]}] [. configure -menu ""] [destroy .#m] \
+ [destroy .m] [destroy hideme]
+} -result {0 {} {} {} {}}
+
+
+test menu-25.1 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.2 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.3 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ destroy .m1
+ menu .m1
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.4 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ . configure -menu .m1
+ menu .m2
+ list [. configure -menu .m2] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.5 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ . configure -menu .m1
+ .m1 clone .m2
+ menu .m3
+ list [. configure -menu .m3] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.6 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ .m1 clone .m2
+ . configure -menu .m2
+ menu .m3
+ list [. configure -menu .m3] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.7 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ menu .m2
+ . configure -menu .m1
+ toplevel .t2
+ .t2 configure -menu .m1
+ list [.t2 configure -menu .m2] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.8 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ menu .m2
+ . configure -menu .m1
+ toplevel .t2
+ wm geometry .t2 +0+0
+ .t2 configure -menu .m1
+ list [. configure -menu .m2] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.9 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ menu .m2
+ . configure -menu .m1
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ toplevel .t3 -menu .m1
+ wm geometry .t3 +0+0
+ list [.t3 configure -menu .m2] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.10 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ menu .m2
+ . configure -menu .m1
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ toplevel .t3 -menu .m1
+ wm geometry .t3 +0+0
+ list [.t2 configure -menu .m2] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.11 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ menu .m2
+ . configure -menu .m1
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ toplevel .t3 -menu .m1
+ wm geometry .t3 +0+0
+ list [. configure -menu .m2] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.12 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.13 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.14 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.15 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.16 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ . configure -menu .m1
+ list [toplevel .t2 -menu m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {.t2 {}}
+
+
+test menu-26.1 {DestroyMenuHashTable} -setup {
+ catch {interp delete testinterp}
+ deleteWindows
+} -body {
+ interp create testinterp
+ load {} Tk testinterp
+ interp eval testinterp {menu .m1}
+ interp delete testinterp
+} -returnCodes ok -result {}
+
+
+test menu-27.1 {GetMenuHashTable} -setup {
+ catch {interp delete testinterp}
+ deleteWindows
+} -body {
+ interp create testinterp
+ load {} Tk testinterp
+ list [catch {interp eval testinterp {menu .m1}} msg] $msg [interp delete testinterp]
+} -cleanup {
+ deleteWindows
+} -result {0 .m1 {}}
+
+
+test menu-28.1 {TkCreateMenuReferences - not there before} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+test menu-28.2 {TkCreateMenuReferences - there already} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m2
+ menu .m2
+} -cleanup {
+ deleteWindows
+} -result {.m2}
+
+
+test menu-29.1 {TkFindMenuReferences - not there} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ .m1 add cascade -menu .m2
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+
+
+test menu-30.1 {TkFindMenuReferences - there already} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ menu .m2
+ .m1 add cascade -menu .m2
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+
+
+test menu-31.1 {TkFreeMenuReferences - menuPtr} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ destroy .m1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-31.2 {TkFreeMenuReferences - cascadePtr} -setup {
+ deleteWindows
+} -body {
+ . configure -menu ""
+ menu .m1
+ .m1 add cascade -menu .m2
+ .m1 entryconfigure 1 -menu .m3
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-31.3 {TkFreeMenuReferences - topLevelListPtr} -setup {
+ deleteWindows
+} -body {
+ . configure -menu .m1
+ . configure -menu ""
+} -cleanup {
+ deleteWindows
+} -returnCodes ok -result {}
+test menu-31.4 {TkFreeMenuReferences - not empty} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m3
+ menu .m2
+ .m2 add cascade -menu .m3
+ .m2 entryconfigure 1 -menu ".foo"
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test menu-32.1 {DeleteMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ .m1 clone .m2
+ .m1 delete 1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.2 {DeleteMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
+
+ menu .m1
+ .m1 add command -label one
+ .m1 add command -label two
+ .m1 add command -label three
+ .m1 add command -label four
+ .m1 clone .m2
+ .m1 delete 2 3
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.3 {DeleteMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label one
+ .m1 add command -label two
+ .m1 add command -label three
+ .m1 add command -label four
+ .m1 clone .m2
+ .m2 configure -tearoff 1
+ .m1 delete 1 2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.4 {DeleteMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label one
+ .m1 add command -label two
+ .m1 add command -label three
+ .m1 add command -label four
+ .m1 clone .m2
+ .m2 configure -tearoff 0
+ .m1 delete 2 3
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.5 {DeleteMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label one
+ .m1 add command -label two
+ .m1 clone .m2
+ .m1 activate one
+ .m1 delete one
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.6 {DeleteMenuCloneEntries - reentrancy - crashes tk8.0} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label test \
+ -command ".m1 delete test ; .m1 add command -label test -command \".m1 delete test\"; .m1 delete test"
+ .m1 invoke test
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.7 {DeleteMenuCloneEntries - one entry} -setup {
+ deleteWindows
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label Hello
+ .m1 delete Hello
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.8 {Ensure all menu clone commands are deleted} -setup {
+ deleteWindows
+} -body {
+ # SF bug #465324
+ menu .menubar
+ . configure -menu .menubar
+ menu .menubar.test
+ .menubar.test add command -label "hi"
+ for {set i 0} {$i < 10} {incr i} {
+ .menubar add cascade -menu .menubar.test -label "Test"
+ .menubar delete Test
+ }
+
+ info commands .#menubar*test*
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} -setup {
+ set res {}
+ deleteWindows
+} -body {
+ menu .menubar
+ . configure -menu .menubar
+ menu .menubar.test
+ .menubar add cascade -menu .menubar.test -label "Test"
+ menu .menubar.cascade
+
+ .menubar.test add cascade -menu .menubar.cascade -label "Cascade"
+ lappend res [.menubar.test entrycget 1 -menu]
+ lappend res [.#menubar.#menubar#test entrycget 1 -menu]
+ destroy .menubar.test
+ menu .menubar.test
+ .menubar.test add cascade -menu .menubar.cascade -label "Cascade"
+ lappend res [.menubar.test entrycget 1 -menu]
+ lappend res [.#menubar.#menubar#test entrycget 1 -menu]
+ return $res
+} -cleanup {
+ deleteWindows
+} -result {.menubar.cascade .#menubar.#menubar#test.#menubar#cascade .menubar.cascade .#menubar.#menubar#test.#menubar#cascade}
+
+
+test menu-33.1 {menu vs command hiding} -setup {
+ deleteWindows
+} -body {
+ set l [interp hidden]
+ menu .m
+ interp hide {} .m
+ destroy .m
+ set result [list [winfo children .] [interp hidden]]
+ expr {$result eq [list {} $l]}
+} -result 1
+
+# menu-34 MenuInit only called at boot time
+
+# creating menus on two different screens then deleting the
+# menu from the first screen crashes Tk8.3.1
+#
+test menu-34.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} -constraints {
+ altDisplay
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .one
+ menu .one.m
+ toplevel .two -screen $::env(TK_ALT_DISPLAY)
+ menu .two.m
+ destroy .one
+ destroy .two
+} -result {}
+
+test menu-35.1 {menu -underline string overruns Bug 1599877} -setup {
+ destroy .m
+} -body {
+ # ensure that -underline does not do string overruns [Bug 1599877]
+ menu .m
+ .m add command -label "File" -underline [expr {1<<30}]
+ . configure -menu .m
+ update
+ tk::TraverseToMenu . "e"
+} -cleanup {
+ deleteWindows
+} -result {}
+
+test menu-37.1 {menubar menues cannot be posted - bug 2160206} -setup {
+ catch {destroy .m}
+} -body {
+ # On Linux the following used to panic
+ # It now returns an error (on all platforms)
+ menu .m -type menubar
+ list [catch ".m post 1 1" msg] $msg
+} -cleanup {
+ destroy .m
+} -result {1 {a menubar menu cannot be posted}}
+
+
+# cleanup
+imageFinish
+deleteWindows
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/menuDraw.test b/tk8.6/tests/menuDraw.test
new file mode 100644
index 0000000..bb632c6
--- /dev/null
+++ b/tk8.6/tests/menuDraw.test
@@ -0,0 +1,717 @@
+# This file is a Tcl script to test drawing of menus in Tk. It is
+# organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1996-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+imageInit
+
+test menuDraw-1.1 {TkMenuInitializeDrawingFields} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+
+
+test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test menuDraw-3.1 {TkMenuFreeDrawOptions} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ destroy .m1
+} -result {}
+
+
+test menuDraw-4.1 {TkMenuEntryFreeDrawOptions} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "This is a test"
+ destroy .m1
+} -result {}
+test menuDraw-4.2 {TkMenuEntryFreeDrawOptions} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add checkbutton -label "This is a test." -font "Courier 12" \
+ -activeforeground red -background green -selectcolor purple
+ destroy .m1
+} -result {}
+
+
+test menuDraw-5.1 {TkMenuConfigureDrawOptions - new menu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+test menuDraw-5.2 {TkMenuConfigureDrawOptions - old menu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 configure -fg red
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} -setup {
+ deleteWindows
+} -body {
+ menu .m1 -disabledforeground ""
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+
+
+test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.2 {TkMenuConfigureEntryDrawOptions - tkfont specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -font "Courier 12"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.3 {TkMenuConfigureEntryDrawOptions - active state - wrong entry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo"
+ .m1 entryconfigure 1 -state active
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.4 {TkMenuConfigureEntryDrawOptions - active state - correct entry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo"
+ .m1 activate 1
+ .m1 entryconfigure 1 -state active
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.5 {TkMenuConfigureEntryDrawOptions - deactivate entry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo"
+ .m1 activate 1
+ .m1 entryconfigure 1 -state normal
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo"
+ .m1 entryconfigure 1 -state foo
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad state "foo": must be active, normal, or disabled}
+test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -font "Courier 12"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.8 {TkMenuConfigureEntryDrawOptions - border specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -background "red"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.9 {TkMenuConfigureEntryDrawOptions - foreground specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -foreground "red"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.10 {TkMenuConfigureEntryDrawOptions - activeBorder specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -activebackground "red"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.11 {TkMenuConfigureEntryDrawOptions - activeforeground specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -activeforeground "red"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.12 {TkMenuConfigureEntryDrawOptions - selectcolor specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add radiobutton -label "foo" -selectcolor "red"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.13 {TkMenuConfigureEntryDrawOptions - textGC disposal} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -font "Helvetica 12"
+ .m1 entryconfigure 1 -font "Courier 12"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.14 {TkMenuConfigureEntryDrawOptions - activeGC disposal} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -activeforeground "red"
+ .m1 entryconfigure 1 -activeforeground "green"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.15 {TkMenuConfigureEntryDrawOptions - disabledGC disposal} -setup {
+ deleteWindows
+} -body {
+ menu .m1 -disabledforeground "red"
+ .m1 add command -label "foo"
+ .m1 configure -disabledforeground "green"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.16 {TkMenuConfigureEntryDrawOptions - indicatorGC disposal} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add radiobutton -label "foo" -selectcolor "red"
+ .m1 entryconfigure 1 -selectcolor "green"
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test menuDraw-7.1 {TkEventuallyRecomputeMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "This is a long label"
+ set tearoff [tk::TearOffMenu .m1]
+ update idletasks
+ .m1 entryconfigure 1 -label "foo"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "This is a long label"
+ set tearoff [tk::TearOffMenu .m1]
+ .m1 entryconfigure 1 -label "foo"
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test menuDraw-8.1 {TkRecomputeMenu} -constraints {
+ win userInteraction
+} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 configure -postcommand [.m1 add command -label foo]
+ .m1 add command -label "Hit ESCAPE to make this menu go away."
+ .m1 post 0 0
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} -setup {
+ deleteWindows
+} -body {
+ catch {unset foo}
+ menu .m1
+ set foo 0
+ .m1 add radiobutton -variable foo -label test
+ tk::TearOffMenu .m1
+ update idletasks
+ list [set foo test] [destroy .m1] [unset foo]
+} -result {test {} {}}
+test menuDraw-9.2 {TkEventuallyRedrawMenu - whole menu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ tk::TearOffMenu .m1
+} -cleanup {
+ deleteWindows
+} -returnCodes ok -match glob -result *
+
+
+# Don't know how to test when window has been deleted and ComputeMenuGeometry
+# gets called.
+test menuDraw-10.1 {ComputeMenuGeometry - menubar} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label test
+ . configure -menu .m1
+ list [update idletasks] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menuDraw-10.2 {ComputeMenuGeometry - non-menubar} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label test
+ update idletasks
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-10.3 {ComputeMenuGeometry - Resize necessary} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label test
+ update idletasks
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label test
+ update idletasks
+ .m1 entryconfigure 1 -label test
+ update idletasks
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create test image1
+ image create test image2
+ menu .m1
+ .m1 add checkbutton -image image1 -selectimage image2
+ .m1 invoke 1
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ update idletasks
+ list [image delete image2] [destroy .m1]
+} -cleanup {
+ imageCleanup
+} -result {{} {}}
+test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create test image1
+ image create test image2
+ menu .m1
+ .m1 add checkbutton -image image1 -selectimage image2
+ .m1 invoke 1
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [image delete image2] [destroy .m1]
+} -cleanup {
+ imageCleanup
+} -result {{} {}}
+test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create test image1
+ image create test image2
+ menu .m1
+ .m1 add checkbutton -image image1 -selectimage image2
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ update idletasks
+ list [image delete image2] [destroy .m1]
+} -cleanup {
+ imageCleanup
+} -result {{} {}}
+
+#Don't know how to test missing tkwin in DisplayMenu
+test menuDraw-12.1 {DisplayMenu - menubar background} -constraints unix -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -label foo -menu .m2
+ . configure -menu .m1
+ list [update] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menuDraw-12.2 {Display menu - no entries} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-12.3 {DisplayMenu - one entry} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-12.4 {DisplayMenu - two entries} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "one"
+ .m1 add command -label "two"
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw.12.5 {DisplayMenu - two columns - first bigger} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "one"
+ .m1 add command -label "two"
+ .m1 add command -label "three" -columnbreak 1
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-12.5 {DisplayMenu - two column - second bigger} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "one"
+ .m1 add command -label "two" -columnbreak 1
+ .m1 add command -label "three"
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw.12.7 {DisplayMenu - three columns} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "one"
+ .m1 add command -label "two" -columnbreak 1
+ .m1 add command -label "three"
+ .m1 add command -label "four"
+ .m1 add command -label "five"
+ .m1 add command -label "six"
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-12.6 {Display menu - testing for extra space and menubars} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -label foo
+ . configure -menu .m1
+ update
+ . configure -menu ""
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-12.7 {Display menu - extra space at end of menu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ wm geometry $tearoff 200x100
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test menuDraw-13.1 {TkMenuEventProc - Expose} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "one"
+ menu .m2
+ .m2 add command -label "two"
+ set tearoff1 [tk::TearOffMenu .m1 40 40]
+ set tearoff2 [tk::TearOffMenu .m2 40 40]
+ list [raise $tearoff2] [update]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo"
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [wm geometry $tearoff 200x100] [update]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+# Testing deletes is hard, and I am going to do my best. Don't know how
+# to test the case where we have already cleared the tkwin field in the
+# menuPtr.
+test menuDraw-13.4 {TkMenuEventProc - simple delete} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ destroy .m1
+} -result {}
+test menuDraw-13.5 {TkMenuEventProc - nothing pending} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ update idletasks
+ destroy .m1
+} -result {}
+
+
+test menuDraw-14.1 {TkMenuImageProc} -constraints testImageType -setup {
+ deleteWindows
+} -body {
+ catch {image delete image1}
+ menu .m1
+ image create test image1
+ .m1 add command -image image1
+ update idletasks
+ image delete image1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-14.2 {TkMenuImageProc} -constraints testImageType -setup {
+ deleteWindows
+} -body {
+ catch {image delete image1}
+ menu .m1
+ image create test image1
+ .m1 add command -image image1
+ image delete image1
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test menuDraw-15.1 {TkPostTearoffMenu - Basic posting} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo"
+ tk::TearOffMenu .m1 40 40
+} -cleanup {
+ deleteWindows
+} -returnCodes ok -match glob -result *
+test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -state active
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ $tearoff index active
+} -cleanup {
+ deleteWindows
+} -result {none}
+test menuDraw-15.3 {TkPostTearoffMenu - post command} -setup {
+ deleteWindows
+} -body {
+ catch {unset foo}
+ menu .m1 -postcommand "set foo .m1"
+ .m1 add command -label "foo"
+ list [catch {tk::TearOffMenu .m1 40 40}] [set foo] [unset foo] [destroy .m1]
+} -result {0 .m1 {} {}}
+test menuDraw-15.4 {TkPostTearoffMenu - post command deleting the menu} -setup {
+ deleteWindows
+} -body {
+ menu .m1 -postcommand "destroy .m1"
+ .m1 add command -label "foo"
+ list [catch {tk::TearOffMenu .m1 40 40} msg] $msg [winfo exists .m1]
+} -result {0 {} 0}
+test menuDraw-15.5 {TkPostTearoffMenu - tearoff at edge of screen} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo"
+ set height [winfo screenheight .m1]
+ tk::TearOffMenu .m1 40 $height
+} -cleanup {
+ deleteWindows
+} -returnCodes ok -match glob -result *
+test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo"
+ set width [winfo screenwidth .m1]
+ tk::TearOffMenu .m1 $width 40
+} -cleanup {
+ deleteWindows
+} -returnCodes ok -match glob -result *
+
+
+test menuDraw-16.1 {TkPostSubmenu} -constraints nonUnixUserInteraction -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -label test -menu .m2
+ menu .m2
+ .m2 add command -label "Hit ESCAPE to make this menu go away."
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ $tearoff postcascade 0
+ $tearoff postcascade 0
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-16.2 {TkPostSubMenu} -constraints nonUnixUserInteraction -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -label "two" -menu .m2
+ .m1 add cascade -label "three" -menu .m3
+ menu .m2
+ .m2 add command -label "two"
+ menu .m3
+ .m3 add command -label "three"
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ $tearoff postcascade 0
+ $tearoff postcascade 1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-16.3 {TkPostSubMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -label test -menu .m2
+ .m1 postcascade 1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-16.4 {TkPostSubMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -label test
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ $tearoff postcascade 0
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-16.5 {TkPostSubMenu} -constraints unix -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -label test -menu .m2
+ menu .m2 -postcommand "glorp"
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ $tearoff postcascade test
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {invalid command name "glorp"}
+test menuDraw-16.6 {TkPostSubMenu} -constraints {
+ win userInteraction
+} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -label test -menu .m2
+ menu .m2
+ .m2 add command -label "Hit ESCAPE to get rid of this menu"
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ $tearoff postcascade 0
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test menuDraw-17.1 {AdjustMenuCoords - menubar} -constraints unix -setup {
+ deleteWindows
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label test -menu .m2
+ menu .m2 -tearoff 0
+ .m2 add command -label foo
+ . configure -menu .m1
+ foreach w [winfo children .] {
+ if {[$w cget -type] == "menubar"} {
+ break
+ }
+ }
+ list [$w postcascade 0] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menuDraw-17.2 {AdjustMenuCoords - menu} -constraints {
+ win userInteraction
+} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade -label test -menu .m2
+ menu .m2
+ .m2 add command -label "Hit ESCAPE to make this menu go away"
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ $tearoff postcascade 0
+} -cleanup {
+ deleteWindows
+} -result {}
+
+# cleanup
+imageFinish
+deleteWindows
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/menubut.test b/tk8.6/tests/menubut.test
new file mode 100644
index 0000000..6efdb0f
--- /dev/null
+++ b/tk8.6/tests/menubut.test
@@ -0,0 +1,762 @@
+# This file is a Tcl script to test menubuttons in Tk. It is
+# organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+# XXX This test file is woefully incomplete right now. If any part
+# XXX of a procedure has tests then the whole procedure has tests,
+# XXX but many procedures have no tests.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+imageInit
+
+# Create entries in the option database to be sure that geometry options
+# like border width have predictable values.
+
+option add *Menubutton.borderWidth 2
+option add *Menubutton.highlightThickness 2
+option add *Menubutton.font {Helvetica -12 bold}
+option add *Button.borderWidth 2
+option add *Button.highlightThickness 2
+option add *Button.font {Helvetica -12 bold}
+
+
+menubutton .mb -text "Test"
+pack .mb
+update
+test menubutton-1.1 {configuration options} -body {
+ .mb configure -activebackground #012345
+ .mb cget -activebackground
+} -cleanup {
+ .mb configure -activebackground [lindex [.mb configure -activebackground] 3]
+} -result {#012345}
+test menubutton-1.2 {configuration options} -body {
+ .mb configure -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test menubutton-1.3 {configuration options} -body {
+ .mb configure -activeforeground #ff0000
+ .mb cget -activeforeground
+} -cleanup {
+ .mb configure -activeforeground [lindex [.mb configure -activeforeground] 3]
+} -result {#ff0000}
+test menubutton-1.4 {configuration options} -body {
+ .mb configure -activeforeground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test menubutton-1.5 {configuration options} -body {
+ .mb configure -anchor nw
+ .mb cget -anchor
+} -cleanup {
+ .mb configure -anchor [lindex [.mb configure -anchor] 3]
+} -result {nw}
+test menubutton-1.6 {configuration options} -body {
+ .mb configure -anchor bogus
+} -returnCodes error -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+test menubutton-1.7 {configuration options} -body {
+ .mb configure -background #ff0000
+ .mb cget -background
+} -cleanup {
+ .mb configure -background [lindex [.mb configure -background] 3]
+} -result {#ff0000}
+test menubutton-1.8 {configuration options} -body {
+ .mb configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test menubutton-1.9 {configuration options} -body {
+ .mb configure -bd 4
+ .mb cget -bd
+} -cleanup {
+ .mb configure -bd [lindex [.mb configure -bd] 3]
+} -result {4}
+test menubutton-1.10 {configuration options} -body {
+ .mb configure -bd badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test menubutton-1.11 {configuration options} -body {
+ .mb configure -bg #ff0000
+ .mb cget -bg
+} -cleanup {
+ .mb configure -bg [lindex [.mb configure -bg] 3]
+} -result {#ff0000}
+test menubutton-1.12 {configuration options} -body {
+ .mb configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test menubutton-1.13 {configuration options} -body {
+ .mb configure -bitmap questhead
+ .mb cget -bitmap
+} -cleanup {
+ .mb configure -bitmap [lindex [.mb configure -bitmap] 3]
+} -result {questhead}
+test menubutton-1.14 {configuration options} -body {
+ .mb configure -bitmap badValue
+} -returnCodes error -result {bitmap "badValue" not defined}
+test menubutton-1.15 {configuration options} -body {
+ .mb configure -borderwidth 1.3
+ .mb cget -borderwidth
+} -cleanup {
+ .mb configure -borderwidth [lindex [.mb configure -borderwidth] 3]
+} -result {1}
+test menubutton-1.16 {configuration options} -body {
+ .mb configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test menubutton-1.17 {configuration options} -body {
+ .mb configure -cursor arrow
+ .mb cget -cursor
+} -cleanup {
+ .mb configure -cursor [lindex [.mb configure -cursor] 3]
+} -result {arrow}
+test menubutton-1.18 {configuration options} -body {
+ .mb configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test menubutton-1.19 {configuration options} -body {
+ .mb configure -direction below
+ .mb cget -direction
+} -cleanup {
+ .mb configure -direction [lindex [.mb configure -direction] 3]
+} -result {below}
+test menubutton-1.20 {configuration options} -body {
+ .mb configure -direction badValue
+} -returnCodes error -result {bad direction "badValue": must be above, below, flush, left, or right}
+test menubutton-1.21 {configuration options} -body {
+ .mb configure -disabledforeground #00ff00
+ .mb cget -disabledforeground
+} -cleanup {
+ .mb configure -disabledforeground [lindex [.mb configure -disabledforeground] 3]
+} -result {#00ff00}
+test menubutton-1.22 {configuration options} -body {
+ .mb configure -disabledforeground xyzzy
+} -returnCodes error -result {unknown color name "xyzzy"}
+test menubutton-1.23 {configuration options} -body {
+ .mb configure -fg #110022
+ .mb cget -fg
+} -cleanup {
+ .mb configure -fg [lindex [.mb configure -fg] 3]
+} -result {#110022}
+test menubutton-1.24 {configuration options} -body {
+ .mb configure -fg bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test menubutton-1.25 {configuration options} -body {
+ .mb configure -font {Helvetica 12}
+ .mb cget -font
+} -cleanup {
+ .mb configure -font [lindex [.mb configure -font] 3]
+} -result {Helvetica 12}
+test menubutton-1.26 {configuration options} -body {
+ .mb configure -foreground #110022
+ .mb cget -foreground
+} -cleanup {
+ .mb configure -foreground [lindex [.mb configure -foreground] 3]
+} -result {#110022}
+test menubutton-1.27 {configuration options} -body {
+ .mb configure -foreground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test menubutton-1.28 {configuration options} -body {
+ .mb configure -height 18
+ .mb cget -height
+} -cleanup {
+ .mb configure -height [lindex [.mb configure -height] 3]
+} -result {18}
+test menubutton-1.29 {configuration options} -body {
+ .mb configure -height 20.0
+} -returnCodes error -result {expected integer but got "20.0"}
+test menubutton-1.30 {configuration options} -body {
+ .mb configure -highlightbackground #112233
+ .mb cget -highlightbackground
+} -cleanup {
+ .mb configure -highlightbackground [lindex [.mb configure -highlightbackground] 3]
+} -result {#112233}
+test menubutton-1.31 {configuration options} -body {
+ .mb configure -highlightbackground ugly
+} -returnCodes error -result {unknown color name "ugly"}
+test menubutton-1.32 {configuration options} -body {
+ .mb configure -highlightcolor #110022
+ .mb cget -highlightcolor
+} -cleanup {
+ .mb configure -highlightcolor [lindex [.mb configure -highlightcolor] 3]
+} -result {#110022}
+test menubutton-1.33 {configuration options} -body {
+ .mb configure -highlightcolor bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test menubutton-1.34 {configuration options} -body {
+ .mb configure -highlightthickness 18
+ .mb cget -highlightthickness
+} -cleanup {
+ .mb configure -highlightthickness [lindex [.mb configure -highlightthickness] 3]
+} -result {18}
+test menubutton-1.35 {configuration options} -body {
+ .mb configure -highlightthickness badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test menubutton-1.36 {configuration options} -constraints {
+ testImageType
+} -setup {
+ catch {image delete image1}
+ image create test image1
+} -body {
+ .mb configure -image image1
+ .mb cget -image
+} -cleanup {
+ .mb configure -image [lindex [.mb configure -image] 3]
+ image create test image1
+} -result {image1}
+test menubutton-1.37 {configuration options} -setup {
+ catch {image delete bogus}
+} -body {
+ .mb configure -image bogus
+} -cleanup {
+ .mb configure -image [lindex [.mb configure -image] 3]
+} -returnCodes error -result {image "bogus" doesn't exist}
+test menubutton-1.38 {configuration options} -body {
+ .mb configure -indicatoron yes
+ .mb cget -indicatoron
+} -cleanup {
+ .mb configure -indicatoron [lindex [.mb configure -indicatoron] 3]
+} -result {1}
+test menubutton-1.39 {configuration options} -body {
+ .mb configure -indicatoron no_way
+} -returnCodes error -result {expected boolean value but got "no_way"}
+test menubutton-1.40 {configuration options} -body {
+ .mb configure -justify right
+ .mb cget -justify
+} -cleanup {
+ .mb configure -justify [lindex [.mb configure -justify] 3]
+} -result {right}
+test menubutton-1.41 {configuration options} -body {
+ .mb configure -justify bogus
+} -returnCodes error -result {bad justification "bogus": must be left, right, or center}
+test menubutton-1.42 {configuration options} -body {
+ .mb configure -menu {any old string}
+ .mb cget -menu
+} -cleanup {
+ .mb configure -menu [lindex [.mb configure -menu] 3]
+} -result {any old string}
+test menubutton-1.43 {configuration options} -body {
+ .mb configure -padx 12
+ .mb cget -padx
+} -cleanup {
+ .mb configure -padx [lindex [.mb configure -padx] 3]
+} -result {12}
+test menubutton-1.44 {configuration options} -body {
+ .mb configure -padx 420x
+} -returnCodes error -result {bad screen distance "420x"}
+test menubutton-1.45 {configuration options} -body {
+ .mb configure -pady 12
+ .mb cget -pady
+} -cleanup {
+ .mb configure -pady [lindex [.mb configure -pady] 3]
+} -result {12}
+test menubutton-1.46 {configuration options} -body {
+ .mb configure -pady 420x
+} -returnCodes error -result {bad screen distance "420x"}
+test menubutton-1.47 {configuration options} -body {
+ .mb configure -relief groove
+ .mb cget -relief
+} -cleanup {
+ .mb configure -relief [lindex [.mb configure -relief] 3]
+} -result {groove}
+test menubutton-1.48 {configuration options} -body {
+ .mb configure -relief 1.5
+} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test menubutton-1.49 {configuration options} -body {
+ .mb configure -state normal
+ .mb cget -state
+} -cleanup {
+ .mb configure -state [lindex [.mb configure -state] 3]
+} -result {normal}
+test menubutton-1.50 {configuration options} -body {
+ .mb configure -state bogus
+} -returnCodes error -result {bad state "bogus": must be active, disabled, or normal}
+test menubutton-1.51 {configuration options} -body {
+ .mb configure -takefocus {any string}
+ .mb cget -takefocus
+} -cleanup {
+ .mb configure -takefocus [lindex [.mb configure -takefocus] 3]
+} -result {any string}
+test menubutton-1.52 {configuration options} -body {
+ .mb configure -text {Sample text}
+ .mb cget -text
+} -cleanup {
+ .mb configure -text [lindex [.mb configure -text] 3]
+} -result {Sample text}
+test menubutton-1.53 {configuration options} -body {
+ .mb configure -textvariable i
+ .mb cget -textvariable
+} -cleanup {
+ .mb configure -textvariable [lindex [.mb configure -textvariable] 3]
+} -result {i}
+test menubutton-1.54 {configuration options} -body {
+ .mb configure -underline 5
+ .mb cget -underline
+} -cleanup {
+ .mb configure -underline [lindex [.mb configure -underline] 3]
+} -result {5}
+test menubutton-1.55 {configuration options} -body {
+ .mb configure -underline 3p
+} -returnCodes error -result {expected integer but got "3p"}
+test menubutton-1.56 {configuration options} -body {
+ .mb configure -width 402
+ .mb cget -width
+} -cleanup {
+ .mb configure -width [lindex [.mb configure -width] 3]
+} -result {402}
+test menubutton-1.57 {configuration options} -body {
+ .mb configure -width 3p
+} -returnCodes error -result {expected integer but got "3p"}
+test menubutton-1.58 {configuration options} -body {
+ .mb configure -wraplength 100
+ .mb cget -wraplength
+} -cleanup {
+ .mb configure -wraplength [lindex [.mb configure -wraplength] 3]
+} -result {100}
+test menubutton-1.59 {configuration options} -body {
+ .mb configure -wraplength 6x
+} -returnCodes error -result {bad screen distance "6x"}
+
+
+deleteWindows
+menubutton .mb -text "Test"
+pack .mb
+update
+test menubutton-2.1 {Tk_MenubuttonCmd procedure} -body {
+ menubutton
+} -returnCodes error -result {wrong # args: should be "menubutton pathName ?-option value ...?"}
+test menubutton-2.2 {Tk_MenubuttonCmd procedure} -body {
+ menubutton foo
+} -returnCodes error -result {bad window path name "foo"}
+test menubutton-2.3 {Tk_MenubuttonCmd procedure} -body {
+ catch {destroy .mb}
+ menubutton .mb
+ winfo class .mb
+} -result {Menubutton}
+test menubutton-2.4 {Tk_ButtonCmd procedure} -setup {
+ destroy .mb
+} -body {
+ menubutton .mb -gorp foo
+} -returnCodes error -result {unknown option "-gorp"}
+test menubutton-2.5 {Tk_ButtonCmd procedure} -setup {
+ destroy .mb
+} -body {
+ catch {menubutton .mb -gorp foo}
+ winfo exists .mb
+} -result 0
+
+
+deleteWindows
+menubutton .mb -text "Test Menu"
+pack .mb
+test menubutton-3.1 {MenuButtonWidgetCmd procedure} -body {
+ .mb
+} -returnCodes error -result {wrong # args: should be ".mb option ?arg ...?"}
+test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} -body {
+ .mb c
+} -returnCodes error -result {ambiguous option "c": must be cget or configure}
+test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} -body {
+ .mb cget
+} -returnCodes error -result {wrong # args: should be ".mb cget option"}
+test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} -body {
+ .mb cget a b
+} -returnCodes error -result {wrong # args: should be ".mb cget option"}
+test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} -body {
+ .mb cget -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} -body {
+ .mb configure -highlightthickness 3
+ .mb cget -highlightthickness
+} -result {3}
+test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} -body {
+ llength [.mb configure]
+} -result {33}
+test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} -body {
+ .mb configure -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} -body {
+ .mb co -bg #ffffff -fg
+} -returnCodes error -result {value for "-fg" missing}
+test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} -body {
+ .mb configure -fg #123456
+ .mb configure -bg #654321
+ lindex [.mb configure -fg] 4
+} -result {#123456}
+test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} -body {
+ .mb foobar
+} -returnCodes error -result {bad option "foobar": must be cget or configure}
+deleteWindows
+
+# XXX Need to add tests for several procedures here. The tests for XXX
+# XXX ConfigureMenuButton aren't complete either. XXX
+
+test menubutton-4.1 {ConfigureMenuButton procedure} -setup {
+ deleteWindows
+} -body {
+ button .mb1 -text "Menubutton 1"
+ .mb1 configure -width 1i
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "1i"}
+test menubutton-4.2 {ConfigureMenuButton procedure} -setup {
+ deleteWindows
+} -body {
+ button .mb1 -text "Menubutton 1"
+ catch {.mb1 configure -width 1i}
+ return $errorInfo
+} -cleanup {
+ deleteWindows
+} -result {expected integer but got "1i"
+ (processing -width option)
+ invoked from within
+".mb1 configure -width 1i"}
+
+test menubutton-4.3 {ConfigureMenuButton procedure} -setup {
+ deleteWindows
+} -body {
+ button .mb1 -text "Menubutton 1"
+ .mb1 configure -height 0.5c
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "0.5c"}
+test menubutton-4.4 {ConfigureMenuButton procedure} -setup {
+ deleteWindows
+} -body {
+ button .mb1 -text "Menubutton 1"
+ catch {.mb1 configure -height 0.5c}
+ return $errorInfo
+} -cleanup {
+ deleteWindows
+} -result {expected integer but got "0.5c"
+ (processing -height option)
+ invoked from within
+".mb1 configure -height 0.5c"}
+
+test menubutton-4.5 {ConfigureMenuButton procedure} -setup {
+ deleteWindows
+} -body {
+ button .mb1 -bitmap questhead
+ .mb1 configure -width abc
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad screen distance "abc"}
+test menubutton-4.6 {ConfigureMenuButton procedure} -setup {
+ deleteWindows
+} -body {
+ button .mb1 -bitmap questhead
+ catch {.mb1 configure -width abc}
+ return $errorInfo
+} -cleanup {
+ deleteWindows
+} -result {bad screen distance "abc"
+ (processing -width option)
+ invoked from within
+".mb1 configure -width abc"}
+
+test menubutton-4.7 {ConfigureMenuButton procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create test image1
+ button .mb1 -image image1
+ .mb1 configure -height 0.5x
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -returnCodes error -result {bad screen distance "0.5x"}
+test menubutton-4.8 {ConfigureMenuButton procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create test image1
+ button .mb1 -image image1
+ catch {.mb1 configure -height 0.5x}
+ return $errorInfo
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {bad screen distance "0.5x"
+ (processing -height option)
+ invoked from within
+".mb1 configure -height 0.5x"}
+
+test menubutton-4.9 {ConfigureMenuButton procedure} -constraints {
+ nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
+ button .mb1 -text "Sample text" -width 10 -height 2
+ pack .mb1
+ set result "[winfo reqwidth .mb1] [winfo reqheight .mb1]"
+ .mb1 configure -bitmap questhead
+ lappend result [winfo reqwidth .mb1] [winfo reqheight .mb1]
+} -cleanup {
+ deleteWindows
+} -result {102 46 20 12}
+
+test menubutton-4.10 {ConfigureMenuButton procedure - bad direction} -setup {
+ deleteWindows
+} -body {
+ menubutton .mb -text "Test"
+ .mb configure -direction badValue
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad direction "badValue": must be above, below, flush, left, or right}
+test menubutton-4.11 {ConfigureMenuButton procedure - bad direction} -setup {
+ deleteWindows
+} -body {
+ menubutton .mb -text "Test"
+ catch {.mb configure -direction badValue}
+ list [.mb cget -direction] [destroy .mb]
+} -cleanup {
+ deleteWindows
+} -result {below {}}
+
+
+
+# XXX Need to add tests for several procedures here. XXX
+
+test menubutton-5.1 {MenuButtonEventProc procedure} -setup {
+ deleteWindows
+ set x {}
+} -body {
+ menubutton .mb1 -bg #543210
+ rename .mb1 .mb2
+ lappend x [winfo children .]
+ lappend x [.mb2 cget -bg]
+ destroy .mb1
+ lappend x [info command .mb*] [winfo children .]
+} -cleanup {
+ deleteWindows
+} -result {.mb1 #543210 {} {}}
+
+
+test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} -setup {
+ deleteWindows
+} -body {
+ menubutton .mb1
+ rename .mb1 {}
+ list [info command .mb*] [winfo children .]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+
+
+test menubutton-7.1 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
+ menubutton .mb -image image1 -bd 4 -highlightthickness 0
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {38 23}
+test menubutton-7.2 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
+ menubutton .mb -image image1 -bd 1 -highlightthickness 2
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {36 21}
+test menubutton-7.3 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
+ menubutton .mb -image image1 -bd 0 -highlightthickness 2 -padx 5 -pady 5
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {34 19}
+test menubutton-7.4 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
+ menubutton .mb -image image1 -bd 2 -relief raised -width 40 \
+ -highlightthickness 2
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {48 23}
+test menubutton-7.5 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
+ menubutton .mb -image image1 -bd 2 -relief raised -height 30 \
+ -highlightthickness 2
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {38 38}
+test menubutton-7.6 {ComputeMenuButtonGeometry procedure} -setup {
+ deleteWindows
+} -body {
+ menubutton .mb -bitmap question -bd 2 -relief raised \
+ -highlightthickness 2
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+} -result {25 35}
+test menubutton-7.7 {ComputeMenuButtonGeometry procedure} -setup {
+ deleteWindows
+} -body {
+ menubutton .mb -bitmap question -bd 2 -relief raised -width 40 \
+ -highlightthickness 1
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+} -result {46 33}
+test menubutton-7.8 {ComputeMenuButtonGeometry procedure} -setup {
+ deleteWindows
+} -body {
+ menubutton .mb -bitmap question -bd 2 -relief raised -height 50 \
+ -highlightthickness 1
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+} -result {23 56}
+test menubutton-7.9 {ComputeMenuButtonGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ menubutton .mb -text String -bd 2 -relief raised -padx 0 -pady 0 \
+ -highlightthickness 1
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+} -result {42 20}
+test menubutton-7.10 {ComputeMenuButtonGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ menubutton .mb -text String -bd 2 -relief raised -width 20 \
+ -padx 0 -pady 0 -highlightthickness 1
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+} -result {146 20}
+test menubutton-7.11 {ComputeMenuButtonGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ menubutton .mb -text String -bd 2 -relief raised -height 2 \
+ -padx 0 -pady 0 -highlightthickness 1
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+} -result {42 34}
+test menubutton-7.12 {ComputeMenuButtonGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ menubutton .mb -text String -bd 2 -relief raised -padx 10 -pady 5 \
+ -highlightthickness 1
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+} -result {62 30}
+test menubutton-7.13 {ComputeMenuButtonGeometry procedure} -constraints {
+ nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
+ menubutton .mb -text String -bd 2 -relief raised \
+ -highlightthickness 1 -indicatoron 1
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+} -result {78 28}
+test menubutton-7.14 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType unix nonPortable
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
+ # The following test is non-portable because the indicator's pixel
+ # size varies to maintain constant absolute size.
+
+ menubutton .mb -image image1 -bd 2 -relief raised \
+ -highlightthickness 2 -indicatoron 1
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {64 23}
+test menubutton-7.15 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType win nonPortable
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
+ # The following test is non-portable because the indicator's pixel
+ # size varies to maintain constant absolute size.
+
+ menubutton .mb -image image1 -bd 2 -relief raised \
+ -highlightthickness 2 -indicatoron 1
+ pack .mb
+ list [winfo reqwidth .mb] [winfo reqheight .mb]
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {65 23}
+
+
+test menubutton-8.1 {menubutton vs hidden commands} -body {
+ set l [interp hidden]
+ deleteWindows
+ menubutton .mb
+ interp hide {} .mb
+ destroy .mb
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 eq $res2}
+} -result 1
+
+
+
+deleteWindows
+option clear
+imageFinish
+
+# cleanup
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/message.test b/tk8.6/tests/message.test
new file mode 100644
index 0000000..dcffc72
--- /dev/null
+++ b/tk8.6/tests/message.test
@@ -0,0 +1,474 @@
+# This file is a Tcl script to test out the "message" command
+# of Tk. It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::loadTestedCommands
+eval tcltest::configure $argv
+
+
+test message-1.1 {configuration option: "anchor"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -anchor w
+ .m cget -anchor
+} -cleanup {
+ destroy .m
+} -result {w}
+test message-1.2 {configuration option: "anchor"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -anchor bogus
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+
+test message-1.3 {configuration option: "aspect"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -aspect 3
+ .m cget -aspect
+} -cleanup {
+ destroy .m
+} -result {3}
+test message-1.4 {configuration option: "aspect"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -aspect bogus
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {expected integer but got "bogus"}
+
+test message-1.5 {configuration option: "background"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -background #ff0000
+ .m cget -background
+} -cleanup {
+ destroy .m
+} -result {#ff0000}
+test message-1.6 {configuration option: "background"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -background non-existent
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test message-1.7 {configuration option: "bd"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -bd 4
+ .m cget -bd
+} -cleanup {
+ destroy .m
+} -result {4}
+test message-1.8 {configuration option: "bd"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -bd badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test message-1.9 {configuration option: "bg"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -bg #ff0000
+ .m cget -bg
+} -cleanup {
+ destroy .m
+} -result {#ff0000}
+test message-1.10 {configuration option: "bg"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -bg non-existent
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test message-1.11 {configuration option: "borderwidth"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -borderwidth 1.3
+ .m cget -borderwidth
+} -cleanup {
+ destroy .m
+} -result {1}
+test message-1.12 {configuration option: "borderwidth"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -borderwidth badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test message-1.13 {configuration option: "cursor"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -cursor arrow
+ .m cget -cursor
+} -cleanup {
+ destroy .m
+} -result {arrow}
+test message-1.14 {configuration option: "cursor"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -cursor badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+
+test message-1.15 {configuration option: "fg"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -fg #00ff00
+ .m cget -fg
+} -cleanup {
+ destroy .m
+} -result {#00ff00}
+test message-1.16 {configuration option: "fg"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -fg badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {unknown color name "badValue"}
+
+test message-1.17 {configuration option: "font"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -font fixed
+ .m cget -font
+} -cleanup {
+ destroy .m
+} -result {fixed}
+test message-1.18 {configuration option: "font"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -font {}
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {font "" doesn't exist}
+
+test message-1.19 {configuration option: "-foreground"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -foreground green
+ .m cget -foreground
+} -cleanup {
+ destroy .m
+} -result {green}
+test message-1.20 {configuration option: "-foreground"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -foreground badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {unknown color name "badValue"}
+
+test message-1.21 {configuration option: "highlightbackground"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -highlightbackground #112233
+ .m cget -highlightbackground
+} -cleanup {
+ destroy .m
+} -result {#112233}
+test message-1.22 {configuration option: "highlightbackground"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -highlightbackground ugly
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {unknown color name "ugly"}
+
+test message-1.23 {configuration option: "highlightcolor"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -highlightcolor #123456
+ .m cget -highlightcolor
+} -cleanup {
+ destroy .m
+} -result {#123456}
+test message-1.24 {configuration option: "highlightcolor"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -highlightcolor non-existent
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test message-1.25 {configuration option: "highlightthickness"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -highlightthickness 2
+ .m cget -highlightthickness
+} -cleanup {
+ destroy .m
+} -result {2}
+test message-1.26 {configuration option: "highlightthickness"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -highlightthickness badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test message-1.27 {configuration option: "justify"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -justify right
+ .m cget -justify
+} -cleanup {
+ destroy .m
+} -result {right}
+test message-1.28 {configuration option: "justify"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -justify bogus
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+
+test message-1.29 {configuration option: "padx"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -padx 12m
+ .m cget -padx
+} -cleanup {
+ destroy .m
+} -result {12m}
+test message-1.30 {configuration option: "padx"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -padx 420x
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad screen distance "420x"}
+
+test message-1.31 {configuration option: "pady"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -pady 12m
+ .m cget -pady
+} -cleanup {
+ destroy .m
+} -result {12m}
+test message-1.32 {configuration option: "pady"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -pady 420x
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad screen distance "420x"}
+
+test message-1.33 {configuration option: "relief"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -relief ridge
+ .m cget -relief
+} -cleanup {
+ destroy .m
+} -result {ridge}
+test message-1.34 {configuration option: "relief"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -relief badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}
+
+test message-1.35 {configuration options: "text"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -text "Sample text"
+ .m cget -text
+} -cleanup {
+ destroy .m
+} -result {Sample text}
+
+test message-1.36 {configuration option: "textvariable"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -textvariable i
+ .m cget -textvariable
+} -cleanup {
+ destroy .m
+} -result {i}
+
+test message-1.37 {configuration option: "width"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -width 2
+ .m cget -width
+} -cleanup {
+ destroy .m
+} -result {2}
+test message-1.38 {configuration option: "width"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -width badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+
+test message-2.1 {Tk_MessageObjCmd procedure} -body {
+ message
+} -returnCodes {error} -result {wrong # args: should be "message pathName ?-option value ...?"}
+
+test message-2.2 {Tk_MessageObjCmd procedure} -body {
+ message foo
+} -returnCodes {error} -result {bad window path name "foo"}
+test message-2.3 {Tk_MessageObjCmd procedure} -body {
+ catch {message foo}
+ winfo child .
+} -result {}
+
+test message-2.4 {Tk_MessageObjCmd procedure} -body {
+ message .s -gorp dump
+} -returnCodes {error} -result {unknown option "-gorp"}
+test message-2.5 {Tk_MessageObjCmd procedure} -body {
+ catch {message .s -gorp dump}
+ winfo child .
+} -result {}
+
+
+test message-3.1 {MessageWidgetObjCmd procedure} -setup {
+ message .m
+} -body {
+ .m
+} -cleanup {
+ destroy .m
+} -returnCodes error -result {wrong # args: should be ".m option ?arg ...?"}
+test message-3.2 {MessageWidgetObjCmd procedure, "cget"} -setup {
+ message .m
+} -body {
+ .m cget
+} -cleanup {
+ destroy .m
+} -returnCodes error -result {wrong # args: should be ".m cget option"}
+test message-3.3 {MessageWidgetObjCmd procedure, "cget"} -setup {
+ message .m
+} -body {
+ .m cget -gorp
+} -cleanup {
+ destroy .m
+} -returnCodes error -result {unknown option "-gorp"}
+
+test message-3.4 {MessageWidgetObjCmd procedure, "configure"} -setup {
+ message .m
+} -body {
+ .m configure -text foobar
+ lindex [.m configure -text] 4
+} -cleanup {
+ destroy .m
+} -result {foobar}
+test message-3.5 {MessageWidgetObjCmd procedure, "configure"} -setup {
+ message .m
+} -body {
+ llength [.m configure]
+} -cleanup {
+ destroy .m
+} -result {21}
+test message-3.6 {MessageWidgetObjCmd procedure, "configure"} -setup {
+ message .m
+} -body {
+ .m configure -foo
+} -cleanup {
+ destroy .m
+} -returnCodes error -result {unknown option "-foo"}
+test message-3.7 {MessageWidgetObjCmd procedure, "configure"} -setup {
+ message .m
+} -body {
+ .m configure -bd 4
+ .m configure -bg #ffffff
+ lindex [.m configure -bd] 4
+} -cleanup {
+ destroy .m
+} -result {4}
+
+cleanupTests
+return
diff --git a/tk8.6/tests/msgbox.test b/tk8.6/tests/msgbox.test
new file mode 100644
index 0000000..643ae2c
--- /dev/null
+++ b/tk8.6/tests/msgbox.test
@@ -0,0 +1,449 @@
+# This file is a Tcl script to test out Tk's "tk_messageBox" command.
+# It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+
+test msgbox-1.1 {tk_messageBox command} -body {
+ tk_messageBox -foo
+} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
+test msgbox-1.2 {tk_messageBox command} -body {
+ tk_messageBox -foo bar
+} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
+
+test msgbox-1.3 {tk_messageBox command} -body {
+ tk_messageBox -default
+} -returnCodes error -result {value for "-default" missing}
+test msgbox-1.4 {tk_messageBox command} -body {
+ tk_messageBox -detail
+} -returnCodes error -result {value for "-detail" missing}
+test msgbox-1.5 {tk_messageBox command} -body {
+ tk_messageBox -icon
+} -returnCodes error -result {value for "-icon" missing}
+test msgbox-1.6 {tk_messageBox command} -body {
+ tk_messageBox -message
+} -returnCodes error -result {value for "-message" missing}
+test msgbox-1.7 {tk_messageBox command} -body {
+ tk_messageBox -parent
+} -returnCodes error -result {value for "-parent" missing}
+test msgbox-1.8 {tk_messageBox command} -body {
+ tk_messageBox -title
+} -returnCodes error -result {value for "-title" missing}
+test msgbox-1.9 {tk_messageBox command} -body {
+ tk_messageBox -type
+} -returnCodes error -result {value for "-type" missing}
+
+test msgbox-1.10 {tk_messageBox command} -body {
+ tk_messageBox -default
+} -returnCodes error -result {value for "-default" missing}
+
+test msgbox-1.11 {tk_messageBox command} -body {
+ tk_messageBox -type foo
+} -returnCodes error -result {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}
+
+test msgbox-1.12 {tk_messageBox command} -constraints unix -body {
+ tk_messageBox -default 1.1
+} -returnCodes error -result {invalid default button "1.1"}
+test msgbox-1.13 {tk_messageBox command} -constraints macOrWin -body {
+ tk_messageBox -default 1.1
+} -returnCodes error -result {bad -default value "1.1": must be abort, retry, ignore, ok, cancel, no, or yes}
+
+test msgbox-1.14 {tk_messageBox command} -constraints unix -body {
+ tk_messageBox -default foo
+} -returnCodes error -result {invalid default button "foo"}
+test msgbox-1.15 {tk_messageBox command} -constraints macOrWin -body {
+ tk_messageBox -default foo
+} -returnCodes error -result {bad -default value "foo": must be abort, retry, ignore, ok, cancel, no, or yes}
+
+test msgbox-1.16 {tk_messageBox command} -constraints unix -body {
+ tk_messageBox -type yesno -default 3
+} -returnCodes error -result {invalid default button "3"}
+test msgbox-1.17 {tk_messageBox command} -constraints macOrWin -body {
+ tk_messageBox -type yesno -default 3
+} -returnCodes error -result {bad -default value "3": must be abort, retry, ignore, ok, cancel, no, or yes}
+
+test msgbox-1.18 {tk_messageBox command} -body {
+ tk_messageBox -icon foo
+} -returnCodes error -result {bad -icon value "foo": must be error, info, question, or warning}
+test msgbox-1.19 {tk_messageBox command} -body {
+ tk_messageBox -parent foo.bar
+} -returnCodes error -result {bad window path name "foo.bar"}
+
+
+catch {tk_messageBox -foo bar}
+set isNative [expr {[info commands tk::MessageBox] == ""}]
+
+proc ChooseMsg {parent btn} {
+ global isNative
+ if {!$isNative} {
+ after 100 SendEventToMsg $parent $btn mouse
+ }
+}
+
+proc ChooseMsgByKey {parent btn} {
+ global isNative
+ if {!$isNative} {
+ after 100 SendEventToMsg $parent $btn key
+ }
+}
+
+proc PressButton {btn} {
+ event generate $btn <Enter>
+ event generate $btn <ButtonPress-1> -x 5 -y 5
+ event generate $btn <ButtonRelease-1> -x 5 -y 5
+}
+
+proc SendEventToMsg {parent btn type} {
+ if {$parent != "."} {
+ set w $parent.__tk__messagebox
+ } else {
+ set w .__tk__messagebox
+ }
+ if ![winfo ismapped $w.$btn] {
+ update
+ }
+ if {$type == "mouse"} {
+ PressButton $w.$btn
+ } else {
+ event generate $w <Enter>
+ focus $w
+ event generate $w.$btn <Enter>
+ event generate $w <KeyPress> -keysym Return
+ }
+}
+#
+# Try out all combinations of (type) x (default button) and
+# (type) x (icon).
+#
+test msgbox-2.1 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" -type abortretryignore
+} -result {abort}
+test msgbox-2.2 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -icon warning
+} -result {abort}
+test msgbox-2.3 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -icon error
+} -result {abort}
+test msgbox-2.4 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -icon info
+} -result {abort}
+test msgbox-2.5 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -icon question
+} -result {abort}
+test msgbox-2.6 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -default abort
+} -result {abort}
+test msgbox-2.7 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type abortretryignore -default retry
+} -result {retry}
+test msgbox-2.8 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ignore
+ tk_messageBox -title Hi -message "Please press ignore" \
+ -type abortretryignore -default ignore
+} -result {ignore}
+test msgbox-2.9 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" -type ok
+} -result {ok}
+test msgbox-2.10 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -icon warning
+} -result {ok}
+test msgbox-2.11 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -icon error
+} -result {ok}
+test msgbox-2.12 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -icon info
+} -result {ok}
+test msgbox-2.13 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -icon question
+} -result {ok}
+test msgbox-2.14 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -default ok
+} -result {ok}
+test msgbox-2.15 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" -type okcancel
+} -result {ok}
+test msgbox-2.16 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -icon warning
+} -result {ok}
+test msgbox-2.17 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -icon error
+} -result {ok}
+test msgbox-2.18 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -icon info
+} -result {ok}
+test msgbox-2.19 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -icon question
+} -result {ok}
+test msgbox-2.20 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -default ok
+} -result {ok}
+test msgbox-2.21 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . cancel
+ tk_messageBox -title Hi -message "Please press cancel" \
+ -type okcancel -default cancel
+} -result {cancel}
+test msgbox-2.22 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" -type retrycancel
+} -result {retry}
+test msgbox-2.23 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -icon warning
+} -result {retry}
+test msgbox-2.24 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -icon error
+} -result {retry}
+test msgbox-2.25 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -icon info
+} -result {retry}
+test msgbox-2.26 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -icon question
+} -result {retry}
+test msgbox-2.27 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -default retry
+} -result {retry}
+test msgbox-2.28 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . cancel
+ tk_messageBox -title Hi -message "Please press cancel" \
+ -type retrycancel -default cancel
+} -result {cancel}
+test msgbox-2.29 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" -type yesno
+} -result {yes}
+test msgbox-2.30 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -icon warning
+} -result {yes}
+test msgbox-2.31 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -icon error
+} -result {yes}
+test msgbox-2.32 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -icon info
+} -result {yes}
+test msgbox-2.33 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -icon question
+} -result {yes}
+test msgbox-2.34 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -default yes
+} -result {yes}
+test msgbox-2.35 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . no
+ tk_messageBox -title Hi -message "Please press no" \
+ -type yesno -default no
+} -result {no}
+test msgbox-2.36 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" -type yesnocancel
+} -result {yes}
+test msgbox-2.37 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -icon warning
+} -result {yes}
+test msgbox-2.38 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -icon error
+} -result {yes}
+test msgbox-2.39 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -icon info
+} -result {yes}
+test msgbox-2.40 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -icon question
+} -result {yes}
+test msgbox-2.41 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -default yes
+} -result {yes}
+test msgbox-2.42 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . no
+ tk_messageBox -title Hi -message "Please press no" \
+ -type yesnocancel -default no
+} -result {no}
+test msgbox-2.43 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . cancel
+ tk_messageBox -title Hi -message "Please press cancel" \
+ -type yesnocancel -default cancel
+} -result {cancel}
+
+
+# These tests will hang your test suite if they fail.
+test msgbox-3.1 {tk_messageBox handles withdrawn parent} -constraints {
+ nonUnixUserInteraction
+} -body {
+ wm withdraw .
+ ChooseMsg . "ok"
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -default ok
+} -cleanup {
+ wm deiconify .
+} -result {ok}
+
+test msgbox-3.2 {tk_messageBox handles iconified parent} -constraints {
+ nonUnixUserInteraction
+} -body {
+ wm iconify .
+ ChooseMsg . "ok"
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -default ok
+} -cleanup {
+ wm deiconify .
+} -result {ok}
+
+# cleanup
+cleanupTests
+return
+
+
diff --git a/tk8.6/tests/obj.test b/tk8.6/tests/obj.test
new file mode 100644
index 0000000..eece58e
--- /dev/null
+++ b/tk8.6/tests/obj.test
@@ -0,0 +1,28 @@
+# This file is a Tcl script to test new object types in Tk.
+# It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test obj-1.1 {TkGetPixelsFromObj} -body {
+} -result {}
+
+test obj-2.1 {FreePixelInternalRep} -body {
+} -result {}
+
+test obj-3.1 {DupPixelInternalRep} -body {
+} -result {}
+
+test obj-4.1 {SetPixelFromAny} -body {
+} -result {}
+
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/oldpack.test b/tk8.6/tests/oldpack.test
new file mode 100644
index 0000000..72ec065
--- /dev/null
+++ b/tk8.6/tests/oldpack.test
@@ -0,0 +1,552 @@
+# This file is a Tcl script to test out the old syntax of Tk's
+# "pack" command (before release 3.3). It is organized in the
+# standard fashion for Tcl tests.
+#
+# Copyright (c) 1991-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+# First, test a single window packed in various ways in a parent
+
+destroy .pack
+frame .pack
+place .pack -width 100 -height 100
+frame .pack.red -width 10 -height 20
+label .pack.red.l -text R -bd 2 -relief raised
+place .pack.red.l -relwidth 1.0 -relheight 1.0
+frame .pack.green -width 30 -height 40
+label .pack.green.l -text G -bd 2 -relief raised
+place .pack.green.l -relwidth 1.0 -relheight 1.0
+frame .pack.blue -width 40 -height 40
+label .pack.blue.l -text B -bd 2 -relief raised
+place .pack.blue.l -relwidth 1.0 -relheight 1.0
+frame .pack.violet -width 80 -height 20
+label .pack.violet.l -text P -bd 2 -relief raised
+place .pack.violet.l -relwidth 1.0 -relheight 1.0
+
+test oldpack-1.1 {basic positioning} -body {
+ pack ap .pack .pack.red top
+ update
+ winfo geometry .pack.red
+} -result 10x20+45+0
+test oldpack-1.2 {basic positioning} -body {
+ pack append .pack .pack.red bottom
+ update
+ winfo geometry .pack.red
+} -result 10x20+45+80
+test oldpack-1.3 {basic positioning} -body {
+ pack append .pack .pack.red left
+ update
+ winfo geometry .pack.red
+} -result 10x20+0+40
+test oldpack-1.4 {basic positioning} -body {
+ pack append .pack .pack.red right
+ update
+ winfo geometry .pack.red
+} -result 10x20+90+40
+
+# Try adding padding around the window and make sure that the
+# window gets a larger frame.
+
+test oldpack-2.1 {padding} -body {
+ pack append .pack .pack.red {t padx 20}
+ update
+ winfo geometry .pack.red
+} -result 10x20+45+0
+test oldpack-2.2 {padding} -body {
+ pack append .pack .pack.red {top pady 20}
+ update
+ winfo geometry .pack.red
+} -result 10x20+45+10
+test oldpack-2.3 {padding} -body {
+ pack append .pack .pack.red {l padx 20}
+ update
+ winfo geometry .pack.red
+} -result 10x20+10+40
+test oldpack-2.4 {padding} -body {
+ pack append .pack .pack.red {left pady 20}
+ update
+ winfo geometry .pack.red
+} -result 10x20+0+40
+
+# Position the window at different positions in its frame to
+# make sure they all work. Try two differenet frame locations,
+# to make sure that frame offsets are being added in correctly.
+
+test oldpack-3.1 {framing} -body {
+ pack append .pack .pack.red {b padx 20 pady 30}
+ update
+ winfo geometry .pack.red
+} -result 10x20+45+65
+test oldpack-3.2 {framing} -body {
+ pack append .pack .pack.red {bottom padx 20 pady 30 fr n}
+ update
+ winfo geometry .pack.red
+} -result 10x20+45+50
+test oldpack-3.3 {framing} -body {
+ pack append .pack .pack.red {bottom padx 20 pady 30 frame ne}
+ update
+ winfo geometry .pack.red
+} -result 10x20+90+50
+test oldpack-3.4 {framing} -body {
+ pack append .pack .pack.red {bottom padx 20 pady 30 frame e}
+ update
+ winfo geometry .pack.red
+} -result 10x20+90+65
+test oldpack-3.5 {framing} -body {
+ pack append .pack .pack.red {bottom padx 20 pady 30 frame se}
+ update
+ winfo geometry .pack.red
+} -result 10x20+90+80
+test oldpack-3.6 {framing} -body {
+ pack append .pack .pack.red {bottom padx 20 pady 30 frame s}
+ update
+ winfo geometry .pack.red
+} -result 10x20+45+80
+test oldpack-3.7 {framing} -body {
+ pack append .pack .pack.red {bottom padx 20 pady 30 frame sw}
+ update
+ winfo geometry .pack.red
+} -result 10x20+0+80
+test oldpack-3.8 {framing} -body {
+ pack append .pack .pack.red {bottom padx 20 pady 30 frame w}
+ update
+ winfo geometry .pack.red
+} -result 10x20+0+65
+test oldpack-3.9 {framing} -body {
+ pack append .pack .pack.red {bottom padx 20 pady 30 frame nw}
+ update
+ winfo geometry .pack.red
+} -result 10x20+0+50
+test oldpack-3.10 {framing} -body {
+ pack append .pack .pack.red {bottom padx 20 pady 30 frame c}
+ update
+ winfo geometry .pack.red
+} -result 10x20+45+65
+test oldpack-3.11 {framing} -body {
+ pack append .pack .pack.red {r padx 20 pady 30}
+ update
+ winfo geometry .pack.red
+} -result 10x20+80+40
+test oldpack-3.12 {framing} -body {
+ pack append .pack .pack.red {right padx 20 pady 30 frame n}
+ update
+ winfo geometry .pack.red
+} -result 10x20+80+0
+test oldpack-3.13 {framing} -body {
+ pack append .pack .pack.red {right padx 20 pady 30 frame ne}
+ update
+ winfo geometry .pack.red
+} -result 10x20+90+0
+test oldpack-3.14 {framing} -body {
+ pack append .pack .pack.red {right padx 20 pady 30 frame e}
+ update
+ winfo geometry .pack.red
+} -result 10x20+90+40
+test oldpack-3.15 {framing} -body {
+ pack append .pack .pack.red {right padx 20 pady 30 frame se}
+ update
+ winfo geometry .pack.red
+} -result 10x20+90+80
+test oldpack-3.16 {framing} -body {
+ pack append .pack .pack.red {right padx 20 pady 30 frame s}
+ update
+ winfo geometry .pack.red
+} -result 10x20+80+80
+test oldpack-3.17 {framing} -body {
+ pack append .pack .pack.red {right padx 20 pady 30 frame sw}
+ update
+ winfo geometry .pack.red
+} -result 10x20+70+80
+test oldpack-3.18 {framing} -body {
+ pack append .pack .pack.red {right padx 20 pady 30 frame w}
+ update
+ winfo geometry .pack.red
+} -result 10x20+70+40
+test oldpack-3.19 {framing} -body {
+ pack append .pack .pack.red {right padx 20 pady 30 frame nw}
+ update
+ winfo geometry .pack.red
+} -result 10x20+70+0
+test oldpack-3.20 {framing} -body {
+ pack append .pack .pack.red {right padx 20 pady 30 frame center}
+ update
+ winfo geometry .pack.red
+} -result 10x20+80+40
+
+# Try out various filling combinations in a couple of different
+# frame locations.
+
+test oldpack-4.1 {filling} -body {
+ pack append .pack .pack.red {bottom padx 20 pady 30 fillx}
+ update
+ winfo geometry .pack.red
+} -result 100x20+0+65
+test oldpack-4.2 {filling} -body {
+ pack append .pack .pack.red {bottom padx 20 pady 30 filly}
+ update
+ winfo geometry .pack.red
+} -result 10x50+45+50
+test oldpack-4.3 {filling} -body {
+ pack append .pack .pack.red {bottom padx 20 pady 30 fill}
+ update
+ winfo geometry .pack.red
+} -result 100x50+0+50
+test oldpack-4.4 {filling} -body {
+ pack append .pack .pack.red {right padx 20 pady 30 fillx}
+ update
+ winfo geometry .pack.red
+} -result 30x20+70+40
+test oldpack-4.5 {filling} -body {
+ pack append .pack .pack.red {right padx 20 pady 30 filly}
+ update
+ winfo geometry .pack.red
+} -result 10x100+80+0
+test oldpack-4.6 {filling} -body {
+ pack append .pack .pack.red {right padx 20 pady 30 fill}
+ update
+ winfo geometry .pack.red
+} -result 30x100+70+0
+
+# Multiple windows: make sure that space is properly subtracted
+# from the cavity as windows are positioned inwards from all
+# different sides. Also make sure that windows get unmapped if
+# there isn't enough space for them.
+
+pack append .pack .pack.red top .pack.green top .pack.blue top \
+ .pack.violet top
+update
+test oldpack-5.1 {multiple windows} -body {
+ winfo geometry .pack.red
+} -result 10x20+45+0
+test oldpack-5.2 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 30x40+35+20
+test oldpack-5.3 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 40x40+30+60
+test oldpack-5.4 {multiple windows} -body {
+ winfo ismapped .pack.violet
+} -result 0
+
+pack b .pack.blue .pack.violet top
+update
+test oldpack-5.5 {multiple windows} -body {
+ winfo ismapped .pack.violet
+} -result 1
+test oldpack-5.6 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 80x20+10+60
+test oldpack-5.7 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 40x20+30+80
+
+pack after .pack.blue .pack.red top
+update
+test oldpack-5.8 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 30x40+35+0
+test oldpack-5.9 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 80x20+10+40
+test oldpack-5.10 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 40x40+30+60
+test oldpack-5.11 {multiple windows} -body {
+ winfo ismapped .pack.red
+} -result 0
+
+pack before .pack.green .pack.red right .pack.blue left
+update
+test oldpack-5.12 {multiple windows} -body {
+ winfo ismapped .pack.red
+} -result 1
+test oldpack-5.13 {multiple windows} -body {
+ winfo geometry .pack.red
+} -result 10x20+90+40
+test oldpack-5.14 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 40x40+0+30
+test oldpack-5.15 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 30x40+50+0
+test oldpack-5.16 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 50x20+40+40
+
+pack append .pack .pack.violet left .pack.green bottom .pack.red bottom \
+ .pack.blue bottom
+update
+test oldpack-5.17 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 80x20+0+40
+test oldpack-5.18 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 20x40+80+60
+test oldpack-5.19 {multiple windows} -body {
+ winfo geometry .pack.red
+} -result 10x20+85+40
+test oldpack-5.20 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 20x40+80+0
+
+pack after .pack.blue .pack.blue top .pack.red right .pack.green right \
+ .pack.violet right
+update
+test oldpack-5.21 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 40x40+30+0
+test oldpack-5.22 {multiple windows} -body {
+ winfo geometry .pack.red
+} -result 10x20+90+60
+test oldpack-5.23 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 30x40+60+50
+test oldpack-5.24 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 60x20+0+60
+
+pack after .pack.blue .pack.red left .pack.green left .pack.violet left
+update
+test oldpack-5.25 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 40x40+30+0
+test oldpack-5.26 {multiple windows} -body {
+ winfo geometry .pack.red
+} -result 10x20+0+60
+test oldpack-5.27 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 30x40+10+50
+test oldpack-5.28 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 60x20+40+60
+
+pack append .pack .pack.violet left .pack.green left .pack.blue left \
+ .pack.red left
+update
+test oldpack-5.29 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 80x20+0+40
+test oldpack-5.30 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 20x40+80+30
+test oldpack-5.31 {multiple windows} -body {
+ winfo ismapped .pack.blue
+} -result 0
+test oldpack-5.32 {multiple windows} -body {
+ winfo ismapped .pack.red
+} -result 0
+
+
+# Test the ability of the packer to propagate geometry information
+# to its parent. Make sure it computes the parent's needs both in
+# the direction of packing (width for "left" and "right" windows,
+# for example), and perpendicular to the pack direction (height for
+# "left" and "right" windows).
+
+pack append .pack .pack.red top .pack.green top .pack.blue top \
+ .pack.violet top
+update
+test oldpack-6.1 {geometry propagation} -body {
+ winfo reqwidth .pack} -result 80
+test oldpack-6.2 {geometry propagation} -body {
+ winfo reqheight .pack} -result 120
+destroy .pack.violet
+update
+test oldpack-6.3 {geometry propagation} -body {
+ winfo reqwidth .pack} -result 40
+test oldpack-6.4 {geometry propagation} -body {
+ winfo reqheight .pack} -result 100
+frame .pack.violet -width 80 -height 20 -bg violet
+label .pack.violet.l -text P -bd 2 -relief raised
+place .pack.violet.l -relwidth 1.0 -relheight 1.0
+pack append .pack .pack.red left .pack.green right .pack.blue bottom \
+ .pack.violet top
+update
+test oldpack-6.5 {geometry propagation} -body {
+ winfo reqwidth .pack} -result 120
+test oldpack-6.6 {geometry propagation} -body {
+ winfo reqheight .pack} -result 60
+pack append .pack .pack.violet top .pack.green top .pack.blue left \
+ .pack.red left
+update
+test oldpack-6.7 {geometry propagation} -body {
+ winfo reqwidth .pack} -result 80
+test oldpack-6.8 {geometry propagation} -body {
+ winfo reqheight .pack} -result 100
+
+# Test the "expand" option, and make sure space is evenly divided
+# when several windows request expansion.
+
+pack append .pack .pack.violet top .pack.green {left e} \
+ .pack.blue {left expand} .pack.red {left expand}
+update
+test oldpack-7.1 {multiple expanded windows} -body {
+ pack append .pack .pack.violet top .pack.green {left e} \
+ .pack.blue {left expand} .pack.red {left expand}
+ update
+ list [winfo geometry .pack.green] [winfo geometry .pack.blue] \
+ [winfo geometry .pack.red]
+} -result {30x40+3+40 40x40+39+40 10x20+86+50}
+test oldpack-7.2 {multiple expanded windows} -body {
+ pack append .pack .pack.green left .pack.violet {bottom expand} \
+ .pack.blue {bottom expand} .pack.red {bottom expand}
+ update
+ list [winfo geometry .pack.violet] [winfo geometry .pack.blue] \
+ [winfo geometry .pack.red]
+} -result {70x20+30+77 40x40+45+30 10x20+60+3}
+test oldpack-7.3 {multiple expanded windows} -body {
+ foreach i [winfo child .pack] {
+ pack unpack $i
+ }
+ pack append .pack .pack.green {left e fill} .pack.red {left expand fill} \
+ .pack.blue {top fill}
+ update
+ list [winfo geometry .pack.green] [winfo geometry .pack.red] \
+ [winfo geometry .pack.blue]
+} -result {40x100+0+0 20x100+40+0 40x40+60+0}
+test oldpack-7.4 {multiple expanded windows} -body {
+ foreach i [winfo child .pack] {
+ pack unpack $i
+ }
+ pack append .pack .pack.red {top expand} .pack.violet {top expand} \
+ .pack.blue {right fill}
+ update
+ list [winfo geometry .pack.red] [winfo geometry .pack.violet] \
+ [winfo geometry .pack.blue]
+} -result {10x20+45+5 80x20+10+35 40x40+60+60}
+test oldpack-7.5 {multiple expanded windows} -body {
+ foreach i [winfo child .pack] {
+ pack unpack $i
+ }
+ pack append .pack .pack.green {right frame s} .pack.red {top expand}
+ update
+ list [winfo geometry .pack.green] [winfo geometry .pack.red]
+} -result {30x40+70+60 10x20+30+40}
+test oldpack-7.6 {multiple expanded windows} -body {
+ foreach i [winfo child .pack] {
+ pack unpack $i
+ }
+ pack append .pack .pack.violet {bottom frame e} .pack.red {right expand}
+ update
+ list [winfo geometry .pack.violet] [winfo geometry .pack.red]
+} -result {80x20+20+80 10x20+45+30}
+
+# Need more bizarre tests with combinations of expanded windows and
+# windows in opposing directions! Also, include padding in expanded
+# (and unexpanded) windows.
+
+# Syntax errors on pack commands
+
+test oldpack-8.1 {syntax errors} -body {
+ pack
+} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"}
+test oldpack-8.2 {syntax errors} -body {
+ pack append
+} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"}
+test oldpack-8.3 {syntax errors} -body {
+ pack gorp foo
+} -returnCodes error -result {bad option "gorp": must be configure, forget, info, propagate, or slaves}
+test oldpack-8.4 {syntax errors} -body {
+ pack a .pack
+} -returnCodes error -result {bad option "a": must be configure, forget, info, propagate, or slaves}
+test oldpack-8.5 {syntax errors} -body {
+ pack after foobar
+} -returnCodes error -result {bad window path name "foobar"}
+test oldpack-8.6 {syntax errors} -setup {
+ destroy .pack.yellow
+} -body {
+ frame .pack.yellow -bg yellow
+ pack after .pack.yellow
+} -cleanup {
+ destroy .pack.yellow
+} -returnCodes error -result {window ".pack.yellow" isn't packed}
+test oldpack-8.7 {syntax errors} -body {
+ pack append foobar
+} -returnCodes error -result {bad window path name "foobar"}
+test oldpack-8.8 {syntax errors} -body {
+ pack before foobar
+} -returnCodes error -result {bad window path name "foobar"}
+test oldpack-8.9 {syntax errors} -setup {
+ destroy .pack.yellow
+} -body {
+ frame .pack.yellow -bg yellow
+ pack before .pack.yellow
+} -cleanup {
+ destroy .pack.yellow
+} -returnCodes error -result {window ".pack.yellow" isn't packed}
+test oldpack-8.10 {syntax errors} -body {
+ pack info .pack help
+} -returnCodes error -result {wrong # args: should be "pack info window"}
+test oldpack-8.11 {syntax errors} -body {
+ pack info foobar
+} -returnCodes error -result {bad window path name "foobar"}
+test oldpack-8.12 {syntax errors} -body {
+ pack append .pack .pack.blue
+} -returnCodes error -result {wrong # args: window ".pack.blue" should be followed by options}
+test oldpack-8.13 {syntax errors} -body {
+ pack append . .pack.blue top
+} -returnCodes error -result {can't pack .pack.blue inside .}
+test oldpack-8.14 {syntax errors} -body {
+ pack append .pack .pack.blue f
+} -returnCodes error -result {bad option "f": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame}
+test oldpack-8.15 {syntax errors} -body {
+ pack append .pack .pack.blue pad
+} -returnCodes error -result {bad option "pad": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame}
+test oldpack-8.16 {syntax errors} -body {
+ pack append .pack .pack.blue {frame south}
+} -returnCodes error -result {bad anchor "south": must be n, ne, e, se, s, sw, w, nw, or center}
+test oldpack-8.17 {syntax errors} -body {
+ pack append .pack .pack.blue {padx -2}
+} -returnCodes error -result {bad pad value "-2": must be positive screen distance}
+test oldpack-8.18 {syntax errors} -body {
+ pack append .pack .pack.blue {padx}
+} -returnCodes error -result {wrong # args: "padx" option must be followed by screen distance}
+test oldpack-8.19 {syntax errors} -body {
+ pack append .pack .pack.blue {pady -2}
+} -returnCodes error -result {bad pad value "-2": must be positive screen distance}
+test oldpack-8.20 {syntax errors} -body {
+ pack append .pack .pack.blue {pady}
+} -returnCodes error -result {wrong # args: "pady" option must be followed by screen distance}
+test oldpack-8.21 {syntax errors} -body {
+ pack append .pack .pack.blue "\{abc"
+} -returnCodes error -result {unmatched open brace in list}
+test oldpack-8.22 {syntax errors} -body {
+ pack append .pack .pack.blue frame
+} -returnCodes error -result {wrong # args: "frame" option must be followed by anchor point}
+
+# Test "pack info" command output.
+
+test oldpack-9.1 {information output} -body {
+ pack append .pack .pack.blue {top fillx frame n} \
+ .pack.red {bottom filly frame s} .pack.green {left fill frame w} \
+ .pack.violet {right expand frame e}
+ list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \
+ [pack info .pack.green] [pack info .pack.violet]
+} -result {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor n -expand 0 -fill x -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor s -expand 0 -fill y -ipadx 0 -ipady 0 -padx 0 -pady 0 -side bottom} {-in .pack -anchor w -expand 0 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 -side left} {-in .pack -anchor e -expand 1 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side right}}
+test oldpack-9.2 {information output} -body {
+ pack append .pack .pack.blue {padx 10 frame nw} \
+ .pack.red {pady 20 frame ne} .pack.green {frame se} \
+ .pack.violet {frame sw}
+ list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \
+ [pack info .pack.green] [pack info .pack.violet]
+} -result {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor nw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 5 -pady 0 -side top} {-in .pack -anchor ne -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 10 -side top} {-in .pack -anchor se -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor sw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}}
+test oldpack-9.3 {information output} -body {
+ pack append .pack .pack.blue {frame center} .pack.red {frame center} \
+ .pack.green {frame c} .pack.violet {frame c}
+ list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \
+ [pack info .pack.green] [pack info .pack.violet]
+} -result {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}}
+
+destroy .pack
+
+# cleanup
+cleanupTests
+return
+
diff --git a/tk8.6/tests/option.file1 b/tk8.6/tests/option.file1
new file mode 100644
index 0000000..32b4a18
--- /dev/null
+++ b/tk8.6/tests/option.file1
@@ -0,0 +1,18 @@
+! This file is a sample option (resource) database used to test
+! Tk's option-handling capabilities.
+
+! Comment line \
+ with a backslash-newline sequence embedded in it.
+
+*x1: blue
+ tktest.x2 : green
+*\
+x3 \
+ : pur\
+ple
+*x 4: brown
+# More comments, this time delimited by hash-marks.
+ # Comment-line with space.
+*x6:
+*x9: \ \ \\\101\n
+# comment line as last line of file.
diff --git a/tk8.6/tests/option.file2 b/tk8.6/tests/option.file2
new file mode 100644
index 0000000..f1d020a
--- /dev/null
+++ b/tk8.6/tests/option.file2
@@ -0,0 +1,2 @@
+*foo1: magenta
+foo2 missing colon
diff --git a/tk8.6/tests/option.file3 b/tk8.6/tests/option.file3
new file mode 100755
index 0000000..146cfd9
--- /dev/null
+++ b/tk8.6/tests/option.file3
@@ -0,0 +1,18 @@
+! This file is a sample option (resource) database used to test
+! Tk's option-handling capabilities.
+
+! Comment line \
+ with a backslash-newline sequence embedded in it.
+
+*x1: blue
+ tktest.x2 : green
+*\
+x3 \
+ : pur\
+ple
+*x 4: brówn
+# More comments, this time delimited by hash-marks.
+ # Comment-line with space.
+*x6:
+*x9: \ \ \\\101\n
+# comment line as last line of file.
diff --git a/tk8.6/tests/option.test b/tk8.6/tests/option.test
new file mode 100644
index 0000000..ea5b5d1
--- /dev/null
+++ b/tk8.6/tests/option.test
@@ -0,0 +1,425 @@
+# This file is a Tcl script to test out the option-handling facilities
+# of Tk. It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1991-1993 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+testConstraint appNameIsTktest [expr {[winfo name .] eq "tktest"}]
+
+deleteWindows
+set appName [winfo name .]
+
+# First, test basic retrievals, being sure to trigger all the various
+# types of NodeElements (EXACT_LEAF_NAME, WILDCARD_NODE_CLASS, and
+# everything in-between).
+
+frame .op1 -class Class1
+frame .op2 -class Class2
+frame .op1.op3 -class Class1
+frame .op1.op4 -class Class3
+frame .op2.op5 -class Class2
+frame .op1.op3.op6 -class Class4
+
+# Configurations for tests 1.* - 12.*
+option clear
+option add *Color1 red
+option add *x blue
+option add *Class1.x yellow
+option add $appName.op1.x green
+option add *Class2.Color1 orange
+option add $appName.op2.op5.Color2 purple
+option add $appName.Class1.Class3.y brown
+option add $appName*op6*Color2 black
+option add $appName*Class1.op1.Color2 grey
+
+test option-1.1 {basic option retrieval} -body {
+ option get . x Color1
+} -result blue
+test option-1.2 {basic option retrieval} -body {
+ option get . y Color1
+} -result red
+test option-1.3 {basic option retrieval} -body {
+ option get . z Color1
+} -result red
+test option-1.4 {basic option retrieval} -body {
+ option get . x Color2
+} -result blue
+test option-1.5 {basic option retrieval} -body {
+ option get . y Color2
+} -result {}
+test option-1.6 {basic option retrieval} -body {
+ option get . z Color2
+} -result {}
+
+
+test option-2.1 {basic option retrieval} -body {
+ option get .op1 x Color1
+} -result green
+test option-2.2 {basic option retrieval} -body {
+ option get .op1 y Color1
+} -result red
+test option-2.3 {basic option retrieval} -body {
+ option get .op1 z Color1
+} -result red
+test option-2.4 {basic option retrieval} -body {
+ option get .op1 x Color2
+} -result green
+test option-2.5 {basic option retrieval} -body {
+ option get .op1 y Color2
+} -result {}
+test option-2.6 {basic option retrieval} -body {
+ option get .op1 z Color2
+} -result {}
+
+
+test option-3.1 {basic option retrieval} -body {
+ option get .op1.op3 x Color1
+} -result yellow
+test option-3.2 {basic option retrieval} -body {
+ option get .op1.op3 y Color1
+} -result red
+test option-3.3 {basic option retrieval} -body {
+ option get .op1.op3 z Color1
+} -result red
+test option-3.4 {basic option retrieval} -body {
+ option get .op1.op3 x Color2
+} -result yellow
+test option-3.5 {basic option retrieval} -body {
+ option get .op1.op3 y Color2
+} -result {}
+test option-3.6 {basic option retrieval} -body {
+ option get .op1.op3 z Color2
+} -result {}
+
+
+test option-4.1 {basic option retrieval} -body {
+ option get .op1.op3.op6 x Color1
+} -result blue
+test option-4.2 {basic option retrieval} -body {
+ option get .op1.op3.op6 y Color1
+} -result red
+test option-4.3 {basic option retrieval} -body {
+ option get .op1.op3.op6 z Color1
+} -result red
+test option-4.4 {basic option retrieval} -body {
+ option get .op1.op3.op6 x Color2
+} -result black
+test option-4.5 {basic option retrieval} -body {
+ option get .op1.op3.op6 y Color2
+} -result black
+test option-4.6 {basic option retrieval} -body {
+ option get .op1.op3.op6 z Color2
+} -result black
+
+
+test option-5.1 {basic option retrieval} -body {
+ option get .op1.op4 x Color1
+} -result blue
+test option-5.2 {basic option retrieval} -body {
+ option get .op1.op4 y Color1
+} -result brown
+test option-5.3 {basic option retrieval} -body {
+ option get .op1.op4 z Color1
+} -result red
+test option-5.4 {basic option retrieval} -body {
+ option get .op1.op4 x Color2
+} -result blue
+test option-5.5 {basic option retrieval} -body {
+ option get .op1.op4 y Color2
+} -result brown
+test option-5.6 {basic option retrieval} -body {
+ option get .op1.op4 z Color2
+} -result {}
+
+
+test option-6.1 {basic option retrieval} -body {
+ option get .op2 x Color1
+} -result orange
+test option-6.2 {basic option retrieval} -body {
+ option get .op2 y Color1
+} -result orange
+test option-6.3 {basic option retrieval} -body {
+ option get .op2 z Color1
+} -result orange
+test option-6.4 {basic option retrieval} -body {
+ option get .op2 x Color2
+} -result blue
+test option-6.5 {basic option retrieval} -body {
+ option get .op2 y Color2
+} -result {}
+test option-6.6 {basic option retrieval} -body {
+ option get .op2 z Color2
+} -result {}
+
+
+test option-7.1 {basic option retrieval} -body {
+ option get .op2.op5 x Color1
+} -result orange
+test option-7.2 {basic option retrieval} -body {
+ option get .op2.op5 y Color1
+} -result orange
+test option-7.3 {basic option retrieval} -body {
+ option get .op2.op5 z Color1
+} -result orange
+test option-7.4 {basic option retrieval} -body {
+ option get .op2.op5 x Color2
+} -result purple
+test option-7.5 {basic option retrieval} -body {
+ option get .op2.op5 y Color2
+} -result purple
+test option-7.6 {basic option retrieval} -body {
+ option get .op2.op5 z Color2
+} -result purple
+
+
+# Now try similar tests to above, except jump around non-hierarchically
+# between windows to make sure that the option stacks are pushed and
+# popped correctly.
+
+option get . foo Foo
+test option-8.1 {stack pushing/popping} -body {
+ option get .op2.op5 x Color1
+} -result orange
+test option-8.2 {stack pushing/popping} -body {
+ option get .op2.op5 y Color1
+} -result orange
+test option-8.3 {stack pushing/popping} -body {
+ option get .op2.op5 z Color1
+} -result orange
+test option-8.4 {stack pushing/popping} -body {
+ option get .op2.op5 x Color2
+} -result purple
+test option-8.5 {stack pushing/popping} -body {
+ option get .op2.op5 y Color2
+} -result purple
+test option-8.6 {stack pushing/popping} -body {
+ option get .op2.op5 z Color2
+} -result purple
+
+
+test option-9.1 {stack pushing/popping} -body {
+ option get . x Color1
+} -result blue
+test option-9.2 {stack pushing/popping} -body {
+ option get . y Color1
+} -result red
+test option-9.3 {stack pushing/popping} -body {
+ option get . z Color1
+} -result red
+test option-9.4 {stack pushing/popping} -body {
+ option get . x Color2
+} -result blue
+test option-9.5 {stack pushing/popping} -body {
+ option get . y Color2
+} -result {}
+test option-9.6 {stack pushing/popping} -body {
+ option get . z Color2
+} -result {}
+
+
+test option-10.1 {stack pushing/popping} -body {
+ option get .op1.op3.op6 x Color1
+} -result blue
+test option-10.2 {stack pushing/popping} -body {
+ option get .op1.op3.op6 y Color1
+} -result red
+test option-10.3 {stack pushing/popping} -body {
+ option get .op1.op3.op6 z Color1
+} -result red
+test option-10.4 {stack pushing/popping} -body {
+ option get .op1.op3.op6 x Color2
+} -result black
+test option-10.5 {stack pushing/popping} -body {
+ option get .op1.op3.op6 y Color2
+} -result black
+test option-10.6 {stack pushing/popping} -body {
+ option get .op1.op3.op6 z Color2
+} -result black
+
+
+test option-11.1 {stack pushing/popping} -body {
+ option get .op1.op3 x Color1
+} -result yellow
+test option-11.2 {stack pushing/popping} -body {
+ option get .op1.op3 y Color1
+} -result red
+test option-11.3 {stack pushing/popping} -body {
+ option get .op1.op3 z Color1
+} -result red
+test option-11.4 {stack pushing/popping} -body {
+ option get .op1.op3 x Color2
+} -result yellow
+test option-11.5 {stack pushing/popping} -body {
+ option get .op1.op3 y Color2
+} -result {}
+test option-11.6 {stack pushing/popping} -body {
+ option get .op1.op3 z Color2
+} -result {}
+
+
+test option-12.1 {stack pushing/popping} -body {
+ option get .op1 x Color1
+} -result green
+test option-12.2 {stack pushing/popping} -body {
+ option get .op1 y Color1
+} -result red
+test option-12.3 {stack pushing/popping} -body {
+ option get .op1 z Color1
+} -result red
+test option-12.4 {stack pushing/popping} -body {
+ option get .op1 x Color2
+} -result green
+test option-12.5 {stack pushing/popping} -body {
+ option get .op1 y Color2
+} -result {}
+test option-12.6 {stack pushing/popping} -body {
+ option get .op1 z Color2
+} -result {}
+
+# Test the major priority levels (widgetDefault, etc.)
+
+# Configurations for tests 13.*
+option clear
+option add $appName.op1.a 100 100
+option add $appName.op1.A interactive interactive
+option add $appName.op1.b userDefault userDefault
+option add $appName.op1.B startupFile startupFile
+option add $appName.op1.c widgetDefault widgetDefault
+option add $appName.op1.C 0 0
+
+test option-13.1 {priority levels} -body {
+ option get .op1 a A
+} -result 100
+test option-13.2 {priority levels} -body {
+ option get .op1 b A
+} -result interactive
+test option-13.3 {priority levels} -body {
+ option get .op1 b B
+} -result userDefault
+test option-13.4 {priority levels} -body {
+ option get .op1 c B
+} -result startupFile
+test option-13.5 {priority levels} -body {
+ option get .op1 c C
+} -result widgetDefault
+option add $appName.op1.B file2 widget
+test option-13.6 {priority levels} -body {
+ option get .op1 c B
+} -result startupFile
+option add $appName.op1.B file2 startupFile
+test option-13.7 {priority levels} -body {
+ option get .op1 c B
+} -result file2
+
+
+# Test various error conditions
+
+test option-14.1 {error conditions} -body {
+ option
+} -returnCodes error -result {wrong # args: should be "option cmd arg ?arg ...?"}
+test option-14.2 {error conditions} -body {
+ option x
+} -returnCodes error -result {bad option "x": must be add, clear, get, or readfile}
+test option-14.3 {error conditions} -body {
+ option foo 3
+} -returnCodes error -result {bad option "foo": must be add, clear, get, or readfile}
+test option-14.4 {error conditions} -body {
+ option add 3
+} -returnCodes error -result {wrong # args: should be "option add pattern value ?priority?"}
+test option-14.5 {error conditions} -body {
+ option add . a b c
+} -returnCodes error -result {wrong # args: should be "option add pattern value ?priority?"}
+test option-14.6 {error conditions} -body {
+ option add . a -1
+} -returnCodes error -result {bad priority level "-1": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
+test option-14.7 {error conditions} -body {
+ option add . a 101
+} -returnCodes error -result {bad priority level "101": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
+test option-14.8 {error conditions} -body {
+ option add . a gorp
+} -returnCodes error -result {bad priority level "gorp": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
+test option-14.9 {error conditions} -body {
+ option get 3
+} -returnCodes error -result {wrong # args: should be "option get window name class"}
+test option-14.10 {error conditions} -body {
+ option get 3 4
+} -returnCodes error -result {wrong # args: should be "option get window name class"}
+test option-14.11 {error conditions} -body {
+ option get 3 4 5 6
+} -returnCodes error -result {wrong # args: should be "option get window name class"}
+test option-14.12 {error conditions} -body {
+ option get .gorp.gorp a A
+} -returnCodes error -result {bad window path name ".gorp.gorp"}
+
+
+set option1 [file join [testsDirectory] option.file1]
+test option-15.1 {database files} -body {
+ option read non-existent
+} -returnCodes error -result {couldn't open "non-existent": no such file or directory}
+test option-15.2 {database files} -body {
+ option read $option1
+ option get . x1 color
+} -result blue
+test option-15.3 {database files} -constraints appNameIsTktest -body {
+ option read $option1
+ option get . x2 color
+} -result green
+test option-15.4 {database files} -body {
+ option read $option1
+ option get . x3 color
+} -result purple
+test option-15.5 {database files} -body {
+ option read $option1
+ option get . {x 4} color
+} -result brown
+test option-15.6 {database files} -body {
+ option read $option1
+ option get . x6 color
+} -result {}
+test option-15.7 {database files} -body {
+ option read $option1
+ option get . x9 color
+} -result " \t\\A\n"
+test option-15.8 {database files} -body {
+ option read $option1 widget foo
+} -returnCodes error -result {wrong # args: should be "option readfile fileName ?priority?"}
+test option-15.9 {database files} -body {
+ option add *x3 burgundy
+ catch {option read $option1 userDefault}
+ option get . x3 color
+} -result burgundy
+test option-15.10 {database files} -body {
+ set option2 [file join [testsDirectory] option.file2]
+ option read $option2
+} -returnCodes error -result {missing colon on line 2}
+set option3 [file join [testsDirectory] option.file3]
+option read $option3
+test option-15.11 {database files} {option get . {x 4} color} br\xf3wn
+
+test option-16.1 {ReadOptionFile} -body {
+ set option4 [makeFile {} option.file3]
+ set file [open $option4 w]
+ fconfigure $file -translation crlf
+ puts $file "*x7: true\n*x8: false"
+ close $file
+ option read $option4 userDefault
+ list [option get . x7 color] [option get . x8 color]
+} -cleanup {
+ removeFile $option4
+} -result {true false}
+
+deleteWindows
+
+# cleanup
+cleanupTests
+return
+
+
+
diff --git a/tk8.6/tests/pack.test b/tk8.6/tests/pack.test
new file mode 100644
index 0000000..eac1562
--- /dev/null
+++ b/tk8.6/tests/pack.test
@@ -0,0 +1,1635 @@
+# This file is a Tcl script to test out the "pack" command
+# of Tk. It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1993 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+
+# Create some test windows.
+
+destroy .pack
+toplevel .pack
+wm geom .pack 300x200+0+0
+wm minsize .pack 1 1
+update idletasks
+foreach i {a b c d} {
+ frame .pack.$i
+ label .pack.$i.label -text $i -relief raised
+ place .pack.$i.label -relwidth 1.0 -relheight 1.0
+}
+.pack.a config -width 20 -height 40
+.pack.b config -width 50 -height 30
+.pack.c config -width 80 -height 80
+.pack.d config -width 40 -height 30
+
+test pack-1.1 {-side option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+0 300x160+0+40}
+test pack-1.2 {-side option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side bottom
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+160 300x160+0+0}
+test pack-1.3 {-side option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side left
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+0+80 280x200+20+0}
+test pack-1.4 {-side option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+280+80 280x200+0+0}
+
+
+test pack-2.1 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -padx 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+260+80 240x200+0+0}
+test pack-2.2 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -padx {10 30}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+250+80 240x200+0+0}
+test pack-2.3 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -padx {35 5}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+275+80 240x200+0+0}
+test pack-2.4 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipadx 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {60x40+240+80 240x200+0+0}
+test pack-2.5 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipadx 5 -padx 10
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {30x40+260+80 250x200+0+0}
+test pack-2.6 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -padx 20 -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+260+80 240x200+0+0}
+test pack-2.7 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -padx {9 31} -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+249+80 240x200+0+0}
+test pack-2.8 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipadx 20 -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {60x40+240+80 240x200+0+0}
+test pack-2.9 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipadx 5 -padx 10 -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {30x40+260+80 250x200+0+0}
+test pack-2.10 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipadx 5 -padx {5 15} -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {30x40+255+80 250x200+0+0}
+test pack-2.11 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -padx 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+0 300x160+0+40}
+test pack-2.12 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -padx {0 40}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+120+0 300x160+0+40}
+test pack-2.13 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -padx {31 9}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+151+0 300x160+0+40}
+test pack-2.14 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {60x40+120+0 300x160+0+40}
+test pack-2.15 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {30x40+135+0 300x160+0+40}
+test pack-2.16 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx {5 15}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {30x40+130+0 300x160+0+40}
+test pack-2.17 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -padx 20 -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {260x40+20+0 300x160+0+40}
+test pack-2.18 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -padx {25 15} -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {260x40+25+0 300x160+0+40}
+test pack-2.19 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 20 -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {300x40+0+0 300x160+0+40}
+test pack-2.20 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {280x40+10+0 300x160+0+40}
+test pack-2.21 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx {5 15} -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {280x40+5+0 300x160+0+40}
+
+test pack-2.22 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -padx 1c
+ set x [pack info .pack.a]
+ set res1 [lindex $x [expr [lsearch -exact $x -padx]+1]]
+ set res2 [winfo pixels .pack 1c]
+ expr {$res1 eq $res2}
+} -result 1
+test pack-2.23 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipadx 1c
+ set x [pack info .pack.a]
+ set res1 [lindex $x [expr [lsearch -exact $x -ipadx]+1]]
+ set res2 [winfo pixels .pack 1c]
+ expr {$res1 eq $res2}
+} -result 1
+
+
+test pack-3.1 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -pady 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+280+80 280x200+0+0}
+test pack-3.2 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -pady {5 35}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+280+65 280x200+0+0}
+test pack-3.3 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -pady {40 0}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+280+100 280x200+0+0}
+test pack-3.4 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipady 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x80+280+60 280x200+0+0}
+test pack-3.5 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipady 5 -pady 10
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x50+280+75 280x200+0+0}
+test pack-3.6 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipady 5 -pady {5 15}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x50+280+70 280x200+0+0}
+test pack-3.7 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -pady 20 -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x160+280+20 280x200+0+0}
+test pack-3.8 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -pady {35 5} -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x160+280+35 280x200+0+0}
+test pack-3.9 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipady 20 -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x200+280+0 280x200+0+0}
+test pack-3.10 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipady 5 -pady 10 -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x180+280+10 280x200+0+0}
+test pack-3.11 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipady 5 -pady {0 20} -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x180+280+0 280x200+0+0}
+test pack-3.12 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -pady 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+20 300x120+0+80}
+test pack-3.13 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -pady {40 0}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+40 300x120+0+80}
+test pack-3.14 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipady 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x80+140+0 300x120+0+80}
+test pack-3.15 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipady 5 -pady 10
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x50+140+10 300x130+0+70}
+test pack-3.16 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipady 5 -pady {3 17}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x50+140+3 300x130+0+70}
+test pack-3.17 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -pady 20 -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+20 300x120+0+80}
+test pack-3.18 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -pady {39 1} -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+39 300x120+0+80}
+test pack-3.19 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipady 20 -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x80+140+0 300x120+0+80}
+test pack-3.20 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipady 5 -pady 10 -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x50+140+10 300x130+0+70}
+test pack-3.21 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipady 5 -pady {1 19} -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x50+140+1 300x130+0+70}
+
+test pack-3.22 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -pady 1c
+ set x [pack info .pack.a]
+ set res1 [lindex $x [expr [lsearch -exact $x -pady]+1]]
+ set res2 [winfo pixels .pack 1c]
+ expr {$res1 eq $res2}
+} -result 1
+test pack-3.23 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipady 1c
+ set x [pack info .pack.a]
+ set res1 [lindex $x [expr [lsearch -exact $x -ipady]+1]]
+ set res2 [winfo pixels .pack 1c]
+ expr {$res1 eq $res2}
+} -result 1
+
+
+test pack-4.1 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor n
+ update
+ winfo geometry .pack.a
+} -result {30x70+135+20}
+test pack-4.2 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor ne
+ update
+ winfo geometry .pack.a
+} -result {30x70+260+20}
+test pack-4.3 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor e
+ update
+ winfo geometry .pack.a
+} -result {30x70+260+65}
+test pack-4.4 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor se
+ update
+ winfo geometry .pack.a
+} -result {30x70+260+110}
+test pack-4.5 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor s
+ update
+ winfo geometry .pack.a
+} -result {30x70+135+110}
+test pack-4.6 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor sw
+ update
+ winfo geometry .pack.a
+} -result {30x70+10+110}
+test pack-4.7 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor w
+ update
+ winfo geometry .pack.a
+} -result {30x70+10+65}
+test pack-4.8 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor nw
+ update
+ winfo geometry .pack.a
+} -result {30x70+10+20}
+test pack-4.9 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor center
+ update
+ winfo geometry .pack.a
+} -result {30x70+135+65}
+
+
+# Repeat above tests, but with a frame that isn't at (0,0), so that
+# we can be sure that the frame offset is being added in correctly.
+
+test pack-5.1 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor n
+ update
+ winfo geometry .pack.b
+} -result {60x60+160+60}
+test pack-5.2 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor ne
+ update
+ winfo geometry .pack.b
+} -result {60x60+230+60}
+test pack-5.3 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor e
+ update
+ winfo geometry .pack.b
+} -result {60x60+230+90}
+test pack-5.4 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor se
+ update
+ winfo geometry .pack.b
+} -result {60x60+230+120}
+test pack-5.5 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor s
+ update
+ winfo geometry .pack.b
+} -result {60x60+160+120}
+test pack-5.6 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor sw
+ update
+ winfo geometry .pack.b
+} -result {60x60+90+120}
+test pack-5.7 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor w
+ update
+ winfo geometry .pack.b
+} -result {60x60+90+90}
+test pack-5.8 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor nw
+ update
+ winfo geometry .pack.b
+} -result {60x60+90+60}
+test pack-5.9 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor center
+ update
+ winfo geometry .pack.b
+} -result {60x60+160+90}
+
+
+test pack-6.1 {-expand option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side left
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b] \
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+0+80 50x30+20+85 80x80+70+60 40x30+150+85}
+test pack-6.2 {-expand option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side left -expand yes
+ pack .pack.b -side left
+ pack .pack.c .pack.d -side left -expand 1
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b] \
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+18+80 50x30+56+85 80x80+124+60 40x30+241+85}
+test pack-6.3 {-expand option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side top
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b] \
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+140+0 50x30+125+40 80x80+110+70 40x30+130+150}
+test pack-6.4 {-expand option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -expand yes
+ pack .pack.b -side top
+ pack .pack.c .pack.d -side top -expand 1
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b] \
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+140+3 50x30+125+46 80x80+110+79 40x30+130+166}
+test pack-6.5 {-expand option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side right
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b] \
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+280+80 50x30+230+85 80x80+150+60 40x30+110+85}
+test pack-6.6 {-expand option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -expand yes
+ pack .pack.b -side right
+ pack .pack.c .pack.d -side right -expand 1
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b] \
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+262+80 50x30+194+85 80x80+95+60 40x30+18+85}
+test pack-6.7 {-expand option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side bottom
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b] \
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+140+160 50x30+125+130 80x80+110+50 40x30+130+20}
+test pack-6.8 {-expand option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side bottom -expand yes
+ pack .pack.b -side bottom
+ pack .pack.c .pack.d -side bottom -expand 1
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b] \
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+140+157 50x30+125+124 80x80+110+40 40x30+130+3}
+test pack-6.9 {-expand option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side bottom -expand yes -fill both
+ pack .pack.b -side right
+ pack .pack.c -side top -expand 1 -fill both
+ pack .pack.d -side left
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b] \
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {300x65+0+135 50x30+250+52 250x105+0+0 40x30+0+105}
+test pack-6.10 {-expand option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side left -expand yes -fill both
+ pack .pack.b -side top
+ pack .pack.c -side right -expand 1 -fill both
+ pack .pack.d -side bottom
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b] \
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {100x200+0+0 50x30+175+0 160x170+140+30 40x30+100+170}
+test pack-6.11 {-expand option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side left -expand yes -fill both
+ pack .pack.b -side top -expand yes -fill both
+ pack .pack.c -side right -expand 1 -fill both
+ pack .pack.d -side bottom -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b] \
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {100x200+0+0 200x100+100+0 160x100+140+100 40x100+100+100}
+
+test pack-6.12 {-expand option} -setup {
+ toplevel .pack2 -height 400 -width 400
+ wm geometry .pack2 +0+0
+ pack propagate .pack2 0
+ foreach i {w1 w2 w3} {
+ frame .pack2.$i -width 30 -height 30 -bd 2 -relief raised
+ label .pack2.$i.l -text $i
+ place .pack2.$i.l -relwidth 1.0 -relheight 1.0
+ }
+} -body {
+ pack .pack2.w1 .pack2.w2 .pack2.w3 -padx 5 -ipadx 4 -pady 2 -ipady 6 -expand 1 -side left
+ update
+ list [winfo geometry .pack2.w1] [winfo geometry .pack2.w2] [winfo geometry .pack2.w3]
+} -cleanup {
+ destroy .pack2
+} -result {38x42+47+179 38x42+180+179 38x42+314+179}
+test pack-6.13 {-expand option} -setup {
+ toplevel .pack2 -height 400 -width 400
+ wm geometry .pack2 +0+0
+ pack propagate .pack2 0
+ foreach i {w1 w2 w3} {
+ frame .pack2.$i -width 30 -height 30 -bd 2 -relief raised
+ label .pack2.$i.l -text $i
+ place .pack2.$i.l -relwidth 1.0 -relheight 1.0
+ }
+} -body {
+ pack .pack2.w1 .pack2.w2 .pack2.w3 -padx 5 -ipadx 4 -pady 2 \
+ -ipady 6 -expand 1 -side top
+ update
+ list [winfo geometry .pack2.w1] [winfo geometry .pack2.w2] [winfo geometry .pack2.w3]
+} -cleanup {
+ destroy .pack2
+} -result {38x42+181+45 38x42+181+178 38x42+181+312}
+
+
+wm geometry .pack {}
+test pack-7.1 {requesting size for parent} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side left -padx 5 -pady 10
+ update
+ list [winfo reqwidth .pack] [winfo reqheight .pack]
+} -result {230 100}
+test pack-7.2 {requesting size for parent} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side top -padx 5 -pady 10
+ update
+ list [winfo reqwidth .pack] [winfo reqheight .pack]
+} -result {90 260}
+test pack-7.3 {requesting size for parent} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side right -padx 5 -pady 10
+ update
+ list [winfo reqwidth .pack] [winfo reqheight .pack]
+} -result {230 100}
+test pack-7.4 {requesting size for parent} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side bottom -padx 5 -pady 10
+ update
+ list [winfo reqwidth .pack] [winfo reqheight .pack]
+} -result {90 260}
+test pack-7.5 {requesting size for parent} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -padx 5 -pady 10
+ pack .pack.b -side right -padx 5 -pady 10
+ pack .pack.c -side bottom -padx 5 -pady 10
+ pack .pack.d -side left -padx 5 -pady 10
+ update
+ list [winfo reqwidth .pack] [winfo reqheight .pack]
+} -result {150 210}
+test pack-7.6 {requesting size for parent} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.d -side bottom
+ update
+ list [winfo reqwidth .pack] [winfo reqheight .pack]
+} -result {120 120}
+test pack-7.7 {requesting size for parent} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right
+ pack .pack.c -side bottom
+ pack .pack.d -side top
+ update
+ list [winfo reqwidth .pack] [winfo reqheight .pack]
+} -result {100 110}
+
+
+# For the tests below, create a couple of "pad" windows to shrink
+# the available space for the remaining windows. The tests have to
+# be done this way rather than shrinking the whole window, because
+# some window managers like mwm won't let a top-level window get
+# very small.
+
+pack forget .pack.a .pack.b .pack.c .pack.d
+frame .pack.right -width 200 -height 10 -bd 2 -relief raised
+frame .pack.bottom -width 10 -height 150 -bd 2 -relief raised
+pack .pack.right -side right
+pack .pack.bottom -side bottom
+pack .pack.a .pack.b .pack.c -side top
+update
+test pack-8.1 {insufficient space} -body {
+ list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x40+30+0 1 50x30+15+40 1 80x80+0+70 1}
+wm geom .pack 270x250
+update
+test pack-8.2 {insufficient space} -body {
+ list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x40+25+0 1 50x30+10+40 1 70x30+0+70 1}
+wm geom .pack 240x220
+update
+test pack-8.3 {insufficient space} -body {
+ list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x40+10+0 1 40x30+0+40 1 70x30+0+70 0}
+wm geom .pack 350x350
+update
+test pack-8.4 {insufficient space} -body {
+ list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x40+65+0 1 50x30+50+40 1 80x80+35+70 1}
+wm geom .pack {}
+pack .pack.a -side left
+pack .pack.b -side right
+pack .pack.c -side left
+update
+test pack-8.5 {insufficient space} -body {
+ list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1}
+wm geom .pack 320x180
+update
+test pack-8.6 {insufficient space} -body {
+ list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x30+0+0 1 50x30+70+0 1 50x30+20+0 1}
+wm geom .pack 250x180
+update
+test pack-8.7 {insufficient space} -body {
+ list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x30+0+0 1 30x30+20+0 1 50x30+20+0 0}
+pack forget .pack.b
+update
+test pack-8.8 {insufficient space} -body {
+ list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x30+0+0 1 30x30+20+0 0 30x30+20+0 1}
+pack .pack.b -side right -after .pack.a
+wm geom .pack {}
+update
+test pack-8.9 {insufficient space} -body {
+ list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1}
+pack forget .pack.right .pack.bottom
+
+
+test pack-9.1 {window ordering} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side top
+ pack .pack.a -after .pack.b
+ pack slaves .pack
+} -result {.pack.b .pack.a .pack.c .pack.d}
+test pack-9.2 {window ordering} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side top
+ pack .pack.a -after .pack.a
+ pack slaves .pack
+} -result {.pack.a .pack.b .pack.c .pack.d}
+test pack-9.3 {window ordering} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side top
+ pack .pack.a -before .pack.d
+ pack slaves .pack
+} -result {.pack.b .pack.c .pack.a .pack.d}
+test pack-9.4 {window ordering} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side top
+ pack .pack.d -before .pack.a
+ pack slaves .pack
+} -result {.pack.d .pack.a .pack.b .pack.c}
+test pack-9.5 {window ordering} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side top
+ pack propagate .pack.c 0
+ pack .pack.a -in .pack.c
+ list [pack slaves .pack] [pack slaves .pack.c]
+} -result {{.pack.b .pack.c .pack.d} .pack.a}
+test pack-9.6 {window ordering} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side top
+ pack .pack.a -in .pack
+ pack slaves .pack
+} -result {.pack.b .pack.c .pack.d .pack.a}
+test pack-9.7 {window ordering} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d -side top
+ pack .pack.a -padx 0
+ pack slaves .pack
+} -result {.pack.a .pack.b .pack.c .pack.d}
+test pack-9.8 {window ordering} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c
+ pack .pack.d
+ pack slaves .pack
+} -result {.pack.a .pack.b .pack.c .pack.d}
+test pack-9.9 {window ordering} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d
+ pack .pack.b .pack.d .pack.c -before .pack.a
+ pack slaves .pack
+} -result {.pack.b .pack.d .pack.c .pack.a}
+test pack-9.10 {window ordering} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d
+ pack .pack.a .pack.c .pack.d .pack.b -after .pack.a
+ pack slaves .pack
+} -result {.pack.a .pack.c .pack.d .pack.b}
+
+
+test pack-10.1 {retaining/clearing configuration state} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side bottom -anchor n -padx 1 -pady 2 -ipadx 3 -ipady 4 \
+ -fill both -expand 1
+ pack forget .pack.a
+ pack .pack.a
+ pack info .pack.a
+} -result {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}
+test pack-10.2 {retaining/clearing configuration state} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side bottom -anchor n -padx 1 -pady 2 -ipadx 3 -ipady 4 \
+ -fill both -expand 1
+ pack .pack.a -pady 14
+ pack info .pack.a
+} -result {-in .pack -anchor n -expand 1 -fill both -ipadx 3 -ipady 4 -padx 1 -pady 14 -side bottom}
+test pack-10.3 {bad -in window does not change master} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ set result [list [winfo manager .pack.a]]
+ catch {pack .pack.a -in .pack.a}
+ lappend result [winfo manager .pack.a]
+} -result {{} {}}
+test pack-10.4 {bad -in window does not change master} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ winfo manager .pack.a
+ pack .pack.a -in .pack.a
+} -returnCodes error -result {can't pack .pack.a inside itself}
+
+
+test pack-11.1 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -in .pack
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -in]+1]
+} -result .pack
+test pack-11.2 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -anchor n
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -anchor]+1]
+} -result n
+test pack-11.3 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -anchor sw
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -anchor]+1]
+} -result sw
+test pack-11.4 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -expand yes
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -expand]+1]
+} -result 1
+test pack-11.5 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -expand no
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -expand]+1]
+} -result 0
+test pack-11.6 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -fill x
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -fill]+1]
+} -result x
+test pack-11.7 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -fill y
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -fill]+1]
+} -result y
+test pack-11.8 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -fill both
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -fill]+1]
+} -result both
+test pack-11.9 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -fill none
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -fill]+1]
+} -result none
+test pack-11.10 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipadx 14
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -ipadx]+1]
+} -result 14
+test pack-11.11 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipady 22
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -ipady]+1]
+} -result 22
+test pack-11.12 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -padx 2
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -padx]+1]
+} -result 2
+test pack-11.13 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -padx {2 9}
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -padx]+1]
+} -result {2 9}
+test pack-11.14 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -pady 3
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -pady]+1]
+} -result 3
+test pack-11.15 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -pady {3 11}
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -pady]+1]
+} -result {3 11}
+test pack-11.16 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -side]+1]
+} -result top
+test pack-11.17 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side bottom
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -side]+1]
+} -result bottom
+test pack-11.18 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side left
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -side]+1]
+} -result left
+test pack-11.19 {info option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -side]+1]
+} -result right
+
+
+test pack-12.1 {command options and errors} -body {
+ pack
+} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"}
+test pack-12.2 {command options and errors} -body {
+ pack foo
+} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"}
+test pack-12.3 {command options and errors} -body {
+ pack configure x
+} -returnCodes error -result {bad argument "x": must be name of window}
+test pack-12.4 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack configure .pack.b .pack.c
+ pack slaves .pack
+} -result {.pack.b .pack.c}
+test pack-12.5 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .foo
+} -returnCodes error -result {bad window path name ".foo"}
+test pack-12.6 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack
+} -returnCodes error -result {can't pack ".pack": it's a top-level window}
+test pack-12.7 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -after .foo
+} -returnCodes error -result {bad window path name ".foo"}
+test pack-12.8 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -after .pack.b
+} -returnCodes error -result {window ".pack.b" isn't packed}
+test pack-12.9 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -anchor gorp
+} -returnCodes error -result {bad anchor "gorp": must be n, ne, e, se, s, sw, w, nw, or center}
+test pack-12.10 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -before gorp
+} -returnCodes error -result {bad window path name "gorp"}
+test pack-12.11 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -before .pack.b
+} -returnCodes error -result {window ".pack.b" isn't packed}
+test pack-12.12 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -expand "who cares?"
+} -returnCodes error -result {expected boolean value but got "who cares?"}
+test pack-12.13 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -fill z
+} -returnCodes error -result {bad fill style "z": must be none, x, y, or both}
+test pack-12.14 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -in z
+} -returnCodes error -result {bad window path name "z"}
+set pad [winfo pixels .pack 1c]
+test pack-12.15 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -padx abc
+} -returnCodes error -result {bad pad value "abc": must be positive screen distance}
+test pack-12.16 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -padx {5 abc}
+} -returnCodes error -result {bad 2nd pad value "abc": must be positive screen distance}
+test pack-12.17 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -padx -1
+} -returnCodes error -result {bad pad value "-1": must be positive screen distance}
+test pack-12.18 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -padx {5 -1}
+} -returnCodes error -result {bad 2nd pad value "-1": must be positive screen distance}
+test pack-12.19 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -pady abc
+} -returnCodes error -result {bad pad value "abc": must be positive screen distance}
+test pack-12.20 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -pady {0 abc}
+} -returnCodes error -result {bad 2nd pad value "abc": must be positive screen distance}
+test pack-12.21 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -pady -1
+} -returnCodes error -result {bad pad value "-1": must be positive screen distance}
+test pack-12.22 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -pady {0 -1}
+} -returnCodes error -result {bad 2nd pad value "-1": must be positive screen distance}
+test pack-12.23 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipadx abc
+} -returnCodes error -result {bad ipadx value "abc": must be positive screen distance}
+test pack-12.24 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipadx -1
+} -returnCodes error -result {bad ipadx value "-1": must be positive screen distance}
+test pack-12.25 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipadx {5 5}
+} -returnCodes error -result {bad ipadx value "5 5": must be positive screen distance}
+test pack-12.26 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipady abc
+} -returnCodes error -result {bad ipady value "abc": must be positive screen distance}
+test pack-12.27 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipady -1
+} -returnCodes error -result {bad ipady value "-1": must be positive screen distance}
+test pack-12.28 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipady {5 5}
+} -returnCodes error -result {bad ipady value "5 5": must be positive screen distance}
+test pack-12.29 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side bac
+} -returnCodes error -result {bad side "bac": must be top, bottom, left, or right}
+test pack-12.30 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -lousy bac
+} -returnCodes error -result {bad option "-lousy": must be -after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, or -side}
+test pack-12.31 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -padx
+} -returnCodes error -result {extra option "-padx" (option with no value?)}
+test pack-12.32 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a ? 22
+} -returnCodes error -result {bad option "?": must be -after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, or -side}
+test pack-12.33 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -in .
+} -returnCodes error -result {can't pack .pack.a inside .}
+test pack-12.34 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ frame .pack.a.a
+ pack .pack.a.a -in .pack.b
+} -returnCodes error -result {can't pack .pack.a.a inside .pack.b}
+test pack-12.35 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -in .pack.a
+} -returnCodes error -result {can't pack .pack.a inside itself}
+test pack-12.36 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a .pack.b .pack.c .pack.d
+ pack forget .pack.a .pack.d
+ pack slaves .pack
+} -result {.pack.b .pack.c}
+test pack-12.37 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ .pack configure -width 300 -height 200
+ pack propagate .pack 0
+ pack .pack.a
+ update
+ set result [list [winfo reqwidth .pack] [winfo reqheight .pack]]
+ pack propagate .pack 1
+ update
+ lappend result [winfo reqwidth .pack] [winfo reqheight .pack]
+ return $result
+} -result {300 200 20 40}
+test pack-12.38 {command options and errors} -body {
+ set result [pack propagate .pack.d]
+ pack propagate .pack.d 0
+ lappend result [pack propagate .pack.d]
+ pack propagate .pack.d 1
+ lappend result [pack propagate .pack.d]
+ return $result
+} -result {1 0 1}
+test pack-12.39 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack propagate .dum
+} -returnCodes error -result {bad window path name ".dum"}
+test pack-12.40 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack propagate .pack foo
+} -returnCodes error -result {expected boolean value but got "foo"}
+test pack-12.41 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack propagate .pack foo bar
+} -returnCodes error -result {wrong # args: should be "pack propagate window ?boolean?"}
+test pack-12.42 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack slaves
+} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"}
+test pack-12.43 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack slaves a b
+} -returnCodes error -result {wrong # args: should be "pack slaves window"}
+test pack-12.44 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack slaves .x
+} -returnCodes error -result {bad window path name ".x"}
+test pack-12.45 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack slaves .pack.a
+} -returnCodes ok -result {}
+test pack-12.46 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack lousy .pack
+} -returnCodes error -result {bad option "lousy": must be configure, forget, info, propagate, or slaves}
+
+
+test pack-13.1 {window deletion} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d .pack.right .pack.bottom
+} -body {
+ pack .pack.right -side right
+ pack .pack.bottom -side bottom
+ pack .pack.a .pack.d .pack.b .pack.c -side top
+ update
+ destroy .pack.d
+ update
+ set result [list [pack slaves .pack] [winfo geometry .pack.a] \
+ [winfo geometry .pack.b] [winfo geometry .pack.c]]
+} -result {{.pack.right .pack.bottom .pack.a .pack.b .pack.c} 20x40+30+0 50x30+15+40 80x80+0+70}
+
+
+test pack-14.1 {respond to changes in expansion} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d .pack.right .pack.bottom
+} -body {
+ pack .pack.right -side right
+ pack .pack.bottom -side bottom
+ wm geom .pack {}
+ pack .pack.a
+ update
+ set result [winfo geom .pack.a]
+ wm geom .pack 400x300
+ update
+ lappend result [winfo geom .pack.a]
+ pack .pack.a -expand true -fill both
+ update
+ lappend result [winfo geom .pack.a]
+} -cleanup {
+ wm geom .pack {}
+} -result {20x40+0+0 20x40+90+0 200x150+0+0}
+
+
+test pack-15.1 {managing geometry with -in option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+ destroy .pack.f
+} -body {
+ pack .pack.a -side top
+ frame .pack.f
+ lower .pack.f
+ pack .pack.f -side top
+ frame .pack.f.f2
+ lower .pack.f.f2
+ pack .pack.f.f2 -side top
+ pack .pack.b -in .pack.f.f2
+ update
+ set result [winfo geom .pack.b]
+ pack unpack .pack.a
+ update
+ lappend result [winfo geom .pack.b]
+} -cleanup {
+ destroy .pack.f
+} -result {50x30+0+40 50x30+0+0}
+test pack-15.2 {managing geometry with -in option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+ destroy .pack.f
+} -body {
+ frame .pack.f
+ lower .pack.f
+ pack .pack.a -in .pack.f -side top
+ update
+ set result [winfo ismapped .pack.a]
+ place .pack.f -x 30 -y 45
+ update
+ lappend result [winfo ismapped .pack.a] [winfo geometry .pack.a]
+ place forget .pack.f
+ update
+ lappend result [winfo ismapped .pack.a]
+} -cleanup {
+ destroy .pack.f
+} -result {0 1 20x40+30+45 0}
+test pack-15.3 {managing geometry with -in option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+ destroy .pack.f
+} -body {
+ pack .pack.a -side top
+ frame .pack.f
+ lower .pack.f
+ pack .pack.f -side top
+ frame .pack.f.f2
+ lower .pack.f.f2
+ pack .pack.f.f2 -side top
+ pack .pack.b -in .pack.f.f2
+ update
+ set result [winfo ismapped .pack.b]
+ pack unpack .pack.f
+ update
+ lappend result [winfo ismapped .pack.b]
+} -cleanup {
+ destroy .pack.f
+} -result {1 0}
+test pack-15.4 {managing geometry with -in option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+ destroy .pack.f1 .pack.f2
+} -body {
+ foreach i {1 2} {
+ frame .pack.f$i -width 100 -height 40 -bd 2 -relief raised
+ lower .pack.f$i
+ pack propagate .pack.f$i 0
+ pack .pack.f$i -side top
+ }
+ pack .pack.b -in .pack.f1 -side right
+ update
+ set result {}
+ lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b]
+ pack .pack.b -in .pack.f2 -side bottom
+ update
+ lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b]
+ .pack.f1 configure -width 50 -height 20
+ update
+ lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b]
+ pack forget .pack.b
+ update
+ lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b]
+} -cleanup {
+ destroy .pack.f1 .pack.f2
+} -result {50x30+48+5 1 50x30+25+48 1 50x30+25+28 1 50x30+25+28 0}
+test pack-15.5 {managing geometry with -in option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+ destroy .pack.f1 .pack.f2
+} -body {
+ foreach i {1 2} {
+ frame .pack.f$i -width 100 -height 20 -bd 2 -relief raised
+ lower .pack.f$i
+ pack propagate .pack.f$i 0
+ pack .pack.f$i -side top
+ }
+ pack .pack.b -in .pack.f2 -side top
+ update
+ set result {}
+ lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b]
+ pack .pack.a -before .pack.b -side top
+ update
+ lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b]
+} -cleanup {
+ destroy .pack.f1 .pack.f2
+} -result {50x16+25+22 1 50x16+25+22 0}
+
+
+test pack-16.1 {geometry manager name} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+ set result {}
+} -body {
+ lappend result [winfo manager .pack.a]
+ pack .pack.a
+ lappend result [winfo manager .pack.a]
+ pack forget .pack.a
+ lappend result [winfo manager .pack.a]
+} -result {{} pack {}}
+
+
+test pack-17.1 {PackLostSlaveProc procedure} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a
+ update
+ place .pack.a -x 40 -y 10
+ update
+ list [winfo manager .pack.a] [winfo geometry .pack.a]
+} -result {place 20x40+40+10}
+test pack-17.2 {PackLostSlaveProc procedure} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a
+ update
+ place .pack.a -x 40 -y 10
+ update
+ winfo manager .pack.a
+ winfo geometry .pack.a
+ pack info .pack.a
+} -returnCodes error -result {window ".pack.a" isn't packed}
+
+
+test pack-18.1 {unmap slaves when master unmapped} -constraints {
+ tempNotPc
+} -setup {
+ eval destroy [winfo child .pack]
+} -body {
+
+ # adjust the position of .pack before test to avoid a screen switch
+ # that occurs with window managers that have desktops four times as big
+ # as the screen (screen switch causes scale and other tests to fail).
+
+ wm geometry .pack +100+100
+
+ # On the PC, when the width/height is configured while the window is
+ # unmapped, the changes don't take effect until the window is remapped.
+ # Who knows why?
+
+ eval destroy [winfo child .pack]
+ frame .pack.a -width 100 -height 50 -relief raised -bd 2
+ pack .pack.a
+ update
+ set result [winfo ismapped .pack.a]
+ wm iconify .pack
+ update
+ lappend result [winfo ismapped .pack.a]
+ .pack.a configure -width 200 -height 75
+ update
+ lappend result [winfo width .pack.a ] [winfo height .pack.a] \
+ [winfo ismapped .pack.a]
+ wm deiconify .pack
+ update
+ lappend result [winfo ismapped .pack.a]
+} -result {1 0 200 75 0 1}
+test pack-18.2 {unmap slaves when master unmapped} -setup {
+ eval destroy [winfo child .pack]
+} -body {
+
+ # adjust the position of .pack before test to avoid a screen switch
+ # that occurs with window managers that have desktops four times as big
+ # as the screen (screen switch causes scale and other tests to fail).
+
+ wm geometry .pack +100+100
+ frame .pack.a -relief raised -bd 2
+ frame .pack.b -width 70 -height 30 -relief sunken -bd 2
+ pack .pack.a
+ pack .pack.b -in .pack.a
+ update
+ set result [winfo ismapped .pack.b]
+ wm iconify .pack
+ update
+ lappend result [winfo ismapped .pack.b]
+ .pack.b configure -width 100 -height 30
+ update
+ lappend result [winfo width .pack.b ] [winfo height .pack.b] \
+ [winfo ismapped .pack.b]
+ wm deiconify .pack
+ update
+ lappend result [winfo ismapped .pack.b]
+} -result {1 0 100 30 0 1}
+
+
+test pack-19.1 {test respect for internalborder} -setup {
+ catch {eval pack forget [pack slaves .pack]}
+ destroy .pack.l .pack.lf
+} -body {
+ wm geometry .pack 200x200
+ frame .pack.l -width 15 -height 10
+ labelframe .pack.lf -labelwidget .pack.l
+ pack .pack.lf -fill both -expand 1
+ frame .pack.lf.f
+ pack .pack.lf.f -fill both -expand 1
+ update
+ set res [list [winfo geometry .pack.lf.f]]
+ .pack.lf configure -labelanchor e -padx 3 -pady 5
+ update
+ lappend res [winfo geometry .pack.lf.f]
+} -cleanup {
+ destroy .pack.l .pack.lf
+} -result {196x188+2+10 177x186+5+7}
+test pack-19.2 {test support for minreqsize} -setup {
+ catch {eval pack forget [pack slaves .pack]}
+ destroy .pack.l .pack.lf
+} -body {
+ wm geometry .pack {}
+ frame .pack.l -width 150 -height 100
+ labelframe .pack.lf -labelwidget .pack.l
+ pack .pack.lf -fill both -expand 1
+ frame .pack.lf.f -width 20 -height 25
+ pack .pack.lf.f
+ update
+ set res [list [winfo geometry .pack.lf]]
+ .pack.lf configure -labelanchor ws
+ update
+ lappend res [winfo geometry .pack.lf]
+} -cleanup {
+ destroy .pack.l .pack.lf
+} -result {162x127+0+0 172x112+0+0}
+
+
+# cleanup
+cleanupTests
+return
+
+
+
diff --git a/tk8.6/tests/packgrid.test b/tk8.6/tests/packgrid.test
new file mode 100644
index 0000000..355b49d
--- /dev/null
+++ b/tk8.6/tests/packgrid.test
@@ -0,0 +1,250 @@
+# This file is a Tcl script to test out interaction between Tk's "pack" and
+# "grid" commands.
+# It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 2008 Peter Spjuth
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::*
+
+test packgrid-1.1 {pack and grid in same master} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Basic conflict
+ grid .g
+ pack .p
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager pack inside . which already has slaves managed by grid}
+
+test packgrid-1.2 {pack and grid in same master} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Basic conflict
+ pack .p
+ grid .g
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager grid inside . which already has slaves managed by pack}
+
+test packgrid-1.3 {pack and grid in same master} -setup {
+ grid propagate . false
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Ok if one is non-propagating
+ grid .g
+ pack .p
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-1.4 {pack and grid in same master} -setup {
+ grid propagate . false
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Ok if one is non-propagating
+ pack .p
+ grid .g
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-1.5 {pack and grid in same master} -setup {
+ grid propagate . true
+ pack propagate . false
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Ok if one is non-propagating
+ grid .g
+ pack .p
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-1.6 {pack and grid in same master} -setup {
+ grid propagate . true
+ pack propagate . false
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Ok if one is non-propagating
+ pack .p
+ grid .g
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-1.7 {pack and grid in same master} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Basic conflict should stop widget from being handled
+ grid .g
+ catch { pack .p }
+ pack slaves .
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-1.8 {pack and grid in same master} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Basic conflict should stop widget from being handled
+ pack .p
+ catch { grid .g }
+ grid slaves .
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-2.1 {pack and grid in same master, change propagation} -setup {
+ grid propagate . false
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+ pack .p
+ grid .g
+ update
+} -body {
+ grid propagate . true
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager grid inside . which already has slaves managed by pack}
+
+test packgrid-2.2 {pack and grid in same master, change propagation} -setup {
+ grid propagate . true
+ pack propagate . false
+ label .p -text PACK
+ label .g -text GRID
+ pack .p
+ grid .g
+ update
+} -body {
+ pack propagate . true
+} -returnCodes error -cleanup {
+ destroy .p
+ update
+ destroy .g
+} -result {cannot use geometry manager pack inside . which already has slaves managed by grid}
+
+test packgrid-2.3 {pack and grid in same master, change propagation} -setup {
+ grid propagate . false
+ pack propagate . false
+ label .p -text PACK
+ label .g -text GRID
+ pack .p
+ grid .g
+ update
+} -body {
+ grid propagate . true
+ update
+ pack propagate . true
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager pack inside . which already has slaves managed by grid}
+
+test packgrid-2.4 {pack and grid in same master, change propagation} -setup {
+ grid propagate . false
+ pack propagate . false
+ label .p -text PACK
+ label .g -text GRID
+ pack .p
+ grid .g
+ update
+} -body {
+ pack propagate . true
+ grid propagate . true
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager grid inside . which already has slaves managed by pack}
+
+test packgrid-3.1 {stealing slave} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Ok to steal if the other one is emptied
+ grid .g
+ pack .g
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-3.2 {stealing slave} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Ok to steal if the other one is emptied
+ pack .g
+ grid .g
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-3.3 {stealing slave} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Not ok to steal if the other one is not emptied
+ grid .g
+ grid .p
+ pack .g
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager pack inside . which already has slaves managed by grid}
+
+test packgrid-3.4 {stealing slave} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Not ok to steal if the other one is not emptied
+ pack .g
+ pack .p
+ grid .g
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager grid inside . which already has slaves managed by pack}
+
+cleanupTests
+return
diff --git a/tk8.6/tests/panedwindow.test b/tk8.6/tests/panedwindow.test
new file mode 100644
index 0000000..ee184ce
--- /dev/null
+++ b/tk8.6/tests/panedwindow.test
@@ -0,0 +1,5551 @@
+# This file is a Tcl script to test entry widgets in Tk. It is
+# organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+deleteWindows
+# Panedwindow for tests 1.*
+panedwindow .p
+# Buttons for tests 1.33 - 1.52
+.p add [button .b]
+.p add [button .c]
+test panedwindow-1.1 {configuration options: -background (good)} -body {
+ .p configure -background #ff0000
+ list [lindex [.p configure -background] 4] [.p cget -background]
+} -cleanup {
+ .p configure -background [lindex [.p configure -background] 3]
+} -result {{#ff0000} #ff0000}
+test panedwindow-1.2 {configuration options: -background (bad)} -body {
+ .p configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test panedwindow-1.3 {configuration options: -bd (good)} -body {
+ .p configure -bd 4
+ list [lindex [.p configure -bd] 4] [.p cget -bd]
+} -cleanup {
+ .p configure -bd [lindex [.p configure -bd] 3]
+} -result {4 4}
+test panedwindow-1.4 {configuration options: -bd (bad)} -body {
+ .p configure -bd badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.5 {configuration options: -bg (good)} -body {
+ .p configure -bg #ff0000
+ list [lindex [.p configure -bg] 4] [.p cget -bg]
+} -cleanup {
+ .p configure -bg [lindex [.p configure -bg] 3]
+} -result {{#ff0000} #ff0000}
+test panedwindow-1.6 {configuration options: -bg (bad)} -body {
+ .p configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test panedwindow-1.7 {configuration options: -borderwidth (good)} -body {
+ .p configure -borderwidth 1.3
+ list [lindex [.p configure -borderwidth] 4] [.p cget -borderwidth]
+} -cleanup {
+ .p configure -borderwidth [lindex [.p configure -borderwidth] 3]
+} -result {1 1}
+test panedwindow-1.8 {configuration options: -borderwidth (bad)} -body {
+ .p configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.9 {configuration options: -cursor (good)} -body {
+ .p configure -cursor arrow
+ list [lindex [.p configure -cursor] 4] [.p cget -cursor]
+} -cleanup {
+ .p configure -cursor [lindex [.p configure -cursor] 3]
+} -result {arrow arrow}
+test panedwindow-1.10 {configuration options: -cursor (bad)} -body {
+ .p configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test panedwindow-1.11 {configuration options: -handlesize (good)} -body {
+ .p configure -handlesize 20
+ list [lindex [.p configure -handlesize] 4] [.p cget -handlesize]
+} -cleanup {
+ .p configure -handlesize [lindex [.p configure -handlesize] 3]
+} -result {20 20}
+test panedwindow-1.12 {configuration options: -handlesize (bad)} -body {
+ .p configure -handlesize badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.13 {configuration options: -height (good)} -body {
+ .p configure -height 20
+ list [lindex [.p configure -height] 4] [.p cget -height]
+} -cleanup {
+ .p configure -height [lindex [.p configure -height] 3]
+} -result {20 20}
+test panedwindow-1.14 {configuration options: -height (bad)} -body {
+ .p configure -height badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.15 {configuration options: -opaqueresize (good)} -body {
+ .p configure -opaqueresize true
+ list [lindex [.p configure -opaqueresize] 4] [.p cget -opaqueresize]
+} -cleanup {
+ .p configure -opaqueresize [lindex [.p configure -opaqueresize] 3]
+} -result {1 1}
+test panedwindow-1.16 {configuration options: -opaqueresize (bad)} -body {
+ .p configure -opaqueresize foo
+} -returnCodes error -result {expected boolean value but got "foo"}
+test panedwindow-1.17 {configuration options: -orient (good)} -body {
+ .p configure -orient horizontal
+ list [lindex [.p configure -orient] 4] [.p cget -orient]
+} -cleanup {
+ .p configure -orient [lindex [.p configure -orient] 3]
+} -result {horizontal horizontal}
+test panedwindow-1.18 {configuration options: -orient (bad)} -body {
+ .p configure -orient badValue
+} -returnCodes error -result {bad orient "badValue": must be horizontal or vertical}
+test panedwindow-1.19 {configuration options: -proxybackground (good)} -body {
+ .p configure -proxybackground "#f0a0a0"
+ list [lindex [.p configure -proxybackground] 4] [.p cget -proxybackground]
+} -cleanup {
+ .p configure -proxybackground [lindex [.p configure -proxybackground] 3]
+} -result {{#f0a0a0} #f0a0a0}
+test panedwindow-1.20 {configuration options: -proxybackground (bad)} -body {
+ .p configure -proxybackground badValue
+} -returnCodes error -result {unknown color name "badValue"}
+test panedwindow-1.21 {configuration options: -proxyborderwidth (good)} -body {
+ .p configure -proxyborderwidth 1.3
+ list [lindex [.p configure -proxyborderwidth] 4] [.p cget -proxyborderwidth]
+} -cleanup {
+ .p configure -proxyborderwidth [lindex [.p configure -proxyborderwidth] 3]
+} -result {1.3 1.3}
+test panedwindow-1.22 {configuration options: -proxyborderwidth (bad)} -body {
+ .p configure -proxyborderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.23 {configuration options: -proxyrelief (good)} -body {
+ .p configure -proxyrelief groove
+ list [lindex [.p configure -proxyrelief] 4] [.p cget -proxyrelief]
+} -cleanup {
+ .p configure -proxyrelief [lindex [.p configure -proxyrelief] 3]
+} -result {groove groove}
+test panedwindow-1.24 {configuration options: -proxyrelief (bad)} -body {
+ .p configure -proxyrelief 1.5
+} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test panedwindow-1.25 {configuration options: -relief (good)} -body {
+ .p configure -relief groove
+ list [lindex [.p configure -relief] 4] [.p cget -relief]
+} -cleanup {
+ .p configure -relief [lindex [.p configure -relief] 3]
+} -result {groove groove}
+test panedwindow-1.26 {configuration options: -relief (bad)} -body {
+ .p configure -relief 1.5
+} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test panedwindow-1.27 {configuration options: -sashcursor (good)} -body {
+ .p configure -sashcursor arrow
+ list [lindex [.p configure -sashcursor] 4] [.p cget -sashcursor]
+} -cleanup {
+ .p configure -sashcursor [lindex [.p configure -sashcursor] 3]
+} -result {arrow arrow}
+test panedwindow-1.28 {configuration options: -sashcursor (bad)} -body {
+ .p configure -sashcursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test panedwindow-1.29 {configuration options: -sashpad (good)} -body {
+ .p configure -sashpad 1.3
+ list [lindex [.p configure -sashpad] 4] [.p cget -sashpad]
+} -cleanup {
+ .p configure -sashpad [lindex [.p configure -sashpad] 3]
+} -result {1 1}
+test panedwindow-1.30 {configuration options: -sashpad (bad)} -body {
+ .p configure -sashpad badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.31 {configuration options: -sashrelief (good)} -body {
+ .p configure -sashrelief groove
+ list [lindex [.p configure -sashrelief] 4] [.p cget -sashrelief]
+} -cleanup {
+ .p configure -sashrelief [lindex [.p configure -sashrelief] 3]
+} -result {groove groove}
+test panedwindow-1.32 {configuration options: -sashrelief (bad)} -body {
+ .p configure -sashrelief 1.5
+} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test panedwindow-1.33 {configuration options: -sashwidth (good)} -body {
+ .p configure -sashwidth 10
+ list [lindex [.p configure -sashwidth] 4] [.p cget -sashwidth]
+} -cleanup {
+ .p configure -sashwidth [lindex [.p configure -sashwidth] 3]
+} -result {10 10}
+test panedwindow-1.34 {configuration options: -sashwidth (bad)} -body {
+ .p configure -sashwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.35 {configuration options: -showhandle (good)} -body {
+ .p configure -showhandle true
+ list [lindex [.p configure -showhandle] 4] [.p cget -showhandle]
+} -cleanup {
+ .p configure -showhandle [lindex [.p configure -showhandle] 3]
+} -result {1 1}
+test panedwindow-1.36 {configuration options: -showhandle (bad)} -body {
+ .p configure -showhandle foo
+} -returnCodes error -result {expected boolean value but got "foo"}
+test panedwindow-1.37 {configuration options: -width (good)} -body {
+ .p configure -width 402
+ list [lindex [.p configure -width] 4] [.p cget -width]
+} -cleanup {
+ .p configure -width [lindex [.p configure -width] 3]
+} -result {402 402}
+test panedwindow-1.38 {configuration options: -width (bad)} -body {
+ .p configure -width badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+
+test panedwindow-1.39 {configuration options: -after (good)} -body {
+ .p paneconfigure .b -after .c
+ list [lindex [.p paneconfigure .b -after] 4] \
+ [.p panecget .b -after]
+} -cleanup {
+ .p paneconfig .b -after [lindex [.p paneconfig .b -after] 3]
+} -result {.c .c}
+test panedwindow-1.40 {configuration options: -after (bad)} -body {
+ .p paneconfigure .b -after badValue
+} -returnCodes error -result {bad window path name "badValue"}
+test panedwindow-1.41 {configuration options: -before (good)} -body {
+ .p paneconfigure .b -before .c
+ list [lindex [.p paneconfigure .b -before] 4] \
+ [.p panecget .b -before]
+} -cleanup {
+ .p paneconfig .b -before [lindex [.p paneconfig .b -before] 3]
+} -result {.c .c}
+test panedwindow-1.42 {configuration options: -before (bad)} -body {
+ .p paneconfigure .b -before badValue
+} -returnCodes error -result {bad window path name "badValue"}
+test panedwindow-1.43 {configuration options: -height (good)} -body {
+ .p paneconfigure .b -height 10
+ list [lindex [.p paneconfigure .b -height] 4] \
+ [.p panecget .b -height]
+} -cleanup {
+ .p paneconfig .b -height [lindex [.p paneconfig .b -height] 3]
+} -result {10 10}
+test panedwindow-1.44 {configuration options: -height (bad)} -body {
+ .p paneconfigure .b -height badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.45 {configuration options: -hide (good)} -body {
+ .p paneconfigure .b -hide false
+ list [lindex [.p paneconfigure .b -hide] 4] \
+ [.p panecget .b -hide]
+} -cleanup {
+ .p paneconfig .b -hide [lindex [.p paneconfig .b -hide] 3]
+} -result {0 0}
+test panedwindow-1.46 {configuration options: -hide (bad)} -body {
+ .p paneconfigure .b -hide foo
+} -returnCodes error -result {expected boolean value but got "foo"}
+test panedwindow-1.47 {configuration options: -minsize (good)} -body {
+ .p paneconfigure .b -minsize 10
+ list [lindex [.p paneconfigure .b -minsize] 4] \
+ [.p panecget .b -minsize]
+} -cleanup {
+ .p paneconfig .b -minsize [lindex [.p paneconfig .b -minsize] 3]
+} -result {10 10}
+test panedwindow-1.48 {configuration options: -minsize (bad)} -body {
+ .p paneconfigure .b -minsize badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.49 {configuration options: -padx (good)} -body {
+ .p paneconfigure .b -padx 1.3
+ list [lindex [.p paneconfigure .b -padx] 4] \
+ [.p panecget .b -padx]
+} -cleanup {
+ .p paneconfig .b -padx [lindex [.p paneconfig .b -padx] 3]
+} -result {1 1}
+test panedwindow-1.50 {configuration options: -padx (bad)} -body {
+ .p paneconfigure .b -padx badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.51 {configuration options: -pady (good)} -body {
+ .p paneconfigure .b -pady 1.3
+ list [lindex [.p paneconfigure .b -pady] 4] \
+ [.p panecget .b -pady]
+} -cleanup {
+ .p paneconfig .b -pady [lindex [.p paneconfig .b -pady] 3]
+} -result {1 1}
+test panedwindow-1.52 {configuration options: -pady (bad)} -body {
+ .p paneconfigure .b -pady badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.53 {configuration options: -sticky (good)} -body {
+ .p paneconfigure .b -sticky nsew
+ list [lindex [.p paneconfigure .b -sticky] 4] \
+ [.p panecget .b -sticky]
+} -cleanup {
+ .p paneconfig .b -sticky [lindex [.p paneconfig .b -sticky] 3]
+} -result {nesw nesw}
+test panedwindow-1.54 {configuration options: -sticky (bad)} -body {
+ .p paneconfigure .b -sticky abcd
+} -returnCodes error -result {bad stickyness value "abcd": must be a string containing zero or more of n, e, s, and w}
+test panedwindow-1.55 {configuration options: -stretch (good)} -body {
+ .p paneconfigure .b -stretch alw
+ list [lindex [.p paneconfigure .b -stretch] 4] \
+ [.p panecget .b -stretch]
+} -cleanup {
+ .p paneconfig .b -stretch [lindex [.p paneconfig .b -stretch] 3]
+} -result {always always}
+test panedwindow-1.56 {configuration options: -stretch (bad)} -body {
+ .p paneconfigure .b -stretch foo
+} -returnCodes error -result {bad stretch "foo": must be always, first, last, middle, or never}
+test panedwindow-1.57 {configuration options: -width (good)} -body {
+ .p paneconfigure .b -width 10
+ list [lindex [.p paneconfigure .b -width] 4] \
+ [.p panecget .b -width]
+} -cleanup {
+ .p paneconfig .b -width [lindex [.p paneconfig .b -width] 3]
+} -result {10 10}
+test panedwindow-1.58 {configuration options: -width (bad)} -body {
+ .p paneconfigure .b -width badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+deleteWindows
+
+
+test panedwindow-2.1 {panedwindow widget command} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p foo
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad command "foo": must be add, cget, configure, forget, identify, panecget, paneconfigure, panes, proxy, or sash}
+
+
+test panedwindow-3.1 {panedwindow panes subcommand} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b]
+ .p add [button .c]
+ set result [list [.p panes]]
+ .p forget .b
+ lappend result [.p panes]
+} -cleanup {
+ deleteWindows
+} -result [list [list .b .c] [list .c]]
+
+
+test panedwindow-4.1 {forget subcommand} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p forget
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p forget widget ?widget ...?"}
+test panedwindow-4.2 {forget subcommand, forget one from start} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b]
+ .p add [button .c]
+ set result [list [.p panes]]
+ .p forget .b
+ lappend result [.p panes]
+} -cleanup {
+ deleteWindows
+} -result [list {.b .c} .c]
+test panedwindow-4.3 {forget subcommand, forget one from end} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b]
+ .p add [button .c]
+ .p add [button .d]
+ set result [list [.p panes]]
+ .p forget .d
+ update
+ lappend result [.p panes]
+} -cleanup {
+ deleteWindows
+} -result [list {.b .c .d} {.b .c}]
+test panedwindow-4.4 {forget subcommand, forget multiple} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b]
+ .p add [button .c]
+ .p add [button .d]
+ set result [list [.p panes]]
+ .p forget .b .c
+ update
+ lappend result [.p panes]
+} -cleanup {
+ deleteWindows
+} -result [list {.b .c .d} .d]
+test panedwindow-4.5 {forget subcommand, panes are unmapped} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b]
+ .p add [button .c]
+ pack .p
+ update
+ set result [list [winfo ismapped .b] [winfo ismapped .c]]
+ .p forget .b
+ update
+ lappend result [winfo ismapped .b] [winfo ismapped .c]
+} -cleanup {
+ deleteWindows
+} -result [list 1 1 0 1]
+test panedwindow-4.6 {forget subcommand, changes reqsize of panedwindow} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false
+ .p add [frame .f -width 20 -height 20] [frame .g -width 20 -height 20]
+ set result [list [winfo reqwidth .p]]
+ .p forget .f
+ lappend result [winfo reqwidth .p]
+} -cleanup {
+ deleteWindows
+} -result [list 44 20]
+
+
+test panedwindow-5.1 {sash subcommand} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p sash
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p sash option ?arg ...?"}
+test panedwindow-5.2 {sash subcommand} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p sash foo
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad option "foo": must be coord, dragto, mark, or place}
+
+
+test panedwindow-6.1 {sash coord subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p sash coord
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p sash coord index"}
+test panedwindow-6.2 {sash coord subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {invalid sash index}
+test panedwindow-6.3 {sash coord subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p sash coord foo
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-6.4 {sash coord subcommand sashes correctly placed} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -showhandle false
+ .p add [frame .p.f -width 20 -height 20] \
+ [frame .p.f2 -width 20 -height 20] \
+ [frame .p.f3 -width 20 -height 20]
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 22 0]
+test panedwindow-6.5 {sash coord subcommand sashes correctly placed} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -showhandle false
+ .p add [frame .p.f -width 20 -height 20] \
+ [frame .p.f2 -width 20 -height 20] \
+ [frame .p.f3 -width 20 -height 20]
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 50 0]
+test panedwindow-6.6 {sash coord subcommand, sashes correctly placed} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -orient vertical \
+ -showhandle false
+ .p add [frame .p.f -width 20 -height 20] \
+ [frame .p.f2 -width 20 -height 20] \
+ [frame .p.f3 -width 20 -height 20]
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 22]
+test panedwindow-6.7 {sash coord subcommand, sashes correctly placed} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -orient vertical \
+ -showhandle false
+ .p add [frame .p.f -width 20 -height 20] \
+ [frame .p.f2 -width 20 -height 20] \
+ [frame .p.f3 -width 20 -height 20]
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 0 50]
+test panedwindow-6.8 {sash coord subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ list [catch {.p sash coord -1} msg] $msg \
+ [catch {.p sash coord 0} msg] $msg \
+ [catch {.p sash coord 1} msg] $msg
+} -cleanup {
+ deleteWindows
+} -result [list 1 "invalid sash index" 1 "invalid sash index" 1 "invalid sash index"]
+test panedwindow-6.9 {sash coord subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ # There are no sashes until you have 2 panes
+ panedwindow .p
+ .p add [frame .p.f]
+ list [catch {.p sash coord -1} msg] $msg \
+ [catch {.p sash coord 0} msg] $msg \
+ [catch {.p sash coord 1} msg] $msg
+} -cleanup {
+ deleteWindows
+} -result [list 1 "invalid sash index" 1 "invalid sash index" 1 "invalid sash index"]
+test panedwindow-6.10 {sash coord subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ # There are no sashes until you have 2 panes
+ panedwindow .p
+ .p add [frame .p.f] [frame .p.f2]
+ list [catch {.p sash coord -1} msg] $msg \
+ [catch {.p sash coord 0} msg] \
+ [catch {.p sash coord 1} msg] $msg \
+ [catch {.p sash coord 2} msg] $msg
+} -cleanup {
+ deleteWindows
+} -result [list 1 "invalid sash index" 0 1 "invalid sash index" 1 "invalid sash index"]
+
+
+test panedwindow-7.1 {sash mark subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p sash mark
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p sash mark index ?x y?"}
+test panedwindow-7.2 {sash mark subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p sash mark foo
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-7.3 {sash mark subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p sash mark 0 foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {invalid sash index}
+test panedwindow-7.4 {sash mark subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b] [button .c]
+ .p sash mark 0 foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-7.5 {sash mark subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b] [button .c]
+ .p sash mark 0 0 bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "bar"}
+test panedwindow-7.6 {sash mark subcommand, mark defaults to 0 0} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b] [button .c]
+ .p sash mark 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 0]
+test panedwindow-7.7 {sash mark subcommand, set mark} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b] [button .c]
+ .p sash mark 0 10 10
+ .p sash mark 0
+} -cleanup {
+ deleteWindows
+} -result [list 10 10]
+
+
+test panedwindow-8.1 {sash dragto subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p sash dragto
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p sash dragto index x y"}
+test panedwindow-8.2 {sash dragto subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p sash dragto foo bar baz
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-8.3 {sash dragto subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p sash dragto 0 foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {invalid sash index}
+test panedwindow-8.4 {sash dragto subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b] [button .c]
+ .p sash dragto 0 foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-8.5 {sash dragto subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b] [button .c]
+ .p sash dragto 0 0 bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "bar"}
+
+
+test panedwindow-9.1 {sash mark/sash dragto interaction} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false
+ .p add [frame .f -width 20 -height 20] [button .c -text foobar]
+ .p sash mark 0 10 10
+ .p sash dragto 0 20 10
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 30 0]
+test panedwindow-9.2 {sash mark/sash dragto interaction} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -orient vertical \
+ -showhandle false
+ .p add [frame .p.f -width 20 -height 20] [button .p.c -text foobar]
+ .p sash mark 0 10 10
+ .p sash dragto 0 10 20
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 30]
+test panedwindow-9.3 {sash mark/sash dragto, respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false
+ .p add [frame .f -width 20 -height 20] [button .c] -minsize 15
+ .p sash mark 0 20 10
+ .p sash dragto 0 10 10
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 15 0]
+
+
+test panedwindow-10.1 {sash place subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p sash place
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p sash place index x y"}
+test panedwindow-10.2 {sash place subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p sash place foo bar baz
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-10.3 {sash place subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p sash place 0 foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {invalid sash index}
+test panedwindow-10.4 {sash place subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b] [button .c]
+ .p sash place 0 foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-10.5 {sash place subcommand, errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b] [button .c]
+ .p sash place 0 0 bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "bar"}
+test panedwindow-10.6 {sash place subcommand, moves sash} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4
+ .p add [frame .f -width 20 -height 20] [button .c]
+ .p sash place 0 10 0
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 10 0]
+test panedwindow-10.7 {sash place subcommand, moves sash} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -orient vertical
+ .p add [frame .f -width 20 -height 20] [button .c]
+ .p sash place 0 0 10
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 10]
+test panedwindow-10.8 {sash place subcommand, respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false
+ .p add [frame .f -width 20 -height 20] [button .c] -minsize 15
+ .p sash place 0 10 0
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 15 0]
+test panedwindow-10.9 {sash place subcommand, respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [frame .f -width 20 -height 20 -bg pink]
+ .p sash place 0 2 0
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {invalid sash index}
+
+
+test panedwindow-11.1 {moving sash changes size of pane to left} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false
+ .p add [frame .f -width 20 -height 20] [button .c -text foobar] -sticky nsew
+ .p sash place 0 30 0
+ pack .p
+ update
+ winfo width .f
+} -result 30
+test panedwindow-11.2 {moving sash changes size of pane to right} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
+ .p add [frame .f -width 20 -height 20] [frame .f2 -width 20 -height 20]
+ pack .p
+ update
+ set result [winfo width .f2]
+ .p sash place 0 30 0
+ update
+ lappend result [winfo width .f2]
+} -cleanup {
+ deleteWindows
+} -result {20 10}
+test panedwindow-11.3 {moving sash does not change reqsize of panedwindow} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
+ .p add [frame .f -width 20 -height 20] [frame .f2 -width 20 -height 20]
+ .p sash place 0 30 0
+ winfo reqwidth .p
+} -result 44
+test panedwindow-11.4 {moving sash changes size of pane above} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
+ -orient vertical
+ .p add [frame .f -width 20 -height 10] [button .c -text foobar] -sticky nsew
+ .p sash place 0 0 20
+ pack .p
+ update
+ set result [winfo height .f]
+ set result
+} -result 20
+test panedwindow-11.5 {moving sash changes size of pane below} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
+ -orient vertical
+ .p add [frame .f -width 20 -height 10] [frame .f2 -width 20 -height 10]
+ pack .p
+ update
+ set result [winfo height .f2]
+ .p sash place 0 0 15
+ update
+ lappend result [winfo height .f2]
+ set result
+} -cleanup {
+ deleteWindows
+} -result {10 5}
+test panedwindow-11.6 {moving sash does not change reqsize of panedwindow} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
+ -orient vertical
+ .p add [frame .f -width 20 -height 10] [frame .f2 -width 20 -height 10]
+ set result [winfo reqheight .p]
+ .p sash place 0 0 20
+ lappend result [winfo reqheight .p]
+ set result
+} -cleanup {
+ deleteWindows
+} -result [list 24 24]
+test panedwindow-11.7 {moving sash does not alter reqsize of widget} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
+ -orient vertical
+ .p add [frame .f -width 20 -height 10] [frame .f2 -width 20 -height 10]
+ set result [winfo reqheight .f]
+ .p sash place 0 0 20
+ lappend result [winfo reqheight .f]
+} -cleanup {
+ deleteWindows
+} -result [list 10 10]
+test panedwindow-11.8 {moving sash restricted to minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
+ .p add [frame .f -width 20 -height 20] [button .c] -minsize 15
+ .p sash place 0 10 0
+ pack .p
+ update
+ winfo width .f
+} -result 15
+test panedwindow-11.9 {moving sash restricted to minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
+ -orient vertical
+ .p add [frame .f -width 20 -height 30] [button .c] -minsize 10
+ .p sash place 0 0 5
+ pack .p
+ update
+ winfo height .f
+} -result 10
+test panedwindow-11.10 {moving sash in unmapped window restricted to reqsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
+ .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20]
+ set result [list [.p sash coord 0]]
+ .p sash place 0 100 0
+ lappend result [.p sash coord 0]
+} -cleanup {
+ deleteWindows
+} -result [list {20 0} {40 0}]
+test panedwindow-11.11 {moving sash right pushes other sashes} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
+ .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \
+ [frame .f3 -width 20 -height 30]
+ .p sash place 0 80 0
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{60 0} {64 0}}
+test panedwindow-11.12 {moving sash left pushes other sashes} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
+ .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \
+ [frame .f3 -width 20 -height 30]
+ .p sash place 1 0 0
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 0} {4 0}}
+test panedwindow-11.13 {move sash in mapped window restricted to visible win} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
+ .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \
+ [frame .f3 -width 20 -height 30]
+ place .p -width 50
+ update
+ .p sash place 1 100 0
+ update
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result {46 0}
+test panedwindow-11.14 {move sash in mapped window restricted to visible win} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
+ .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \
+ [frame .f3 -width 20 -height 30]
+ place .p -width 100
+ update
+ .p sash place 1 200 0
+ update
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result {96 0}
+test panedwindow-11.15 {moving sash into "virtual" space on last pane increases reqsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
+ .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \
+ [frame .f3 -width 20 -height 30]
+ place .p -width 100
+ set result [winfo reqwidth .p]
+ update
+ .p sash place 1 200 0
+ update
+ lappend result [winfo reqwidth .p]
+} -cleanup {
+ deleteWindows
+} -result {68 100}
+
+
+test panedwindow-12.1 {horizontal panedwindow lays out widgets properly} -setup {
+ deleteWindows
+ set result {}
+} -body {
+ panedwindow .p -showhandle false -borderwidth 2 -sashpad 2 -sashwidth 2
+ foreach win {.p.f .p.f2 .p.f3} {.p add [frame $win -width 20 -height 10]}
+ pack .p
+ update
+ foreach w [.p panes] {lappend result [winfo x $w] [winfo y $w]}
+ return $result
+} -cleanup {
+ deleteWindows
+} -result [list 2 2 28 2 54 2]
+test panedwindow-12.2 {vertical panedwindow lays out widgets properly} -setup {
+ deleteWindows
+ set result {}
+} -body {
+ panedwindow .p -showhandle false -borderwidth 2 -sashpad 2 -sashwidth 2 \
+ -orient vertical
+ foreach win {.p.f .p.f2 .p.f3} {.p add [frame $win -width 20 -height 10]}
+ pack .p
+ update
+ foreach w [.p panes] {lappend result [winfo x $w] [winfo y $w]}
+ return $result
+} -cleanup {
+ deleteWindows
+} -result [list 2 2 2 18 2 34]
+test panedwindow-12.3 {horizontal panedwindow lays out widgets properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ foreach {win color} {.p.f blue .p.f2 green} {
+ .p add [frame $win -width 20 -height 20 -bg $color] -padx 10 -pady 5 \
+ -sticky ""
+ }
+ pack .p
+ update
+ set result [list [winfo reqwidth .p] [winfo reqheight .p]]
+ foreach win {.p.f .p.f2} {lappend result [winfo x $win] [winfo y $win]}
+ .p paneconfigure .p.f -padx 0 -pady 0
+ update
+ lappend result [winfo reqwidth .p] [winfo reqheight .p]
+ foreach win {.p.f .p.f2} {lappend result [winfo x $win] [winfo y $win]}
+ return $result
+} -cleanup {
+ deleteWindows
+} -result [list 80 30 10 5 50 5 60 30 0 5 30 5]
+test panedwindow-12.4 {vertical panedwindow lays out widgets properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \
+ -orient vertical
+ foreach win {.p.f .p.f2} {
+ .p add [frame $win -width 20 -height 20] -padx 10 -pady 5 -sticky ""
+ }
+ pack .p
+ update
+ set result [list [winfo reqwidth .p] [winfo reqheight .p]]
+ foreach win {.p.f .p.f2} {lappend result [winfo x $win] [winfo y $win]}
+ .p paneconfigure .p.f -padx 0 -pady 0
+ update
+ lappend result [winfo reqwidth .p] [winfo reqheight .p]
+ foreach win {.p.f .p.f2} {lappend result [winfo x $win] [winfo y $win]}
+ return $result
+} -cleanup {
+ deleteWindows
+} -result [list 40 60 10 5 10 35 40 50 10 0 10 25]
+test panedwindow-12.5 {panedwindow respects reqsize of panes when possible} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -width 20 -height 20] -sticky ""
+ place .p -width 40
+ update
+ set result [list [winfo width .p.f]]
+ .p.f configure -width 30
+ update
+ lappend result [winfo width .p.f]
+} -cleanup {
+ deleteWindows
+} -result [list 20 30]
+test panedwindow-12.6 {panedwindow takes explicit widget width over reqwidth} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -width 20 -height 20] -width 20 -sticky ""
+ place .p -width 40
+ update
+ set result [list [winfo width .p.f]]
+ .p.f configure -width 30
+ update
+ lappend result [winfo width .p.f]
+} -cleanup {
+ deleteWindows
+} -result [list 20 20]
+test panedwindow-12.7 {horizontal panedwindow reqheight is max slave height} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
+ .p add [frame .p.f -width 20 -height 20] [frame .p.f2 -width 20 -height 20]
+ set result [winfo reqheight .p]
+ .p.f config -height 40
+ lappend result [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 40}
+test panedwindow-12.8 {horizontal panedwindow reqheight is max slave height} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
+ foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]}
+ .p paneconfigure .p.f -height 15
+ set result [winfo reqheight .p]
+ .p.f config -height 40
+ lappend result [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+test panedwindow-12.9 {panedwindow pane width overrides widget width} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
+ foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]}
+ .p sash place 0 10 0
+ pack .p
+ update
+ set result [winfo width .p.f]
+ .p paneconfigure .p.f -width 30
+ lappend result [winfo width .p.f]
+} -cleanup {
+ deleteWindows
+} -result [list 10 10]
+test panedwindow-12.10 {panedwindow respects reqsize of panes when possible} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -width 20 -height 20] -sticky ""
+ place .p -height 40
+ update
+ set result [list [winfo height .p.f]]
+ .p.f configure -height 30
+ update
+ lappend result [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result [list 20 30]
+test panedwindow-12.11 {panedwindow takes explicit height over reqheight} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -width 20 -height 20] -height 20 -sticky ""
+ place .p -height 40
+ update
+ set result [list [winfo height .p.f]]
+ .p.f configure -height 30
+ update
+ lappend result [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result [list 20 20]
+test panedwindow-12.12 {vertical panedwindow reqwidth is max slave width} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
+ -orient vertical
+ .p add [frame .p.f -width 20 -height 20] [frame .p.f2 -width 20 -height 20]
+ set result [winfo reqwidth .p]
+ .p.f config -width 40
+ lappend result [winfo reqwidth .p]
+} -cleanup {
+ deleteWindows
+} -result {20 40}
+test panedwindow-12.13 {vertical panedwindow reqwidth is max slave width} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
+ -orient vertical
+ foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]}
+ .p paneconfigure .p.f -width 15
+ set result [winfo reqwidth .p]
+ .p.f config -width 40
+ lappend result [winfo reqwidth .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+test panedwindow-12.14 {panedwindow pane height overrides widget width} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
+ -orient vertical
+ foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]}
+ .p sash place 0 0 10
+ pack .p
+ update
+ set result [winfo height .p.f]
+ .p paneconfigure .p.f -height 30
+ lappend result [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result [list 10 10]
+
+
+test panedwindow-13.1 {PanestructureProc, widget yields managements} -setup {
+ deleteWindows
+} -body {
+ # Check that the panedwindow correctly yields geometry management of
+ # a slave when the slave is destroyed.
+
+ # This test should not cause a core dump, and it should not cause
+ # a memory leak.
+ panedwindow .p
+ .p add [button .b]
+ destroy .p
+ pack .b
+ destroy .b
+ set result ""
+} -result {}
+test panedwindow-13.2 {PanedWindowLostSlaveProc, widget yields management} -setup {
+ deleteWindows
+} -body {
+ # Check that the paned window correctly yields geometry management of
+ # a slave when some other geometry manager steals the slave from us.
+
+ # This test should not cause a core dump, and it should not cause a
+ # memory leak.
+ panedwindow .p
+ .p add [button .b]
+ pack .p
+ update
+ pack .b
+ update
+ set result [.p panes]
+ destroy .p .b
+ set result
+} -result {}
+
+
+test panedwindow-14.1 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky n
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {n}
+test panedwindow-14.2 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky s
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {s}
+test panedwindow-14.3 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky e
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {e}
+test panedwindow-14.4 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky w
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {w}
+test panedwindow-14.5 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky sn
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {ns}
+test panedwindow-14.6 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky ns
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {ns}
+test panedwindow-14.7 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky en
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {ne}
+test panedwindow-14.8 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky ne
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {ne}
+test panedwindow-14.9 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky wn
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {nw}
+test panedwindow-14.10 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky nw
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {nw}
+test panedwindow-14.11 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky esn
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {nes}
+test panedwindow-14.12 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky nse
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {nes}
+test panedwindow-14.13 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky nsw
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {nsw}
+test panedwindow-14.14 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky nsew
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {nesw}
+test panedwindow-14.15 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky ""
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test panedwindow-15.1 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky {}
+ place .p -width 40 -height 40
+ update
+ list {} [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {{} 10 10 20 20}
+test panedwindow-15.2 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky n
+ place .p -width 40 -height 40
+ update
+ list n [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {n 10 0 20 20}
+test panedwindow-15.3 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky s
+ place .p -width 40 -height 40
+ update
+ list s [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {s 10 20 20 20}
+test panedwindow-15.4 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky e
+ place .p -width 40 -height 40
+ update
+ list e [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {e 20 10 20 20}
+test panedwindow-15.5 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky w
+ place .p -width 40 -height 40
+ update
+ list w [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {w 0 10 20 20}
+test panedwindow-15.6 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky ns
+ place .p -width 40 -height 40
+ update
+ list ns [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {ns 10 0 20 40}
+test panedwindow-15.7 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky ew
+ place .p -width 40 -height 40
+ update
+ list ew [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {ew 0 10 40 20}
+test panedwindow-15.8 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky nw
+ place .p -width 40 -height 40
+ update
+ list nw [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {nw 0 0 20 20}
+test panedwindow-15.9 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky ne
+ place .p -width 40 -height 40
+ update
+ list ne [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {ne 20 0 20 20}
+test panedwindow-15.10 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky se
+ place .p -width 40 -height 40
+ update
+ list se [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {se 20 20 20 20}
+test panedwindow-15.11 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky sw
+ place .p -width 40 -height 40
+ update
+ list sw [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {sw 0 20 20 20}
+test panedwindow-15.12 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky nse
+ place .p -width 40 -height 40
+ update
+ list nse [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {nse 20 0 20 40}
+test panedwindow-15.13 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky nsw
+ place .p -width 40 -height 40
+ update
+ list nsw [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {nsw 0 0 20 40}
+test panedwindow-15.14 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky sew
+ place .p -width 40 -height 40
+ update
+ list sew [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {sew 0 20 40 20}
+test panedwindow-15.15 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky new
+ place .p -width 40 -height 40
+ update
+ list new [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {new 0 0 40 20}
+test panedwindow-15.16 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky news
+ place .p -width 40 -height 40
+ update
+ list news [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {news 0 0 40 40}
+
+
+test panedwindow-16.1 {setting minsize when pane is too small snaps width} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ .p add [frame .p.f -height 20 -width 20 -bg red]
+ set result [winfo reqwidth .p]
+ .p paneconfigure .p.f -minsize 40
+ lappend result [winfo reqwidth .p]
+} -cleanup {
+ deleteWindows
+} -result [list 20 40]
+
+
+test panedwindow-17.1 {MoveSash, move right} -setup {
+ deleteWindows
+ set result {}
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ # Get the requested width of the paned window
+ lappend result [winfo reqwidth .p]
+
+ .p sash place 0 30 0
+
+ # Get the reqwidth again, to make sure it hasn't changed
+ lappend result [winfo reqwidth .p]
+
+ # Check that the sash moved
+ lappend result [.p sash coord 0]
+} -cleanup {
+ deleteWindows
+} -result [list 42 42 {30 0}]
+test panedwindow-17.2 {MoveSash, move right (unmapped) clipped by reqwidth} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ .p sash place 0 100 0
+
+ # Get the new sash coord; it should be clipped by the reqwidth of
+ # the panedwindow.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 40 0]
+test panedwindow-17.3 {MoveSash, move right (mapped, width < reqwidth) clipped by width} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ # Put the panedwindow up on the display and give it a width < reqwidth
+ place .p -x 0 -y 0 -width 32
+ update
+
+ .p sash place 0 100 0
+
+ # Get the new sash coord; it should be clipped by the visible width of
+ # the panedwindow.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 30 0]
+test panedwindow-17.4 {MoveSash, move right (mapped, width > reqwidth) clipped by width} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ # Put the panedwindow up on the display and give it a width > reqwidth
+ place .p -x 0 -y 0 -width 102
+ update
+
+ .p sash place 0 200 0
+
+ # Get the new sash coord; it should be clipped by the visible width of
+ # the panedwindow.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 100 0]
+test panedwindow-17.5 {MoveSash, move right respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ }
+
+ .p sash place 0 100 0
+
+ # Get the new sash coord; it should have moved as far as possible while
+ # respecting minsizes.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 30 0]
+test panedwindow-17.6 {MoveSash, move right respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ }
+
+ .p sash place 0 100 0
+
+ # Get the new sash coord; it should have moved as far as possible.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 40 0]
+test panedwindow-17.7 {MoveSash, move right pushes other sashes} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ .p sash place 0 100 0
+
+ # Get the new sash coord; it should have moved as far as possible while
+ # respecting minsizes.
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 62 0]
+test panedwindow-17.8 {MoveSash, move right pushes other sashes, respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ }
+
+ .p sash place 0 100 0
+
+ # Get the new sash coord; it should have moved as far as possible while
+ # respecting minsizes.
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 52 0]
+test panedwindow-17.9 {MoveSash, move right respects minsize, exludes pad} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize 10 -padx 5
+ }
+
+ .p sash place 0 100 0
+
+ # Get the new sash coord; it should have moved as far as possible,
+ # respecting minsizes.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 50 0]
+test panedwindow-17.10 {MoveSash, move right, negative minsize becomes 0} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize -50
+ }
+
+ .p sash place 0 50 0
+
+ # Get the new sash coord; it should have moved as far as possible,
+ # respecting minsizes.
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result [list [list 50 0] [list 52 0]]
+test panedwindow-17.11 {MoveSash, move left} -setup {
+ deleteWindows
+} -body {
+ set result {}
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ # Get the requested width of the paned window
+ lappend result [winfo reqwidth .p]
+
+ .p sash place 0 10 0
+
+ # Get the reqwidth again, to make sure it hasn't changed
+ lappend result [winfo reqwidth .p]
+
+ # Check that the sash moved
+ lappend result [.p sash coord 0]
+} -cleanup {
+ deleteWindows
+} -result [list 42 42 {10 0}]
+test panedwindow-17.12 {MoveSash, move left, can't move outside of window} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ .p sash place 0 -100 0
+
+ # Get the new sash coord; it should be clipped by the reqwidth of
+ # the panedwindow.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 0]
+test panedwindow-17.13 {MoveSash, move left respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ }
+
+ .p sash place 0 0 0
+
+ # Get the new sash coord; it should have moved as far as possible while
+ # respecting minsizes.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 10 0]
+test panedwindow-17.14 {MoveSash, move left respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ }
+
+ .p sash place 1 0 0
+
+ # Get the new sash coord; it should have moved as far as possible.
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 22 0]
+test panedwindow-17.15 {MoveSash, move left pushes other sashes} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ .p sash place 1 0 0
+
+ # Get the new sash coord; it should have moved as far as possible while
+ # respecting minsizes.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 0]
+test panedwindow-17.16 {MoveSash, move left pushes other sashes, respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ }
+
+ .p sash place 1 0 0
+
+ # Get the new sash coord; it should have moved as far as possible while
+ # respecting minsizes.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 10 0]
+test panedwindow-17.17 {MoveSash, move left respects minsize, exludes pad} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize 10 -padx 5
+ }
+
+ .p sash place 1 0 0
+
+ # Get the new sash coord; it should have moved as far as possible,
+ # respecting minsizes.
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 42 0]
+test panedwindow-17.18 {MoveSash, move left, negative minsize becomes 0} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ foreach w {.f1 .f2 .f3} c {red blue green} {
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize -50
+ }
+
+ .p sash place 1 10 0
+
+ # Get the new sash coord; it should have moved as far as possible,
+ # respecting minsizes.
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result [list [list 8 0] [list 10 0]]
+
+
+test panedwindow-18.1 {MoveSash, move down} -setup {
+ deleteWindows
+} -body {
+ set result {}
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ # Get the requested width of the paned window
+ lappend result [winfo reqheight .p]
+
+ .p sash place 0 0 30
+
+ # Get the reqwidth again, to make sure it hasn't changed
+ lappend result [winfo reqheight .p]
+
+ # Check that the sash moved
+ lappend result [.p sash coord 0]
+} -cleanup {
+ deleteWindows
+} -result [list 42 42 {0 30}]
+test panedwindow-18.2 {MoveSash, move down (unmapped) clipped by reqheight} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ .p sash place 0 0 100
+
+ # Get the new sash coord; it should be clipped by the reqheight of
+ # the panedwindow.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 40]
+test panedwindow-18.3 {MoveSash, move down (mapped, height < reqheight) clipped by height} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ # Put the panedwindow up on the display and give it a height < reqheight
+ place .p -x 0 -y 0 -height 32
+ update
+
+ .p sash place 0 0 100
+
+ # Get the new sash coord; it should be clipped by the visible height of
+ # the panedwindow.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 30]
+test panedwindow-18.4 {MoveSash, move down (mapped, height > reqheight) clipped by height} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ # Put the panedwindow up on the display and give it a width > reqwidth
+ place .p -x 0 -y 0 -height 102
+ update
+
+ .p sash place 0 0 200
+
+ # Get the new sash coord; it should be clipped by the visible width of
+ # the panedwindow.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 100]
+test panedwindow-18.5 {MoveSash, move down respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ }
+
+ .p sash place 0 0 100
+
+ # Get the new sash coord; it should have moved as far as possible while
+ # respecting minsizes.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 30]
+test panedwindow-18.6 {MoveSash, move down respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ }
+
+ .p sash place 0 0 100
+
+ # Get the new sash coord; it should have moved as far as possible while
+ # respecting minsizes.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 40]
+test panedwindow-18.7 {MoveSash, move down pushes other sashes} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ .p sash place 0 0 100
+
+ # Get the new sash coord; it should have moved as far as possible while
+ # respecting minsizes.
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 0 62]
+test panedwindow-18.8 {MoveSash, move down pushes other sashes, respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ }
+
+ .p sash place 0 0 100
+
+ # Get the new sash coord; it should have moved as far as possible while
+ # respecting minsizes.
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 0 52]
+test panedwindow-18.9 {MoveSash, move down respects minsize, exludes pad} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize 10 -pady 5
+ }
+
+ .p sash place 0 0 100
+
+ # Get the new sash coord; it should have moved as far as possible,
+ # respecting minsizes.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 50]
+test panedwindow-18.10 {MoveSash, move right, negative minsize becomes 0} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize -50
+ }
+
+ .p sash place 0 0 50
+
+ # Get the new sash coord; it should have moved as far as possible,
+ # respecting minsizes.
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result [list [list 0 50] [list 0 52]]
+test panedwindow-18.11 {MoveSash, move up} -setup {
+ deleteWindows
+} -body {
+ set result {}
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ # Get the requested width of the paned window
+ lappend result [winfo reqheight .p]
+
+ .p sash place 0 0 10
+
+ # Get the reqwidth again, to make sure it hasn't changed
+ lappend result [winfo reqheight .p]
+
+ # Check that the sash moved
+ lappend result [.p sash coord 0]
+} -cleanup {
+ deleteWindows
+} -result [list 42 42 {0 10}]
+test panedwindow-18.12 {MoveSash, move up, can't move outside of window} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ .p sash place 0 0 -100
+
+ # Get the new sash coord; it should be clipped by the reqwidth of
+ # the panedwindow.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 0]
+test panedwindow-18.13 {MoveSash, move up respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ }
+
+ .p sash place 0 0 0
+
+ # Get the new sash coord; it should have moved as far as possible while
+ # respecting minsizes.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 10]
+test panedwindow-18.14 {MoveSash, move up respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ }
+
+ .p sash place 1 0 0
+
+ # Get the new sash coord; it should have moved as far as possible.
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 0 22]
+test panedwindow-18.15 {MoveSash, move up pushes other sashes} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ }
+
+ .p sash place 1 0 0
+
+ # Get the new sash coord; it should have moved as far as possible while
+ # respecting minsizes.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 0]
+test panedwindow-18.16 {MoveSash, move up pushes other sashes, respects minsize} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ }
+
+ .p sash place 1 0 0
+
+ # Get the new sash coord; it should have moved as far as possible while
+ # respecting minsizes.
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 10]
+test panedwindow-18.17 {MoveSash, move up respects minsize, exludes pad} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} c {red blue} {
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize 10 -pady 5
+ }
+
+ .p sash place 1 0 0
+
+ # Get the new sash coord; it should have moved as far as possible,
+ # respecting minsizes.
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 0 42]
+test panedwindow-18.18 {MoveSash, move up, negative minsize becomes 0} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} c {red blue green} {
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize -50
+ }
+
+ .p sash place 1 0 10
+
+ # Get the new sash coord; it should have moved as far as possible,
+ # respecting minsizes.
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result [list [list 0 8] [list 0 10]]
+
+
+# The following tests check that the panedwindow is correctly computing its
+# geometry based on the various configuration options that can affect the
+# geometry.
+
+test panedwindow-19.1 {ComputeGeometry, reqheight taken from widgets} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue]
+ }
+ set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]]
+ .f3 configure -height 40
+ lappend result [list [winfo reqwidth .p] [winfo reqheight .p]]
+} -cleanup {
+ deleteWindows
+} -result [list [list 60 20] [list 60 40]]
+
+test panedwindow-19.2 {ComputeGeometry, reqheight taken from widgets} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue]
+ }
+ set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]]
+ .p paneconfigure .f3 -height 40
+ lappend result [list [winfo reqwidth .p] [winfo reqheight .p]]
+} -cleanup {
+ deleteWindows
+} -result [list [list 60 20] [list 60 40]]
+
+test panedwindow-19.3 {ComputeGeometry, reqheight taken from widgets} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -pady 20
+ }
+ set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]]
+ .p paneconfigure .f3 -height 40
+ lappend result [list [winfo reqwidth .p] [winfo reqheight .p]]
+} -cleanup {
+ deleteWindows
+} -result [list [list 60 60] [list 60 80]]
+
+test panedwindow-19.4 {ComputeGeometry, reqwidth taken from widgets} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue]
+ }
+ set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]]
+ .f3 configure -width 40
+ lappend result [list [winfo reqwidth .p] [winfo reqheight .p]]
+} -cleanup {
+ deleteWindows
+} -result [list [list 20 60] [list 40 60]]
+
+test panedwindow-19.5 {ComputeGeometry, reqwidth taken from widgets} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue]
+ }
+ set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]]
+ .p paneconfigure .f3 -width 40
+ lappend result [list [winfo reqwidth .p] [winfo reqheight .p]]
+} -cleanup {
+ deleteWindows
+} -result [list [list 20 60] [list 40 60]]
+
+test panedwindow-19.6 {ComputeGeometry, reqwidth taken from widgets} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -padx 20
+ }
+ set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]]
+ .p paneconfigure .f3 -width 40
+ lappend result [list [winfo reqwidth .p] [winfo reqheight .p]]
+} -cleanup {
+ deleteWindows
+} -result [list [list 60 60] [list 80 60]]
+
+test panedwindow-19.7 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.8 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {60 20}
+
+test panedwindow-19.9 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{20 0} {40 0}}
+
+test panedwindow-19.10 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {53 3 20 20} {95 3 20 20}}
+
+test panedwindow-19.11 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.12 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 60}
+
+test panedwindow-19.13 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 20} {0 40}}
+
+test panedwindow-19.14 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 53 20 20} {3 95 20 20}}
+test panedwindow-19.15 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {22 20}
+
+test panedwindow-19.16 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {72 20}
+
+test panedwindow-19.17 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{23 0} {49 0}}
+
+test panedwindow-19.18 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {59 3 20 20} {107 3 20 20}}
+
+test panedwindow-19.19 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 22}
+
+test panedwindow-19.20 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 72}
+
+test panedwindow-19.21 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 23} {0 49}}
+
+test panedwindow-19.22 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 59 20 20} {3 107 20 20}}
+test panedwindow-19.23 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.24 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {66 20}
+
+test panedwindow-19.25 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{20 0} {43 0}}
+
+test panedwindow-19.26 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {56 3 20 20} {101 3 20 20}}
+
+test panedwindow-19.27 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.28 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 66}
+
+test panedwindow-19.29 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 20} {0 43}}
+
+test panedwindow-19.30 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 56 20 20} {3 101 20 20}}
+test panedwindow-19.31 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {22 20}
+
+test panedwindow-19.32 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {72 20}
+
+test panedwindow-19.33 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{21 0} {47 0}}
+
+test panedwindow-19.34 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {59 3 20 20} {107 3 20 20}}
+
+test panedwindow-19.35 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 22}
+
+test panedwindow-19.36 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 72}
+
+test panedwindow-19.37 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 21} {0 47}}
+
+test panedwindow-19.38 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 59 20 20} {3 107 20 20}}
+test panedwindow-19.39 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.40 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {80 20}
+
+test panedwindow-19.41 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{25 0} {55 0}}
+
+test panedwindow-19.42 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {63 3 20 20} {115 3 20 20}}
+
+test panedwindow-19.43 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.44 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 80}
+
+test panedwindow-19.45 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 25} {0 55}}
+
+test panedwindow-19.46 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 63 20 20} {3 115 20 20}}
+test panedwindow-19.47 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {22 20}
+
+test panedwindow-19.48 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {92 20}
+
+test panedwindow-19.49 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{28 0} {64 0}}
+
+test panedwindow-19.50 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {69 3 20 20} {127 3 20 20}}
+
+test panedwindow-19.51 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 22}
+
+test panedwindow-19.52 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 92}
+
+test panedwindow-19.53 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 28} {0 64}}
+
+test panedwindow-19.54 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 69 20 20} {3 127 20 20}}
+test panedwindow-19.55 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.56 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {86 20}
+
+test panedwindow-19.57 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{25 0} {58 0}}
+
+test panedwindow-19.58 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {66 3 20 20} {121 3 20 20}}
+
+test panedwindow-19.59 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.60 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 86}
+
+test panedwindow-19.61 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 25} {0 58}}
+
+test panedwindow-19.62 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 66 20 20} {3 121 20 20}}
+test panedwindow-19.63 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {22 20}
+
+test panedwindow-19.64 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {92 20}
+
+test panedwindow-19.65 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{26 0} {62 0}}
+
+test panedwindow-19.66 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {69 3 20 20} {127 3 20 20}}
+
+test panedwindow-19.67 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 22}
+
+test panedwindow-19.68 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 92}
+
+test panedwindow-19.69 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 26} {0 62}}
+
+test panedwindow-19.70 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 69 20 20} {3 127 20 20}}
+test panedwindow-19.71 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.72 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {64 24}
+
+test panedwindow-19.73 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{22 2} {42 2}}
+
+test panedwindow-19.74 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {55 5 20 20} {97 5 20 20}}
+
+test panedwindow-19.75 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.76 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 64}
+
+test panedwindow-19.77 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 22} {2 42}}
+
+test panedwindow-19.78 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 55 20 20} {5 97 20 20}}
+test panedwindow-19.79 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {26 24}
+
+test panedwindow-19.80 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {76 24}
+
+test panedwindow-19.81 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{25 2} {51 2}}
+
+test panedwindow-19.82 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {61 5 20 20} {109 5 20 20}}
+
+test panedwindow-19.83 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 26}
+
+test panedwindow-19.84 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 76}
+
+test panedwindow-19.85 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 25} {2 51}}
+
+test panedwindow-19.86 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 61 20 20} {5 109 20 20}}
+test panedwindow-19.87 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.88 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {70 24}
+
+test panedwindow-19.89 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{22 2} {45 2}}
+
+test panedwindow-19.90 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {58 5 20 20} {103 5 20 20}}
+
+test panedwindow-19.91 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.92 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 70}
+
+test panedwindow-19.93 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 22} {2 45}}
+
+test panedwindow-19.94 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 58 20 20} {5 103 20 20}}
+test panedwindow-19.95 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {26 24}
+
+test panedwindow-19.96 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {76 24}
+
+test panedwindow-19.97 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{23 2} {49 2}}
+
+test panedwindow-19.98 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {61 5 20 20} {109 5 20 20}}
+
+test panedwindow-19.99 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 26}
+
+test panedwindow-19.100 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 76}
+
+test panedwindow-19.101 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 23} {2 49}}
+
+test panedwindow-19.102 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 61 20 20} {5 109 20 20}}
+test panedwindow-19.103 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.104 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {84 24}
+
+test panedwindow-19.105 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{27 2} {57 2}}
+
+test panedwindow-19.106 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {65 5 20 20} {117 5 20 20}}
+
+test panedwindow-19.107 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.108 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 84}
+
+test panedwindow-19.109 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 27} {2 57}}
+
+test panedwindow-19.110 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 65 20 20} {5 117 20 20}}
+test panedwindow-19.111 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {26 24}
+
+test panedwindow-19.112 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {96 24}
+
+test panedwindow-19.113 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{30 2} {66 2}}
+
+test panedwindow-19.114 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {71 5 20 20} {129 5 20 20}}
+
+test panedwindow-19.115 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 26}
+
+test panedwindow-19.116 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 96}
+
+test panedwindow-19.117 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 30} {2 66}}
+
+test panedwindow-19.118 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 71 20 20} {5 129 20 20}}
+test panedwindow-19.119 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.120 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {90 24}
+
+test panedwindow-19.121 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{27 2} {60 2}}
+
+test panedwindow-19.122 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {68 5 20 20} {123 5 20 20}}
+
+test panedwindow-19.123 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.124 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 90}
+
+test panedwindow-19.125 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 27} {2 60}}
+
+test panedwindow-19.126 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 68 20 20} {5 123 20 20}}
+test panedwindow-19.127 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {26 24}
+
+test panedwindow-19.128 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {96 24}
+
+test panedwindow-19.129 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{28 2} {64 2}}
+
+test panedwindow-19.130 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {71 5 20 20} {129 5 20 20}}
+
+test panedwindow-19.131 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 26}
+
+test panedwindow-19.132 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 96}
+
+test panedwindow-19.133 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 28} {2 64}}
+
+test panedwindow-19.134 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 71 20 20} {5 129 20 20}}
+
+
+test panedwindow-20.1 {destroyed widgets are removed from panedwindow} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [frame .f -width 20 -height 20 -bg blue]
+ destroy .f
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-20.2 {destroyed slave causes geometry recomputation} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 2
+ .p add [frame .f -width 20 -height 20 -bg blue] \
+ [frame .f2 -width 20 -height 20 -bg red]
+ destroy .f
+ winfo reqwidth .p
+} -cleanup {
+ deleteWindows
+} -result 20
+
+
+test panedwindow-21.1 {ArrangePanes, extra space is given to the last pane} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ .p add [frame .f1 -width 20 -height 20 -bg blue] \
+ [frame .f2 -width 20 -height 20 -bg red] -sticky nsew
+ place .p -width 100 -x 0 -y 0
+ update
+ winfo width .f2
+} -cleanup {
+ deleteWindows
+} -result 78
+test panedwindow-21.2 {ArrangePanes, extra space is given to the last pane} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ .p add [frame .f1 -width 20 -height 20 -bg blue] \
+ [frame .f2 -width 20 -height 20 -bg red] -sticky nsew
+ place .p -height 100 -x 0 -y 0
+ update
+ winfo height .f2
+} -cleanup {
+ deleteWindows
+} -result 78
+test panedwindow-21.3 {ArrangePanes, explicit height/width are preferred} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ .p add [frame .f1 -width 20 -height 20 -bg blue] \
+ [frame .f2 -width 20 -height 20 -bg red] -sticky ""
+ .p paneconfigure .f1 -width 10 -height 15
+ pack .p
+ update
+ list [winfo width .f1] [winfo height .f1]
+} -cleanup {
+ deleteWindows
+} -result {10 15}
+test panedwindow-21.4 {ArrangePanes, panes clipped by size of pane} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ .p add [frame .f1 -width 20 -height 20 -bg blue] \
+ [frame .f2 -width 20 -height 20 -bg red]
+ .p sash place 0 10 0
+ pack .p
+ update
+ list [winfo width .f1] [winfo height .f1]
+} -cleanup {
+ deleteWindows
+} -result {10 20}
+test panedwindow-21.5 {ArrangePanes, panes clipped by size of pane} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ .p add [frame .f1 -width 20 -height 20 -bg blue] \
+ [frame .f2 -width 20 -height 20 -bg red]
+ .p sash place 0 0 10
+ pack .p
+ update
+ list [winfo width .f1] [winfo height .f1]
+} -cleanup {
+ deleteWindows
+} -result {20 10}
+test panedwindow-21.6 {ArrangePanes, height of pane taken from total height} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ .p add [frame .p.f1 -width 20 -height 20 -bg blue] \
+ [frame .p.f2 -width 20 -height 40 -bg red] -sticky ""
+ pack .p
+ update
+ winfo y .p.f1
+} -cleanup {
+ deleteWindows
+} -result 10
+test panedwindow-21.7 {ArrangePanes, width of pane taken from total width} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ .p add [frame .p.f1 -width 20 -height 20 -bg blue] \
+ [frame .p.f2 -width 40 -height 40 -bg red] -sticky ""
+ pack .p
+ update
+ winfo x .p.f1
+} -cleanup {
+ deleteWindows
+} -result 10
+test panedwindow-21.8 {ArrangePanes, panes with width <= 0 are unmapped} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ .p add [frame .f1 -width 20 -height 20 -bg blue] \
+ [frame .f2 -width 20 -height 40 -bg red]
+ pack .p
+ update
+ set result [winfo ismapped .f1]
+ .p sash place 0 0 0
+ update
+ lappend result [winfo ismapped .f1]
+} -cleanup {
+ deleteWindows
+} -result {1 0}
+test panedwindow-21.9 {ArrangePanes, panes with width <= 0 are unmapped} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ .p add [frame .p.f1 -width 20 -height 20 -bg blue] \
+ [frame .p.f2 -width 20 -height 40 -bg red]
+ pack .p
+ update
+ set result [winfo ismapped .p.f1]
+ .p sash place 0 0 0
+ update
+ lappend result [winfo ismapped .p.f1]
+} -cleanup {
+ deleteWindows
+} -result {1 0}
+test panedwindow-21.10 {ArrangePanes, panes with width <= 0 are unmapped} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 -orient vertical
+ .p add [frame .p.f1 -width 20 -height 20 -bg blue] \
+ [frame .p.f2 -width 20 -height 40 -bg red]
+ pack .p
+ update
+ set result [winfo ismapped .p.f1]
+ .p sash place 0 0 0
+ update
+ lappend result [winfo ismapped .p.f1]
+} -cleanup {
+ deleteWindows
+} -result {1 0}
+test panedwindow-21.11 {ArrangePanes, last pane shrinks} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
+ .p add [frame .f1 -width 20 -height 20 -bg blue] \
+ [frame .f2 -width 20 -height 20 -bg red] -sticky nsew
+ place .p -width 40 -x 0 -y 0
+ update
+ winfo width .f2
+} -cleanup {
+ deleteWindows
+} -result 18
+test panedwindow-21.12 {ArrangePanes, last pane shrinks} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
+ -orient vertical
+ .p add [frame .f1 -width 20 -height 20 -bg blue] \
+ [frame .f2 -width 20 -height 20 -bg red] -sticky nsew
+ place .p -height 40 -x 0 -y 0
+ update
+ winfo height .f2
+} -cleanup {
+ deleteWindows
+} -result 18
+test panedwindow-21.13 {ArrangePanes, panedwindow resizes} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -width 200 -borderwidth 0
+ frame .f1 -height 50 -bg blue
+ set result [list]
+ lappend result [winfo reqwidth .p] [winfo reqheight .p]
+ .p add .f1
+ pack .p
+ lappend result [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {200 1 200 50}
+test panedwindow-21.14 {ArrangePanes, panedwindow resizes} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -height 200 -borderwidth 0 -orient vertical
+ frame .f1 -width 50 -bg blue
+ set result [list]
+ lappend result [winfo reqwidth .p] [winfo reqheight .p]
+ .p add .f1
+ pack .p
+ lappend result [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {1 200 50 200}
+test panedwindow-21.15 {ArrangePanes, last pane grows} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -height 50
+ .p add [frame .f1 -width 50 -bg red] [frame .f2 -width 50 -bg white] \
+ [frame .f3 -width 50 -bg blue] [frame .f4 -width 50 -bg green]
+ .p sash place 1 250 0
+ pack .p
+ update
+ set result [list]
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4] [winfo width .p]
+ .p configure -width 300
+ update
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4] [winfo width .p]
+} -cleanup {
+ deleteWindows
+} -result {50 150 1 1 211 50 150 1 89 300}
+
+
+test panedwindow-22.1 {PanedWindowReqProc, react to slave geometry changes} -setup {
+ deleteWindows
+} -body {
+ # Basically just want to make sure that the PanedWindowReqProc is called
+ panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 2
+ .p add [frame .f1 -width 20 -height 20 -bg blue] \
+ [frame .f2 -width 20 -height 40 -bg red]
+ set result [winfo reqheight .p]
+ .f1 configure -height 80
+ lappend result [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {40 80}
+test panedwindow-22.2 {PanedWindowReqProc, react to slave geometry changes} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -orient horizontal -sashpad 0 -sashwidth 2
+ .p add [frame .f1 -width 10] [frame .f2 -width 10]
+ set result [winfo reqwidth .p]
+ .f1 configure -width 20
+ lappend result [winfo reqwidth .p]
+ destroy .p .f1 .f2
+ expr {[lindex $result 1] - [lindex $result 0]}
+} -cleanup {
+ deleteWindows
+} -result {10}
+
+
+test panedwindow-23.1 {ConfigurePanes, can't add panedwindow to itself} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add .p
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't add .p to itself}
+test panedwindow-23.2 {ConfigurePanes, bad window throws error} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add .b
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad window path name ".b"}
+test panedwindow-23.3 {ConfigurePanes, bad window aborts processing} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .b
+ catch {.p add .b .a}
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-23.4 {ConfigurePanes, bad option aborts processing} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .b
+ catch {.p add .b -sticky foobar}
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-23.5 {ConfigurePanes, after win isn't managed by panedwin} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .b
+ button .c
+ .p add .b -after .c
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {window ".c" is not managed by .p}
+test panedwindow-23.6 {ConfigurePanes, before win isn't managed by panedwin} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .b
+ button .c
+ .p add .b -before .c
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {window ".c" is not managed by .p}
+test panedwindow-23.7 {ConfigurePanes, -after {} is a no-op} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b] [button .c]
+ .p paneconfigure .b -after {}
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.b .c}
+test panedwindow-23.8 {ConfigurePanes, -before {} is a no-op} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b] [button .c]
+ .p paneconfigure .b -before {}
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.b .c}
+test panedwindow-23.9 {ConfigurePanes, new panes are added} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b] [button .c]
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.b .c}
+test panedwindow-23.10 {ConfigurePanes, options applied to all panes} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b] [button .c] -sticky ne -height 5 -width 5 -minsize 10
+ set result {}
+ foreach w {.b .c} {
+ set val {}
+ foreach option {-sticky -height -width -minsize} {
+ lappend val $option [.p panecget $w $option]
+ }
+ lappend result $w $val
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {.b {-sticky ne -height 5 -width 5 -minsize 10} .c {-sticky ne -height 5 -width 5 -minsize 10}}
+
+test panedwindow-23.11 {ConfigurePanes, existing panes are reconfigured} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b] -sticky nw -height 10
+ .p add .b [button .c] -sticky se -height 2
+ list [.p panes] [.p panecget .b -sticky] [.p panecget .b -height] \
+ [.p panecget .c -sticky] [.p panecget .c -height]
+} -cleanup {
+ deleteWindows
+} -result [list {.b .c} es 2 es 2]
+test panedwindow-23.12 {ConfigurePanes, widgets added to end by default} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p add [button .b]
+ .p add [button .c]
+ .p add [button .d]
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.b .c .d}
+test panedwindow-23.13 {ConfigurePanes, -after, single addition} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .a
+ button .b
+ button .c
+
+ .p add .a .b
+ .p add .c -after .a
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.a .c .b}
+test panedwindow-23.14 {ConfigurePanes, -after, multiple additions} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .a
+ button .b
+ button .c
+ button .d
+
+ .p add .a .b
+ .p add .c .d -after .a
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.a .c .d .b}
+test panedwindow-23.15 {ConfigurePanes, -after, relocates existing widget} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .a
+ button .b
+ button .c
+ button .d
+
+ .p add .a .b .c .d
+ .p add .d -after .a
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.a .d .b .c}
+test panedwindow-23.16 {ConfigurePanes, -after, relocates existing widgets} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .a
+ button .b
+ button .c
+ button .d
+
+ .p add .a .b .c .d
+ .p add .b .d -after .a
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.a .b .d .c}
+test panedwindow-23.17 {ConfigurePanes, -after, relocates existing widgets} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .a
+ button .b
+ button .c
+ button .d
+
+ .p add .a .b .c .d
+ .p add .d .a -after .b
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.b .d .a .c}
+test panedwindow-23.18 {ConfigurePanes, -after, relocates existing widgets} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .a
+ button .b
+ button .c
+ button .d
+
+ .p add .a .b .c .d
+ .p add .d .a -after .a
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.d .a .b .c}
+test panedwindow-23.19 {ConfigurePanes, -after, after last window} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .a
+ button .b
+ button .c
+ button .d
+
+ .p add .a .b .c
+ .p add .d -after .c
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.a .b .c .d}
+test panedwindow-23.20 {ConfigurePanes, -before, before first window} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .a
+ button .b
+ button .c
+ button .d
+
+ .p add .a .b .c
+ .p add .d -before .a
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.d .a .b .c}
+test panedwindow-23.21 {ConfigurePanes, -before, relocate existing windows} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .a
+ button .b
+ button .c
+ button .d
+
+ .p add .a .b .c
+ .p add .d .b -before .a
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.d .b .a .c}
+test panedwindow-23.22 {ConfigurePanes, slave specified multiple times} -setup {
+ deleteWindows
+} -body {
+ # This test should not cause a core dump
+
+ panedwindow .p
+ button .a
+ button .b
+ button .c
+
+ .p add .a .a .b .c
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.a .b .c}
+test panedwindow-23.23 {ConfigurePanes, slave specified multiple times} -setup {
+ deleteWindows
+} -body {
+ # This test should not cause a core dump
+
+ panedwindow .p
+ button .a
+ button .b
+ button .c
+
+ .p add .a .a .b .c
+ .p add .a .b .a -after .c
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.c .a .b}
+test panedwindow-23.24 {ConfigurePanes, panedwindow cannot manage toplevels} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ toplevel .t
+ .p add .t
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't add toplevel .t to .p}
+test panedwindow-23.25 {ConfigurePanes, restrict possible panes} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ frame .f
+ button .f.b
+ .p add .f.b
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't add .f.b to .p}
+test panedwindow-23.26 {ConfigurePanes, restrict possible panes} -setup {
+ deleteWindows
+} -body {
+ frame .f
+ panedwindow .f.p
+ button .b
+ .f.p add .b
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-23.27 {ConfigurePanes, restrict possible panes} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ button .p.b
+ .p add .p.b
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-23.28 {ConfigurePanes, restrict possible panes} -setup {
+ deleteWindows
+} -body {
+ frame .f
+ frame .f.f
+ frame .f.f.f
+ panedwindow .f.f.f.p
+ button .b
+ .f.f.f.p add .b
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-23.29 {ConfigurePanes, -hide works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ frame .f1 -width 40 -height 100 -bg red
+ frame .f2 -width 40 -height 100 -bg white
+ frame .f3 -width 40 -height 100 -bg blue
+ frame .f4 -width 40 -height 100 -bg green
+ .p add .f1 .f2 .f3 .f4
+ pack .p
+ update
+ set result [list]
+ lappend result [winfo ismapped .f1] [winfo ismapped .f2] \
+ [winfo ismapped .f3] [winfo ismapped .f4]
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4] [winfo width .p]
+ .p paneconfigure .f2 -hide 1
+ update
+ lappend result [winfo ismapped .f1] [winfo ismapped .f2] \
+ [winfo ismapped .f3] [winfo ismapped .f4]
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4] [winfo width .p]
+} -cleanup {
+ deleteWindows
+} -result {1 1 1 1 40 40 40 40 171 1 0 1 1 40 40 40 40 128}
+test panedwindow-23.30 {ConfigurePanes, -hide works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -width 130 -height 100
+ frame .f1 -width 40 -bg red
+ frame .f2 -width 40 -bg white
+ frame .f3 -width 40 -bg blue
+ frame .f4 -width 40 -bg green
+ .p add .f1 .f2 .f3 .f4
+ pack .p
+ update
+ set result [list]
+ lappend result [winfo ismapped .f1] [winfo ismapped .f2] \
+ [winfo ismapped .f3] [winfo ismapped .f4]
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4] [winfo width .p]
+ .p paneconfigure .f2 -hide 1
+ update
+ lappend result [winfo ismapped .f1] [winfo ismapped .f2] \
+ [winfo ismapped .f3] [winfo ismapped .f4]
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4] [winfo width .p]
+} -cleanup {
+ deleteWindows
+} -result {1 1 1 0 39 40 40 1 130 1 0 1 1 40 40 40 42 130}
+test panedwindow-23.30a {ConfigurePanes, hidden panes are unmapped} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p1 -sashrelief raised
+ panedwindow .p2 -sashrelief raised
+ label .l1 -text Label1
+ label .l2 -text Label2
+ label .l3 -text Label3
+ .p2 add .l2 -sticky nsew
+ .p2 add .l3 -sticky nsew
+ .p1 add .p2 -sticky nsew
+ .p1 add .l1 -sticky nsew
+ pack .p1 -side top -expand 1 -fill both
+ update
+ set result [list]
+ lappend result [list [winfo ismapped .p1] [winfo ismapped .p2] \
+ [winfo ismapped .l1] [winfo ismapped .l2] [winfo ismapped .l3]]
+ .p2 paneconfigure .l1 -hide 1
+ update
+ lappend result [list [winfo ismapped .p1] [winfo ismapped .p2] \
+ [winfo ismapped .l1] [winfo ismapped .l2] [winfo ismapped .l3]]
+ .p1 paneconfigure .p2 -hide 1
+ update
+ lappend result [list [winfo ismapped .p1] [winfo ismapped .p2] \
+ [winfo ismapped .l1] [winfo ismapped .l2] [winfo ismapped .l3]]
+ .p1 paneconfigure .p2 -hide 0
+ update
+ lappend result [list [winfo ismapped .p1] [winfo ismapped .p2] \
+ [winfo ismapped .l1] [winfo ismapped .l2] [winfo ismapped .l3]]
+} -cleanup {
+ deleteWindows
+} -result {{1 1 1 1 1} {1 1 0 1 1} {1 0 0 0 0} {1 1 0 1 1}}
+test panedwindow-23.31 {ConfigurePanes, -hide works, last pane stretches} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -width 200 -height 200 -borderwidth 0
+ frame .f1 -width 50 -bg red
+ frame .f2 -width 50 -bg green
+ frame .f3 -width 50 -bg blue
+ .p add .f1 .f2 .f3
+ pack .p
+ update
+ set result [list]
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3]
+ .p paneconfigure .f2 -hide 1
+ update
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3]
+} -cleanup {
+ deleteWindows
+} -result {50 50 94 50 50 147}
+test panedwindow-23.32 {ConfigurePanes, -hide works, last pane stretches} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -width 200 -height 200 \
+ -borderwidth 0 -orient vertical
+ frame .f1 -height 50 -bg red
+ frame .f2 -height 50 -bg green
+ frame .f3 -height 50 -bg blue
+ .p add .f1 .f2 .f3
+ pack .p
+ update
+ set result [list]
+ lappend result [winfo height .f1] [winfo height .f2] [winfo height .f3]
+ .p paneconfigure .f2 -hide 1
+ update
+ lappend result [winfo height .f1] [winfo height .f2] [winfo height .f3]
+} -cleanup {
+ deleteWindows
+} -result {50 50 94 50 50 147}
+
+test panedwindow-23.33 {ConfigurePanes, -stretch first} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -height 100 -width 182
+ frame .f1 -width 40 -bg red
+ frame .f2 -width 40 -bg white
+ frame .f3 -width 40 -bg blue
+ frame .f4 -width 40 -bg green
+ .p add .f1 .f2 .f3 .f4 -stretch first
+ pack .p
+ update
+ set result [list]
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4]
+ .p paneconfigure .f2 -hide 1
+ update
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4]
+} -cleanup {
+ deleteWindows
+} -result {51 40 40 40 94 40 40 40}
+test panedwindow-23.34 {ConfigurePanes, -stretch middle} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -height 100 -width 182
+ frame .f1 -width 40 -bg red
+ frame .f2 -width 40 -bg white
+ frame .f3 -width 40 -bg blue
+ frame .f4 -width 40 -bg green
+ .p add .f1 .f2 .f3 .f4 -stretch middle
+ pack .p
+ update
+ set result [list]
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4]
+ .p paneconfigure .f2 -hide 1
+ update
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4]
+} -cleanup {
+ deleteWindows
+} -result {40 45 46 40 40 45 94 40}
+test panedwindow-23.35 {ConfigurePanes, -stretch always} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -height 100 -width 182
+ frame .f1 -width 40 -bg red
+ frame .f2 -width 40 -bg white
+ frame .f3 -width 40 -bg blue
+ frame .f4 -width 40 -bg green
+ .p add .f1 .f2 .f3 .f4 -stretch always
+ pack .p
+ update
+ set result [list]
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4]
+ .p paneconfigure .f2 -hide 1
+ update
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4]
+} -cleanup {
+ deleteWindows
+} -result {42 43 43 43 58 43 58 58}
+test panedwindow-23.36 {ConfigurePanes, -stretch never} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -height 100 -width 182
+ frame .f1 -width 40 -bg red
+ frame .f2 -width 40 -bg white
+ frame .f3 -width 40 -bg blue
+ frame .f4 -width 40 -bg green
+ .p add .f1 .f2 .f3 .f4 -stretch never
+ pack .p
+ update
+ set result [list]
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4]
+ .p paneconfigure .f2 -hide 1
+ update
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
+ [winfo width .f4]
+} -cleanup {
+ deleteWindows
+} -result {40 40 40 40 40 40 40 40}
+
+
+test panedwindow-24.1 {Unlink, remove a paned with -before/-after refs} -setup {
+ deleteWindows
+} -body {
+ # Bug 928413
+ set result {}
+ panedwindow .pw
+ label .pw.l1 -text Label1
+ label .pw.l2 -text Label2
+ label .pw.l3 -text Label3
+ .pw add .pw.l1
+ .pw add .pw.l3
+ .pw add .pw.l2 -before .pw.l3
+ lappend result [.pw panecget .pw.l2 -before]
+ destroy .pw.l3
+ lappend result [.pw panecget .pw.l2 -before]
+ .pw paneconfigure .pw.l2 -before .pw.l1
+ lappend result [.pw panecget .pw.l2 -before]
+} -cleanup {
+ deleteWindows
+} -result {.pw.l3 {} .pw.l1}
+
+
+test panedwindow-25.1 {DestroyPanedWindow} -setup {
+ deleteWindows
+} -body {
+ # This test should not result in any memory leaks.
+ panedwindow .p
+ foreach w {.a .b .c .d .e .f .g .h .i .j .k .l .m .n .o .q .r .s .t} {
+ .p add [button $w]
+ }
+ foreach w {.a .b .c .d .e .f .g .h .i .j .k .l .m .n .o .p .q .r .s .t} {
+ destroy $w
+ }
+ set result {}
+} -result {}
+test panedwindow-25.2 {UnmapNotify and MapNotify events are propagated to slaves} -setup {
+ deleteWindows
+} -body {
+ panedwindow .pw
+ .pw add [button .pw.b]
+ pack .pw
+ update
+ set result [winfo ismapped .pw.b]
+ pack forget .pw
+ update
+ lappend result [winfo ismapped .pw.b]
+ lappend result [winfo ismapped .pw]
+ pack .pw
+ update
+ lappend result [winfo ismapped .pw]
+ lappend result [winfo ismapped .pw.b]
+ destroy .pw .pw.b
+ set result
+} -cleanup {
+ deleteWindows
+} -result {1 0 0 1 1}
+
+
+test panedwindow-26.1 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 0 0
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-26.2 {PanedWindowIdentifyCoords, padding is included} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 20 0
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.3 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 22 0
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.4 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 24 0
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.5 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 26 0
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.6 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 26 -1
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-26.7 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 26 100
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-26.8 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
+ -handlesize 6
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 22 4
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.9 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
+ -handlesize 6
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 22 5
+} -cleanup {
+ deleteWindows
+} -result {0 handle}
+test panedwindow-26.10 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
+ -handlesize 8
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 20 5
+} -cleanup {
+ deleteWindows
+} -result {0 handle}
+test panedwindow-26.11 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
+ -handlesize 8
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 20 0
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.12 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -bd 0 -sashwidth 2 -sashpad 2
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20] \
+ [frame .f3 -bg green -width 20 -height 20]
+ .p identify 48 0
+} -cleanup {
+ deleteWindows
+} -result {1 sash}
+test panedwindow-26.13 {identify subcommand errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4
+ .p identify
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p identify x y"}
+test panedwindow-26.14 {identify subcommand errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p identify foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-26.15 {identify subcommand errors} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p identify 0 bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "bar"}
+test panedwindow-26.16 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 0 0
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-26.17 {PanedWindowIdentifyCoords, padding is included} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 0 20
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.18 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 0 22
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.19 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 0 24
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.20 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 0 26
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.21 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify -1 26
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-26.22 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 100 26
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-26.23 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
+ -handlesize 6 -orient vertical
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 4 22
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.24 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
+ -handlesize 6 -orient vertical
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 5 22
+} -cleanup {
+ deleteWindows
+} -result {0 handle}
+test panedwindow-26.25 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
+ -handlesize 8 -orient vertical
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 5 20
+} -cleanup {
+ deleteWindows
+} -result {0 handle}
+test panedwindow-26.26 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
+ -handlesize 8 -orient vertical
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20]
+ .p identify 0 20
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.27 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
+ .p add [frame .f -bg red -width 20 -height 20] \
+ [frame .f2 -bg blue -width 20 -height 20] \
+ [frame .f3 -bg green -width 20 -height 20]
+ .p identify 0 48
+} -cleanup {
+ deleteWindows
+} -result {1 sash}
+
+
+test panedwindow-27.1 {destroy the window cleanly on error [Bug #616589]} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bogusopt bogus
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown option "-bogusopt"}
+test panedwindow-27.2 {destroy the window cleanly on rename [Bug #616589]} -setup {
+ deleteWindows
+} -body {
+ destroy .p
+ panedwindow .p
+ rename .p {}
+ winfo exists .p
+} -cleanup {
+ deleteWindows
+} -result {0}
+
+
+test panedwindow-28.1 {resizing width} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 5
+ frame .f1 -width 100 -height 50 -bg blue
+ frame .f2 -width 100 -height 50 -bg red
+
+ .p add .f1 -sticky news
+ .p add .f2 -sticky news
+ pack .p -side top -fill both -expand 1
+ wm geometry . ""
+ update
+ # Note the width
+ set a [winfo width .f2]
+ # Increase the size by 10
+ regexp {^(\d+)x(\d+)} [wm geometry .] -> w h
+ wm geometry . [expr {$w + 10}]x$h
+ update
+ set b "$a [winfo width .f2]"
+} -cleanup {
+ deleteWindows
+} -result {100 110}
+
+test panedwindow-28.2 {resizing height} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -orient vertical -bd 5
+ frame .f1 -width 50 -height 100 -bg blue
+ frame .f2 -width 50 -height 100 -bg red
+
+ .p add .f1 -sticky news
+ .p add .f2 -sticky news
+ pack .p -side top -fill both -expand 1
+ wm geometry . ""
+ update
+ # Note the height
+ set a [winfo height .f2]
+ # Increase the size by 10
+ regexp {^(\d+)x(\d+)} [wm geometry .] -> w h
+ wm geometry . ${w}x[expr {$h + 10}]
+ update
+ set b "$a [winfo height .f2]"
+} -cleanup {
+ deleteWindows
+} -result {100 110}
+
+
+test panedwindow-29.1 {display on depths other than the default one} -constraints {
+ pseudocolor8 haveTruecolor24
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -visual {truecolor 24}
+ pack [panedwindow .t.p]
+ .t.p add [frame .t.p.f1] [frame .t.p.f2]
+ update
+ # If we got here, we didn't crash and that's good
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-29.2 {display on depths other than the default one} -constraints {
+ pseudocolor8 haveTruecolor24
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -visual {pseudocolor 8}
+ pack [frame .t.f -visual {truecolor 24}]
+ pack [panedwindow .t.f.p]
+ .t.f.p add [frame .t.f.p.f1 -width 5] [frame .t.f.p.f2 -width 5]
+ update
+ .t.f.p proxy place 1 1
+ update
+ .t.f.p proxy forget
+ update
+ # If we got here, we didn't crash and that's good
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+# cleanup
+cleanupTests
+return
+
+
diff --git a/tk8.6/tests/place.test b/tk8.6/tests/place.test
new file mode 100644
index 0000000..ddfa64c
--- /dev/null
+++ b/tk8.6/tests/place.test
@@ -0,0 +1,504 @@
+# This file is a Tcl script to test out the "place" command. It is
+# organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# Used for constraining memory leak tests
+testConstraint memory [llength [info commands memory]]
+
+# XXX - This test file is woefully incomplete. At present, only a
+# few of the features are tested.
+
+# Widgets used in tests 1.* - 8.*
+toplevel .t -width 300 -height 200 -bd 0
+wm geom .t +0+0
+frame .t.f -width 154 -height 84 -bd 2 -relief raised
+place .t.f -x 48 -y 38
+frame .t.f2 -width 30 -height 60 -bd 2 -relief raised
+update
+
+test place-1.1 {Tk_PlaceCmd procedure, "info" option} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -x 0
+ place info .t.f2
+} -result {-in .t -x 0 -relx 0 -y 0 -rely 0 -width {} -relwidth {} -height {} -relheight {} -anchor nw -bordermode inside}
+test place-1.2 {Tk_PlaceCmd procedure, "info" option} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -x 1 -y 2 -width 3 -height 4 -relx 0.1 -rely 0.2 \
+ -relwidth 0.3 -relheight 0.4 -anchor se -in .t.f \
+ -bordermode outside
+ place info .t.f2
+} -result {-in .t.f -x 1 -relx 0.1 -y 2 -rely 0.2 -width 3 -relwidth 0.3 -height 4 -relheight 0.4 -anchor se -bordermode outside}
+test place-1.3 {Tk_PlaceCmd procedure, "info" option} -setup {
+ place forget .t.f2
+ destroy .t.a.b
+} -body {
+ # Make sure the result is built as a proper list by using a space in parent
+ frame ".t.a b"
+ place .t.f2 -x 1 -y 2 -width {} -height 4 -relx 0.2 -rely 0.2 \
+ -relwidth 0.3 -relheight {} -anchor w -in ".t.a b" \
+ -bordermode ignore
+ place info .t.f2
+} -cleanup {
+ destroy ".t.a.b"
+} -result {-in {.t.a b} -x 1 -relx 0.2 -y 2 -rely 0.2 -width {} -relwidth 0.3 -height 4 -relheight {} -anchor w -bordermode ignore}
+
+
+test place-2.1 {ConfigureSlave procedure, -height option} -body {
+ place .t.f2 -height abcd
+} -returnCodes error -result {bad screen distance "abcd"}
+test place-2.2 {ConfigureSlave procedure, -height option} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -height 40
+ update
+ winfo height .t.f2
+} -result {40}
+test place-2.3 {ConfigureSlave procedure, -height option} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -height 120
+ update
+ place .t.f2 -height {}
+ update
+ winfo height .t.f2
+} -result {60}
+
+
+test place-3.1 {ConfigureSlave procedure, -relheight option} -body {
+ place .t.f2 -relheight abcd
+} -returnCodes error -result {expected floating-point number but got "abcd"}
+test place-3.2 {ConfigureSlave procedure, -relheight option} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -relheight .5
+ update
+ winfo height .t.f2
+} -result {40}
+test place-3.3 {ConfigureSlave procedure, -relheight option} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -relheight .8
+ update
+ place .t.f2 -relheight {}
+ update
+ winfo height .t.f2
+} -result {60}
+
+
+test place-4.1 {ConfigureSlave procedure, bad -in options} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f2
+} -returnCodes error -result {can't place .t.f2 relative to itself}
+test place-4.2 {ConfigureSlave procedure, bad -in option} -setup {
+ place forget .t.f2
+} -body {
+ set result [list [winfo manager .t.f2]]
+ catch {place .t.f2 -in .t.f2}
+ lappend result [winfo manager .t.f2]
+} -result {{} {}}
+test place-4.3 {ConfigureSlave procedure, bad -in option} -setup {
+ place forget .t.f2
+} -body {
+ winfo manager .t.f2
+ place .t.f2 -in .t.f2
+} -returnCodes error -result {can't place .t.f2 relative to itself}
+test place-4.4 {ConfigureSlave procedure, bad -in option} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .
+} -returnCodes error -result {can't place .t.f2 relative to .}
+
+
+test place-5.1 {ConfigureSlave procedure, -relwidth option} -body {
+ place .t.f2 -relwidth abcd
+} -returnCodes error -result {expected floating-point number but got "abcd"}
+test place-5.2 {ConfigureSlave procedure, -relwidth option} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -relwidth .5
+ update
+ winfo width .t.f2
+} -result {75}
+test place-5.3 {ConfigureSlave procedure, -relwidth option} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -relwidth .8
+ update
+ place .t.f2 -relwidth {}
+ update
+ winfo width .t.f2
+} -result {30}
+
+test place-6.1 {ConfigureSlave procedure, -width option} -body {
+ place .t.f2 -width abcd
+} -returnCodes error -result {bad screen distance "abcd"}
+test place-6.2 {ConfigureSlave procedure, -width option} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -width 100
+ update
+ winfo width .t.f2
+} -result {100}
+test place-6.3 {ConfigureSlave procedure, -width option} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -width 120
+ update
+ place .t.f2 -width {}
+ update
+ winfo width .t.f2
+} -result {30}
+
+
+test place-7.1 {ReconfigurePlacement procedure, computing position} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -x -2 -relx .5 -y 3 -rely .4
+ update
+ winfo geometry .t.f2
+} -result {30x60+123+75}
+test place-7.2 {ReconfigurePlacement procedure, position rounding} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -x -1.4 -y -2.3
+ update
+ winfo geometry .t.f2
+} -result {30x60+49+38}
+test place-7.3 {ReconfigurePlacement procedure, position rounding} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -x 1.4 -y 2.3
+ update
+ winfo geometry .t.f2
+} -result {30x60+51+42}
+test place-7.4 {ReconfigurePlacement procedure, position rounding} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -x -1.6 -y -2.7
+ update
+ winfo geometry .t.f2
+} -result {30x60+48+37}
+test place-7.5 {ReconfigurePlacement procedure, position rounding} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -x 1.6 -y 2.7
+ update
+ winfo geometry .t.f2
+} -result {30x60+52+43}
+test place-7.6 {ReconfigurePlacement procedure, position rounding} -setup {
+ destroy .t.f3
+} -body {
+ frame .t.f3 -width 100 -height 100 -bg #f00000 -bd 0
+ place .t.f3 -x 0 -y 0
+ raise .t.f2
+ place forget .t.f2
+ place .t.f2 -in .t.f3 -relx .303 -rely .406 -relwidth .304 -relheight .206
+ update
+ winfo geometry .t.f2
+} -cleanup {
+ destroy .t.f3
+} -result {31x20+30+41}
+test place-7.7 {ReconfigurePlacement procedure, computing size} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -width 120 -height 89
+ update
+ list [winfo width .t.f2] [winfo height .t.f2]
+} -result {120 89}
+test place-7.8 {ReconfigurePlacement procedure, computing size} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -relwidth .4 -relheight .5
+ update
+ list [winfo width .t.f2] [winfo height .t.f2]
+} -result {60 40}
+test place-7.9 {ReconfigurePlacement procedure, computing size} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5
+ update
+ list [winfo width .t.f2] [winfo height .t.f2]
+} -result {70 36}
+test place-7.10 {ReconfigurePlacement procedure, computing size} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5
+ place .t.f2 -width {} -relwidth {} -height {} -relheight {}
+ update
+ list [winfo width .t.f2] [winfo height .t.f2]
+} -result {30 60}
+
+
+test place-8.1 {MasterStructureProc, mapping and unmapping slaves} -setup {
+ place forget .t.f2
+ place forget .t.f
+} -body {
+ place .t.f2 -relx 1.0 -rely 1.0 -anchor sw
+ update
+ set result [winfo ismapped .t.f2]
+ wm iconify .t
+ update
+ lappend result [winfo ismapped .t.f2]
+ place .t.f2 -x 40 -y 30 -relx 0 -rely 0 -anchor nw
+ update
+ lappend result [winfo x .t.f2] [winfo y .t.f2] [winfo ismapped .t.f2]
+ wm deiconify .t
+ update
+ lappend result [winfo ismapped .t.f2]
+} -result {1 0 40 30 0 1}
+test place-8.2 {MasterStructureProc, mapping and unmapping slaves} -setup {
+ place forget .t.f2
+ place forget .t.f
+} -body {
+ place .t.f -x 0 -y 0 -width 200 -height 100
+ place .t.f2 -in .t.f -relx 1.0 -rely 1.0 -anchor sw -width 50 -height 20
+ update
+ set result [winfo ismapped .t.f2]
+ wm iconify .t
+ update
+ lappend result [winfo ismapped .t.f2]
+ place .t.f2 -x 40 -y 30 -relx 0 -rely 0 -anchor nw
+ update
+ lappend result [winfo x .t.f2] [winfo y .t.f2] [winfo ismapped .t.f2]
+ wm deiconify .t
+ update
+ lappend result [winfo ismapped .t.f2]
+} -result {1 0 42 32 0 1}
+destroy .t
+
+
+test place-9.1 {PlaceObjCmd} -body {
+ place
+} -returnCodes error -result {wrong # args: should be "place option|pathName args"}
+test place-9.2 {PlaceObjCmd} -body {
+ place foo
+} -returnCodes error -result {wrong # args: should be "place option|pathName args"}
+test place-9.3 {PlaceObjCmd} -setup {
+ destroy .foo
+} -body {
+ place .foo bar
+} -returnCodes error -result {bad window path name ".foo"}
+test place-9.4 {PlaceObjCmd} -setup {
+ destroy .foo
+} -body {
+ place bar .foo
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {bad window path name ".foo"}
+test place-9.5 {PlaceObjCmd} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place badopt .foo
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {bad option "badopt": must be configure, forget, info, or slaves}
+test place-9.6 {PlaceObjCmd, configure errors} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place configure .foo
+} -cleanup {
+ destroy .foo
+} -returnCodes ok -result {}
+test place-9.7 {PlaceObjCmd, configure errors} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place configure .foo bar
+} -cleanup {
+ destroy .foo
+} -returnCodes ok -result {}
+test place-9.8 {PlaceObjCmd, configure} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place .foo -x 0 -y 0
+ place configure .foo
+} -cleanup {
+ destroy .foo
+} -result [list {-anchor {} {} nw nw} {-bordermode {} {} inside inside} {-height {} {} {} {}} {-in {} {} {} .} {-relheight {} {} {} {}} {-relwidth {} {} {} {}} {-relx {} {} 0 0.0} {-rely {} {} 0 0.0} {-width {} {} {} {}} {-x {} {} 0 0} {-y {} {} 0 0}]
+test place-9.9 {PlaceObjCmd, configure} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place .foo -x 0 -y 0
+ place configure .foo -x
+} -cleanup {
+ destroy .foo
+} -result {-x {} {} 0 0}
+test place-9.10 {PlaceObjCmd, forget errors} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place forget .foo bar
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {wrong # args: should be "place forget pathName"}
+test place-9.11 {PlaceObjCmd, info errors} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place info .foo bar
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {wrong # args: should be "place info pathName"}
+test place-9.12 {PlaceObjCmd, slaves errors} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place slaves .foo bar
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {wrong # args: should be "place slaves pathName"}
+
+
+test place-10.1 {ConfigureSlave} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place .foo -badopt
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {unknown option "-badopt"}
+test place-10.2 {ConfigureSlave} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place .foo -anchor
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {value for "-anchor" missing}
+test place-10.3 {ConfigureSlave} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place .foo -bordermode j
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {bad bordermode "j": must be inside, outside, or ignore}
+test place-10.4 {ConfigureSlave} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place configure .foo -x 0 -y
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {value for "-y" missing}
+
+
+test place-11.1 {PlaceObjCmd, slaves command} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place slaves .foo
+} -cleanup {
+ destroy .foo
+} -result {}
+test place-11.2 {PlaceObjCmd, slaves command} -setup {
+ destroy .foo .bar
+} -body {
+ frame .foo
+ frame .bar
+ place .bar -in .foo
+ place slaves .foo
+} -cleanup {
+ destroy .foo .bar
+} -result [list .bar]
+
+
+test place-12.1 {PlaceObjCmd, forget command} -setup {
+ destroy .foo
+} -body {
+ frame .foo
+ place .foo -width 50 -height 50
+ update
+ set res [winfo ismapped .foo]
+ place forget .foo
+ update
+ lappend res [winfo ismapped .foo]
+} -cleanup {
+ destroy .foo
+} -result {1 0}
+
+
+test place-13.1 {test respect for internalborder} -setup {
+ destroy .pack
+} -body {
+ toplevel .pack
+ wm geometry .pack 200x200
+ frame .pack.l -width 15 -height 10
+ labelframe .pack.lf -labelwidget .pack.l
+ pack .pack.lf -fill both -expand 1
+ frame .pack.lf.f
+ place .pack.lf.f -x 0 -y 0 -relwidth 1.0 -relheight 1.0
+ update
+ set res [list [winfo geometry .pack.lf.f]]
+ .pack.lf configure -labelanchor e -padx 3 -pady 5
+ update
+ lappend res [winfo geometry .pack.lf.f]
+} -cleanup {
+ destroy .pack
+} -result {196x188+2+10 177x186+5+7}
+
+
+test place-14.1 {memory leak testing} -constraints memory -setup {
+ destroy .f
+ proc getbytes {} {
+ set lines [split [memory info] "\n"]
+ lindex [lindex $lines 3] 3
+ }
+ # Repeat each body checking that memory does not increase
+ proc stress {args} {
+ set res {}
+ foreach body $args {
+ set end 0
+ for {set i 0} {$i < 5} {incr i} {
+ uplevel 1 $body
+ set tmp $end
+ set end [getbytes]
+ }
+ lappend res [expr {$end - $tmp}]
+ }
+ return $res
+ }
+} -body {
+ # Test all manners of forgetting a slave
+ frame .f
+ frame .f.f
+ stress {
+ place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}]
+ place forget .f.f
+ } {
+ place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}]
+ pack .f.f
+ } {
+ place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}]
+ destroy .f
+ frame .f
+ frame .f.f
+ }
+} -cleanup {
+ destroy .f
+ rename getbytes {}
+ rename stress {}
+} -result {0 0 0}
+
+
+# cleanup
+cleanupTests
+return
+
+
+
diff --git a/tk8.6/tests/pwrdLogo150.gif b/tk8.6/tests/pwrdLogo150.gif
new file mode 100644
index 0000000..89eec7c
--- /dev/null
+++ b/tk8.6/tests/pwrdLogo150.gif
Binary files differ
diff --git a/tk8.6/tests/raise.test b/tk8.6/tests/raise.test
new file mode 100644
index 0000000..461ccbf
--- /dev/null
+++ b/tk8.6/tests/raise.test
@@ -0,0 +1,320 @@
+# This file is a Tcl script to test out Tk's "raise" and
+# "lower" commands, plus associated code to manage window
+# stacking order. It is organized in the standard fashion
+# for Tcl tests.
+#
+# Copyright (c) 1993-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+# Procedure to create a bunch of overlapping windows, which should
+# make it easy to detect differences in order.
+
+proc raise_setup {} {
+ foreach i [winfo child .raise] {
+ destroy $i
+ }
+ foreach i {a b c d e} {
+ label .raise.$i -text $i -relief raised -bd 2
+ }
+ place .raise.a -x 20 -y 60 -width 60 -height 80
+ place .raise.b -x 60 -y 60 -width 60 -height 80
+ place .raise.c -x 100 -y 60 -width 60 -height 80
+ place .raise.d -x 40 -y 20 -width 100 -height 60
+ place .raise.e -x 40 -y 120 -width 100 -height 60
+}
+
+# Procedure to return information about which windows are on top
+# of which other windows.
+
+proc raise_getOrder {} {
+ set x [winfo rootx .raise]
+ set y [winfo rooty .raise]
+ list [winfo name [winfo containing [expr $x+50] [expr $y+70]]] \
+ [winfo name [winfo containing [expr $x+90] [expr $y+70]]] \
+ [winfo name [winfo containing [expr $x+130] [expr $y+70]]] \
+ [winfo name [winfo containing [expr $x+70] [expr $y+100]]] \
+ [winfo name [winfo containing [expr $x+110] [expr $y+100]]] \
+ [winfo name [winfo containing [expr $x+50] [expr $y+130]]] \
+ [winfo name [winfo containing [expr $x+90] [expr $y+130]]] \
+ [winfo name [winfo containing [expr $x+130] [expr $y+130]]]
+}
+
+# Procedure to set up a collection of top-level windows
+
+proc raise_makeToplevels {} {
+ deleteWindows
+ foreach i {.raise1 .raise2 .raise3} {
+ toplevel $i
+ wm geom $i 150x100+0+0
+ update
+ }
+}
+
+toplevel .raise
+wm geom .raise 250x200+0+0
+
+
+test raise-1.1 {preserve creation order} -body {
+ raise_setup
+ tkwait visibility .raise.e
+ raise_getOrder
+} -result {d d d b c e e e}
+test raise-1.2 {preserve creation order} -constraints testmakeexist -body {
+ raise_setup
+ testmakeexist .raise.a
+ update
+ raise_getOrder
+} -result {d d d b c e e e}
+test raise-1.3 {preserve creation order} -constraints testmakeexist -body {
+ raise_setup
+ testmakeexist .raise.c
+ update
+ raise_getOrder
+} -result {d d d b c e e e}
+test raise-1.4 {preserve creation order} -constraints testmakeexist -body {
+ raise_setup
+ testmakeexist .raise.e
+ update
+ raise_getOrder
+} -result {d d d b c e e e}
+test raise-1.5 {preserve creation order} -constraints testmakeexist -body {
+ raise_setup
+ testmakeexist .raise.d .raise.c .raise.b
+ update
+ raise_getOrder
+} -result {d d d b c e e e}
+
+
+test raise-2.1 {raise internal windows before creation} -body {
+ raise_setup
+ raise .raise.a
+ update
+ raise_getOrder
+} -result {a d d a c a e e}
+test raise-2.2 {raise internal windows before creation} -body {
+ raise_setup
+ raise .raise.c
+ update
+ raise_getOrder
+} -result {d d c b c e e c}
+test raise-2.3 {raise internal windows before creation} -body {
+ raise_setup
+ raise .raise.e
+ update
+ raise_getOrder
+} -result {d d d b c e e e}
+test raise-2.4 {raise internal windows before creation} -body {
+ raise_setup
+ raise .raise.e .raise.a
+ update
+ raise_getOrder
+} -result {d d d b c e b c}
+test raise-2.5 {raise internal windows before creation} -body {
+ raise_setup
+ raise .raise.a .raise.d
+ update
+ raise_getOrder
+} -result {a d d a c e e e}
+
+
+test raise-3.1 {raise internal windows after creation} -body {
+ raise_setup
+ update
+ raise .raise.a .raise.d
+ raise_getOrder
+} -result {a d d a c e e e}
+test raise-3.2 {raise internal windows after creation} -constraints {
+ testmakeexist
+} -body {
+ raise_setup
+ testmakeexist .raise.a .raise.b
+ raise .raise.a .raise.b
+ update
+ raise_getOrder
+} -result {d d d a c e e e}
+test raise-3.3 {raise internal windows after creation} -constraints {
+ testmakeexist
+} -body {
+ raise_setup
+ testmakeexist .raise.a .raise.d
+ raise .raise.a .raise.b
+ update
+ raise_getOrder
+} -result {d d d a c e e e}
+test raise-3.4 {raise internal windows after creation} -constraints {
+ testmakeexist
+} -body {
+ raise_setup
+ testmakeexist .raise.a .raise.c .raise.d
+ raise .raise.a .raise.b
+ update
+ raise_getOrder
+} -result {d d d a c e e e}
+
+
+test raise-4.1 {raise relative to nephews} -body {
+ raise_setup
+ update
+ frame .raise.d.child
+ raise .raise.a .raise.d.child
+ raise_getOrder
+} -result {a d d a c e e e}
+test raise-4.2 {raise relative to nephews} -setup {
+ destroy .raise2
+} -body {
+ raise_setup
+ update
+ frame .raise2
+ raise .raise.a .raise2
+} -cleanup {
+ destroy .raise2
+} -returnCodes error -result {can't raise ".raise.a" above ".raise2"}
+
+
+test raise-5.1 {lower internal windows} -body {
+ raise_setup
+ update
+ lower .raise.d
+ raise_getOrder
+} -result {a b c b c e e e}
+test raise-5.2 {lower internal windows} -body {
+ raise_setup
+ update
+ lower .raise.d .raise.b
+ raise_getOrder
+} -result {d b c b c e e e}
+test raise-5.3 {lower internal windows} -body {
+ raise_setup
+ update
+ lower .raise.a .raise.e
+ raise_getOrder
+} -result {a d d a c e e e}
+test raise-5.4 {lower internal windows} -setup {
+ destroy .raise2
+} -body {
+ raise_setup
+ update
+ frame .raise2
+ lower .raise.a .raise2
+} -cleanup {
+ destroy .raise2
+} -returnCodes error -result {can't lower ".raise.a" below ".raise2"}
+
+
+test raise-6.1 {raise/lower toplevel windows} -constraints {
+ nonPortable
+} -body {
+ raise_makeToplevels
+ update
+ raise .raise1
+ winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
+} -result {.raise1}
+test raise-6.2 {raise/lower toplevel windows} -constraints {
+ nonPortable
+} -body {
+ raise_makeToplevels
+ update
+ raise .raise2
+ winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
+} -result {.raise2}
+test raise-6.3 {raise/lower toplevel windows} -constraints {
+ nonPortable
+} -body {
+ raise_makeToplevels
+ update
+ raise .raise3
+ raise .raise2
+ raise .raise1 .raise3
+ set result [winfo containing [winfo rootx .raise1] \
+ [winfo rooty .raise1]]
+ destroy .raise2
+ update
+ after 500
+ list $result [winfo containing [winfo rootx .raise1] \
+ [winfo rooty .raise1]]
+} -result {.raise2 .raise1}
+test raise-6.4 {raise/lower toplevel windows} -constraints {
+ nonPortable
+} -body {
+ raise_makeToplevels
+ update
+ raise .raise2
+ raise .raise1
+ lower .raise3 .raise1
+ set result [winfo containing [winfo rootx .raise1] \
+ [winfo rooty .raise1]]
+ wm geometry .raise2 +30+30
+ wm geometry .raise1 +60+60
+ destroy .raise1
+ update
+ after 500
+ list $result [winfo containing [winfo rootx .raise2] \
+ [winfo rooty .raise2]]
+} -result {.raise1 .raise3}
+test raise-6.5 {raise/lower toplevel windows} -constraints {
+ nonPortable
+} -body {
+ raise_makeToplevels
+ raise .raise1
+ set time [lindex [time {raise .raise1}] 0]
+ expr {$time < 2000000}
+} -result 1
+test raise-6.6 {raise/lower toplevel windows} -constraints {
+ nonPortable
+} -body {
+ raise_makeToplevels
+ update
+ raise .raise2
+ raise .raise1
+ raise .raise3
+ frame .raise1.f1
+ frame .raise1.f1.f2
+ lower .raise3 .raise1.f1.f2
+ set result [winfo containing [winfo rootx .raise1] \
+ [winfo rooty .raise1]]
+ destroy .raise1
+ update
+ after 500
+ list $result [winfo containing [winfo rootx .raise2] \
+ [winfo rooty .raise2]]
+} -result {.raise1 .raise3}
+
+
+test raise-7.1 {errors in raise/lower commands} -body {
+ raise
+} -returnCodes error -result {wrong # args: should be "raise window ?aboveThis?"}
+test raise-7.2 {errors in raise/lower commands} -body {
+ raise a b c
+} -returnCodes error -result {wrong # args: should be "raise window ?aboveThis?"}
+test raise-7.3 {errors in raise/lower commands} -body {
+ raise badName
+} -returnCodes error -result {bad window path name "badName"}
+test raise-7.4 {errors in raise/lower commands} -body {
+ raise . badName2
+} -returnCodes error -result {bad window path name "badName2"}
+test raise-7.5 {errors in raise/lower commands} -body {
+ lower
+} -returnCodes error -result {wrong # args: should be "lower window ?belowThis?"}
+test raise-7.6 {errors in raise/lower commands} -body {
+ lower a b c
+} -returnCodes error -result {wrong # args: should be "lower window ?belowThis?"}
+test raise-7.7 {errors in raise/lower commands} -body {
+ lower badName3
+} -returnCodes error -result {bad window path name "badName3"}
+test raise-7.8 {errors in raise/lower commands} -body {
+ lower . badName4
+} -returnCodes error -result {bad window path name "badName4"}
+
+deleteWindows
+
+# cleanup
+cleanupTests
+return
+
diff --git a/tk8.6/tests/safe.test b/tk8.6/tests/safe.test
new file mode 100644
index 0000000..69a67ba
--- /dev/null
+++ b/tk8.6/tests/safe.test
@@ -0,0 +1,248 @@
+# This file is a Tcl script to test the Safe Tk facility. It is organized in
+# the standard fashion for Tk tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+## NOTE: Any time tests fail here with an error like:
+
+# Can't find a usable tk.tcl in the following directories:
+# {$p(:26:)}
+#
+# $p(:26:)/tk.tcl: script error
+# script error
+# invoked from within
+# "source {$p(:26:)/tk.tcl}"
+# ("uplevel" body line 1)
+# invoked from within
+# "uplevel #0 [list source $file]"
+#
+#
+# This probably means that tk wasn't installed properly.
+
+## it indicates that something went wrong sourcing tk.tcl.
+## Ensure that any changes that occured to tk.tcl will work or are properly
+## prevented in a safe interpreter. -- hobbs
+
+# The set of hidden commands is platform dependent:
+
+set hidden_cmds {bell cd clipboard encoding exec exit fconfigure glob grab load menu open pwd selection socket source toplevel unload wm}
+lappend hidden_cmds {*}[apply {{} {
+ foreach cmd {
+ atime attributes copy delete dirname executable exists extension
+ isdirectory isfile link lstat mkdir mtime nativename normalize owned
+ readable readlink rename rootname size stat tail tempfile type
+ volumes writable
+ } {lappend result tcl:file:$cmd}; return $result
+}}]
+if {[tk windowingsystem] ne "x11"} {
+ lappend hidden_cmds tk_chooseColor tk_chooseDirectory tk_getOpenFile \
+ tk_getSaveFile tk_messageBox
+}
+if {[llength [info commands send]]} {
+ lappend hidden_cmds send
+}
+
+set saveAutoPath $::auto_path
+set auto_path [list [info library] $::tk_library]
+set hidden_cmds [lsort $hidden_cmds]
+
+test safe-1.1 {Safe Tk loading into an interpreter} -setup {
+ catch {safe::interpDelete a}
+} -body {
+ safe::loadTk [safe::interpCreate a]
+ safe::interpDelete a
+ set x {}
+ return $x
+} -result {}
+test safe-1.2 {Safe Tk loading into an interpreter} -setup {
+ catch {safe::interpDelete a}
+} -body {
+ safe::interpCreate a
+ safe::loadTk a
+ lsort [interp hidden a]
+} -cleanup {
+ safe::interpDelete a
+} -result $hidden_cmds
+test safe-1.3 {Safe Tk loading into an interpreter} -setup {
+ catch {safe::interpDelete a}
+} -body {
+ safe::interpCreate a
+ safe::loadTk a
+ lsort [interp aliases a]
+} -cleanup {
+ safe::interpDelete a
+} -match glob -result {*encoding*exit*glob*load*source*}
+
+test safe-2.1 {Unsafe commands not available} -setup {
+ catch {safe::interpDelete a}
+} -body {
+ safe::interpCreate a
+ safe::loadTk a
+ set status broken
+ if {[catch {interp eval a {toplevel .t}} msg]} {
+ set status ok
+ }
+ return $status
+} -cleanup {
+ safe::interpDelete a
+} -result ok
+test safe-2.2 {Unsafe commands not available} -setup {
+ catch {safe::interpDelete a}
+} -body {
+ safe::interpCreate a
+ safe::loadTk a
+ set status broken
+ if {[catch {interp eval a {menu .m}} msg]} {
+ set status ok
+ }
+ return $status
+} -cleanup {
+ safe::interpDelete a
+} -result ok
+test safe-2.3 {Unsafe subcommands not available} -setup {
+ catch {safe::interpDelete a}
+} -body {
+ safe::interpCreate a
+ safe::loadTk a
+ set status broken
+ if {[catch {interp eval a {tk appname}} msg]} {
+ set status ok
+ }
+ list $status $msg
+} -cleanup {
+ safe::interpDelete a
+} -result {ok {appname not accessible in a safe interpreter}}
+test safe-2.4 {Unsafe subcommands not available} -setup {
+ catch {safe::interpDelete a}
+} -body {
+ safe::interpCreate a
+ safe::loadTk a
+ set status broken
+ if {[catch {interp eval a {tk scaling}} msg]} {
+ set status ok
+ }
+ list $status $msg
+} -cleanup {
+ safe::interpDelete a
+} -result {ok {scaling not accessible in a safe interpreter}}
+
+test safe-3.1 {Unsafe commands are available hidden} -setup {
+ catch {safe::interpDelete a}
+} -body {
+ safe::interpCreate a
+ safe::loadTk a
+ set status ok
+ if {[catch {interp invokehidden a toplevel .t} msg]} {
+ set status broken
+ }
+ return $status
+} -cleanup {
+ safe::interpDelete a
+} -result ok
+test safe-3.2 {Unsafe commands are available hidden} -setup {
+ catch {safe::interpDelete a}
+} -body {
+ safe::interpCreate a
+ safe::loadTk a
+ set status ok
+ if {[catch {interp invokehidden a menu .m} msg]} {
+ set status broken
+ }
+ return $status
+} -cleanup {
+ safe::interpDelete a
+} -result ok
+
+test safe-4.1 {testing loadTk} -body {
+ # no error shall occur, the user will eventually see a new toplevel
+ set i [safe::loadTk [safe::interpCreate]]
+ interp eval $i {button .b -text "hello world!"; pack .b}
+ # lets don't update because it might imply that the user has to position
+ # the window (if the wm does not do it automatically) and thus make the
+ # test suite not runable non interactively
+ safe::interpDelete $i
+} -result {}
+test safe-4.2 {testing loadTk -use} -setup {
+ destroy .safeTkFrame
+} -body {
+ set w .safeTkFrame
+ frame $w -container 1;
+ pack $w
+ set i [safe::loadTk [safe::interpCreate] -use [winfo id $w]]
+ interp eval $i {button .b -text "hello world!"; pack .b}
+ safe::interpDelete $i
+ destroy $w
+} -result {}
+
+test safe-5.1 {loading Tk in safe interps without master's clearance} -body {
+ set i [safe::interpCreate]
+ interp eval $i {load {} Tk}
+} -cleanup {
+ safe::interpDelete $i
+} -returnCodes error -result {not allowed}
+test safe-5.2 {multi-level Tk loading with clearance} -setup {
+ set safeParent [safe::interpCreate]
+} -body {
+ # No error shall occur in that test and no window shall remain at the end.
+ set i [safe::interpCreate [list $safeParent x]]
+ safe::loadTk $i
+ interp eval $i {
+ button .b -text Ok -command {destroy .}
+ pack .b
+# tkwait window . ; # for interactive testing/debugging
+ }
+} -cleanup {
+ catch {safe::interpDelete $i}
+ safe::interpDelete $safeParent
+} -result {}
+
+test safe-6.1 {loadTk -use windowPath} -setup {
+ destroy .safeTkFrame
+} -body {
+ set w .safeTkFrame
+ frame $w -container 1;
+ pack $w
+ set i [safe::loadTk [safe::interpCreate] -use $w]
+ interp eval $i {button .b -text "hello world!"; pack .b}
+ safe::interpDelete $i
+ destroy $w
+} -result {}
+test safe-6.2 {loadTk -use windowPath, conflicting -display} -setup {
+ destroy .safeTkFrame
+} -body {
+ set w .safeTkFrame
+ frame $w -container 1;
+ pack $w
+ set i [safe::interpCreate]
+ catch {safe::loadTk $i -use $w -display :23.56} msg
+ string range $msg 0 36
+} -cleanup {
+ safe::interpDelete $i
+ destroy $w
+} -result {conflicting -display :23.56 and -use }
+
+test safe-7.1 {canvas printing} -body {
+ set i [safe::loadTk [safe::interpCreate]]
+ interp eval $i {canvas .c; .c postscript}
+} -cleanup {
+ safe::interpDelete $i
+} -returnCodes ok -match glob -result *
+
+# cleanup
+set ::auto_path $saveAutoPath
+unset hidden_cmds
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/tk8.6/tests/scale.test b/tk8.6/tests/scale.test
new file mode 100644
index 0000000..8c14ed4
--- /dev/null
+++ b/tk8.6/tests/scale.test
@@ -0,0 +1,1511 @@
+# This file is a Tcl script to test out the "scale" command
+# of Tk. It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# Create entries in the option database to be sure that geometry options
+# like border width have predictable values.
+
+option add *Scale.borderWidth 2
+option add *Scale.highlightThickness 2
+option add *Scale.font {Helvetica -12 bold}
+
+# Widget used in 1.* tests
+scale .s -from 100 -to 300
+pack .s
+update
+
+test scale-1.1 {configuration options} -body {
+ .s configure -activebackground #ff0000
+ .s cget -activebackground
+} -cleanup {
+ .s configure -activebackground [lindex [.s configure -activebackground] 3]
+} -result {#ff0000}
+test scale-1.2 {configuration options} -body {
+ .s configure -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.3 {configuration options} -body {
+ .s configure -background #ff0000
+ .s cget -background
+} -cleanup {
+ .s configure -background [lindex [.s configure -background] 3]
+} -result {#ff0000}
+test scale-1.4 {configuration options} -body {
+ .s configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.5 {configuration options} -body {
+ .s configure -bd 4
+ .s cget -bd
+} -cleanup {
+ .s configure -bd [lindex [.s configure -bd] 3]
+} -result {4}
+test scale-1.6 {configuration options} -body {
+ .s configure -bd badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.7 {configuration options} -body {
+ .s configure -bigincrement 12.5
+ .s cget -bigincrement
+} -cleanup {
+ .s configure -bigincrement [lindex [.s configure -bigincrement] 3]
+} -result {12.5}
+test scale-1.8 {configuration options} -body {
+ .s configure -bigincrement badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.9 {configuration options} -body {
+ .s configure -bg #ff0000
+ .s cget -bg
+} -cleanup {
+ .s configure -bg [lindex [.s configure -bg] 3]
+} -result {#ff0000}
+test scale-1.10 {configuration options} -body {
+ .s configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.11 {configuration options} -body {
+ .s configure -borderwidth 1.3
+ .s cget -borderwidth
+} -cleanup {
+ .s configure -borderwidth [lindex [.s configure -borderwidth] 3]
+} -result {1}
+test scale-1.12 {configuration options} -body {
+ .s configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.13 {configuration options} -body {
+ .s configure -command {set x}
+ .s cget -command
+} -cleanup {
+ .s configure -command [lindex [.s configure -command] 3]
+} -result {set x}
+test scale-1.15 {configuration options} -body {
+ .s configure -cursor arrow
+ .s cget -cursor
+} -cleanup {
+ .s configure -cursor [lindex [.s configure -cursor] 3]
+} -result {arrow}
+test scale-1.16 {configuration options} -body {
+ .s configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test scale-1.17 {configuration options} -body {
+ .s configure -digits 5
+ .s cget -digits
+} -cleanup {
+ .s configure -digits [lindex [.s configure -digits] 3]
+} -result {5}
+test scale-1.18 {configuration options} -body {
+ .s configure -digits badValue
+} -returnCodes error -result {expected integer but got "badValue"}
+test scale-1.19 {configuration options} -body {
+ .s configure -fg #00ff00
+ .s cget -fg
+} -cleanup {
+ .s configure -fg [lindex [.s configure -fg] 3]
+} -result {#00ff00}
+test scale-1.20 {configuration options} -body {
+ .s configure -fg badValue
+} -returnCodes error -result {unknown color name "badValue"}
+test scale-1.21 {configuration options} -body {
+ .s configure -font fixed
+ .s cget -font
+} -cleanup {
+ .s configure -font [lindex [.s configure -font] 3]
+} -result {fixed}
+test scale-1.23 {configuration options} -body {
+ .s configure -foreground green
+ .s cget -foreground
+} -cleanup {
+ .s configure -foreground [lindex [.s configure -foreground] 3]
+} -result {green}
+test scale-1.24 {configuration options} -body {
+ .s configure -foreground badValue
+} -returnCodes error -result {unknown color name "badValue"}
+test scale-1.25 {configuration options} -body {
+ .s configure -from -15.0
+ .s cget -from
+} -cleanup {
+ .s configure -from [lindex [.s configure -from] 3]
+} -result {-15.0}
+test scale-1.26 {configuration options} -body {
+ .s configure -from badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.27 {configuration options} -body {
+ .s configure -highlightbackground #112233
+ .s cget -highlightbackground
+} -cleanup {
+ .s configure -highlightbackground [lindex [.s configure -highlightbackground] 3]
+} -result {#112233}
+test scale-1.28 {configuration options} -body {
+ .s configure -highlightbackground ugly
+} -returnCodes error -result {unknown color name "ugly"}
+test scale-1.29 {configuration options} -body {
+ .s configure -highlightcolor #123456
+ .s cget -highlightcolor
+} -cleanup {
+ .s configure -highlightcolor [lindex [.s configure -highlightcolor] 3]
+} -result {#123456}
+test scale-1.30 {configuration options} -body {
+ .s configure -highlightcolor non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.31 {configuration options} -body {
+ .s configure -highlightthickness 2
+ .s cget -highlightthickness
+} -cleanup {
+ .s configure -highlightthickness [lindex [.s configure -highlightthickness] 3]
+} -result {2}
+test scale-1.32 {configuration options} -body {
+ .s configure -highlightthickness badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.33 {configuration options} -body {
+ .s configure -label {Some text}
+ .s cget -label
+} -cleanup {
+ .s configure -label [lindex [.s configure -label] 3]
+} -result {Some text}
+test scale-1.35 {configuration options} -body {
+ .s configure -length 130
+ .s cget -length
+} -cleanup {
+ .s configure -length [lindex [.s configure -length] 3]
+} -result {130}
+test scale-1.36 {configuration options} -body {
+ .s configure -length badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.37 {configuration options} -body {
+ .s configure -orient horizontal
+ .s cget -orient
+} -cleanup {
+ .s configure -orient [lindex [.s configure -orient] 3]
+} -result {horizontal}
+test scale-1.38 {configuration options} -body {
+ .s configure -orient badValue
+} -returnCodes error -result {bad orient "badValue": must be horizontal or vertical}
+test scale-1.39 {configuration options} -body {
+ .s configure -orient horizontal
+ .s cget -orient
+} -cleanup {
+ .s configure -orient [lindex [.s configure -orient] 3]
+} -result {horizontal}
+test scale-1.41 {configuration options} -body {
+ .s configure -relief ridge
+ .s cget -relief
+} -cleanup {
+ .s configure -relief [lindex [.s configure -relief] 3]
+} -result {ridge}
+test scale-1.42 {configuration options} -body {
+ .s configure -relief badValue
+} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}
+test scale-1.43 {configuration options} -body {
+ .s configure -repeatdelay 14
+ .s cget -repeatdelay
+} -cleanup {
+ .s configure -repeatdelay [lindex [.s configure -repeatdelay] 3]
+} -result {14}
+test scale-1.44 {configuration options} -body {
+ .s configure -repeatdelay bogus
+} -returnCodes error -result {expected integer but got "bogus"}
+test scale-1.45 {configuration options} -body {
+ .s configure -repeatinterval 14
+ .s cget -repeatinterval
+} -cleanup {
+ .s configure -repeatinterval [lindex [.s configure -repeatinterval] 3]
+} -result {14}
+test scale-1.46 {configuration options} -body {
+ .s configure -repeatinterval bogus
+} -returnCodes error -result {expected integer but got "bogus"}
+test scale-1.47 {configuration options} -body {
+ .s configure -resolution 2.0
+ .s cget -resolution
+} -cleanup {
+ .s configure -resolution [lindex [.s configure -resolution] 3]
+} -result {2.0}
+test scale-1.48 {configuration options} -body {
+ .s configure -resolution badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.49 {configuration options} -body {
+ .s configure -showvalue 0
+ .s cget -showvalue
+} -cleanup {
+ .s configure -showvalue [lindex [.s configure -showvalue] 3]
+} -result {0}
+test scale-1.50 {configuration options} -body {
+ .s configure -showvalue badValue
+} -returnCodes error -result {expected boolean value but got "badValue"}
+test scale-1.51 {configuration options} -body {
+ .s configure -sliderlength 86
+ .s cget -sliderlength
+} -cleanup {
+ .s configure -sliderlength [lindex [.s configure -sliderlength] 3]
+} -result {86}
+test scale-1.52 {configuration options} -body {
+ .s configure -sliderlength badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.53 {configuration options} -body {
+ .s configure -sliderrelief raised
+ .s cget -sliderrelief
+} -cleanup {
+ .s configure -sliderrelief [lindex [.s configure -sliderrelief] 3]
+} -result {raised}
+test scale-1.54 {configuration options} -body {
+ .s configure -sliderrelief badValue
+} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}
+test scale-1.55 {configuration options} -body {
+ .s configure -state d
+ .s cget -state
+} -cleanup {
+ .s configure -state [lindex [.s configure -state] 3]
+} -result {disabled}
+test scale-1.56 {configuration options} -body {
+ .s configure -state badValue
+} -returnCodes error -result {bad state "badValue": must be active, disabled, or normal}
+test scale-1.57 {configuration options} -body {
+ .s configure -state n
+ .s cget -state
+} -cleanup {
+ .s configure -state [lindex [.s configure -state] 3]
+} -result {normal}
+test scale-1.59 {configuration options} -body {
+ .s configure -takefocus {any string}
+ .s cget -takefocus
+} -cleanup {
+ .s configure -takefocus [lindex [.s configure -takefocus] 3]
+} -result {any string}
+test scale-1.61 {configuration options} -body {
+ .s configure -tickinterval 4.3
+ .s cget -tickinterval
+} -cleanup {
+ .s configure -tickinterval [lindex [.s configure -tickinterval] 3]
+} -result {4.0}
+test scale-1.62 {configuration options} -body {
+ .s configure -tickinterval badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.63 {configuration options} -body {
+ .s configure -to 14.9
+ .s cget -to
+} -cleanup {
+ .s configure -to [lindex [.s configure -to] 3]
+} -result {15.0}
+test scale-1.64 {configuration options} -body {
+ .s configure -to badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.65 {configuration options} -body {
+ .s configure -troughcolor #ff0000
+ .s cget -troughcolor
+} -cleanup {
+ .s configure -troughcolor [lindex [.s configure -troughcolor] 3]
+} -result {#ff0000}
+test scale-1.66 {configuration options} -body {
+ .s configure -troughcolor non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.67 {configuration options} -body {
+ .s configure -variable x
+ .s cget -variable
+} -cleanup {
+ .s configure -variable [lindex [.s configure -variable] 3]
+} -result {x}
+test scale-1.69 {configuration options} -body {
+ .s configure -width 32
+ .s cget -width
+} -cleanup {
+ .s configure -width [lindex [.s configure -width] 3]
+} -result {32}
+test scale-1.70 {configuration options} -body {
+ .s configure -width badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+destroy .s
+
+
+test scale-2.1 {Tk_ScaleCmd procedure} -body {
+ scale
+} -returnCodes error -result {wrong # args: should be "scale pathName ?-option value ...?"}
+test scale-2.2 {Tk_ScaleCmd procedure} -body {
+ scale foo
+} -returnCodes error -result {bad window path name "foo"}
+test scale-2.3 {Tk_ScaleCmd procedure} -body {
+ catch {scale foo}
+ winfo child .
+} -result {}
+test scale-2.4 {Tk_ScaleCmd procedure} -body {
+ scale .s -gorp dumb
+} -returnCodes error -result {unknown option "-gorp"}
+test scale-2.5 {Tk_ScaleCmd procedure} -body {
+ catch {scale .s -gorp dumb}
+ winfo child .
+} -result {}
+
+
+# Widget used in 3.* tests
+destroy .s
+scale .s -from 100 -to 200
+pack .s
+update idletasks
+test scale-3.1 {ScaleWidgetCmd procedure} -body {
+ .s
+} -returnCodes error -result {wrong # args: should be ".s option ?arg ...?"}
+test scale-3.2 {ScaleWidgetCmd procedure, cget option} -body {
+ .s cget
+} -returnCodes error -result {wrong # args: should be ".s cget option"}
+test scale-3.3 {ScaleWidgetCmd procedure, cget option} -body {
+ .s cget a b
+} -returnCodes error -result {wrong # args: should be ".s cget option"}
+test scale-3.4 {ScaleWidgetCmd procedure, cget option} -body {
+ .s cget -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test scale-3.5 {ScaleWidgetCmd procedure, cget option} -body {
+ .s configure -highlightthickness 2
+ .s cget -highlightthickness
+} -result {2}
+test scale-3.6 {ScaleWidgetCmd procedure, configure option} -body {
+ list [llength [.s configure]] [lindex [.s configure] 6]
+} -result {33 {-command command Command {} {}}}
+test scale-3.7 {ScaleWidgetCmd procedure, configure option} -body {
+ .s configure -foo
+} -returnCodes error -result {unknown option "-foo"}
+test scale-3.8 {ScaleWidgetCmd procedure, configure option} -body {
+ .s configure -borderwidth 2 -bg
+} -returnCodes error -result {value for "-bg" missing}
+test scale-3.9 {ScaleWidgetCmd procedure, coords option} -body {
+ .s coords a b
+} -returnCodes error -result {wrong # args: should be ".s coords ?value?"}
+test scale-3.10 {ScaleWidgetCmd procedure, coords option} -body {
+ .s coords bad
+} -returnCodes error -result {expected floating-point number but got "bad"}
+test scale-3.11 {ScaleWidgetCmd procedure} -constraints {
+ fonts
+} -body {
+ .s configure -from 100 -to 200
+ update idletasks
+ .s set 120
+ .s coords
+} -result {38 34}
+test scale-3.12 {ScaleWidgetCmd procedure, coords option} -constraints {
+ fonts
+} -body {
+ .s configure -from 100 -to 200 -orient horizontal
+ update idletasks
+ .s set 120
+ .s coords
+} -result {34 31}
+test scale-3.13 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
+ .s get a
+} -returnCodes error -result {wrong # args: should be ".s get ?x y?"}
+test scale-3.14 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
+ .s get a b c
+} -returnCodes error -result {wrong # args: should be ".s get ?x y?"}
+test scale-3.15 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
+ .s get a 11
+} -returnCodes error -result {expected integer but got "a"}
+test scale-3.16 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
+ .s get 12 b
+} -returnCodes error -result {expected integer but got "b"}
+test scale-3.17 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
+ .s set 133
+ .s get
+} -result 133
+test scale-3.18 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical -resolution 0.5
+ update
+ .s set 150
+ .s get 37 34
+} -result {119.5}
+.s configure -resolution 1
+test scale-3.19 {ScaleWidgetCmd procedure, identify option} -body {
+ .s identify
+} -returnCodes error -result {wrong # args: should be ".s identify x y"}
+test scale-3.20 {ScaleWidgetCmd procedure, identify option} -body {
+ .s identify 1 2 3
+} -returnCodes error -result {wrong # args: should be ".s identify x y"}
+test scale-3.21 {ScaleWidgetCmd procedure, identify option} -body {
+ .s identify boo 16
+} -returnCodes error -result {expected integer but got "boo"}
+test scale-3.22 {ScaleWidgetCmd procedure, identify option} -body {
+ .s identify 17 bad
+} -returnCodes error -result {expected integer but got "bad"}
+test scale-3.23 {ScaleWidgetCmd procedure, identify option} -constraints {
+ fonts
+} -body {
+ .s configure -from 100 -to 200 -orient vertical -resolution 1
+ update
+ .s set 120
+ list [.s identify 35 10] [.s identify 35 30] [.s identify 35 80] [.s identify 5 80]
+} -result {trough1 slider trough2 {}}
+test scale-3.24 {ScaleWidgetCmd procedure, set option} -body {
+ .s set
+} -returnCodes error -result {wrong # args: should be ".s set value"}
+test scale-3.25 {ScaleWidgetCmd procedure, set option} -body {
+ .s set a b
+} -returnCodes error -result {wrong # args: should be ".s set value"}
+test scale-3.26 {ScaleWidgetCmd procedure, set option} -body {
+ .s set bad
+} -returnCodes error -result {expected floating-point number but got "bad"}
+test scale-3.27 {ScaleWidgetCmd procedure, set option} -body {
+ .s configure -from 100 -to 200 -orient vertical -resolution 0.5
+ update
+ .s set 142
+} -result {}
+test scale-3.28 {ScaleWidgetCmd procedure, set option} -body {
+ .s configure -from 100 -to 200 -orient vertical -resolution 1
+ update
+ .s set 118
+ .s configure -state disabled
+ .s set 181
+ .s configure -state normal
+ .s get
+} -result {118}
+test scale-3.29 {ScaleWidgetCmd procedure} -body {
+ .s dumb
+} -returnCodes error -result {bad option "dumb": must be cget, configure, coords, get, identify, or set}
+test scale-3.30 {ScaleWidgetCmd procedure} -body {
+ .s c
+} -returnCodes error -result {ambiguous option "c": must be cget, configure, coords, get, identify, or set}
+test scale-3.31 {ScaleWidgetCmd procedure} -body {
+ .s co
+} -returnCodes error -result {ambiguous option "co": must be cget, configure, coords, get, identify, or set}
+destroy .s
+
+test scale-3.32 {ScaleWidgetCmd procedure, Tk_Preserve} -setup {
+ destroy .s
+} -body {
+ proc kill args {
+ destroy .s
+ }
+ scale .s -variable x -from 0 -to 100 -orient horizontal
+ pack .s
+ update
+ .s configure -command kill
+ .s set 55
+} -cleanup {
+ destroy .s
+} -result {}
+
+
+test scale-4.1 {DestroyScale procedure} -setup {
+ deleteWindows
+} -body {
+ set x 50
+ scale .s -variable x -from 0 -to 100 -orient horizontal
+ pack .s
+ update
+ destroy .s
+ list [catch {set x foo} msg] $msg $x
+} -result {0 foo foo}
+
+
+test scale-5.1 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
+ set x 66
+ set y 77
+ scale .s -variable x -from 0 -to 100
+ pack .s
+ update
+ .s configure -variable y
+ list [catch {set x foo} msg] $msg $x [.s get]
+} -cleanup {
+ deleteWindows
+} -result {0 foo foo 77}
+test scale-5.2 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100
+ .s configure -foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown option "-foo"}
+test scale-5.3 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
+ catch {unset x}
+ scale .s -from 0 -to 100 -variable x
+ set result $x
+ lappend result [.s get]
+ set x 92
+ lappend result [.s get]
+ .s set 3
+ lappend result $x
+ unset x
+ lappend result [set x]
+} -cleanup {
+ deleteWindows
+} -result {0 0 92 3 3}
+test scale-5.4 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100
+ .s configure -orient dumb
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad orient "dumb": must be horizontal or vertical}
+test scale-5.5 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 1.11 -to 1.89 -resolution .1 -tickinterval .76
+ list [format %.1f [.s cget -from]] [format %.1f [.s cget -to]] \
+ [format %.1f [.s cget -tickinterval]]
+} -cleanup {
+ deleteWindows
+} -result {1.1 1.9 0.8}
+test scale-5.6 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 1 -to 10 -tickinterval -2
+ pack .s
+ set result [lindex [.s configure -tickinterval] 4]
+ .s configure -from 10 -to 1 -tickinterval 2
+ lappend result [lindex [.s configure -tickinterval] 4]
+} -cleanup {
+ deleteWindows
+} -result {2.0 -2.0}
+test scale-5.7 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100 -state bogus
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad state "bogus": must be active, disabled, or normal}
+
+
+# Widget used in 6.* tests
+destroy .s
+scale .s -orient horizontal -length 200
+pack .s
+test scale-6.1 {ComputeFormat procedure} -body {
+ .s configure -from 10 -to 100 -resolution 10
+ .s set 49.3
+ .s get
+} -result {50}
+test scale-6.2 {ComputeFormat procedure} -body {
+ .s configure -from 100 -to 1000 -resolution 100
+ .s set 493
+ .s get
+} -result {500}
+test scale-6.3 {ComputeFormat procedure} -body {
+ .s configure -from 1000 -to 10000 -resolution 1000
+ .s set 4930
+ .s get
+} -result {5000}
+test scale-6.4 {ComputeFormat procedure} -body {
+ .s configure -from 10000 -to 100000 -resolution 10000
+ .s set 49000
+ .s get
+} -result {50000}
+test scale-6.5 {ComputeFormat procedure} -body {
+ .s configure -from 100000 -to 1000000 -resolution 100000
+ .s set 493000
+ .s get
+} -result {500000}
+test scale-6.6 {ComputeFormat procedure} -constraints {
+ nonPortable
+} -body {
+ # This test is non-portable because some platforms format the
+ # result as 5e+06.
+ .s configure -from 1000000 -to 10000000 -resolution 1000000
+ .s set 4930000
+ .s get
+} -result {5000000}
+test scale-6.7 {ComputeFormat procedure} -body {
+ .s configure -from 1000000000 -to 10000000000 -resolution 1000000000
+ .s set 4930000000
+ expr {[.s get] == 5.0e+09}
+} -result 1
+test scale-6.8 {ComputeFormat procedure} -body {
+ .s configure -from .1 -to 1 -resolution .1
+ .s set .6
+ .s get
+} -result {0.6}
+test scale-6.9 {ComputeFormat procedure} -body {
+ .s configure -from .01 -to .1 -resolution .01
+ .s set .06
+ .s get
+} -result {0.06}
+test scale-6.10 {ComputeFormat procedure} -body {
+ .s configure -from .001 -to .01 -resolution .001
+ .s set .006
+ .s get
+} -result {0.006}
+test scale-6.11 {ComputeFormat procedure} -body {
+ .s configure -from .0001 -to .001 -resolution .0001
+ .s set .0006
+ .s get
+} -result {0.0006}
+test scale-6.12 {ComputeFormat procedure} -body {
+ .s configure -from .00001 -to .0001 -resolution .00001
+ .s set .00006
+ .s get
+} -result {0.00006}
+test scale-6.13 {ComputeFormat procedure} -body {
+ .s configure -from .000001 -to .00001 -resolution .000001
+ .s set .000006
+ expr {[.s get] == 6.0e-06}
+} -result {1}
+test scale-6.14 {ComputeFormat procedure} -body {
+ .s configure -to .00001 -from .0001 -resolution .00001
+ .s set .00006
+ .s get
+} -result {0.00006}
+test scale-6.15 {ComputeFormat procedure} -body {
+ .s configure -to .000001 -from .00001 -resolution .000001
+ .s set .000006
+ expr {[.s get] == 6.0e-06}
+} -result {1}
+test scale-6.16 {ComputeFormat procedure} -body {
+ .s configure -from .00001 -to .0001 -resolution .00001 -digits 1
+ .s set .00006
+ expr {[.s get] == 6e-05}
+} -result {1}
+test scale-6.17 {ComputeFormat procedure} -body {
+ .s configure -from 10000000 -to 100000000 -resolution 10000000 -digits 3
+ .s set 49300000
+ .s get
+} -result {50000000}
+test scale-6.18 {ComputeFormat procedure} -body {
+ .s configure -length 200 -from 0 -to 10 -resolution 0 -digits 0
+ .s set .111111111
+ .s get
+} -result {0.11}
+test scale-6.19 {ComputeFormat procedure} -body {
+ .s configure -length 200 -from 1000 -to 1002 -resolution 0 -digits 0
+ .s set 1001.23456789
+ .s get
+} -result {1001.23}
+test scale-6.20 {ComputeFormat procedure} -body {
+ .s configure -length 200 -from 1000 -to 1001.8 -resolution 0 -digits 0
+ .s set 1001.23456789
+ .s get
+} -result {1001.235}
+test scale-6.21 {ComputeFormat procedure} -body {
+ .s configure -length 200 -from 1000 -to 1001.8 -resolution 0 -digits 200
+ .s set 1001.23456789
+ .s get
+} -result {1001.235}
+destroy .s
+
+
+test scale-7.1 {ComputeScaleGeometry procedure} -constraints {
+ nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 10 -label "Short" -orient vertical -length 5i
+ pack .s
+ update
+ list [winfo reqwidth .s] [winfo reqheight .s]
+} -cleanup {
+ deleteWindows
+} -result {88 458}
+test scale-7.2 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 1000 -label "Long string" -orient vertical -tick 200
+ pack .s
+ update
+ list [winfo reqwidth .s] [winfo reqheight .s]
+} -cleanup {
+ deleteWindows
+} -result {168 108}
+test scale-7.3 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -width 10 \
+ -sliderlength 10
+ pack .s
+ update
+ list [winfo reqwidth .s] [winfo reqheight .s]
+} -cleanup {
+ deleteWindows
+} -result {22 108}
+test scale-7.4 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -bd 5 \
+ -relief sunken
+ pack .s
+ update
+ list [winfo reqwidth .s] [winfo reqheight .s]
+} -cleanup {
+ deleteWindows
+} -result {39 114}
+test scale-7.5 {ComputeScaleGeometry procedure} -constraints {
+ nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 10 -label "Short" -orient horizontal -length 5i
+ pack .s
+ update
+ list [winfo reqwidth .s] [winfo reqheight .s]
+} -cleanup {
+ deleteWindows
+} -result {458 61}
+test scale-7.6 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 1000 -label "Long string" -orient horizontal \
+ -tick 500
+ pack .s
+ update
+ list [winfo reqwidth .s] [winfo reqheight .s]
+} -cleanup {
+ deleteWindows
+} -result {108 79}
+test scale-7.7 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 1000 -orient horizontal -showvalue 0
+ pack .s
+ update
+ list [winfo reqwidth .s] [winfo reqheight .s]
+} -cleanup {
+ deleteWindows
+} -result {108 27}
+test scale-7.8 {ComputeScaleGeometry procedure} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 1000 -orient horizontal -showvalue 0 -bd 5 \
+ -relief raised -highlightthickness 2
+ pack .s
+ update
+ list [winfo reqwidth .s] [winfo reqheight .s]
+} -cleanup {
+ deleteWindows
+} -result {114 39}
+
+
+test scale-8.1 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300
+ pack .s
+ .s set 30
+ update
+ list [.s identify 53 52] [.s identify 54 52] [.s identify 70 52] \
+ [.s identify 71 52]
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough1 {}}
+test scale-8.2 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300
+ pack .s
+ .s set 30
+ update
+ list [.s identify 60 2] [.s identify 60 3] [.s identify 60 302] \
+ [.s identify 60 303]
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough2 {}}
+test scale-8.3 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300
+ pack .s
+ .s set 30
+ update
+ list [.s identify 60 83] [.s identify 60 84] [.s identify 60 113] \
+ [.s identify 60 114] \
+} -cleanup {
+ deleteWindows
+} -result {trough1 slider slider trough2}
+test scale-8.4 {ScaleElement procedure} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100 -orient vertical -bd 4 -width 10 \
+ -highlightthickness 1 -length 300 -showvalue 0
+ pack .s
+ .s set 30
+ update
+ list [.s identify 4 40] [.s identify 5 40] [.s identify 22 40] \
+ [.s identify 23 40] \
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough1 {}}
+test scale-8.5 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100 -orient horizontal -bd 1 \
+ -highlightthickness 2 -tick 20 -sliderlength 20 \
+ -length 200 -label Test
+ pack .s
+ .s set 30
+ update
+ list [.s identify 150 36] [.s identify 150 37] [.s identify 150 53] \
+ [.s identify 150 54]
+} -cleanup {
+ deleteWindows
+} -result {{} trough2 trough2 {}}
+test scale-8.6 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100 -orient horizontal -bd 2 \
+ -highlightthickness 1 -tick 20 -length 200
+ pack .s
+ .s set 30
+ update
+ list [.s identify 150 20] [.s identify 150 21] [.s identify 150 39] \
+ [.s identify 150 40]
+} -cleanup {
+ deleteWindows
+} -result {{} trough2 trough2 {}}
+test scale-8.7 {ScaleElement procedure} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100 -orient horizontal -bd 4 -highlightthickness 2 \
+ -length 200 -width 10 -showvalue 0
+ pack .s
+ .s set 30
+ update
+ list [.s identify 30 5] [.s identify 30 6] [.s identify 30 23] \
+ [.s identify 30 24]
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough1 {}}
+test scale-8.8 {ScaleElement procedure} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100 -orient horizontal -bd 1 -highlightthickness 2 \
+ -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0
+ pack .s
+ .s set 30
+ update
+ list [.s identify 2 28] [.s identify 3 28] [.s identify 202 28] \
+ [.s identify 203 28]
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough2 {}}
+test scale-8.9 {ScaleElement procedure} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100 -orient horizontal -bd 1 -highlightthickness 2 \
+ -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0
+ pack .s
+ .s set 80
+ update
+ list [.s identify 145 28] [.s identify 146 28] [.s identify 165 28] \
+ [.s identify 166 28]
+} -cleanup {
+ deleteWindows
+} -result {trough1 slider slider trough2}
+
+
+#widget used in 9.* tests
+destroy .s
+pack [scale .s]
+test scale-9.1 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
+ .s get 46 0
+} -result 0
+test scale-9.2 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
+ .s get -10 9
+} -result 0
+test scale-9.3 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
+ .s get -10 12
+} -result 1
+test scale-9.4 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
+ .s get -10 46
+} -result 35
+test scale-9.5 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
+ .s get -10 110
+} -result 99
+test scale-9.6 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
+ .s get -10 111
+} -result 100
+test scale-9.7 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
+ .s get -10 112
+} -result 100
+test scale-9.8 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
+ .s get -10 154
+} -result 100
+test scale-9.9 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal
+ update
+ .s get 76 152
+} -result 65
+destroy .s
+
+
+test scale-10.1 {ValueToPixel procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100 -sliderlength 20 -length 124 -bd 2 \
+ -orient horizontal -label Test -tick 20
+ pack .s
+ update
+ list [.s coords -10] [.s coords 40] [.s coords 1000]
+} -cleanup {
+ deleteWindows
+} -result {{16 47} {56 47} {116 47}}
+test scale-10.2 {ValueToPixel procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 100 -to 0 -sliderlength 20 -length 122 -bd 1 \
+ -orient vertical -label Test -tick 20
+ pack .s
+ update
+ list [.s coords -10] [.s coords 40] [.s coords 1000]
+} -cleanup {
+ deleteWindows
+} -result {{62 114} {62 74} {62 14}}
+
+
+test scale-11.1 {ScaleEventProc procedure} -setup {
+ deleteWindows
+} -body {
+ proc killScale value {
+ global x
+ if {$value > 30} {
+ destroy .s1
+ lappend x [winfo exists .s1] [info commands .s1]
+ }
+ }
+ set x initial
+ scale .s1 -from 0 -to 100 -command killScale
+ .s1 set 20
+ pack .s1
+ update idletasks
+ lappend x [winfo exists .s1]
+ .s1 set 40
+ update idletasks
+ return $x
+} -cleanup {
+ rename killScale {}
+ deleteWindows
+} -result {initial 1 0 {}}
+test scale-11.2 {ScaleEventProc procedure} -setup {
+ deleteWindows
+ set x {}
+} -body {
+ scale .s1 -bg #543210
+ rename .s1 .s2
+ lappend x [winfo children .]
+ lappend x [.s2 cget -bg]
+ destroy .s1
+ lappend x [info command .s*] [winfo children .]
+} -cleanup {
+ deleteWindows
+} -result {.s1 #543210 {} {}}
+
+test scale-12.1 {ScaleCmdDeletedProc procedure} -setup {
+ deleteWindows
+} -body {
+ scale .s1
+ rename .s1 {}
+ list [info command .s*] [winfo children .]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+
+
+# Widget used in 13.* tests
+destroy .s
+pack [scale .s]
+update
+test scale-13.1 {SetScaleValue procedure} -body {
+ .s configure -from 0 -to 100 -command {set x} -variable y
+ update
+ set x xyzzy
+ .s set 44
+ set result [list $x $y]
+ update
+ lappend result $x $y
+} -result {xyzzy 44 44 44}
+test scale-13.2 {SetScaleValue procedure} -body {
+ .s set -3
+ .s get
+} -result 0
+test scale-13.3 {SetScaleValue procedure} -body {
+ .s set 105
+ .s get
+} -result 100
+.s configure -from 100 -to 0
+test scale-13.4 {SetScaleValue procedure} -body {
+ .s set -3
+ .s get
+} -result 0
+test scale-13.5 {SetScaleValue procedure} -body {
+ .s set 105
+ .s get
+} -result 100
+test scale-13.6 {SetScaleValue procedure} -body {
+ proc varTrace args {
+ global traceInfo
+ set traceInfo $args
+ }
+ .s configure -from 0 -to 100 -command {set x} -variable y
+ update
+
+ .s set 50
+ update
+ trace variable y w varTrace
+ set traceInfo empty
+ set x untouched
+ .s set 50
+ update
+ list $x $traceInfo
+} -result {untouched empty}
+
+
+# Widget used in 14.* tests
+destroy .s
+pack [scale .s]
+update
+test scale-14.1 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
+ .s get 84 152
+} -result 72
+test scale-14.2 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
+ .s get 86 152
+} -result 76
+
+test scale-14.3 {RoundToResolution procedure} -body {
+ .s configure -from 100 -to 0 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
+ .s get 84 152
+} -result 28
+test scale-14.4 {RoundToResolution procedure} -body {
+ .s configure -from 100 -to 0 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
+ .s get 86 152
+} -result 24
+
+test scale-14.5 {RoundToResolution procedure} -body {
+ .s configure -from -100 -to 0 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
+ .s get 84 152
+} -result {-28}
+test scale-14.6 {RoundToResolution procedure} -body {
+ .s configure -from -100 -to 0 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
+ .s get 86 152
+} -result {-24}
+
+test scale-14.7 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to -100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
+ .s get 84 152
+} -result {-72}
+test scale-14.8 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to -100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
+ .s get 86 152
+} -result {-76}
+
+test scale-14.9 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 2.25 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 0
+ update
+ .s get 84 152
+} -result {1.64}
+test scale-14.10 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 2.25 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 0
+ update
+ .s get 86 152
+} -result {1.69}
+
+test scale-14.11 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 225 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 0 -digits 5
+ update
+ .s get 84 152
+} -result {164.25}
+test scale-14.12 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 225 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 0 -digits 5
+ update
+ .s get 86 152
+} -result {168.75}
+destroy .s
+
+
+test scale-15.1 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
+ set y -130
+ scale .s -from 0 -to -200 -variable y -orient horizontal -length 150
+ pack .s
+ return $y
+} -result {-130}
+test scale-15.2 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
+ set y -130
+ scale .s -from -200 -to 0 -variable y -orient horizontal -length 150
+ pack .s
+ set y -87
+ .s get
+} -result {-87}
+test scale-15.3 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
+ set y -130
+ scale .s -from -200 -to 0 -variable y -orient horizontal -length 150
+ pack .s
+ set y 40q
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't set "y": can't assign non-numeric value to scale variable}
+test scale-15.4 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
+ set y -130
+ scale .s -from -200 -to 0 -variable y -orient horizontal -length 150
+ pack .s
+ catch {set y 40q}
+ .s get
+} -cleanup {
+ deleteWindows
+} -result {-130}
+test scale-15.5 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
+ set y 1
+ scale .s -from 1 -to 0 -variable y -orient horizontal -length 150
+ pack .s
+ set y x
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't set "y": can't assign non-numeric value to scale variable}
+test scale-15.6 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
+ set y 1
+ scale .s -from 1 -to 0 -variable y -orient horizontal -length 150
+ pack .s
+ catch {set y x}
+ .s get
+} -cleanup {
+ deleteWindows
+} -result 1
+test scale-15.7 {ScaleVarProc procedure, variable deleted} -setup {
+ deleteWindows
+} -body {
+ set y 6
+ scale .s -from 10 -to 0 -variable y -orient horizontal -length 150 \
+ -command "set x"
+ pack .s
+ update
+ set x untouched
+ unset y
+ update
+ list [catch {set y} msg] $msg [.s get] $x
+} -cleanup {
+ deleteWindows
+} -result {0 6 6 untouched}
+test scale-15.8 {ScaleVarProc procedure, don't call -command} -setup {
+ deleteWindows
+} -body {
+ set y 6
+ scale .s -from 0 -to 100 -variable y -orient horizontal -length 150 \
+ -command "set x"
+ pack .s
+ update
+ set x untouched
+ set y 60
+ update
+ list $x [.s get]
+} -cleanup {
+ deleteWindows
+} -result {untouched 60}
+
+
+test scale-16.1 {scale widget vs hidden commands} -body {
+ set l [interp hidden]
+ deleteWindows
+ scale .s
+ interp hide {} .s
+ destroy .s
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 eq $res2}
+} -cleanup {
+ deleteWindows
+} -result 1
+
+
+test scale-17.1 {bug fix 1786} -setup {
+ deleteWindows
+} -body {
+ # Perhaps x is set to {}, depending on what other tests have run.
+ # If x is unset, or set to something not convertable to a double,
+ # then the scale try to initialize its value with the contents
+ # of uninitialized memory. Sometimes that causes an FPE.
+
+ set x {}
+ scale .s -from 100 -to 300
+ pack .s
+ update
+ .s configure -variable x ;# CRASH! -> Floating point exception
+
+ # Bug 4833 changed the result to realize that x should pick up
+ # a value from the scale. In an FPE occurs, it is due to the
+ # lack of errno being set to 0 by some libc's. (see bug 4942)
+ return $x
+} -cleanup {
+ deleteWindows
+} -result {100}
+
+
+test scale-18.1 {DestroyScale, -cursor option [Bug: 3897]} -setup {
+ deleteWindows
+} -body {
+ scale .s -cursor trek
+ destroy .s
+} -result {}
+
+test scale-18.2 {Scale button 1 events [Bug 787065]} -setup {
+ destroy .s
+ set ::error {}
+ proc bgerror {args} {set ::error $args}
+} -body {
+ set y 5
+ scale .s -from 0 -to 10 -variable y -orient horizontal -length 150
+ pack .s
+ tkwait visibility .s
+ list [catch {
+ event generate .s <1> -x 0 -y 0
+ event generate .s <ButtonRelease-1> -x 0 -y 0
+ update
+ set ::error
+ } msg] $msg
+} -cleanup {
+ unset ::error
+ rename bgerror {}
+ destroy .s
+} -result {0 {}}
+
+test scale-18.3 {Scale button 2 events [Bug 787065]} -setup {
+ destroy .s
+ set ::error {}
+ proc bgerror {args} {set ::error $args}
+} -body {
+ set y 5
+ scale .s -from 0 -to 10 -variable y -orient horizontal -length 150
+ pack .s
+ tkwait visibility .s
+ list [catch {
+ event generate .s <2> -x 0 -y 0
+ event generate .s <ButtonRelease-2> -x 0 -y 0
+ update
+ set ::error
+ } msg] $msg
+} -cleanup {
+ unset ::error
+ rename bgerror {}
+ destroy .s
+} -result {0 {}}
+
+
+test scale-19 {Bug [3529885fff] - Click in through goes in wrong direction} \
+ -setup {
+ catch {destroy .s}
+ catch {destroy .s1 .s2 .s3 .s4}
+ unset -nocomplain x1 x2 x3 x4 x y
+ scale .s1 -from 0 -to 100 -resolution 1 -variable x1 -digits 4 -orient horizontal -length 100
+ scale .s2 -from 0 -to 100 -resolution -1 -variable x2 -digits 4 -orient horizontal -length 100
+ scale .s3 -from 100 -to 0 -resolution 1 -variable x3 -digits 4 -orient horizontal -length 100
+ scale .s4 -from 100 -to 0 -resolution -1 -variable x4 -digits 4 -orient horizontal -length 100
+ pack .s1 .s2 .s3 .s4 -side left
+ update
+ } \
+ -body {
+ foreach {x y} [.s1 coord 50] {}
+ event generate .s1 <1> -x $x -y $y
+ event generate .s1 <ButtonRelease-1> -x $x -y $y
+ foreach {x y} [.s2 coord 50] {}
+ event generate .s2 <1> -x $x -y $y
+ event generate .s2 <ButtonRelease-1> -x $x -y $y
+ foreach {x y} [.s3 coord 50] {}
+ event generate .s3 <1> -x $x -y $y
+ event generate .s3 <ButtonRelease-1> -x $x -y $y
+ foreach {x y} [.s4 coord 50] {}
+ event generate .s4 <1> -x $x -y $y
+ event generate .s4 <ButtonRelease-1> -x $x -y $y
+ update
+ list $x1 $x2 $x3 $x4
+ } \
+ -cleanup {
+ unset x1 x2 x3 x4 x y
+ destroy .s1 .s2 .s3 .s4
+ } \
+ -result {1.0 1.0 1.0 1.0}
+
+test scale-20.1 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 1} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+} -body {
+ scale .s -from 1 -to 50 -command {set commandedVar}
+ pack .s
+ update ; # -command callback shall NOT fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {1 -1}
+test scale-20.2 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 2} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+ set scaleVar 7
+} -body {
+ scale .s -from 1 -to 50 -variable scaleVar -command {set commandedVar}
+ pack .s
+ update ; # -command callback shall NOT fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {7 -1}
+test scale-20.3 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 3} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+} -body {
+ scale .s -from 1 -to 50
+ .s set 10
+ .s configure -command {set commandedVar}
+ pack .s
+ update ; # -command callback shall NOT fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {10 -1}
+test scale-20.4 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 4} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+} -body {
+ scale .s -from 1 -to 50 -command {set commandedVar}
+ .s set 10
+ pack .s
+ update ; # -command callback shall fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {10 10}
+test scale-20.5 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 5} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+} -body {
+ scale .s -from 1 -to 50
+ pack .s
+ .s set 10
+ .s configure -command {set commandedVar}
+ update ; # -command callback shall NOT fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {10 -1}
+test scale-20.6 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 6} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+} -body {
+ scale .s -from 1 -to 50
+ pack .s
+ .s configure -command {set commandedVar}
+ .s set 10
+ update ; # -command callback shall fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {10 10}
+test scale-20.7 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 7} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+} -body {
+ scale .s -from 1 -to 50 -command {set commandedVar}
+ pack .s
+ .s set 10
+ update ; # -command callback shall fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {10 10}
+test scale-20.8 {Bug [2262543fff] - Scale widget unexpectedly fires command callback, case 8} -setup {
+ catch {destroy .s}
+ set res {}
+ set commandedVar -1
+ set scaleVar 7
+} -body {
+ scale .s -from 1 -to 50 -variable scaleVar -command {set commandedVar}
+ pack .s
+ .s set 10
+ update ; # -command callback shall fire
+ set res [list [.s get] $commandedVar]
+} -cleanup {
+ destroy .s
+} -result {10 10}
+
+option clear
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/scrollbar.test b/tk8.6/tests/scrollbar.test
new file mode 100644
index 0000000..bd14067
--- /dev/null
+++ b/tk8.6/tests/scrollbar.test
@@ -0,0 +1,707 @@
+# This file is a Tcl script to test out scrollbar widgets and
+# the "scrollbar" command of Tk. It is organized in the standard
+# fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+proc scroll args {
+ global scrollInfo
+ set scrollInfo $args
+}
+
+proc getTroughSize {w} {
+ if {[testConstraint testmetrics]} {
+ if [string match v* [$w cget -orient]] {
+ return [expr [winfo height $w] - 2*[testmetrics cyvscroll $w]]
+ } else {
+ return [expr [winfo width $w] - 2*[testmetrics cxhscroll $w]]
+ }
+ } else {
+ if [string match v* [$w cget -orient]] {
+ return [expr [winfo height $w] \
+ - ([winfo width $w] \
+ - [$w cget -highlightthickness] \
+ - [$w cget -bd] + 1)*2]
+ } else {
+ return [expr [winfo width $w] \
+ - ([winfo height $w] \
+ - [$w cget -highlightthickness] \
+ - [$w cget -bd] + 1)*2]
+ }
+ }
+}
+
+# XXX Note: this test file is woefully incomplete. Right now there are
+# only bits and pieces of tests. Please make this file more complete
+# as you fix bugs and add features.
+
+foreach {width height} [wm minsize .] {
+ set height [expr ($height < 200) ? 200 : $height]
+ set width [expr ($width < 1) ? 1 : $width]
+}
+
+frame .f -height $height -width $width
+pack .f -side left
+scrollbar .s
+pack .s -side right -fill y
+update
+set i 1
+foreach test {
+ {-activebackground #ff0000 #ff0000 non-existent
+ {unknown color name "non-existent"}}
+ {-activerelief sunken sunken non-existent
+ {bad relief "non-existent": must be flat, groove, raised, ridge, solid, or sunken}}
+ {-background #ff0000 #ff0000 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"}}
+ {-command "set x" {set x} {} {}}
+ {-elementborderwidth 4 4 badValue {bad screen distance "badValue"}}
+ {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
+ {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
+ {-highlightcolor #123456 #123456 bogus {unknown color name "bogus"}}
+ {-highlightthickness 6 6 bogus {bad screen distance "bogus"}}
+ {-highlightthickness -2 0 {} {}}
+ {-jump true 1 silly {expected boolean value but got "silly"}}
+ {-orient horizontal horizontal badValue
+ {bad orientation "badValue": must be vertical or horizontal}}
+ {-orient horizontal horizontal bogus {bad orientation "bogus": must be vertical or horizontal}}
+ {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
+ {-repeatdelay 140 140 129.3 {expected integer but got "129.3"}}
+ {-repeatinterval 140 140 129.3 {expected integer but got "129.3"}}
+ {-takefocus "any string" "any string" {} {}}
+ {-troughcolor #432 #432 lousy {unknown color name "lousy"}}
+ {-width 32 32 badValue {bad screen distance "badValue"}}
+} {
+ lassign $test name value okResult badValue badResult
+ # Assume $name is plain; true of all our in-use options!
+ test scrollbar-1.$i {configuration options} \
+ ".s configure $name [list $value]; .s cget $name" $okResult
+ incr i
+ if {$badValue ne ""} {
+ test scrollbar-1.$i {configuration options} \
+ -body [list .s configure $name $badValue] \
+ -returnCodes error -result $badResult
+ incr i
+ }
+ .s configure $name [lindex [.s configure $name] 3]
+}
+
+destroy .s
+test scrollbar-2.1 {Tk_ScrollbarCmd procedure} -returnCodes error -body {
+ scrollbar
+} -result {wrong # args: should be "scrollbar pathName ?-option value ...?"}
+test scrollbar-2.2 {Tk_ScrollbarCmd procedure} -body {
+ scrollbar gorp
+} -returnCodes error -result {bad window path name "gorp"}
+test scrollbar-2.3 {Tk_ScrollbarCmd procedure} -setup {
+ scrollbar .s
+} -body {
+ list [winfo class .s] [info command .s]
+} -cleanup {
+ destroy .s
+} -result {Scrollbar .s}
+test scrollbar-2.4 {Tk_ScrollbarCmd procedure} {
+ list [catch {scrollbar .s -gorp blah} msg] $msg [winfo exists .s] \
+ [info command .s]
+} {1 {unknown option "-gorp"} 0 {}}
+test scrollbar-2.5 {Tk_ScrollbarCmd procedure} -setup {
+ catch {destroy .s}
+} -body {
+ scrollbar .s
+} -cleanup {
+ destroy .s
+} -result .s
+
+scrollbar .s -orient vertical -command scroll -highlightthickness 2 -bd 2
+pack .s -side right -fill y
+update
+test scrollbar-3.1 {ScrollbarWidgetCmd procedure} {
+ list [catch {.s} msg] $msg
+} {1 {wrong # args: should be ".s option ?arg ...?"}}
+test scrollbar-3.2 {ScrollbarWidgetCmd procedure, "cget" option} {
+ list [catch {.s cget} msg] $msg
+} {1 {wrong # args: should be ".s cget option"}}
+test scrollbar-3.3 {ScrollbarWidgetCmd procedure, "cget" option} {
+ list [catch {.s cget -gorp} msg] $msg
+} {1 {unknown option "-gorp"}}
+test scrollbar-3.4 {ScrollbarWidgetCmd procedure, "activate" option} {
+ list [catch {.s activate a b} msg] $msg
+} {1 {wrong # args: should be ".s activate element"}}
+test scrollbar-3.5 {ScrollbarWidgetCmd procedure, "activate" option} {
+ .s activate arrow1
+ .s activate
+} {arrow1}
+test scrollbar-3.6 {ScrollbarWidgetCmd procedure, "activate" option} {
+ .s activate slider
+ .s activate
+} {slider}
+test scrollbar-3.7 {ScrollbarWidgetCmd procedure, "activate" option} {
+ .s activate arrow2
+ .s activate
+} {arrow2}
+test scrollbar-3.8 {ScrollbarWidgetCmd procedure, "activate" option} {
+ .s activate s
+ .s activate {}
+ .s activate
+} {}
+test scrollbar-3.9 {ScrollbarWidgetCmd procedure, "activate" option} {
+ list [catch {.s activate trough1} msg] $msg
+} {0 {}}
+test scrollbar-3.10 {ScrollbarWidgetCmd procedure, "cget" option} {
+ list [catch {.s cget -orient} msg] $msg
+} {0 vertical}
+scrollbar .s2
+test scrollbar-3.11 {ScrollbarWidgetCmd procedure, "cget" option} {
+ expr {[.s2 cget -bd] == [lindex [.s2 configure -bd] 3]}
+} 1
+test scrollbar-3.12 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest {
+ # empty test; duplicated scrollbar-3.11
+} {}
+test scrollbar-3.12.1 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest {
+ # empty test; duplicated scrollbar-3.11
+} {}
+test scrollbar-3.13 {ScrollbarWidgetCmd procedure, "cget" option} {
+ expr {[.s2 cget -highlightthickness] == [lindex [.s2 configure -highlightthickness] 3]}
+} 1
+test scrollbar-3.14 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest {
+ # empty test; duplicated scrollbar-3.13
+} {}
+test scrollbar-3.14.1 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest {
+ # empty test; duplicated scrollbar-3.13
+} {}
+destroy .s2
+test scrollbar-3.15 {ScrollbarWidgetCmd procedure, "configure" option} {
+ llength [.s configure]
+} {20}
+test scrollbar-3.16 {ScrollbarWidgetCmd procedure, "configure" option} {
+ list [catch {.s configure -bad} msg] $msg
+} {1 {unknown option "-bad"}}
+test scrollbar-3.17 {ScrollbarWidgetCmd procedure, "configure" option} {
+ .s configure -orient
+} {-orient orient Orient vertical vertical}
+test scrollbar-3.18 {ScrollbarWidgetCmd procedure, "configure" option} {
+ .s configure -orient horizontal
+ set x [.s cget -orient]
+ .s configure -orient vertical
+ set x
+} {horizontal}
+test scrollbar-3.19 {ScrollbarWidgetCmd procedure, "configure" option} {
+ list [catch {.s configure -bad worse} msg] $msg
+} {1 {unknown option "-bad"}}
+test scrollbar-3.20 {ScrollbarWidgetCmd procedure, "delta" option} {
+ list [catch {.s delta 24} msg] $msg
+} {1 {wrong # args: should be ".s delta xDelta yDelta"}}
+test scrollbar-3.21 {ScrollbarWidgetCmd procedure, "delta" option} {
+ list [catch {.s delta 24 35 42} msg] $msg
+} {1 {wrong # args: should be ".s delta xDelta yDelta"}}
+test scrollbar-3.22 {ScrollbarWidgetCmd procedure, "delta" option} {
+ list [catch {.s delta silly 24} msg] $msg
+} {1 {expected integer but got "silly"}}
+test scrollbar-3.23 {ScrollbarWidgetCmd procedure, "delta" option} {
+ list [catch {.s delta 18 xxyz} msg] $msg
+} {1 {expected integer but got "xxyz"}}
+test scrollbar-3.24 {ScrollbarWidgetCmd procedure, "delta" option} {
+ list [catch {.s delta 18 xxyz} msg] $msg
+} {1 {expected integer but got "xxyz"}}
+test scrollbar-3.25 {ScrollbarWidgetCmd procedure, "delta" option} {
+ format {%.6g} [.s delta 20 0]
+} {0}
+test scrollbar-3.26 {ScrollbarWidgetCmd procedure, "delta" option} {
+ format {%.6g} [.s delta 0 20]
+} [format %.6g [expr 20.0/([getTroughSize .s]-1)]]
+test scrollbar-3.27 {ScrollbarWidgetCmd procedure, "delta" option} {
+ format {%.6g} [.s delta 0 -20]
+} [format %.6g [expr -20.0/([getTroughSize .s]-1)]]
+test scrollbar-3.28 {ScrollbarWidgetCmd procedure, "delta" option} {
+ toplevel .t -width 250 -height 100
+ wm geom .t +0+0
+ scrollbar .t.s -orient horizontal -borderwidth 2
+ place .t.s -width 201
+ update
+ set result [list [format {%.6g} [.t.s delta 0 20]] \
+ [format {%.6g} [.t.s delta [expr [getTroughSize .t.s] - 1] 0]]]
+ destroy .t
+ set result
+} {0 1}
+test scrollbar-3.29 {ScrollbarWidgetCmd procedure, "fraction" option} {
+ list [catch {.s fraction 24} msg] $msg
+} {1 {wrong # args: should be ".s fraction x y"}}
+test scrollbar-3.30 {ScrollbarWidgetCmd procedure, "fraction" option} {
+ list [catch {.s fraction 24 30 32} msg] $msg
+} {1 {wrong # args: should be ".s fraction x y"}}
+test scrollbar-3.31 {ScrollbarWidgetCmd procedure, "fraction" option} {
+ list [catch {.s fraction silly 24} msg] $msg
+} {1 {expected integer but got "silly"}}
+test scrollbar-3.32 {ScrollbarWidgetCmd procedure, "fraction" option} {
+ list [catch {.s fraction 24 bogus} msg] $msg
+} {1 {expected integer but got "bogus"}}
+test scrollbar-3.33 {ScrollbarWidgetCmd procedure, "fraction" option} {
+ format {%.6g} [.s fraction 0 0]
+} {0}
+test scrollbar-3.34 {ScrollbarWidgetCmd procedure, "fraction" option} {
+ format {%.6g} [.s fraction 0 1000]
+} {1}
+test scrollbar-3.35 {ScrollbarWidgetCmd procedure, "fraction" option} {
+ format {%.6g} [.s fraction 4 21]
+} [format %.6g [expr (21.0 - ([winfo height .s] - [getTroughSize .s])/2.0) \
+ /([getTroughSize .s] - 1)]]
+test scrollbar-3.36 {ScrollbarWidgetCmd procedure, "fraction" option} unix {
+ format {%.6g} [.s fraction 4 179]
+} {1}
+test scrollbar-3.37 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics} {
+ format {%.6g} [.s fraction 4 [expr 200 - [testmetrics cyvscroll .s]]]
+} {1}
+test scrollbar-3.38 {ScrollbarWidgetCmd procedure, "fraction" option} unix {
+ format {%.6g} [.s fraction 4 178]
+} {0.993711}
+test scrollbar-3.39 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics win} {
+ expr \
+ [format {%.6g} [.s fraction 4 [expr 200 - [testmetrics cyvscroll .s] - 2]]] \
+ == [format %g [expr (200.0 - [testmetrics cyvscroll .s]*2 - 2) \
+ / ($height - 1 - [testmetrics cyvscroll .s]*2)]]
+} 1
+
+toplevel .t -width 250 -height 100
+wm geom .t +0+0
+scrollbar .t.s -orient horizontal -borderwidth 2
+place .t.s -width 201
+update
+
+test scrollbar-3.41 {ScrollbarWidgetCmd procedure, "fraction" option} {
+ format {%.6g} [.t.s fraction 100 0]
+} {0.5}
+if {[testConstraint testmetrics]} {
+ place configure .t.s -width [expr 2*[testmetrics cxhscroll .t.s]+1]
+} else {
+ place configure .t.s -width [expr [winfo reqwidth .t.s] - 4]
+}
+update
+test scrollbar-3.42 {ScrollbarWidgetCmd procedure, "fraction" option} {
+ format {%.6g} [.t.s fraction 100 0]
+} {0}
+destroy .t
+test scrollbar-3.43 {ScrollbarWidgetCmd procedure, "get" option} {
+ list [catch {.s get a} msg] $msg
+} {1 {wrong # args: should be ".s get"}}
+test scrollbar-3.44 {ScrollbarWidgetCmd procedure, "get" option} {
+ .s set 100 10 13 14
+ .s get
+} {100 10 13 14}
+test scrollbar-3.45 {ScrollbarWidgetCmd procedure, "get" option} {
+ .s set 0.6 0.8
+ set result {}
+ foreach element [.s get] {
+ lappend result [format %.1f $element]
+ }
+ set result
+} {0.6 0.8}
+test scrollbar-3.46 {ScrollbarWidgetCmd procedure, "identify" option} {
+ list [catch {.s identify 0} msg] $msg
+} {1 {wrong # args: should be ".s identify x y"}}
+test scrollbar-3.47 {ScrollbarWidgetCmd procedure, "identify" option} {
+ list [catch {.s identify 0 0 1} msg] $msg
+} {1 {wrong # args: should be ".s identify x y"}}
+test scrollbar-3.48 {ScrollbarWidgetCmd procedure, "identify" option} {
+ list [catch {.s identify bogus 2} msg] $msg
+} {1 {expected integer but got "bogus"}}
+test scrollbar-3.49 {ScrollbarWidgetCmd procedure, "identify" option} {
+ list [catch {.s identify -1 bogus} msg] $msg
+} {1 {expected integer but got "bogus"}}
+test scrollbar-3.50 {ScrollbarWidgetCmd procedure, "identify" option} {
+ .s identify 5 5
+} {arrow1}
+test scrollbar-3.51 {ScrollbarWidgetCmd procedure, "identify" option} {
+ .s identify 5 35
+} {trough1}
+test scrollbar-3.52 {ScrollbarWidgetCmd procedure, "identify" option} {
+ .s set .3 .6
+ .s identify 5 80
+} {slider}
+test scrollbar-3.53 {ScrollbarWidgetCmd procedure, "identify" option} {
+ .s identify 5 145
+} {trough2}
+test scrollbar-3.54 {ScrollbarWidgetCmd procedure, "identify" option} {unixOrPc} {
+ .s identify 5 195
+} {arrow2}
+test scrollbar-3.56 {ScrollbarWidgetCmd procedure, "identify" option} unix {
+ .s identify 0 0
+} {}
+test scrollbar-3.57 {ScrollbarWidgetCmd procedure, "set" option} {
+ list [catch {.s set abc def} msg] $msg
+} {1 {expected floating-point number but got "abc"}}
+test scrollbar-3.58 {ScrollbarWidgetCmd procedure, "set" option} {
+ list [catch {.s set 0.6 def} msg] $msg
+} {1 {expected floating-point number but got "def"}}
+test scrollbar-3.59 {ScrollbarWidgetCmd procedure, "set" option} {
+ .s set -.2 .3
+ set result {}
+ foreach element [.s get] {
+ lappend result [format %.1f $element]
+ }
+ set result
+} {0.0 0.3}
+test scrollbar-3.60 {ScrollbarWidgetCmd procedure, "set" option} {
+ .s set 1.1 .4
+ .s get
+} {1.0 1.0}
+test scrollbar-3.61 {ScrollbarWidgetCmd procedure, "set" option} {
+ .s set .5 -.3
+ .s get
+} {0.5 0.5}
+test scrollbar-3.62 {ScrollbarWidgetCmd procedure, "set" option} {
+ .s set .5 87
+ .s get
+} {0.5 1.0}
+test scrollbar-3.63 {ScrollbarWidgetCmd procedure, "set" option} {
+ .s set .4 .3
+ set result {}
+ foreach element [.s get] {
+ lappend result [format %.1f $element]
+ }
+ set result
+} {0.4 0.4}
+test scrollbar-3.64 {ScrollbarWidgetCmd procedure, "set" option} {
+ list [catch {.s set abc def ghi jkl} msg] $msg
+} {1 {expected integer but got "abc"}}
+test scrollbar-3.65 {ScrollbarWidgetCmd procedure, "set" option} {
+ list [catch {.s set 1 def ghi jkl} msg] $msg
+} {1 {expected integer but got "def"}}
+test scrollbar-3.66 {ScrollbarWidgetCmd procedure, "set" option} {
+ list [catch {.s set 1 2 ghi jkl} msg] $msg
+} {1 {expected integer but got "ghi"}}
+test scrollbar-3.67 {ScrollbarWidgetCmd procedure, "set" option} {
+ list [catch {.s set 1 2 3 jkl} msg] $msg
+} {1 {expected integer but got "jkl"}}
+test scrollbar-3.68 {ScrollbarWidgetCmd procedure, "set" option} {
+ .s set -10 50 20 30
+ .s get
+} {0 50 0 0}
+test scrollbar-3.69 {ScrollbarWidgetCmd procedure, "set" option} {
+ .s set 100 -10 20 30
+ .s get
+} {100 0 20 30}
+test scrollbar-3.70 {ScrollbarWidgetCmd procedure, "set" option} {
+ .s set 100 50 30 20
+ .s get
+} {100 50 30 30}
+test scrollbar-3.71 {ScrollbarWidgetCmd procedure, "set" option} {
+ list [catch {.s set 1 2 3} msg] $msg
+} {1 {wrong # args: should be ".s set firstFraction lastFraction" or ".s set totalUnits windowUnits firstUnit lastUnit"}}
+test scrollbar-3.72 {ScrollbarWidgetCmd procedure, "set" option} {
+ list [catch {.s set 1 2 3 4 5} msg] $msg
+} {1 {wrong # args: should be ".s set firstFraction lastFraction" or ".s set totalUnits windowUnits firstUnit lastUnit"}}
+test scrollbar-3.73 {ScrollbarWidgetCmd procedure} {
+ list [catch {.s bogus} msg] $msg
+} {1 {bad option "bogus": must be activate, cget, configure, delta, fraction, get, identify, or set}}
+test scrollbar-3.74 {ScrollbarWidgetCmd procedure} {
+ list [catch {.s c} msg] $msg
+} {1 {ambiguous option "c": must be activate, cget, configure, delta, fraction, get, identify, or set}}
+
+test scrollbar-4.1 {ScrollbarEventProc procedure} {
+ catch {destroy .s1}
+ scrollbar .s1 -bg #543210
+ rename .s1 .s2
+ set x {}
+ lappend x [winfo exists .s1]
+ lappend x [.s2 cget -bg]
+ destroy .s1
+ lappend x [info command .s?] [winfo exists .s1] [winfo exists .s2]
+} {1 #543210 {} 0 0}
+
+test scrollbar-5.1 {ScrollbarCmdDeletedProc procedure} {
+ catch {destroy .s1}
+ scrollbar .s1
+ rename .s1 {}
+ list [info command .s?] [winfo exists .s1]
+} {{} 0}
+
+catch {destroy .s}
+scrollbar .s -orient vertical -relief sunken -bd 2 -highlightthickness 2
+pack .s -side left -fill y
+.s set .2 .4
+update
+
+test scrollbar-6.1 {ScrollbarPosition procedure} unix {
+ .s identify 8 3
+} {}
+test scrollbar-6.3 {ScrollbarPosition procedure} unix {
+ .s identify 8 196
+} {}
+test scrollbar-6.4 {ScrollbarPosition procedure} unix {
+ .s identify 3 100
+} {}
+test scrollbar-6.6 {ScrollbarPosition procedure} unix {
+ .s identify 19 100
+} {}
+test scrollbar-6.7 {ScrollbarPosition procedure} {
+ .s identify [expr [winfo width .s] / 2] -1
+} {}
+test scrollbar-6.8 {ScrollbarPosition procedure} {
+ .s identify [expr [winfo width .s] / 2] [expr [winfo height .s]]
+} {}
+test scrollbar-6.9 {ScrollbarPosition procedure} {
+ .s identify -1 [expr [winfo height .s] / 2]
+} {}
+test scrollbar-6.10 {ScrollbarPosition procedure} {
+ .s identify [winfo width .s] [expr [winfo height .s] / 2]
+} {}
+test scrollbar-6.11 {ScrollbarPosition procedure} unix {
+ .s identify 8 4
+} {arrow1}
+test scrollbar-6.12 {ScrollbarPosition procedure} unix {
+ .s identify 8 19
+} {arrow1}
+test scrollbar-6.14 {ScrollbarPosition procedure} win {
+ .s identify [expr [winfo width .s] / 2] 0
+} {arrow1}
+test scrollbar-6.15 {ScrollbarPosition procedure} {testmetrics win} {
+ .s identify [expr [winfo width .s] / 2] [expr [testmetrics cyvscroll .s] - 1]
+} {arrow1}
+test scrollbar-6.16 {ScrollbarPosition procedure} unix {
+ .s identify 8 20
+} {trough1}
+test scrollbar-6.17 {ScrollbarPosition procedure} {unix nonPortable} {
+ # Don't know why this is non-portable, but it doesn't work on
+ # some platforms.
+ .s identify 8 51
+} {trough1}
+test scrollbar-6.18 {ScrollbarPosition procedure} {testmetrics win} {
+ .s identify [expr [winfo width .s] / 2] [testmetrics cyvscroll .s]
+} {trough1}
+test scrollbar-6.19 {ScrollbarPosition procedure} {testmetrics win} {
+ .s identify [expr [winfo width .s] / 2] [expr int(.2 / [.s delta 0 1]) \
+ + [testmetrics cyvscroll .s] - 1]
+} {trough1}
+test scrollbar-6.20 {ScrollbarPosition procedure} unix {
+ .s identify 8 52
+} {slider}
+test scrollbar-6.21 {ScrollbarPosition procedure} {unix nonPortable} {
+ # Don't know why this is non-portable, but it doesn't work on
+ # some platforms.
+ .s identify 8 83
+} {slider}
+test scrollbar-6.22 {ScrollbarPosition procedure} {testmetrics win} {
+ .s identify [expr [winfo width .s] / 2] \
+ [expr int(.2 / [.s delta 0 1] + 0.5) + [testmetrics cyvscroll .s]]
+} {slider}
+test scrollbar-6.23 {ScrollbarPosition procedure} {testmetrics win} {
+ .s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \
+ + [testmetrics cyvscroll .s] - 1]
+} {slider}
+test scrollbar-6.24 {ScrollbarPosition procedure} unix {
+ .s identify 8 84
+} {trough2}
+test scrollbar-6.25 {ScrollbarPosition procedure} unix {
+ .s identify 8 179
+} {trough2}
+test scrollbar-6.27 {ScrollbarPosition procedure} {testmetrics win knownBug} {
+ # This asks for 8,21, which is actually the slider, but there is a
+ # bug in that GetSystemMetrics(SM_CYVTHUMB) actually returns a value
+ # that is larger than the thumb displayed, skewing the ability to
+ # calculate the trough2 area correctly (Win2k). -- hobbs
+ .s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \
+ + [testmetrics cyvscroll .s]]
+} {trough2}
+test scrollbar-6.28 {ScrollbarPosition procedure} {testmetrics win} {
+ .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \
+ - [testmetrics cyvscroll .s] - 1]
+} {trough2}
+test scrollbar-6.29 {ScrollbarPosition procedure} unix {
+ .s identify 8 180
+} {arrow2}
+test scrollbar-6.30 {ScrollbarPosition procedure} unix {
+ .s identify 8 195
+} {arrow2}
+test scrollbar-6.32 {ScrollbarPosition procedure} {testmetrics win} {
+ .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \
+ - [testmetrics cyvscroll .s]]
+} {arrow2}
+test scrollbar-6.33 {ScrollbarPosition procedure} win {
+ .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] - 1]
+} {arrow2}
+test scrollbar-6.34 {ScrollbarPosition procedure} unix {
+ .s identify 4 100
+} {trough2}
+test scrollbar-6.35 {ScrollbarPosition procedure} unix {
+ .s identify 18 100
+} {trough2}
+test scrollbar-6.37 {ScrollbarPosition procedure} win {
+ .s identify 0 100
+} {trough2}
+test scrollbar-6.38 {ScrollbarPosition procedure} win {
+ .s identify [expr [winfo width .s] - 1] 100
+} {trough2}
+
+catch {destroy .t}
+toplevel .t -width 250 -height 150
+wm geometry .t +0+0
+scrollbar .t.s -orient horizontal -relief sunken -bd 2 -highlightthickness 2
+place .t.s -width 200
+.t.s set .2 .4
+update
+
+test scrollbar-6.39 {ScrollbarPosition procedure} unix {
+ .t.s identify 4 8
+} {arrow1}
+test scrollbar-6.40 {ScrollbarPosition procedure} win {
+ .t.s identify 0 [expr [winfo height .t.s] / 2]
+} {arrow1}
+test scrollbar-6.41 {ScrollbarPosition procedure} unix {
+ .t.s identify 82 8
+} {slider}
+test scrollbar-6.43 {ScrollbarPosition procedure} {testmetrics win} {
+ .t.s identify [expr int(.4 / [.t.s delta 1 0]) + [testmetrics cxhscroll .t.s] \
+ - 1] [expr [winfo height .t.s] / 2]
+} {slider}
+test scrollbar-6.44 {ScrollbarPosition procedure} unix {
+ .t.s identify 100 18
+} {trough2}
+test scrollbar-6.46 {ScrollbarPosition procedure} win {
+ .t.s identify 100 [expr [winfo height .t.s] - 1]
+} {trough2}
+
+test scrollbar-7.1 {EventuallyRedraw} {
+ .s configure -orient horizontal
+ update
+ set result [.s cget -orient]
+ .s configure -orient vertical
+ update
+ lappend result [.s cget -orient]
+} {horizontal vertical}
+
+catch {destroy .t}
+toplevel .t
+wm geometry .t +0+0
+test scrollbar-8.1 {TkScrollbarEventProc: recursive deletion} {
+ proc doit {args} { destroy .t.f }
+ proc bgerror {args} {}
+ destroy .t.f
+ frame .t.f
+ scrollbar .t.f.s -command doit
+ pack .t.f -fill both -expand 1
+ pack .t.f.s -fill y -expand 1 -side right
+ wm geometry .t 100x100
+ .t.f.s set 0 .5
+ update
+ set result [winfo exists .t.f.s]
+ event generate .t.f.s <ButtonPress> -button 1 -x [expr [winfo width .t.f.s] / 2] -y 5
+ event generate .t <ButtonRelease> -button 1
+ update
+ lappend result [winfo exists .t.f.s] [winfo exists .t.f]
+ rename bgerror {}
+ set result
+} {1 0 0}
+test scrollbar-8.2 {TkScrollbarEventProc: recursive deletion} {
+ proc doit {args} { destroy .t.f.s }
+ proc bgerror {args} {}
+ destroy .t.f
+ frame .t.f
+ scrollbar .t.f.s -command doit
+ pack .t.f -fill both -expand 1
+ pack .t.f.s -fill y -expand 1 -side right
+ wm geometry .t 100x100
+ .t.f.s set 0 .5
+ update
+ set result [winfo exists .t.f.s]
+ event generate .t.f.s <ButtonPress> -button 1 -x [expr [winfo width .t.f.s] / 2] -y 5
+ event generate .t.f <ButtonRelease> -button 1
+ update
+ lappend result [winfo exists .t.f.s] [winfo exists .t.f]
+ rename bgerror {}
+ set result
+} {1 0 1}
+
+set l [interp hidden]
+deleteWindows
+
+test scrollbar-9.1 {scrollbar widget vs hidden commands} {
+ catch {destroy .s}
+ scrollbar .s
+ interp hide {} .s
+ destroy .s
+ list [winfo children .] [interp hidden]
+} [list {} $l]
+
+test scrollbar-10.1 {<MouseWheel> event on scrollbar} -constraints {win|unix} -setup {
+ destroy .t .s
+} -body {
+ pack [text .t -yscrollcommand {.s set}] -side left
+ for {set i 1} {$i < 100} {incr i} {.t insert end "Line $i\n"}
+ pack [scrollbar .s -command {.t yview}] -fill y -expand 1 -side left
+ update
+ focus -force .s
+ event generate .s <MouseWheel> -delta -120
+ after 200 {set eventprocessed 1} ; vwait eventprocessed
+ .t index @0,0
+} -cleanup {
+ destroy .t .s
+} -result {5.0}
+
+test scrollbar-10.2 {<MouseWheel> event on scrollbar} -constraints {win|unix} -setup {
+ destroy .t .s
+} -body {
+ pack [text .t -xscrollcommand {.s set} -wrap none] -side top
+ for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "}
+ pack [scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top
+ update
+ focus -force .s
+ event generate .s <Shift-MouseWheel> -delta -120
+ after 200 {set eventprocessed 1} ; vwait eventprocessed
+ .t index @0,0
+} -cleanup {
+ destroy .t .s
+} -result {1.4}
+
+test scrollbar-11.1 {bug fix: [011706ec42] Scrollbar unsafe wrt widget destruction} -body {
+ proc destroy_scrollbar {} {
+ if {[winfo exists .top.s]} {
+ destroy .top.s
+ }
+ }
+ toplevel .top
+ scrollbar .top.s
+ bind .top.s <2> {destroy_scrollbar}
+ pack .top.s
+ focus -force .top.s
+ update
+ event generate .top.s <2>
+ update ; # shall not trigger error invalid command name ".top.s"
+} -cleanup {
+ destroy .top.s .top
+} -result {}
+test scrollbar-11.2 {bug fix: [011706ec42] Scrollbar unsafe wrt widget destruction} -body {
+ proc destroy_scrollbar {{y 0}} {
+ if {[winfo exists .top.s]} {
+ destroy .top.s
+ }
+ }
+ toplevel .top
+ wm minsize .top 50 400
+ update
+ scrollbar .top.s
+ bind .top.s <2> {after idle destroy_scrollbar}
+ pack .top.s -expand true -fill y
+ focus -force .top.s
+ update
+ event generate .top.s <2> -x 2 -y [expr {[winfo height .top.s] / 2}]
+ update ; # shall not trigger error invalid command name ".top.s"
+} -cleanup {
+ destroy .top.s .top
+} -result {}
+
+catch {destroy .s}
+catch {destroy .t}
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/select.test b/tk8.6/tests/select.test
new file mode 100644
index 0000000..77bfb2e
--- /dev/null
+++ b/tk8.6/tests/select.test
@@ -0,0 +1,1160 @@
+# This file is a Tcl script to test out Tk's selection management code,
+# especially the "selection" command. It is organized in the standard fashion
+# for Tcl tests.
+#
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+#
+# Note: Multiple display selection handling will only be tested if the
+# environment variable TK_ALT_DISPLAY is set to an alternate display.
+#
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+namespace import ::tk::test:loadTkCommand
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+global longValue selValue selInfo
+
+set selValue {}
+set selInfo {}
+
+proc handler {type offset count} {
+ global selValue selInfo
+ lappend selInfo $type $offset $count
+ set numBytes [expr {[string length $selValue] - $offset}]
+ if {$numBytes <= 0} {
+ return ""
+ }
+ string range $selValue $offset [expr $numBytes+$offset]
+}
+
+proc errIncrHandler {type offset count} {
+ global selValue selInfo pass
+ if {$offset == 4000} {
+ if {$pass == 0} {
+ # Just sizing the selection; don't do anything here.
+ set pass 1
+ } else {
+ # Fetching the selection; wait long enough to cause a timeout.
+ after 6000
+ }
+ }
+ lappend selInfo $type $offset $count
+ set numBytes [expr {[string length $selValue] - $offset}]
+ if {$numBytes <= 0} {
+ return ""
+ }
+ string range $selValue $offset [expr $numBytes+$offset]
+}
+
+proc errHandler args {
+ error "selection handler aborted"
+}
+
+proc badHandler {path type offset count} {
+ global selValue selInfo
+ selection handle -type $type $path {}
+ lappend selInfo $path $type $offset $count
+ set numBytes [expr {[string length $selValue] - $offset}]
+ if {$numBytes <= 0} {
+ return ""
+ }
+ string range $selValue $offset [expr $numBytes+$offset]
+}
+proc reallyBadHandler {path type offset count} {
+ global selValue selInfo pass
+ if {$offset == 4000} {
+ if {$pass == 0} {
+ set pass 1
+ } else {
+ selection handle -type $type $path {}
+ }
+ }
+ lappend selInfo $path $type $offset $count
+ set numBytes [expr {[string length $selValue] - $offset}]
+ if {$numBytes <= 0} {
+ return ""
+ }
+ string range $selValue $offset [expr $numBytes+$offset]
+}
+
+# Eliminate any existing selection on the screen. This is needed in case
+# there is a selection in some other application, in order to prevent races
+# from causing false errors in the tests below.
+
+selection clear .
+after 1500
+
+# common setup code
+proc setup {{path .f1} {display {}}} {
+ catch {destroy $path}
+ if {$display == {}} {
+ frame $path
+ } else {
+ toplevel $path -screen $display
+ wm geom $path +0+0
+ }
+ selection own $path
+}
+
+# set up a very large buffer to test INCR retrievals
+set longValue ""
+foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} {
+ set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14
+ append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j
+}
+
+# Now we start the main body of the test code
+
+test select-1.1 {Tk_CreateSelHandler procedure} -setup {
+ setup
+} -body {
+ lsort [selection get TARGETS]
+} -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}
+test select-1.2 {Tk_CreateSelHandler procedure} -setup {
+ setup
+} -body {
+ selection handle .f1 {handler TEST} TEST
+ lsort [selection get TARGETS]
+} -result {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}
+test select-1.3 {Tk_CreateSelHandler procedure} -setup {
+ global selValue selInfo
+ setup
+} -body {
+ selection handle .f1 {handler TEST} TEST
+ set selValue "Test value"
+ set selInfo ""
+ list [selection get TEST] $selInfo
+} -result {{Test value} {TEST 0 4000}}
+test select-1.4.1 {Tk_CreateSelHandler procedure} -constraints unix -setup {
+ setup
+} -body {
+ selection handle .f1 {handler TEST} TEST
+ selection handle .f1 {handler STRING}
+ lsort [selection get TARGETS]
+} -result {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}
+test select-1.4.2 {Tk_CreateSelHandler procedure} -constraints win -setup {
+ setup
+} -body {
+ selection handle .f1 {handler TEST} TEST
+ selection handle .f1 {handler STRING}
+ lsort [selection get TARGETS]
+} -result {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}
+test select-1.5 {Tk_CreateSelHandler procedure} -setup {
+ global selValue selInfo
+ setup
+} -body {
+ selection handle .f1 {handler TEST} TEST
+ selection handle .f1 {handler STRING}
+ set selValue ""
+ set selInfo ""
+ list [selection get] $selInfo
+} -result {{} {STRING 0 4000}}
+test select-1.6.1 {Tk_CreateSelHandler procedure} -constraints unix -setup {
+ global selValue selInfo
+ setup
+} -body {
+ selection handle .f1 {handler TEST} TEST
+ selection handle .f1 {handler STRING}
+ set selValue ""
+ set selInfo ""
+ selection get
+ selection get -type TEST
+ selection handle .f1 {handler TEST2} TEST
+ selection get -type TEST
+ list $selInfo [lsort [selection get TARGETS]]
+} -result {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}}
+test select-1.6.2 {Tk_CreateSelHandler procedure} -constraints win -setup {
+ global selValue selInfo
+ setup
+} -body {
+ selection handle .f1 {handler TEST} TEST
+ selection handle .f1 {handler STRING}
+ set selValue ""
+ set selInfo ""
+ selection get
+ selection get -type TEST
+ selection handle .f1 {handler TEST2} TEST
+ selection get -type TEST
+ list $selInfo [lsort [selection get TARGETS]]
+} -result {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-1.7.1 {Tk_CreateSelHandler procedure} -constraints unix -setup {
+ setup
+} -body {
+ selection own -selection CLIPBOARD .f1
+ selection handle -selection CLIPBOARD .f1 {handler TEST} TEST
+ selection handle -selection PRIMARY .f1 {handler TEST2} STRING
+ list [lsort [selection get -selection PRIMARY TARGETS]] \
+ [lsort [selection get -selection CLIPBOARD TARGETS]]
+} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-1.7.2 {Tk_CreateSelHandler procedure} -constraints win -setup {
+ setup
+} -body {
+ selection own -selection CLIPBOARD .f1
+ selection handle -selection CLIPBOARD .f1 {handler TEST} TEST
+ selection handle -selection PRIMARY .f1 {handler TEST2} STRING
+ list [lsort [selection get -selection PRIMARY TARGETS]] \
+ [lsort [selection get -selection CLIPBOARD TARGETS]]
+} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-1.8 {Tk_CreateSelHandler procedure} -setup {
+ setup
+} -body {
+ selection handle -format INTEGER -type TEST .f1 {handler TEST}
+ lsort [selection get TARGETS]
+} -result {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}
+
+##############################################################################
+
+test select-2.1 {Tk_DeleteSelHandler procedure} -constraints unix -setup {
+ setup
+} -body {
+ selection handle .f1 {handler STRING}
+ selection handle -type TEST .f1 {handler TEST}
+ selection handle -type USER .f1 {handler USER}
+ set result [list [lsort [selection get TARGETS]]]
+ selection handle -type TEST .f1 {}
+ lappend result [lsort [selection get TARGETS]]
+} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING}}
+test select-2.2 {Tk_DeleteSelHandler procedure} -constraints unix -setup {
+ setup
+} -body {
+ selection handle .f1 {handler STRING}
+ selection handle -type TEST .f1 {handler TEST}
+ selection handle -type USER .f1 {handler USER}
+ set result [list [lsort [selection get TARGETS]]]
+ selection handle -type USER .f1 {}
+ lappend result [lsort [selection get TARGETS]]
+} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}}
+test select-2.3 {Tk_DeleteSelHandler procedure} -constraints unix -setup {
+ setup
+} -body {
+ selection own -selection CLIPBOARD .f1
+ selection handle -selection PRIMARY .f1 {handler STRING}
+ selection handle -selection CLIPBOARD .f1 {handler STRING}
+ selection handle -selection CLIPBOARD .f1 {}
+ list [lsort [selection get TARGETS]] \
+ [lsort [selection get -selection CLIPBOARD TARGETS]]
+} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-2.4 {Tk_DeleteSelHandler procedure} -constraints win -setup {
+ setup
+} -body {
+ selection handle .f1 {handler STRING}
+ selection handle -type TEST .f1 {handler TEST}
+ selection handle -type USER .f1 {handler USER}
+ set result [list [lsort [selection get TARGETS]]]
+ selection handle -type TEST .f1 {}
+ lappend result [lsort [selection get TARGETS]]
+} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER}}
+test select-2.5 {Tk_DeleteSelHandler procedure} -constraints win -setup {
+ setup
+} -body {
+ selection handle .f1 {handler STRING}
+ selection handle -type TEST .f1 {handler TEST}
+ selection handle -type USER .f1 {handler USER}
+ set result [list [lsort [selection get TARGETS]]]
+ selection handle -type USER .f1 {}
+ lappend result [lsort [selection get TARGETS]]
+} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-2.6 {Tk_DeleteSelHandler procedure} -constraints win -setup {
+ setup
+} -body {
+ selection own -selection CLIPBOARD .f1
+ selection handle -selection PRIMARY .f1 {handler STRING}
+ selection handle -selection CLIPBOARD .f1 {handler STRING}
+ selection handle -selection CLIPBOARD .f1 {}
+ list [lsort [selection get TARGETS]] \
+ [lsort [selection get -selection CLIPBOARD TARGETS]]
+} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-2.7 {Tk_DeleteSelHandler procedure} -setup {
+ setup
+} -body {
+ selection handle .f1 {handler STRING}
+ list [selection handle .f1 {}] [selection handle .f1 {}]
+} -result {{} {}}
+
+##############################################################################
+
+test select-3.1 {Tk_OwnSelection procedure} -setup {
+ setup
+} -body {
+ selection own
+} -result {.f1}
+test select-3.2 {Tk_OwnSelection procedure} -body {
+ setup .f1
+ set result [selection own]
+ setup .f2
+ lappend result [selection own]
+} -result {.f1 .f2}
+test select-3.3 {Tk_OwnSelection procedure} -setup {
+ setup .f1
+ setup .f2
+} -body {
+ selection own -selection CLIPBOARD .f1
+ list [selection own] [selection own -selection CLIPBOARD]
+} -result {.f2 .f1}
+test select-3.4 {Tk_OwnSelection procedure} -setup {
+ global lostSel
+ setup
+} -body {
+ set lostSel {owned}
+ selection own -command { set lostSel {lost} } .f1
+ selection clear .f1
+ set lostSel
+} -result {lost}
+test select-3.5 {Tk_OwnSelection procedure} -setup {
+ global lostSel
+ setup .f1
+ setup .f2
+} -body {
+ set lostSel {owned}
+ selection own -command { set lostSel {lost1} } .f1
+ selection own -command { set lostSel {lost2} } .f2
+ list $lostSel [selection own]
+} -result {lost1 .f2}
+test select-3.6 {Tk_OwnSelection procedure} -setup {
+ global lostSel
+ setup
+} -body {
+ set lostSel {owned}
+ selection own -command { set lostSel {lost1} } .f1
+ selection own -command { set lostSel {lost2} } .f1
+ set result $lostSel
+ selection clear .f1
+ lappend result $lostSel
+} -result {owned lost2}
+test select-3.7 {Tk_OwnSelection procedure} -constraints unix -setup {
+ global lostSel
+ setup
+ setupbg
+} -body {
+ set lostSel {owned}
+ selection own -command { set lostSel {lost1} } .f1
+ update
+ set result {}
+ lappend result [dobg { selection own . }]
+ lappend result [dobg {selection own}]
+ update
+ cleanupbg
+ lappend result $lostSel
+} -result {{} . lost1}
+# check reentrancy on selection replacement
+test select-3.8 {Tk_OwnSelection procedure} -setup {
+ setup
+} -body {
+ selection own -selection CLIPBOARD -command { destroy .f1 } .f1
+ selection own -selection CLIPBOARD .
+} -result {}
+test select-3.9 {Tk_OwnSelection procedure} -setup {
+ setup .f2
+ setup .f1
+} -body {
+ selection own -selection CLIPBOARD -command { destroy .f2 } .f1
+ selection own -selection CLIPBOARD .f2
+} -result {}
+# multiple display tests
+test select-3.10 {Tk_OwnSelection procedure} -constraints {
+ altDisplay
+} -body {
+ setup .f1
+ setup .f2 $env(TK_ALT_DISPLAY)
+ list [selection own -displayof .f1] [selection own -displayof .f2]
+} -result {.f1 .f2}
+test select-3.11 {Tk_OwnSelection procedure} -constraints {
+ altDisplay
+} -setup {
+ setup .f1
+ setup .f2 $env(TK_ALT_DISPLAY)
+ setupbg
+ update
+ set result ""
+} -body {
+ lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"]
+ lappend result [selection own -displayof .f1] \
+ [selection own -displayof .f2]
+} -cleanup {
+ cleanupbg
+} -result {{} .f1 {}}
+
+##############################################################################
+
+test select-4.1 {Tk_ClearSelection procedure} -setup {
+ setup
+} -body {
+ set result [selection own]
+ selection clear .f1
+ lappend result [selection own]
+} -result {.f1 {}}
+test select-4.2 {Tk_ClearSelection procedure} -setup {
+ setup
+} -body {
+ selection own -selection CLIPBOARD .f1
+ selection clear .f1
+ selection own -selection CLIPBOARD
+} -result {.f1}
+test select-4.3 {Tk_ClearSelection procedure} -setup {
+ setup
+} -body {
+ list [selection clear .f1] [selection clear .f1]
+} -result {{} {}}
+test select-4.4 {Tk_ClearSelection procedure} -constraints unix -setup {
+ global lostSel
+ setup
+ setupbg
+} -body {
+ set lostSel {owned}
+ selection own -command { set lostSel {lost1} } .f1
+ update
+ set result {}
+ lappend result [dobg {selection clear; update}]
+ update
+ cleanupbg
+ lappend result [selection own]
+} -result {{} {}}
+# multiple display tests
+test select-4.5 {Tk_ClearSelection procedure} -constraints {
+ altDisplay
+} -setup {
+ global lostSel lostSel2
+ setup .f1
+ setup .f2 $env(TK_ALT_DISPLAY)
+} -body {
+ set lostSel {owned}
+ set lostSel2 {owned2}
+ selection own -command { set lostSel {lost1} } .f1
+ selection own -command { set lostSel2 {lost2} } .f2
+ update
+ selection clear -displayof .f2
+ update
+ list $lostSel $lostSel2
+} -result {owned lost2}
+test select-4.6 {Tk_ClearSelection procedure} -constraints {
+ unix altDisplay
+} -setup {
+ setup .f1
+ setup .f2 $env(TK_ALT_DISPLAY)
+ setupbg
+} -body {
+ set lostSel {owned}
+ set lostSel2 {owned2}
+ selection own -command { set lostSel {lost1} } .f1
+ selection own -command { set lostSel2 {lost2} } .f2
+ update
+ set result ""
+ lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"]
+ lappend result [selection own -displayof .f1] \
+ [selection own -displayof .f2] $lostSel $lostSel2
+ cleanupbg
+ set result
+} -result {{} .f1 {} owned lost2}
+
+##############################################################################
+
+test select-5.1 {Tk_GetSelection procedure} -returnCodes error -setup {
+ setup
+} -body {
+ selection get TEST
+} -result {PRIMARY selection doesn't exist or form "TEST" not defined}
+test select-5.2 {Tk_GetSelection procedure} -setup {
+ setup
+} -body {
+ selection get TK_WINDOW
+} -result {.f1}
+test select-5.3 {Tk_GetSelection procedure} -setup {
+ setup
+} -body {
+ selection handle -selection PRIMARY .f1 {handler TEST} TEST
+ set selValue "Test value"
+ set selInfo ""
+ list [selection get TEST] $selInfo
+} -result {{Test value} {TEST 0 4000}}
+test select-5.4 {Tk_GetSelection procedure} -setup {
+ setup
+} -returnCodes error -body {
+ selection handle .f1 ERROR errHandler
+ selection get ERROR
+} -result {PRIMARY selection doesn't exist or form "ERROR" not defined}
+test select-5.5 {Tk_GetSelection procedure} -setup {
+ setup
+} -body {
+ set selValue $longValue
+ set selInfo ""
+ selection handle .f1 {handler STRING}
+ list [selection get] $selInfo
+} -result "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000}"
+test select-5.6 {Tk_GetSelection procedure} -setup {
+ setup
+} -returnCodes error -body {
+ set selValue $longValue
+ set selInfo ""
+ selection handle .f1 {apply {{type offset count} {
+ selection handle .f1 {}
+ handler $type $offset $count
+ }} STRING}
+ selection get
+} -result {PRIMARY selection doesn't exist or form "STRING" not defined}
+test select-5.7 {Tk_GetSelection procedure} -setup {
+ setup
+} -returnCodes error -body {
+ set selValue "Test Value"
+ set selInfo ""
+ selection handle .f1 {apply {{type offset count} {
+ destroy .f1
+ handler $type $offset $count
+ }} STRING}
+ selection get
+} -result {PRIMARY selection doesn't exist or form "STRING" not defined}
+test select-5.8 {Tk_GetSelection procedure} -setup {
+ setup
+} -body {
+ set selValue $longValue
+ set selInfo ""
+ selection handle .f1 {apply {{type offset count} {
+ selection clear
+ handler $type $offset $count
+ }} STRING}
+ list [selection get] $selInfo [catch {selection get} msg] $msg
+} -result "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000} 1 {PRIMARY selection doesn't exist or form \"STRING\" not defined}"
+test select-5.9 {Tk_GetSelection procedure} -constraints unix -setup {
+ setup
+ setupbg
+} -body {
+ selection handle -selection PRIMARY .f1 {handler TEST} TEST
+ update
+ set selValue "Test value"
+ set selInfo ""
+ set result ""
+ lappend result [dobg {selection get TEST}]
+ cleanupbg
+ lappend result $selInfo
+} -result {{Test value} {TEST 0 4000}}
+test select-5.10 {Tk_GetSelection procedure} -constraints unix -setup {
+ setup
+ setupbg
+} -body {
+ selection handle -selection PRIMARY .f1 {handler TEST} TEST
+ update
+ set selValue "Test value"
+ set selInfo ""
+ selection own .f1
+ set result ""
+ lappend result [dobg {selection get TEST} 1]
+ cleanupbg
+ lappend result $selInfo
+} -result {{selection owner didn't respond} {}}
+# multiple display tests
+test select-5.11 {Tk_GetSelection procedure} -constraints {
+ altDisplay
+} -setup {
+ setup .f1
+ setup .f2 $env(TK_ALT_DISPLAY)
+} -body {
+ selection handle -selection PRIMARY .f1 {handler TEST} TEST
+ selection handle -selection PRIMARY .f2 {handler TEST2} TEST
+ set selValue "Test value"
+ set selInfo ""
+ set result [list [selection get TEST] $selInfo]
+ set selValue "Test value2"
+ set selInfo ""
+ lappend result [selection get -displayof .f2 TEST] $selInfo
+} -result {{Test value} {TEST 0 4000} {Test value2} {TEST2 0 4000}}
+test select-5.12 {Tk_GetSelection procedure} -constraints {
+ altDisplay
+} -setup {
+ global lostSel lostSel2
+ setup .f1
+ setup .f2 $env(TK_ALT_DISPLAY)
+} -body {
+ selection handle -selection PRIMARY .f1 {handler TEST} TEST
+ selection handle -selection PRIMARY .f2 {} TEST
+ set selValue "Test value"
+ set selInfo ""
+ set result [list [catch {selection get TEST} msg] $msg $selInfo]
+ set selValue "Test value2"
+ set selInfo ""
+ lappend result [catch {selection get -displayof .f2 TEST} msg] $msg \
+ $selInfo
+} -result {0 {Test value} {TEST 0 4000} 1 {PRIMARY selection doesn't exist or form "TEST" not defined} {}}
+test select-5.13 {Tk_GetSelection procedure} -constraints {
+ unix altDisplay
+} -setup {
+ setup .f1
+ setup .f2 $env(TK_ALT_DISPLAY)
+ setupbg
+} -body {
+ selection handle -selection PRIMARY .f1 {handler TEST} TEST
+ selection own .f1
+ selection handle -selection PRIMARY .f2 {handler TEST2} TEST
+ selection own .f2
+ set selValue "Test value"
+ set selInfo ""
+ update
+ set result ""
+ lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"]
+ set selValue "Test value2"
+ lappend result [dobg "selection get TEST"]
+ cleanupbg
+ lappend result $selInfo
+} -result {{Test value} {Test value2} {TEST2 0 4000 TEST 0 4000}}
+test select-5.14 {Tk_GetSelection procedure} -constraints {
+ unix altDisplay
+} -setup {
+ setup .f1
+ setup .f2 $env(TK_ALT_DISPLAY)
+ setupbg
+} -body {
+ selection handle -selection PRIMARY .f1 {handler TEST} TEST
+ selection own .f1
+ selection handle -selection PRIMARY .f2 {} TEST
+ selection own .f2
+ set selValue "Test value"
+ set selInfo ""
+ update
+ set result ""
+ lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"]
+ set selValue "Test value2"
+ lappend result [dobg "selection get TEST"]
+ cleanupbg
+ lappend result $selInfo
+} -result {{PRIMARY selection doesn't exist or form "TEST" not defined} {Test value2} {TEST 0 4000}}
+test select-5.15 {Tk_GetSelection procedure} -setup {
+ setup
+ if {[llength [info command ::bgerror]]} {
+ rename ::bgerror ::TMPbgerror
+ }
+ set ::bgerrors {}
+} -body {
+ proc ::bgerror msg {lappend ::bgerrors $msg}
+ selection handle -type ERROR .f1 errHandler
+ list [catch {selection get ERROR} msg] $msg [update] {*}$::bgerrors
+} -cleanup {
+ rename ::bgerror {}
+ if {[llength [info command ::TMPbgerror]]} {
+ rename ::TMPbgerror ::bgerror
+ }
+} -result {1 {PRIMARY selection doesn't exist or form "ERROR" not defined} {} {selection handler aborted}}
+
+##############################################################################
+
+test select-6.1 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection
+} -result {wrong # args: should be "selection option ?arg ...?"}
+# selection clear
+test select-6.2 {Tk_SelectionCmd procedure} -body {
+ selection clear -selection
+} -returnCodes error -result {value for "-selection" missing}
+test select-6.3 {Tk_SelectionCmd procedure} -setup {
+ setup
+} -body {
+ selection own .
+ set result [selection own]
+ selection clear -displayof .f1
+ lappend result [selection own]
+} -result {. {}}
+test select-6.4 {Tk_SelectionCmd procedure} -setup {
+ setup
+} -body {
+ selection own -selection CLIPBOARD .f1
+ set result [list [selection own] [selection own -selection CLIPBOARD]]
+ selection clear -selection CLIPBOARD .f1
+ lappend result [selection own] [selection own -selection CLIPBOARD]
+} -result {.f1 .f1 .f1 {}}
+test select-6.5 {Tk_SelectionCmd procedure} -setup {
+ setup
+} -body {
+ selection own -selection CLIPBOARD .
+ set result [list [selection own] [selection own -selection CLIPBOARD]]
+ selection clear -selection CLIPBOARD -displayof .f1
+ lappend result [selection own] [selection own -selection CLIPBOARD]
+} -result {.f1 . .f1 {}}
+test select-6.6 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection clear -badopt foo
+} -result {bad option "-badopt": must be -displayof or -selection}
+test select-6.7 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection clear -selectionfoo foo
+} -result {bad option "-selectionfoo": must be -displayof or -selection}
+test select-6.8 {Tk_SelectionCmd procedure} -body {
+ destroy .f2
+ selection clear -displayof .f2
+} -returnCodes error -result {bad window path name ".f2"}
+test select-6.9 {Tk_SelectionCmd procedure} -body {
+ destroy .f2
+ selection clear .f2
+} -returnCodes error -result {bad window path name ".f2"}
+test select-6.10 {Tk_SelectionCmd procedure} -setup {
+ setup
+} -body {
+ set result [selection own -selection PRIMARY]
+ selection clear
+ lappend result [selection own -selection PRIMARY]
+} -result {.f1 {}}
+test select-6.11 {Tk_SelectionCmd procedure} -setup {
+ setup
+} -body {
+ selection own -selection CLIPBOARD .f1
+ set result [selection own -selection CLIPBOARD]
+ selection clear -selection CLIPBOARD
+ lappend result [selection own -selection CLIPBOARD]
+} -result {.f1 {}}
+test select-6.12 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection clear foo bar
+} -result {wrong # args: should be "selection clear ?-option value ...?"}
+# selection get
+test select-6.13 {Tk_SelectionCmd procedure} -body {
+ selection get -selection
+} -returnCodes error -result {value for "-selection" missing}
+test select-6.14 {Tk_SelectionCmd procedure} -setup {
+ global selValue selInfo
+ setup
+} -body {
+ selection handle .f1 {handler TEST}
+ set selValue "Test value"
+ set selInfo ""
+ list [selection get -displayof .f1] $selInfo
+} -result {{Test value} {TEST 0 4000}}
+test select-6.15 {Tk_SelectionCmd procedure} -setup {
+ global selValue selInfo
+ setup
+} -body {
+ selection handle .f1 {handler STRING}
+ selection handle -selection CLIPBOARD .f1 {handler TEST}
+ selection own -selection CLIPBOARD .f1
+ set selValue "Test value"
+ set selInfo ""
+ list [selection get -selection CLIPBOARD] $selInfo
+} -result {{Test value} {TEST 0 4000}}
+test select-6.16 {Tk_SelectionCmd procedure} -setup {
+ global selValue selInfo
+ setup
+} -body {
+ selection handle -type TEST .f1 {handler TEST}
+ selection handle -type STRING .f1 {handler STRING}
+ set selValue "Test value"
+ set selInfo ""
+ list [selection get -type TEST] $selInfo
+} -result {{Test value} {TEST 0 4000}}
+test select-6.17 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection get -badopt foo
+} -result {bad option "-badopt": must be -displayof, -selection, or -type}
+test select-6.18 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection get -selectionfoo foo
+} -result {bad option "-selectionfoo": must be -displayof, -selection, or -type}
+test select-6.19 {Tk_SelectionCmd procedure} -body {
+ catch { destroy .f2 }
+ selection get -displayof .f2
+} -returnCodes error -result {bad window path name ".f2"}
+test select-6.20 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection get foo bar
+} -result {wrong # args: should be "selection get ?-option value ...?"}
+test select-6.21 {Tk_SelectionCmd procedure} -setup {
+ global selValue selInfo
+ setup
+} -body {
+ selection handle -type TEST .f1 {handler TEST}
+ selection handle -type STRING .f1 {handler STRING}
+ set selValue "Test value"
+ set selInfo ""
+ list [selection get TEST] $selInfo
+} -result {{Test value} {TEST 0 4000}}
+# selection handle
+# most of the handle section has been covered earlier
+test select-6.22 {Tk_SelectionCmd procedure} -body {
+ selection handle -selection
+} -returnCodes error -result {value for "-selection" missing}
+test select-6.23 {Tk_SelectionCmd procedure} -setup {
+ global selValue selInfo
+ setup
+} -body {
+ set selValue "Test value"
+ set selInfo ""
+ list [selection handle -format INTEGER .f1 {handler TEST}] [selection get -displayof .f1] $selInfo
+} -result {{} {Test value} {TEST 0 4000}}
+test select-6.24 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection handle -badopt foo
+} -result {bad option "-badopt": must be -format, -selection, or -type}
+test select-6.25 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection handle -selectionfoo foo
+} -result {bad option "-selectionfoo": must be -format, -selection, or -type}
+test select-6.26 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection handle
+} -result {wrong # args: should be "selection handle ?-option value ...? window command"}
+test select-6.27 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection handle .
+} -result {wrong # args: should be "selection handle ?-option value ...? window command"}
+test select-6.28 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection handle . foo bar baz blat
+} -result {wrong # args: should be "selection handle ?-option value ...? window command"}
+test select-6.29 {Tk_SelectionCmd procedure} -body {
+ catch { destroy .f2 }
+ selection handle .f2 dummy
+} -returnCodes error -result {bad window path name ".f2"}
+# selection own
+test select-6.30 {Tk_SelectionCmd procedure} -body {
+ selection own -selection
+} -returnCodes error -result {value for "-selection" missing}
+test select-6.31 {Tk_SelectionCmd procedure} -setup {
+ setup
+} -body {
+ selection own .
+ selection own -displayof .f1
+} -result {.}
+test select-6.32 {Tk_SelectionCmd procedure} -setup {
+ setup
+} -body {
+ selection own .
+ selection own -selection CLIPBOARD .f1
+ list [selection own] [selection own -selection CLIPBOARD]
+} -result {. .f1}
+test select-6.33 {Tk_SelectionCmd procedure} -setup {
+ global lostSel
+ setup
+} -body {
+ set lostSel owned
+ selection own -command { set lostSel lost } .
+ selection own -selection CLIPBOARD .f1
+ set result $lostSel
+ selection own .f1
+ lappend result $lostSel
+} -result {owned lost}
+test select-6.34 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection own -badopt foo
+} -result {bad option "-badopt": must be -command, -displayof, or -selection}
+test select-6.35 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection own -selectionfoo foo
+} -result {bad option "-selectionfoo": must be -command, -displayof, or -selection}
+test select-6.36 {Tk_SelectionCmd procedure} -body {
+ destroy .f2
+ selection own -displayof .f2
+} -returnCodes error -result {bad window path name ".f2"}
+test select-6.37 {Tk_SelectionCmd procedure} -body {
+ destroy .f2
+ selection own .f2
+} -returnCodes error -result {bad window path name ".f2"}
+test select-6.38 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection own foo bar baz
+} -result {wrong # args: should be "selection own ?-option value ...? ?window?"}
+test select-6.39 {Tk_SelectionCmd procedure} -returnCodes error -body {
+ selection foo
+} -result {bad option "foo": must be clear, get, handle, or own}
+
+##############################################################################
+
+# This test is non-portable because some old X11/News servers ignore a
+# selection request when the window doesn't exist, which causes a different
+# error message.
+test select-7.1 {TkSelDeadWindow procedure} -constraints nonPortable -setup {
+ setup
+} -body {
+ selection handle .f1 { handler TEST }
+ set result [selection own]
+ destroy .f1
+ lappend result [selection own] [catch {selection get} msg] $msg
+} -result {.f1 {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined}}
+
+##############################################################################
+
+# Check reentrancy on losing selection
+test select-8.1 {TkSelEventProc procedure} -constraints unix -setup {
+ setup
+ setupbg
+} -body {
+ selection own -selection CLIPBOARD -command {destroy .f1} .f1
+ update
+ dobg {selection own -selection CLIPBOARD .}
+} -cleanup {
+ cleanupbg
+} -result {}
+
+##############################################################################
+
+test select-9.1 {SelCvtToX and SelCvtFromX procedures} -setup {
+ setup
+ setupbg
+} -constraints unix -body {
+ set selValue "1024"
+ set selInfo ""
+ selection handle -selection PRIMARY -format INTEGER -type TEST \
+ .f1 {handler TEST}
+ update
+ set result ""
+ lappend result [dobg {selection get TEST}]
+ cleanupbg
+ lappend result $selInfo
+} -result {{0x400 } {TEST 0 4000}}
+test select-9.2 {SelCvtToX and SelCvtFromX procedures} -setup {
+ setup
+ setupbg
+} -constraints unix -body {
+ set selValue "1024 0xffff 2048 -2 "
+ set selInfo ""
+ selection handle -selection PRIMARY -format INTEGER -type TEST \
+ .f1 {handler TEST}
+ set result ""
+ lappend result [dobg {selection get TEST}]
+ cleanupbg
+ lappend result $selInfo
+} -result {{0x400 0xffff 0x800 0xfffffffe } {TEST 0 4000}}
+test select-9.3 {SelCvtToX and SelCvtFromX procedures} -setup {
+ setup
+ setupbg
+} -constraints unix -body {
+ set selValue " "
+ set selInfo ""
+ selection handle -selection PRIMARY -format INTEGER -type TEST \
+ .f1 {handler TEST}
+ set result ""
+ lappend result [dobg {selection get TEST}]
+ cleanupbg
+ lappend result $selInfo
+} -result {{ } {TEST 0 4000}}
+test select-9.4 {SelCvtToX and SelCvtFromX procedures} -setup {
+ setup
+ setupbg
+} -constraints unix -body {
+ set selValue "16 foobar 32"
+ set selInfo ""
+ selection handle -selection PRIMARY -format INTEGER -type TEST \
+ .f1 {handler TEST}
+ set result ""
+ lappend result [dobg {selection get TEST}]
+ cleanupbg
+ lappend result $selInfo
+} -result {{0x10 0x0 0x20 } {TEST 0 4000}}
+test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup {
+ setup
+ setupbg
+} -constraints unix -body {
+ # Ensure that lists of atoms are constructed correctly, even when the
+ # atom names have spaces in. [Bug 1353414]
+ set selValue "foo bar"
+ set selInfo ""
+ set selType {text/x-tk-test;detail="foo bar"}
+ selection handle -selection PRIMARY -format STRING -type $selType \
+ .f1 [list handler $selType]
+ lsort [dobg {selection get TARGETS}]
+} -cleanup {
+ cleanupbg
+} -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW {text/x-tk-test;detail="foo bar"}}
+
+##############################################################################
+# note, we are not testing MULTIPLE style selections
+
+# most control paths have been exercised above
+test select-10.1 {ConvertSelection procedure, race with selection clear} -constraints {
+ unix
+} -setup {
+ setup
+} -body {
+ proc Ready {fd} {
+ variable x
+ lappend x [gets $fd]
+ }
+ set fd [open "|[list [interpreter] -geometry +0+0 -name tktest]" r+]
+ puts $fd "puts foo; [loadTkCommand]; flush stdout"
+ flush $fd
+ gets $fd
+ fileevent $fd readable [list Ready $fd]
+ set selValue "Just a simple test"
+ set selInfo ""
+ selection handle .f1 {handler STRING}
+ update
+ puts $fd {puts "[catch {selection get} msg]:$msg"; puts **DONE**; flush stdout}
+ flush $fd
+ after 200
+ selection own .
+ set x {}
+ vwait [namespace which -variable x]
+ puts $fd {exit}
+ flush $fd
+ # Don't understand why, but the [loadTkCommand] above causes
+ # a "broken pipe" error when Tk was actually [load]ed in the child.
+ catch {close $fd}
+ lappend x $selInfo
+} -result {{1:PRIMARY selection doesn't exist or form "STRING" not defined} {}}
+test select-10.2 {ConvertSelection procedure} -constraints unix -setup {
+ setup
+ setupbg
+} -body {
+ set selValue [string range $longValue 0 3999]
+ set selInfo ""
+ selection handle .f1 {handler STRING}
+ set result ""
+ lappend result [dobg {selection get}]
+ cleanupbg
+ lappend result $selInfo
+} -result [list [string range $longValue 0 3999] {STRING 0 4000 STRING 4000 4000 STRING 0 4000 STRING 4000 4000}]
+test select-10.3 {ConvertSelection procedure} -constraints unix -setup {
+ setup
+ setupbg
+} -body {
+ selection handle .f1 ERROR errHandler
+ dobg {selection get ERROR}
+} -cleanup {
+ cleanupbg
+} -result {PRIMARY selection doesn't exist or form "ERROR" not defined}
+# testing timers
+# This one hangs in Exceed
+test select-10.4 {ConvertSelection procedure} -constraints {
+ unix noExceed
+} -setup {
+ setup
+ setupbg
+} -body {
+ set selValue $longValue
+ set selInfo ""
+ selection handle .f1 {errIncrHandler STRING}
+ set result ""
+ set pass 0
+ lappend result [dobg {selection get}]
+ cleanupbg
+ lappend result $selInfo
+} -result {{selection owner didn't respond} {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000 STRING 0 4000 STRING 4000 4000}}
+test select-10.5 {ConvertSelection procedure, reentrancy issues} -constraints {
+ unix
+} -setup {
+ setup
+ setupbg
+} -body {
+ set selValue "Test value"
+ set selInfo ""
+ selection handle -type TEST .f1 { handler TEST }
+ selection handle -type STRING .f1 { badHandler .f1 STRING }
+ set result ""
+ lappend result [dobg {selection get}]
+ cleanupbg
+ lappend result $selInfo
+} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000}}
+test select-10.6 {ConvertSelection procedure, reentrancy issues} -constraints {
+ unix
+} -setup {
+ setup
+ setupbg
+} -body {
+ proc weirdHandler {type offset count} {
+ destroy .f1
+ handler $type $offset $count
+ }
+ set selValue $longValue
+ set selInfo ""
+ selection handle .f1 {weirdHandler STRING}
+ set result ""
+ lappend result [dobg {selection get}]
+ cleanupbg
+ lappend result $selInfo
+} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {STRING 0 4000}}
+
+##############################################################################
+
+# testing reentrancy
+test select-11.1 {TkSelPropProc procedure} -constraints unix -setup {
+ setup
+ setupbg
+} -body {
+ set selValue $longValue
+ set selInfo ""
+ selection handle -type TEST .f1 { handler TEST }
+ selection handle -type STRING .f1 { reallyBadHandler .f1 STRING }
+ set result ""
+ set pass 0
+ lappend result [dobg {selection get}]
+ cleanupbg
+ lappend result $selInfo
+} -result {{selection owner didn't respond} {.f1 STRING 0 4000 .f1 STRING 4000 4000 .f1 STRING 8000 4000 .f1 STRING 12000 4000 .f1 STRING 16000 4000 .f1 STRING 0 4000 .f1 STRING 4000 4000}}
+
+##############################################################################
+
+# Note, this assumes we are using CurrentTtime
+test select-12.1 {DefaultSelection procedure} -constraints unix -body {
+ setup
+ set result [selection get -type TIMESTAMP]
+ setupbg
+ lappend result [dobg {selection get -type TIMESTAMP}]
+ cleanupbg
+ set result
+} -result {0x0 {0x0 }}
+test select-12.2 {DefaultSelection procedure} -constraints unix -body {
+ setup
+ set result [lsort [list [selection get -type TARGETS]]]
+ setupbg
+ lappend result [dobg {lsort [selection get -type TARGETS]}]
+ cleanupbg
+ set result
+} -result {{MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-12.3 {DefaultSelection procedure} -constraints unix -body {
+ setup
+ selection handle .f1 {handler TEST} TEST
+ set result [list [lsort [selection get -type TARGETS]]]
+ setupbg
+ lappend result [dobg {lsort [selection get -type TARGETS]}]
+ cleanupbg
+ set result
+} -result {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-12.4 {DefaultSelection procedure} -constraints unix -setup {
+ setup
+ set result ""
+} -body {
+ lappend result [selection get -type TK_APPLICATION]
+ setupbg
+ lappend result [dobg {selection get -type TK_APPLICATION}]
+ cleanupbg
+ set result
+} -result [list [winfo name .] [winfo name .]]
+test select-12.5 {DefaultSelection procedure} -constraints unix -body {
+ setup
+ set result [selection get -type TK_WINDOW]
+ setupbg
+ lappend result [dobg {selection get -type TK_WINDOW}]
+ cleanupbg
+ set result
+} -result {.f1 .f1}
+test select-12.6 {DefaultSelection procedure} -body {
+ setup
+ selection handle .f1 {handler TARGETS.f1} TARGETS
+ set selValue "Targets value"
+ set selInfo ""
+ set result [list [selection get TARGETS] $selInfo]
+ selection handle .f1 {} TARGETS
+ lappend result [selection get TARGETS]
+} -result {{Targets value} {TARGETS.f1 0 4000} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
+
+test select-13.1 {SelectionSize procedure, handler deleted} -constraints {
+ unix
+} -setup {
+ setup
+ setupbg
+} -body {
+ proc badHandler {path type offset count} {
+ global selValue selInfo abortCount
+ incr abortCount -1
+ if {$abortCount == 0} {
+ selection handle -type $type $path {}
+ }
+ lappend selInfo $path $type $offset $count
+ set numBytes [expr {[string length $selValue] - $offset}]
+ if {$numBytes <= 0} {
+ return ""
+ }
+ string range $selValue $offset [expr $numBytes+$offset]
+ }
+ set selValue $longValue
+ set selInfo ""
+ selection handle .f1 {badHandler .f1 STRING}
+ set result ""
+ set abortCount 2
+ lappend result [dobg {selection get}]
+ cleanupbg
+ lappend result $selInfo
+} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000 .f1 STRING 4000 4000}}
+
+catch {rename weirdHandler {}}
+
+# cleanup
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/send.test b/tk8.6/tests/send.test
new file mode 100644
index 0000000..945d4d0
--- /dev/null
+++ b/tk8.6/tests/send.test
@@ -0,0 +1,624 @@
+# This file is a Tcl script to test out the "send" command and the
+# other procedures in the file tkSend.c. It is organized in the
+# standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2001 by ActiveState Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+testConstraint xhost [llength [auto_execok xhost]]
+
+# Compute a script that will load Tk into a child interpreter.
+
+foreach pkg [info loaded] {
+ if {[lindex $pkg 1] == "Tk"} {
+ set loadTk "load $pkg"
+ break
+ }
+}
+
+# Procedure to create a new application with a given name and class.
+
+proc newApp {screen name class} {
+ global loadTk
+ interp create $name
+ $name eval [list set argv [list -display $screen -name $name -class $class]]
+ eval $loadTk $name
+}
+
+set name [tk appname]
+set commId ""
+catch {
+ set registry [testsend prop root InterpRegistry]
+ set commId [lindex [testsend prop root InterpRegistry] 0]
+}
+tk appname tktest
+catch {send t_s_1 destroy .}
+catch {send t_s_2 destroy .}
+
+test send-1.1 {RegOpen procedure, bogus property} {secureserver testsend} {
+ testsend bogus
+ set result [winfo interps]
+ tk appname tktest
+ list $result [winfo interps]
+} {{} tktest}
+test send-1.2 {RegOpen procedure, bogus property} {secureserver testsend} {
+ testsend prop root InterpRegistry {}
+ set result [winfo interps]
+ tk appname tktest
+ list $result [winfo interps]
+} {{} tktest}
+test send-1.3 {RegOpen procedure, bogus property} {secureserver testsend} {
+ testsend prop root InterpRegistry abcdefg
+ tk appname tktest
+ set x [testsend prop root InterpRegistry]
+ string range $x [string first " " $x] end
+} " tktest\nabcdefg\n"
+
+frame .f -width 1 -height 1
+set id [string range [winfo id .f] 2 end]
+test send-2.1 {RegFindName procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry {}
+ list [catch {send foo bar} msg] $msg
+} {1 {no application named "foo"}}
+test send-2.2 {RegFindName procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry " abc\n def\nghi\n\n$id foo\n"
+ tk appname foo
+} {foo #2}
+test send-2.3 {RegFindName procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry "gyz foo\n"
+ tk appname foo
+} {foo}
+test send-2.4 {RegFindName procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry "${id}z foo\n"
+ tk appname foo
+} {foo}
+
+test send-3.1 {RegDeleteName procedure} {secureserver testsend} {
+ tk appname tktest
+ testsend prop root InterpRegistry "012345 gorp\n12345 foo\n12345 tktest"
+ tk appname x
+ set x [testsend prop root InterpRegistry]
+ string range $x [string first " " $x] end
+} " x\n012345 gorp\n12345 foo\n"
+test send-3.2 {RegDeleteName procedure} {secureserver testsend} {
+ tk appname tktest
+ testsend prop root InterpRegistry "012345 gorp\n12345 tktest\n23456 tktest"
+ tk appname x
+ set x [testsend prop root InterpRegistry]
+ string range $x [string first " " $x] end
+} " x\n012345 gorp\n23456 tktest\n"
+test send-3.3 {RegDeleteName procedure} {secureserver testsend} {
+ tk appname tktest
+ testsend prop root InterpRegistry "012345 tktest\n12345 bar\n23456 tktest"
+ tk appname x
+ set x [testsend prop root InterpRegistry]
+ string range $x [string first " " $x] end
+} " x\n12345 bar\n23456 tktest\n"
+test send-3.4 {RegDeleteName procedure} {secureserver testsend} {
+ tk appname tktest
+ testsend prop root InterpRegistry "foo"
+ tk appname x
+ set x [testsend prop root InterpRegistry]
+ string range $x [string first " " $x] end
+} " x\nfoo\n"
+test send-3.5 {RegDeleteName procedure} {secureserver testsend} {
+ tk appname tktest
+ testsend prop root InterpRegistry ""
+ tk appname x
+ set x [testsend prop root InterpRegistry]
+ string range $x [string first " " $x] end
+} " x\n"
+
+test send-4.1 {RegAddName procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry ""
+ tk appname bar
+ testsend prop root InterpRegistry
+} "$commId bar\n"
+test send-4.2 {RegAddName procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry "abc def"
+ tk appname bar
+ tk appname foo
+ testsend prop root InterpRegistry
+} "$commId foo\nabc def\n"
+
+# Previous checks should already cover the Regclose procedure.
+
+test send-5.1 {ValidateName procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry "123 abc\n"
+ winfo interps
+} {}
+test send-5.2 {ValidateName procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry "$id Hi there"
+ winfo interps
+} {{Hi there}}
+test send-5.3 {ValidateName procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry "$id Bogus"
+ list [catch {send Bogus set a 44} msg] $msg
+} {1 {target application died or uses a Tk version before 4.0}}
+test send-5.4 {ValidateName procedure} {secureserver testsend} {
+ tk appname test
+ testsend prop root InterpRegistry "$commId Bogus\n$commId test\n"
+ winfo interps
+} {test}
+
+if {[testConstraint nonPortable] && [testConstraint xhost]} {
+ winfo interps
+ tk appname tktest
+ update
+ setupbg
+ set x [split [exec xhost] \n]
+ foreach i [lrange $x 1 end] {
+ exec xhost - $i
+ }
+}
+
+test send-6.1 {ServerSecure procedure} {nonPortable secureserver} {
+ set a 44
+ list [dobg [list send [tk appname] set a 55]] $a
+} {55 55}
+test send-6.2 {ServerSecure procedure} {nonPortable secureserver xhost} {
+ set a 22
+ exec xhost [exec hostname]
+ list [catch {dobg [list send [tk appname] set a 33]} msg] $a $msg
+} {0 22 {X server insecure (must use xauth-style authorization); command ignored}}
+test send-6.3 {ServerSecure procedure} {nonPortable secureserver xhost} {
+ set a abc
+ exec xhost - [exec hostname]
+ list [dobg [list send [tk appname] set a new]] $a
+} {new new}
+cleanupbg
+
+test send-7.1 {Tk_SetAppName procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry ""
+ tk appname newName
+ list [tk appname oldName] [testsend prop root InterpRegistry]
+} "oldName {$commId oldName\n}"
+test send-7.2 {Tk_SetAppName procedure, name not in use} {secureserver testsend} {
+ testsend prop root InterpRegistry ""
+ list [tk appname gorp] [testsend prop root InterpRegistry]
+} "gorp {$commId gorp\n}"
+test send-7.3 {Tk_SetAppName procedure, name in use by us} {secureserver testsend} {
+ tk appname name1
+ testsend prop root InterpRegistry "$commId name2\n"
+ list [tk appname name2] [testsend prop root InterpRegistry]
+} "name2 {$commId name2\n}"
+test send-7.4 {Tk_SetAppName procedure, name in use} {secureserver testsend} {
+ tk appname name1
+ testsend prop root InterpRegistry "$id foo\n$id foo #2\n$id foo #3\n"
+ list [tk appname foo] [testsend prop root InterpRegistry]
+} "{foo #4} {$commId foo #4\n$id foo\n$id foo #2\n$id foo #3\n}"
+
+test send-8.1 {Tk_SendCmd procedure, options} {secureserver} {
+ setupbg
+ set app [dobg {tk appname}]
+ set a 66
+ send -async $app [list send [tk appname] set a 77]
+ set result $a
+ after 200 set x 40
+ tkwait variable x
+ cleanupbg
+ lappend result $a
+} {66 77}
+test send-8.2 {Tk_SendCmd procedure, options} {secureserver altDisplay} {
+ setupbg -display $env(TK_ALT_DISPLAY)
+ tk appname xyzgorp
+ set a homeDisplay
+ set result [dobg "
+ toplevel .t -screen [winfo screen .]
+ wm geometry .t +0+0
+ set a altDisplay
+ tk appname xyzgorp
+ list \[send xyzgorp set a\] \[send -displayof .t xyzgorp set a\]
+ "]
+ cleanupbg
+ set result
+} {altDisplay homeDisplay}
+test send-8.3 {Tk_SendCmd procedure, options} {secureserver} {
+ list [catch {send -- -async foo bar baz} msg] $msg
+} {1 {no application named "-async"}}
+test send-8.4 {Tk_SendCmd procedure, options} {secureserver} {
+ list [catch {send -gorp foo bar baz} msg] $msg
+} {1 {no application named "-gorp"}}
+test send-8.5 {Tk_SendCmd procedure, options} {secureserver} {
+ list [catch {send -async foo} msg] $msg
+} {1 {wrong # args: should be "send ?-option value ...? interpName arg ?arg ...?"}}
+test send-8.6 {Tk_SendCmd procedure, options} {secureserver} {
+ list [catch {send foo} msg] $msg
+} {1 {wrong # args: should be "send ?-option value ...? interpName arg ?arg ...?"}}
+test send-8.7 {Tk_SendCmd procedure, local execution} {secureserver} {
+ set a initial
+ send [tk appname] {set a new}
+ set a
+} {new}
+test send-8.8 {Tk_SendCmd procedure, local execution} {secureserver} {
+ set a initial
+ send [tk appname] set a new
+ set a
+} {new}
+test send-8.9 {Tk_SendCmd procedure, local execution} {secureserver} {
+ set a initial
+ string tolower [list [catch {send [tk appname] open bad_file} msg] \
+ $msg $errorInfo $errorCode]
+} {1 {couldn't open "bad_file": no such file or directory} {couldn't open "bad_file": no such file or directory
+ while executing
+"open bad_file"
+ invoked from within
+"send [tk appname] open bad_file"} {posix enoent {no such file or directory}}}
+test send-8.10 {Tk_SendCmd procedure, no such interpreter} {secureserver} {
+ list [catch {send bogus_name bogus_command} msg] $msg
+} {1 {no application named "bogus_name"}}
+
+catch {
+ newApp "" t_s_1 Test
+ t_s_1 eval wm withdraw .
+}
+
+test send-8.11 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} {
+ set a us
+ send t_s_1 set a them
+ list $a [send t_s_1 set a]
+} {us them}
+test send-8.12 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} {
+ set a us
+ send t_s_1 {set a them}
+ list $a [send t_s_1 {set a}]
+} {us them}
+test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} {
+ set a us
+ send t_s_1 {set a them}
+ list $a [send t_s_1 {set a}]
+} {us them}
+test send-8.14 {Tk_SendCmd procedure, local interp killed by send} {secureserver testsend} {
+ newApp "" t_s_2 Test
+ list [catch {send t_s_2 {destroy .; concat result}} msg] $msg
+} {0 result}
+
+catch {interp delete t_s_2}
+
+test send-8.15 {Tk_SendCmd procedure, local interp, error info} {secureserver testsend} {
+ catch {error foo}
+ list [catch {send t_s_1 {if 1 {open bogus_file_name}}} msg] $msg $errorInfo $errorCode
+} {1 {couldn't open "bogus_file_name": no such file or directory} {couldn't open "bogus_file_name": no such file or directory
+ while executing
+"open bogus_file_name"
+ invoked from within
+"if 1 {open bogus_file_name}"
+ invoked from within
+"send t_s_1 {if 1 {open bogus_file_name}}"} {POSIX ENOENT {no such file or directory}}}
+test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {secureserver testsend} {
+ testsend prop root InterpRegistry "10234 bogus\n"
+ set result [list [catch {send bogus bogus command} msg] $msg]
+ winfo interps
+ tk appname tktest
+ set result
+} {1 {no application named "bogus"}}
+
+catch {interp delete t_s_1}
+
+test send-8.17 {Tk_SendCmd procedure, deferring events} {secureserver nonPortable} {
+ # Non-portable because some window managers ignore "raise"
+ # requests so can't guarantee that new app's window won't
+ # obscure .f, thereby masking the Expose event.
+
+ setupbg
+ set app [dobg {tk appname}]
+ raise . ; # Don't want new app obscuring .f
+ catch {destroy .f}
+ frame .f
+ place .f -x 0 -y 0
+ bind .f <Expose> {set a exposed}
+ set a {no event yet}
+ set result ""
+ lappend result [send $app send [list [tk appname]] set a]
+ lappend result $a
+ update
+ cleanupbg
+ lappend result $a
+} {{no event yet} {no event yet} exposed}
+test send-8.18 {Tk_SendCmd procedure, error in remote app} {secureserver} {
+ setupbg
+ set app [dobg {tk appname}]
+ set result [string tolower [list [catch {send $app open bad_name} msg] \
+ $msg $errorInfo $errorCode]]
+ cleanupbg
+ set result
+} {1 {couldn't open "bad_name": no such file or directory} {couldn't open "bad_name": no such file or directory
+ while executing
+"open bad_name"
+ invoked from within
+"send $app open bad_name"} {posix enoent {no such file or directory}}}
+test send-8.19 {Tk_SendCmd, using modal timeouts} {secureserver} {
+ setupbg
+ set app [dobg {tk appname}]
+ set x no
+ set result ""
+ after 0 {set x yes}
+ lappend result [send $app {concat x y z}]
+ lappend result $x
+ update
+ cleanupbg
+ lappend result $x
+} {{x y z} no yes}
+
+tk appname tktest
+catch {destroy .f}
+frame .f
+set id [string range [winfo id .f] 2 end]
+
+test send-9.1 {Tk_GetInterpNames procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry \
+ "$commId tktest\nfoo bar\n$commId tktest\n$id frame .f\n\n\n"
+ list [winfo interps] [testsend prop root InterpRegistry]
+} "{tktest tktest {frame .f}} {$commId tktest\n$commId tktest\n$id frame .f
+}"
+test send-9.2 {Tk_GetInterpNames procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry \
+ "$commId tktest\nfoobar\n$commId gorp\n"
+ list [winfo interps] [testsend prop root InterpRegistry]
+} "tktest {$commId tktest\n}"
+test send-9.3 {Tk_GetInterpNames procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry {}
+ list [winfo interps] [testsend prop root InterpRegistry]
+} {{} {}}
+
+catch {testsend prop root InterpRegistry "$commId tktest\n$id dummy\n"}
+
+test send-10.1 {SendEventProc procedure, bogus comm property} {secureserver testsend} {
+ testsend prop comm Comm {abc def}
+ testsend prop comm Comm {}
+ update
+} {}
+test send-10.2 {SendEventProc procedure, simultaneous messages} {secureserver testsend} {
+ testsend prop comm Comm \
+ "c\n-n tktest\n-s set a 44\nc\n-n tktest\n-s set b 45\n"
+ set a null
+ set b xyzzy
+ update
+ list $a $b
+} {44 45}
+test send-10.3 {SendEventProc procedure, simultaneous messages} {secureserver testsend} {
+ testsend prop comm Comm \
+ "c\n-n tktest\n-s set a newA\nr\n-s [testsend serial]\n-r 12345\nc\n-n tktest\n-s set b newB\n"
+ set a null
+ set b xyzzy
+ set x [send dummy bogus]
+ list $x $a $b
+} {12345 newA newB}
+test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} {secureserver testsend} {
+ testsend prop comm Comm \
+ "\n\nx\n-bogus\n\nc\n-n tktest\n-s set a 44\n"
+ set a null
+ update
+ set a
+} {44}
+test send-10.5 {SendEventProc procedure, extraneous command options} {secureserver testsend} {
+ testsend prop comm Comm \
+ "c\n-n tktest\n-x miscellanous\n-y who knows?\n-s set a new\n"
+ set a null
+ update
+ set a
+} {new}
+test send-10.6 {SendEventProc procedure, unknown interpreter} {secureserver testsend} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n unknown\n-r $id 44\n-s set a new\n"
+ set a null
+ update
+ list [testsend prop [winfo id .f] Comm] $a
+} "{\nr\n-s 44\n-r receiver never heard of interpreter \"unknown\"\n-c 1\n} null"
+test send-10.7 {SendEventProc procedure, error in script} {secureserver testsend} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n tktest\n-r $id 62\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n"
+ update
+ testsend prop [winfo id .f] Comm
+} {
+r
+-s 62
+-r test error
+-i Initial errorInfo
+ ("foreach" body line 1)
+ invoked from within
+"foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}"
+-e test code
+-c 1
+}
+test send-10.8 {SendEventProc procedure, exceptional return} {secureserver testsend} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n tktest\n-r $id 62\n-s break\n"
+ update
+ testsend prop [winfo id .f] Comm
+} {
+r
+-s 62
+-r
+-c 3
+}
+test send-10.9 {SendEventProc procedure, empty return} {secureserver testsend} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n tktest\n-r $id 62\n-s concat\n"
+ update
+ testsend prop [winfo id .f] Comm
+} {
+r
+-s 62
+-r
+}
+test send-10.10 {SendEventProc procedure, asynchronous calls} {secureserver testsend} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n tktest\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n"
+ update
+ testsend prop [winfo id .f] Comm
+} {}
+test send-10.11 {SendEventProc procedure, exceptional return} {secureserver testsend} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n tktest\n-s break\n"
+ update
+ testsend prop [winfo id .f] Comm
+} {}
+test send-10.12 {SendEventProc procedure, empty return} {secureserver testsend} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n tktest\n-s concat\n"
+ update
+ testsend prop [winfo id .f] Comm
+} {}
+test send-10.13 {SendEventProc procedure, return processing} {secureserver testsend} {
+ testsend prop comm Comm \
+ "r\n-c 1\n-e test1\n-i test2\n-r test3\n-s [testsend serial]\n"
+ list [catch {send dummy foo} msg] $msg $errorInfo $errorCode
+} {1 test3 {test2
+ invoked from within
+"send dummy foo"} test1}
+test send-10.14 {SendEventProc procedure, extraneous return options} {secureserver testsend} {
+ testsend prop comm Comm \
+ "r\n-x test1\n-y test2\n-r result\n-s [testsend serial]\n"
+ list [catch {send dummy foo} msg] $msg
+} {0 result}
+test send-10.15 {SendEventProc procedure, serial number} {secureserver testsend} {
+ testsend prop comm Comm \
+ "r\n-r response\n"
+ list [catch {send dummy foo} msg] $msg
+} {1 {target application died or uses a Tk version before 4.0}}
+test send-10.16 {SendEventProc procedure, serial number} {secureserver testsend} {
+ testsend prop comm Comm \
+ "r\n-r response\n\n-s 0"
+ list [catch {send dummy foo} msg] $msg
+} {1 {target application died or uses a Tk version before 4.0}}
+test send-10.17 {SendEventProc procedure, errorCode and errorInfo} {secureserver testsend} {
+ testsend prop comm Comm \
+ "r\n-i test1\n-e test2\n-c 4\n-s [testsend serial]\n"
+ set errorCode oldErrorCode
+ set errorInfo oldErrorInfo
+ list [catch {send dummy foo} msg] $msg $errorInfo $errorCode
+} {4 {} oldErrorInfo oldErrorCode}
+test send-10.18 {SendEventProc procedure, send kills application} {secureserver testsend} {
+ setupbg
+ dobg {tk appname t_s_3}
+ set x [list [catch {send t_s_3 destroy .} msg] $msg]
+ cleanupbg
+ set x
+} {0 {}}
+test send-10.19 {SendEventProc procedure, send exits} {secureserver testsend} {
+ setupbg
+ dobg {tk appname t_s_3}
+ set x [list [catch {send t_s_3 exit} msg] $msg]
+ cleanupbg
+ set x
+} {1 {target application died}}
+
+test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} {secureserver testsend} {
+ testsend prop root InterpRegistry "0x21447 dummy\n"
+ list [catch {send dummy foo} msg] $msg
+} {1 {no application named "dummy"}}
+test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} {secureserver testsend} {
+ testsend prop comm Comm "c\n-r0x123 44\n-n tktest\n-s concat a b c\n"
+ update
+} {}
+
+winfo interps
+tk appname tktest
+catch {destroy .f}
+frame .f
+set id [string range [winfo id .f] 2 end]
+
+test send-12.1 {TimeoutProc procedure} {secureserver testsend} {
+ testsend prop root InterpRegistry "$id dummy\n"
+ list [catch {send dummy foo} msg] $msg
+} {1 {target application died or uses a Tk version before 4.0}}
+
+catch {testsend prop root InterpRegistry ""}
+
+test send-12.2 {TimeoutProc procedure} {secureserver} {
+ winfo interps
+ tk appname tktest
+ update
+ setupbg
+ set app [dobg {
+ after 10 {after 10 {after 5000; exit}}
+ tk appname
+ }]
+ after 200
+ set result [list [catch {send $app foo} msg] $msg]
+ cleanupbg
+ set result
+} {1 {target application died}}
+
+winfo interps
+tk appname tktest
+test send-13.1 {DeleteProc procedure} {secureserver} {
+ setupbg
+ set app [dobg {rename send {}; tk appname}]
+ set result [list [catch {send $app foo} msg] $msg [winfo interps]]
+ cleanupbg
+ set result
+} {1 {no application named "tktest #2"} tktest}
+test send-13.2 {DeleteProc procedure} {secureserver} {
+ winfo interps
+ tk appname tktest
+ rename send {}
+ set result {}
+ lappend result [winfo interps] [info commands send]
+ tk appname foo
+ lappend result [winfo interps] [info commands send]
+} {{} {} foo send}
+
+test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {secureserver altDisplay} {
+ setupbg -display $env(TK_ALT_DISPLAY)
+ set result [dobg "
+ toplevel .t -screen [winfo screen .]
+ wm geometry .t +0+0
+ tk appname xyzgorp1
+ set x child
+ "]
+ toplevel .t -screen $env(TK_ALT_DISPLAY)
+ wm geometry .t +0+0
+ tk appname xyzgorp2
+ update
+ set y parent
+ set result [send -displayof .t xyzgorp1 {list $x [send -displayof .t xyzgorp2 set y]}]
+ destroy .t
+ cleanupbg
+ set result
+} {child parent}
+
+catch {
+ testsend prop root InterpRegister $registry
+ tk appname tktest
+}
+test send-15.1 {UpdateCommWindow procedure} {secureserver testsend} {
+ set x [list [testsend prop comm TK_APPLICATION]]
+ newApp "" t_s_1 Test
+ send t_s_1 wm withdraw .
+ newApp "" t_s_2 Test
+ send t_s_2 wm withdraw .
+ lappend x [testsend prop comm TK_APPLICATION]
+ interp delete t_s_1
+ lappend x [testsend prop comm TK_APPLICATION]
+ interp delete t_s_2
+ lappend x [testsend prop comm TK_APPLICATION]
+} {tktest {t_s_2 t_s_1 tktest} {t_s_2 tktest} tktest}
+
+catch {
+ tk appname $name
+ testsend prop root InterpRegistry $registry
+ testdeleteapps
+}
+rename newApp {}
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/spinbox.test b/tk8.6/tests/spinbox.test
new file mode 100644
index 0000000..594cc90
--- /dev/null
+++ b/tk8.6/tests/spinbox.test
@@ -0,0 +1,3832 @@
+# This file is a Tcl script to test spinbox widgets in Tk. It is
+# organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# For xscrollcommand
+proc scroll args {
+ global scrollInfo
+ set scrollInfo $args
+}
+# For trace variable
+proc override args {
+ global x
+ set x 12345
+}
+
+# Procedures used in widget VALIDATION tests
+proc doval {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ return 1
+}
+proc doval2 {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ set ::e mydata
+ return 1
+}
+proc doval3 {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ return 0
+}
+
+set cy [font metrics {Courier -12} -linespace]
+
+test spinbox-1.1 {configuration option: "activebackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -activebackground #ff0000
+ .e cget -activebackground
+} -cleanup {
+ destroy .e
+} -result {#ff0000}
+test spinbox-1.2 {configuration option: "activebackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -activebackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test spinbox-1.3 {configuration option: "background"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -background #ff0000
+ .e cget -background
+} -cleanup {
+ destroy .e
+} -result {#ff0000}
+test spinbox-1.4 {configuration option: "background" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -background non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test spinbox-1.5 {configuration option: "bd"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -bd 4
+ .e cget -bd
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-1.6 {configuration option: "bd" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -bd badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test spinbox-1.7 {configuration option: "bg"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -bg #ff0000
+ .e cget -bg
+} -cleanup {
+ destroy .e
+} -result {#ff0000}
+test spinbox-1.8 {configuration option: "bg" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -bg non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test spinbox-1.9 {configuration option: "borderwidth"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -borderwidth 1.3
+ .e cget -borderwidth
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-1.10 {configuration option: "borderwidth" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -borderwidth badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test spinbox-1.11 {configuration option: "buttonbackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -buttonbackground #ff0000
+ .e cget -buttonbackground
+} -cleanup {
+ destroy .e
+} -result {#ff0000}
+test spinbox-1.12 {configuration option: "buttonbackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -buttonbackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test spinbox-1.13 {configuration option: "buttoncursor"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -buttoncursor arrow
+ .e cget -buttoncursor
+} -cleanup {
+ destroy .e
+} -result {arrow}
+test spinbox-1.14 {configuration option: "buttoncursor" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -buttoncursor badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+
+test spinbox-1.15 {configuration option: "command"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -command {a command}
+ .e cget -command
+} -cleanup {
+ destroy .e
+} -result {a command}
+
+test spinbox-1.16 {configuration option: "cursor"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -cursor arrow
+ .e cget -cursor
+} -cleanup {
+ destroy .e
+} -result {arrow}
+test spinbox-1.17 {configuration option: "cursor" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -cursor badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+
+test spinbox-1.18 {configuration option: "disabledbackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -disabledbackground green
+ .e cget -disabledbackground
+} -cleanup {
+ destroy .e
+} -result {green}
+test spinbox-1.19 {configuration option: "disabledbackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -disabledbackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test spinbox-1.20 {configuration option: "disabledforeground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -disabledforeground #110022
+ .e cget -disabledforeground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test spinbox-1.21 {configuration option: "disabledforeground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -disabledforeground bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.22 {configuration option: "exportselection"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -exportselection yes
+ .e cget -exportselection
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-1.23 {configuration option: "exportselection" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -exportselection xyzzy
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected boolean value but got "xyzzy"}
+
+test spinbox-1.24 {configuration option: "fg"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -fg #110022
+ .e cget -fg
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test spinbox-1.25 {configuration option: "fg" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -fg bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.26 {configuration option: "font"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+ .e cget -font
+} -cleanup {
+ destroy .e
+} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*}
+test spinbox-1.27 {configuration option: "font" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -font {}
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {font "" doesn't exist}
+
+test spinbox-1.28 {configuration option: "foreground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -foreground #110022
+ .e cget -foreground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test spinbox-1.29 {configuration option: "foreground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -foreground bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.30 {configuration option: "format"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -format %0.5f
+ .e cget -format
+} -cleanup {
+ destroy .e
+} -result {%0.5f}
+test spinbox-1.31 {configuration option: "format" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -format %d
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad spinbox format specifier "%d"}
+
+test spinbox-1.32 {configuration option: "from"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -from -10
+ .e cget -from
+} -cleanup {
+ destroy .e
+} -result {-10.0}
+test spinbox-1.33 {configuration option: "from" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -from bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected floating-point number but got "bogus"}
+
+test spinbox-1.34 {configuration option: "highlightbackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightbackground #123456
+ .e cget -highlightbackground
+} -cleanup {
+ destroy .e
+} -result {#123456}
+test spinbox-1.35 {configuration option: "highlightbackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightbackground ugly
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "ugly"}
+
+test spinbox-1.36 {configuration option: "highlightcolor"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightcolor #123456
+ .e cget -highlightcolor
+} -cleanup {
+ destroy .e
+} -result {#123456}
+test spinbox-1.37 {configuration option: "highlightcolor" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightcolor bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.38 {configuration option: "highlightthickness"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightthickness 6
+ .e cget -highlightthickness
+} -cleanup {
+ destroy .e
+} -result {6}
+test spinbox-1.39 {configuration option: "highlightthickness" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightthickness bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "bogus"}
+
+test spinbox-1.40 {configuration option: "highlightthickness"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightthickness -2
+ .e cget -highlightthickness
+} -cleanup {
+ destroy .e
+} -result {0}
+
+test spinbox-1.41 {configuration option: "increment"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -increment 1.0
+ .e cget -increment
+} -cleanup {
+ destroy .e
+} -result {1.0}
+test spinbox-1.42 {configuration option: "increment" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -increment bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected floating-point number but got "bogus"}
+
+test spinbox-1.43 {configuration option: "insertbackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertbackground #110022
+ .e cget -insertbackground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test spinbox-1.44 {configuration option: "insertbackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertbackground bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.45 {configuration option: "insertborderwidth"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertborderwidth 1.3
+ .e cget -insertborderwidth
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-1.46 {configuration option: "insertborderwidth" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertborderwidth 2.6x
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "2.6x"}
+
+test spinbox-1.47 {configuration option: "insertofftime"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertofftime 100
+ .e cget -insertofftime
+} -cleanup {
+ destroy .e
+} -result {100}
+test spinbox-1.48 {configuration option: "insertofftime" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertofftime 3.2
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3.2"}
+
+test spinbox-1.49 {configuration option: "insertontime"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertontime 100
+ .e cget -insertontime
+} -cleanup {
+ destroy .e
+} -result {100}
+test spinbox-1.50 {configuration option: "insertontime" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertontime 3.2
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3.2"}
+
+test spinbox-1.51 {configuration option: "invalidcommand"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -invalidcommand "a command"
+ .e cget -invalidcommand
+} -cleanup {
+ destroy .e
+} -result {a command}
+
+test spinbox-1.52 {configuration option: "invcmd"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -invcmd "a command"
+ .e cget -invcmd
+} -cleanup {
+ destroy .e
+} -result {a command}
+
+test spinbox-1.53 {configuration option: "justify"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -justify right
+ .e cget -justify
+} -cleanup {
+ destroy .e
+} -result {right}
+test spinbox-1.54 {configuration option: "justify" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -justify bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+
+test spinbox-1.55 {configuration option: "readonlybackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -readonlybackground green
+ .e cget -readonlybackground
+} -cleanup {
+ destroy .e
+} -result {green}
+test spinbox-1.56 {configuration option: "readonlybackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -readonlybackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test spinbox-1.57 {configuration option: "relief"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -relief groove
+ .e cget -relief
+} -cleanup {
+ destroy .e
+} -result {groove}
+test spinbox-1.58 {configuration option: "relief" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -relief 1.5
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+
+test spinbox-1.59 {configuration option: "repeatdelay"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -repeatdelay 500
+ .e cget -repeatdelay
+} -cleanup {
+ destroy .e
+} -result {500}
+test spinbox-1.60 {configuration option: "repeatdelay" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -repeatdelay 3p
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3p"}
+
+test spinbox-1.61 {configuration option: "repeatinterval"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -repeatinterval -500
+ .e cget -repeatinterval
+} -cleanup {
+ destroy .e
+} -result {-500}
+test spinbox-1.62 {configuration option: "repeatinterval" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -repeatinterval 3p
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3p"}
+
+test spinbox-1.63 {configuration option: "selectbackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -selectbackground #110022
+ .e cget -selectbackground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test spinbox-1.64 {configuration option: "selectbackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -selectbackground bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.65 {configuration option: "selectborderwidth"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -selectborderwidth 1.3
+ .e cget -selectborderwidth
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-1.66 {configuration option: "selectborderwidth" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -selectborderwidth badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test spinbox-1.67 {configuration option: "selectforeground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -selectforeground #654321
+ .e cget -selectforeground
+} -cleanup {
+ destroy .e
+} -result {#654321}
+test spinbox-1.68 {configuration option: "selectforeground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -selectforeground bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.69 {configuration option: "state"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -state n
+ .e cget -state
+} -cleanup {
+ destroy .e
+} -result {normal}
+test spinbox-1.70 {configuration option: "state" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -state bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad state "bogus": must be disabled, normal, or readonly}
+
+test spinbox-1.71 {configuration option: "takefocus"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -takefocus "any string"
+ .e cget -takefocus
+} -cleanup {
+ destroy .e
+} -result {any string}
+
+test spinbox-1.72 {configuration option: "textvariable"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -textvariable i
+ .e cget -textvariable
+} -cleanup {
+ destroy .e
+} -result {i}
+
+test spinbox-1.73 {configuration option: "to"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -to 14.9
+ .e cget -to
+} -cleanup {
+ destroy .e
+} -result {14.9}
+test spinbox-1.74 {configuration option: "to" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -to bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected floating-point number but got "bogus"}
+
+test spinbox-1.75 {configuration option: "validate"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -validate "key"
+ .e cget -validate
+} -cleanup {
+ destroy .e
+} -result {key}
+test spinbox-1.76 {configuration option: "validate" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -validate "bogus"
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad validate "bogus": must be all, key, focus, focusin, focusout, or none}
+
+test spinbox-1.77 {configuration option: "validatecommand"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -validatecommand "a command"
+ .e cget -validatecommand
+} -cleanup {
+ destroy .e
+} -result {a command}
+
+test spinbox-1.78 {configuration option: "values"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -values {mon tue wed thur}
+ .e cget -values
+} -cleanup {
+ destroy .e
+} -result {mon tue wed thur}
+test spinbox-1.79 {configuration option: "values" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -values {bad {}list}
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {list element in braces followed by "list" instead of space}
+
+test spinbox-1.80 {configuration option: "vcmd"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -vcmd "a command"
+ .e cget -vcmd
+} -cleanup {
+ destroy .e
+} -result {a command}
+
+test spinbox-1.81 {configuration option: "width"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -width 402
+ .e cget -width
+} -cleanup {
+ destroy .e
+} -result {402}
+test spinbox-1.82 {configuration option: "width" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -width 3p
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3p"}
+
+test spinbox-1.83 {configuration option: "wrap"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -wrap yes
+ .e cget -wrap
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-1.84 {configuration option: "wrap" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -wrap xyzzy
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected boolean value but got "xyzzy"}
+
+test spinbox-1.85 {configuration option: "xscrollcommand"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -xscrollcommand {Some command}
+ .e cget -xscrollcommand
+} -cleanup {
+ destroy .e
+} -result {Some command}
+
+
+test spinbox-2.1 {Tk_SpinboxCmd procedure} -body {
+ spinbox
+} -returnCodes error -result {wrong # args: should be "spinbox pathName ?-option value ...?"}
+test spinbox-2.2 {Tk_SpinboxCmd procedure} -body {
+ spinbox gorp
+} -returnCodes error -result {bad window path name "gorp"}
+test spinbox-2.3 {Tk_SpinboxCmd procedure} -body {
+ spinbox .e
+ pack .e
+ update
+ list [winfo exists .e] [winfo class .e] [info commands .e]
+} -cleanup {
+ destroy .e
+} -result {1 Spinbox .e}
+test spinbox-2.4 {Tk_SpinboxCmd procedure} -body {
+ spinbox .e -gorp foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "-gorp"}
+test spinbox-2.4.1 {Tk_SpinboxCmd procedure} -body {
+ catch {spinbox .e -gorp foo}
+ list [winfo exists .e] [info commands .e]
+} -cleanup {
+ destroy .e
+} -result {0 {}}
+test spinbox-2.5 {Tk_SpinboxCmd procedure} -body {
+ spinbox .e
+} -cleanup {
+ destroy .e
+} -result {.e}
+
+
+test spinbox-3.1 {SpinboxWidgetCmd procedure} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e option ?arg ...?"}
+test spinbox-3.2 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e bbox
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e bbox index"}
+test spinbox-3.3 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e bbox a b
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e bbox index"}
+test spinbox-3.4 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e bbox bogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "bogus"}
+test spinbox-3.5 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e bbox 0
+} -cleanup {
+ destroy .e
+} -result [list 5 5 0 $cy]
+
+# Oryginaly the result was count using measurements
+# and metrics. It was changed to less verbose solution - the result is the one
+# that passes fonts constraint (this concerns tests 3.6, 3.7, 3.8, 3.10)
+test spinbox-3.6 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): no utf chars
+ .e insert 0 "abc"
+ list [.e bbox 3] [.e bbox end]
+} -cleanup {
+ destroy .e
+} -result {{19 5 7 13} {19 5 7 13}}
+test spinbox-3.7 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): utf at end
+ .e insert 0 "ab\u4e4e"
+ .e bbox end
+} -cleanup {
+ destroy .e
+} -result {19 5 12 13}
+test spinbox-3.8 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): utf before index
+ .e insert 0 "ab\u4e4ec"
+ .e bbox 3
+} -cleanup {
+ destroy .e
+} -result {31 5 7 13}
+test spinbox-3.9 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): no chars
+ .e bbox end
+} -cleanup {
+ destroy .e
+} -result "5 5 0 $cy"
+test spinbox-3.10 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e insert 0 "abcdefghij\u4e4eklmnop"
+ list [.e bbox 0] [.e bbox 1] [.e bbox 10] [.e bbox end]
+} -cleanup {
+ destroy .e
+} -result {{5 5 7 13} {12 5 7 13} {75 5 12 13} {122 5 7 13}}
+test spinbox-3.11 {SpinboxWidgetCmd procedure, "cget" widget command} -setup {
+ spinbox .e
+} -body {
+ .e cget
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e cget option"}
+test spinbox-3.12 {SpinboxWidgetCmd procedure, "cget" widget command} -setup {
+ spinbox .e
+} -body {
+ .e cget a b
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e cget option"}
+test spinbox-3.13 {SpinboxWidgetCmd procedure, "cget" widget command} -setup {
+ spinbox .e
+} -body {
+ .e cget -gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "-gorp"}
+test spinbox-3.14 {SpinboxWidgetCmd procedure, "cget" widget command} -setup {
+ spinbox .e
+} -body {
+ .e configure -bd 4
+ .e cget -bd
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-3.15 {SpinboxWidgetCmd procedure, "configure" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ llength [.e configure]
+} -cleanup {
+ destroy .e
+} -result {49}
+test spinbox-3.16 {SpinboxWidgetCmd procedure, "configure" widget command} -setup {
+ spinbox .e
+} -body {
+ .e configure -foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "-foo"}
+test spinbox-3.17 {SpinboxWidgetCmd procedure, "configure" widget command} -setup {
+ spinbox .e
+} -body {
+ .e configure -bd 4
+ .e configure -bg #ffffff
+ lindex [.e configure -bd] 4
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-3.18 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+} -body {
+ .e delete
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"}
+test spinbox-3.19 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+} -body {
+ .e delete a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"}
+test spinbox-3.20 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+} -body {
+ .e delete foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "foo"}
+test spinbox-3.21 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+} -body {
+ .e delete 0 bar
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "bar"}
+test spinbox-3.22 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e delete 2 4
+ .e get
+} -cleanup {
+ destroy .e
+} -result {014567890}
+test spinbox-3.23 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+} -body {
+ .e insert end "01234567890"
+ .e delete 6
+ .e get
+} -cleanup {
+ destroy .e
+} -result {0123457890}
+test spinbox-3.24 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+ set x {}
+} -body {
+# UTF
+ .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]
+} -cleanup {
+ destroy .e
+} -result [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"]
+test spinbox-3.25 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e delete 6 5
+ .e get
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test spinbox-3.26 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e configure -state disabled
+ .e delete 2 8
+ .e configure -state normal
+ .e get
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test spinbox-3.26.1 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e configure -state readonly
+ .e delete 2 8
+ .e configure -state normal
+ .e get
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test spinbox-3.27 {SpinboxWidgetCmd procedure, "get" widget command} -setup {
+ spinbox .e
+} -body {
+ .e get foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e get"}
+test spinbox-3.28 {SpinboxWidgetCmd procedure, "icursor" widget command} -setup {
+ spinbox .e
+} -body {
+ .e icursor
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e icursor pos"}
+test spinbox-3.29 {SpinboxWidgetCmd procedure, "icursor" widget command} -setup {
+ spinbox .e
+} -body {
+ .e icursor foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "foo"}
+test spinbox-3.30 {SpinboxWidgetCmd procedure, "icursor" widget command} -setup {
+ spinbox .e
+} -body {
+ .e insert end "01234567890"
+ .e icursor 4
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-3.31 {SpinboxWidgetCmd procedure, "index" widget command} -setup {
+ spinbox .e
+} -body {
+ .e in
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {ambiguous option "in": must be bbox, cget, configure, delete, get, icursor, identify, index, insert, invoke, scan, selection, set, validate, or xview}
+test spinbox-3.32 {SpinboxWidgetCmd procedure, "index" widget command} -setup {
+ spinbox .e
+} -body {
+ .e index
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e index string"}
+test spinbox-3.33 {SpinboxWidgetCmd procedure, "index" widget command} -setup {
+ spinbox .e
+} -body {
+ .e index foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "foo"}
+test spinbox-3.34 {SpinboxWidgetCmd procedure, "index" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e index 0
+} -cleanup {
+ destroy .e
+} -returnCodes {ok} -match glob -result {*}
+test spinbox-3.35 {SpinboxWidgetCmd procedure, "index" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+# UTF
+ .e insert 0 abc\u4e4e\u0153def
+ list [.e index 3] [.e index 4] [.e index end]
+} -cleanup {
+ destroy .e
+} -result {3 4 8}
+test spinbox-3.36 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+} -body {
+ .e insert a
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e insert index text"}
+test spinbox-3.37 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+} -body {
+ .e insert a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e insert index text"}
+test spinbox-3.38 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+} -body {
+ .e insert foo Text
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "foo"}
+test spinbox-3.39 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e insert 3 xxx
+ .e get
+} -cleanup {
+ destroy .e
+} -result {012xxx34567890}
+test spinbox-3.40 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e configure -state disabled
+ .e insert 3 xxx
+ .e configure -state normal
+ .e get
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test spinbox-3.40.1 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e configure -state readonly
+ .e insert 3 xxx
+ .e configure -state normal
+ .e get
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test spinbox-3.41 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+} -body {
+ .e insert a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e insert index text"}
+test spinbox-3.42 {SpinboxWidgetCmd procedure, "scan" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e scan a
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e scan mark|dragto x"}
+test spinbox-3.43 {SpinboxWidgetCmd procedure, "scan" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e scan a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e scan mark|dragto x"}
+test spinbox-3.44 {SpinboxWidgetCmd procedure, "scan" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e scan foobar 20
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad scan option "foobar": must be mark or dragto}
+test spinbox-3.45 {SpinboxWidgetCmd procedure, "scan" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e scan mark 20.1
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {expected integer but got "20.1"}
+
+# This test is non-portable because character sizes vary.
+test spinbox-3.46 {SpinboxWidgetCmd procedure, "scan" widget command} -constraints {
+ fonts
+} -setup {
+ spinbox .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e insert end "This is quite a long string, in fact a "
+ .e insert end "very very long string"
+ .e scan mark 30
+ .e scan dragto 28
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {2}
+test spinbox-3.47 {SpinboxWidgetCmd procedure, "select" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection option ?index?"}
+test spinbox-3.48 {SpinboxWidgetCmd procedure, "select" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad selection option "foo": must be adjust, clear, element, from, present, range, or to}
+
+test spinbox-3.49 {SpinboxWidgetCmd procedure, "select clear" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select clear gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection clear"}
+test spinbox-3.50 {SpinboxWidgetCmd procedure, "select clear" widget command} -setup {
+ spinbox .e
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 4
+ update
+ .e select clear
+ selection get
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined}
+test spinbox-3.50.1 {SpinboxWidgetCmd procedure, "select clear" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 4
+ update
+ .e select clear
+ catch {selection get}
+ selection own
+} -cleanup {
+ destroy .e
+} -result {.e}
+
+test spinbox-3.51 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup {
+ spinbox .e
+} -body {
+ .e selection present foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection present"}
+test spinbox-3.52 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end 0123456789
+ .e select from 3
+ .e select to 6
+ .e selection present
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-3.53 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end 0123456789
+ .e select from 3
+ .e select to 6
+ .e configure -exportselection false
+ .e selection present
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-3.54 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end 0123456789
+ .e select from 3
+ .e select to 6
+ .e delete 0 end
+ .e selection present
+} -cleanup {
+ destroy .e
+} -result {0}
+test spinbox-3.55 {SpinboxWidgetCmd procedure, "selection adjust" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select adjust x
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "x"}
+test spinbox-3.56 {SpinboxWidgetCmd procedure, "selection adjust" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select adjust 2 3
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection adjust index"}
+test spinbox-3.57 {SpinboxWidgetCmd procedure, "selection adjust" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 5
+ update
+ .e select adjust 4
+ selection get
+} -cleanup {
+ destroy .e
+} -result {123}
+test spinbox-3.58 {SpinboxWidgetCmd procedure, "selection adjust" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 5
+ update
+ .e select adjust 2
+ selection get
+} -cleanup {
+ destroy .e
+} -result {234}
+test spinbox-3.59 {SpinboxWidgetCmd procedure, "selection from" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select from 2 3
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection from index"}
+
+test spinbox-3.60 {SpinboxWidgetCmd procedure, "selection range" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select range 2
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection range start end"}
+test spinbox-3.61 {SpinboxWidgetCmd procedure, "selection range" widget command} -setup {
+ spinbox .e
+} -body {
+ .e selection range 2 3 4
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection range start end"}
+test spinbox-3.62 {SpinboxWidgetCmd procedure, "selection range" widget command} -setup {
+ spinbox .e
+} -body {
+ .e insert end 0123456789
+ .e select from 1
+ .e select to 5
+ .e select range 4 4
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+test spinbox-3.63 {SpinboxWidgetCmd procedure, "selection range" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end 0123456789
+ .e select from 3
+ .e select to 7
+ .e select range 2 9
+ list [.e index sel.first] [.e index sel.last] [.e index anchor]
+} -cleanup {
+ destroy .e
+} -result {2 9 3}
+test spinbox-3.64 {SpinboxWidgetCmd procedure, "selection to" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+ .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."
+} -body {
+ .e select to 2 3
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection to index"}
+test spinbox-3.64.1 {SpinboxWidgetCmd procedure, "selection" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .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]
+} -cleanup {
+ destroy .e
+} -result {0 10}
+test spinbox-3.64.2 {SpinboxWidgetCmd procedure, "selection" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .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]
+} -cleanup {
+ destroy .e
+} -result {2 4}
+
+test spinbox-3.65 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .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 xview 5
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.053763 0.268817}
+test spinbox-3.66 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e xview gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "gorp"}
+test spinbox-3.67 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .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 xview 0
+ .e icursor 10
+ .e xview insert
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.107527 0.322581}
+test spinbox-3.68 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e xview moveto foo bar
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e xview moveto fraction"}
+test spinbox-3.69 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e xview moveto foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {expected floating-point number but got "foo"}
+test spinbox-3.70 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .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 xview moveto 0.5
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.505376 0.720430}
+test spinbox-3.71 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .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 xview scroll 24
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e xview scroll number units|pages"}
+test spinbox-3.72 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview scroll gorp units
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {expected integer but got "gorp"}
+test spinbox-3.73 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview moveto 0
+ .e xview scroll 1 pages
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.193548 0.408602}
+test spinbox-3.74 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .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 xview moveto .9
+ update
+ .e xview scroll -2 p
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.397849 0.612903}
+test spinbox-3.75 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview 30
+ update
+ .e xview scroll 2 units
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {32}
+test spinbox-3.76 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview 30
+ update
+ .e xview scroll -1 units
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {29}
+test spinbox-3.77 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview scroll 23 foobars
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad argument "foobars": must be units or pages}
+test spinbox-3.78 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview eat 23 hamburgers
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "eat": must be moveto or scroll}
+test spinbox-3.79 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .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 xview 0
+ update
+ .e xview -4
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {0}
+test spinbox-3.80 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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."
+ update
+ .e xview 300
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {73}
+test spinbox-3.81 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .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 insert 10 \u4e4e
+ update
+# 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 [format {%.6f} [lindex [.e xview] 0]]
+ .e xview moveto .11
+ lappend x [format {%.6f} [lindex [.e xview] 0]]
+ .e xview moveto .12
+ lappend x [format {%.6f} [lindex [.e xview] 0]]
+} -cleanup {
+ destroy .e
+} -result {0.095745 0.106383 0.117021}
+
+test spinbox-3.82 {SpinboxWidgetCmd procedure} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, identify, index, insert, invoke, scan, selection, set, validate, or xview}
+
+test spinbox-5.1 {ConfigureSpinbox procedure, -textvariable} -body {
+ set x 12345
+ spinbox .e -textvariable x
+ .e get
+} -cleanup {
+ destroy .e
+} -result {12345}
+test spinbox-5.2 {ConfigureSpinbox procedure, -textvariable} -body {
+ set x 12345
+ spinbox .e -textvariable x
+ set y abcde
+ .e configure -textvariable y
+ set x 54321
+ .e get
+} -cleanup {
+ destroy .e
+} -result {abcde}
+test spinbox-5.3 {ConfigureSpinbox procedure, -textvariable} -setup {
+ unset -nocomplain x
+ spinbox .e
+} -body {
+ .e insert 0 "Some text"
+ .e configure -textvariable x
+ set x
+} -cleanup {
+ destroy .e
+} -result {Some text}
+test spinbox-5.4 {ConfigureSpinbox procedure, -textvariable} -setup {
+ unset -nocomplain x
+ spinbox .e
+} -body {
+ trace variable x w override
+ .e insert 0 "Some text"
+ .e configure -textvariable x
+ list $x [.e get]
+} -cleanup {
+ destroy .e
+ trace vdelete x w override
+} -result {12345 12345}
+
+test spinbox-5.5 {ConfigureSpinbox procedure} -setup {
+ set x {}
+ spinbox .e1
+ spinbox .e2
+} -body {
+ .e2 insert end "This is some sample text"
+ .e1 configure -exportselection false
+ .e1 insert end "0123456789"
+ pack .e1 .e2
+ .e2 select from 0
+ .e2 select to 10
+ lappend x [selection get]
+ .e1 select from 1
+ .e1 select to 5
+ lappend x [selection get]
+ .e1 configure -exportselection 1
+ lappend x [selection get]
+ set x
+} -cleanup {
+ destroy .e1 .e2
+} -result {{This is so} {This is so} 1234}
+test spinbox-5.6 {ConfigureSpinbox procedure} -setup {
+ spinbox .e
+ pack .e
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 5
+ .e configure -exportselection 0
+ selection get
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined}
+test spinbox-5.6.1 {ConfigureSpinbox procedure} -setup {
+ spinbox .e
+ pack .e
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 5
+ .e configure -exportselection 0
+ catch {selection get}
+ list [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {1 5}
+
+test spinbox-5.7 {ConfigureSpinbox procedure} -setup {
+ spinbox .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -width 4 -xscrollcommand scroll
+ .e insert end "01234567890"
+ update
+ .e configure -width 5
+ format {%.6f %.6f} {*}$scrollInfo
+} -cleanup {
+ destroy .e
+} -result {0.000000 0.363636}
+
+test spinbox-5.8 {ConfigureSpinbox procedure} -constraints {
+ fonts
+} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -width 0 -font {Helvetica -12}
+ .e insert end "0123"
+ update
+ .e configure -font {Helvetica -24}
+ update
+ winfo geom .e
+} -cleanup {
+ destroy .e
+} -result {79x37+0+0}
+test spinbox-5.9 {ConfigureSpinbox procedure} -constraints {
+ fonts
+} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised
+ .e insert end "0123"
+ update
+ list [.e index @10] [.e index @11] [.e index @12] [.e index @13]
+} -cleanup {
+ destroy .e
+} -result {0 0 1 1}
+test spinbox-5.10 {ConfigureSpinbox procedure} -constraints {
+ fonts
+} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief flat
+ .e insert end "0123"
+ update
+ list [.e index @10] [.e index @11] [.e index @12] [.e index @13]
+} -cleanup {
+ destroy .e
+} -result {0 0 1 1}
+test spinbox-5.11 {ConfigureSpinbox procedure} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+# If "0" in selected font had 0 width, caused divide-by-zero error.
+ .e configure -font {{open look glyph}}
+ .e scan dragto 30
+ update
+} -cleanup {
+ destroy .e
+} -result {}
+
+# No tests for DisplaySpinbox.
+
+test spinbox-6.1 {SpinboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ spinbox .e
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 20 -highlightthickness 3
+ .e insert end 012\t45
+ update
+ list [.e index @61] [.e index @62]
+} -cleanup {
+ destroy .e
+} -result {3 4}
+test spinbox-6.2 {SpinboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ spinbox .e
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 20 -justify center \
+ -highlightthickness 3
+ .e insert end 012\t45
+ update
+ list [.e index @96] [.e index @97]
+} -cleanup {
+ destroy .e
+} -result {3 4}
+test spinbox-6.3 {SpinboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ spinbox .e
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 20 -justify right \
+ -highlightthickness 3
+ .e insert end 012\t45
+ update
+ list [.e index @131] [.e index @132]
+} -cleanup {
+ destroy .e
+} -result {3 4}
+test spinbox-6.4 {SpinboxComputeGeometry procedure} -setup {
+ spinbox .e
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 5
+ .e insert end "01234567890"
+ update
+ .e xview 6
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {6}
+test spinbox-6.5 {SpinboxComputeGeometry procedure} -setup {
+ spinbox .e -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 5
+ .e insert end "01234567890"
+ update
+ .e xview 7
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {6}
+test spinbox-6.6 {SpinboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ spinbox .e -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 10
+ .e insert end "01234\t67890"
+ update
+ .e xview 3
+ list [.e index @39] [.e index @40]
+} -cleanup {
+ destroy .e
+} -result {5 6}
+test spinbox-6.7 {SpinboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ spinbox .e -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Helvetica -24} -bd 3 -relief raised -width 5
+ .e insert end "01234567"
+ update
+ list [winfo reqwidth .e] [winfo reqheight .e]
+} -cleanup {
+ destroy .e
+} -result {94 39}
+test spinbox-6.8 {SpinboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ spinbox .e -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0
+ .e insert end "01234567"
+ update
+ list [winfo reqwidth .e] [winfo reqheight .e]
+} -cleanup {
+ destroy .e
+} -result {133 39}
+test spinbox-6.9 {SpinboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ spinbox .e -highlightthickness 2
+ pack .e
+} -body {
+ .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0
+ update
+ list [winfo reqwidth .e] [winfo reqheight .e]
+} -cleanup {
+ destroy .e
+} -result {42 39}
+
+
+test spinbox-7.1 {InsertChars procedure} -setup {
+ unset -nocomplain contents
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
+ .e insert 0 abcde
+ .e insert 2 XXX
+ update
+ list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
+} -cleanup {
+ destroy .e
+} -result {abXXXcde abXXXcde {0.000000 1.000000}}
+
+test spinbox-7.2 {InsertChars procedure} -setup {
+ unset -nocomplain contents
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
+ .e insert 0 abcde
+ .e insert 500 XXX
+ update
+ list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
+} -cleanup {
+ destroy .e
+} -result {abcdeXXX abcdeXXX {0.000000 1.000000}}
+test spinbox-7.3 {InsertChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 0123456789
+ .e select from 2
+ .e select to 6
+ .e insert 2 XXX
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 8
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {5 9 5 8}
+test spinbox-7.4 {InsertChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 0123456789
+ .e select from 2
+ .e select to 6
+ .e insert 3 XXX
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 8
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {2 9 2 8}
+test spinbox-7.5 {InsertChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 0123456789
+ .e select from 2
+ .e select to 6
+ .e insert 5 XXX
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 8
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {2 9 2 8}
+test spinbox-7.6 {InsertChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 0123456789
+ .e select from 2
+ .e select to 6
+ .e insert 6 XXX
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 5
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {2 6 2 5}
+test spinbox-7.7 {InsertChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -xscrollcommand scroll
+ .e insert 0 0123456789
+ .e icursor 4
+ .e insert 4 XXX
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {7}
+test spinbox-7.8 {InsertChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 0123456789
+ .e icursor 4
+ .e insert 5 XXX
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-7.9 {InsertChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 "This is a very long string"
+ update
+ .e xview 4
+ .e insert 3 XXX
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {7}
+test spinbox-7.10 {InsertChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 "This is a very long string"
+ update
+ .e xview 4
+ .e insert 4 XXX
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {4}
+
+test spinbox-7.11 {InsertChars procedure} -constraints {
+ fonts
+} -setup {
+ spinbox .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 "xyzzy"
+ update
+ .e insert 2 00
+ winfo reqwidth .e
+} -cleanup {
+ destroy .e
+} -result {70}
+
+test spinbox-8.1 {DeleteChars procedure} -setup {
+ unset -nocomplain contents
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
+ .e insert 0 abcde
+ .e delete 2 4
+ update
+ list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
+} -cleanup {
+ destroy .e
+} -result {abe abe {0.000000 1.000000}}
+test spinbox-8.2 {DeleteChars procedure} -setup {
+ unset -nocomplain contents
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
+ .e insert 0 abcde
+ .e delete -2 2
+ update
+ list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
+} -cleanup {
+ destroy .e
+} -result {cde cde {0.000000 1.000000}}
+test spinbox-8.3 {DeleteChars procedure} -setup {
+ unset -nocomplain contents
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
+ .e insert 0 abcde
+ .e delete 3 1000
+ update
+ list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
+} -cleanup {
+ destroy .e
+} -result {abc abc {0.000000 1.000000}}
+test spinbox-8.4 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 3
+ .e select to 8
+ .e delete 1 3
+ update
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 5
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {1 6 1 5}
+test spinbox-8.5 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 3
+ .e select to 8
+ .e delete 1 4
+ update
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 4
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {1 5 1 4}
+test spinbox-8.6 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 3
+ .e select to 8
+ .e delete 1 7
+ update
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 5
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {1 2 1 5}
+test spinbox-8.7 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 3
+ .e select to 8
+ .e delete 1 8
+ update
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+test spinbox-8.8 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 3
+ .e select to 8
+ .e delete 3 7
+ update
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 8
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {3 4 3 8}
+test spinbox-8.9 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 3
+ .e select to 8
+ .e delete 3 8
+ update
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+test spinbox-8.10 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 8
+ .e select to 3
+ .e delete 5 8
+ update
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 8
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {3 5 5 8}
+test spinbox-8.11 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e select from 8
+ .e select to 3
+ .e delete 8 10
+ update
+ set x "[.e index sel.first] [.e index sel.last]"
+ .e select to 4
+ lappend x [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {3 8 4 8}
+test spinbox-8.12 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e icursor 4
+ .e delete 1 4
+ update
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-8.13 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e icursor 4
+ .e delete 1 5
+ update
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-8.14 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 0123456789abcde
+ .e icursor 4
+ .e delete 4 6
+ update
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-8.15 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 "This is a very long string"
+ .e xview 4
+ .e delete 1 4
+ update
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-8.16 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 "This is a very long string"
+ .e xview 4
+ .e delete 1 5
+ update
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-8.17 {DeleteChars procedure} -setup {
+ spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 "This is a very long string"
+ .e xview 4
+ .e delete 4 6
+ update
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-8.18 {DeleteChars procedure} -setup {
+ spinbox .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e insert 0 "xyzzy"
+ update
+ .e delete 2 4
+ winfo reqwidth .e
+} -cleanup {
+ destroy .e
+} -result {42}
+
+test spinbox-9.1 {SpinboxValueChanged procedure} -setup {
+ unset -nocomplain x
+} -body {
+ trace variable x w override
+ spinbox .e -textvariable x -width 0
+ .e insert 0 foo
+ list $x [.e get]
+} -cleanup {
+ destroy .e
+ trace vdelete x w override
+} -result {12345 12345}
+
+
+test spinbox-10.1 {SpinboxSetValue procedure} -constraints fonts -body {
+ set x abcde
+ set y ab
+ spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 -width 0
+ pack .e
+ .e configure -textvariable x
+ .e configure -textvariable y
+ update
+ list [.e get] [winfo reqwidth .e]
+} -cleanup {
+ destroy .e
+} -result {ab 35}
+test spinbox-10.2 {SpinboxSetValue procedure, updating selection} -setup {
+ unset -nocomplain x
+ spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -textvariable x
+ .e insert 0 "abcdefghjklmnopqrstu"
+ .e selection range 4 10
+ set x "a"
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+test spinbox-10.3 {SpinboxSetValue procedure, updating selection} -setup {
+ unset -nocomplain x
+ spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -textvariable x
+ .e insert 0 "abcdefghjklmnopqrstu"
+ .e selection range 4 10
+ set x "abcdefg"
+ list [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {4 7}
+test spinbox-10.4 {SpinboxSetValue procedure, updating selection} -setup {
+ unset -nocomplain x
+ spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -textvariable x
+ .e insert 0 "abcdefghjklmnopqrstu"
+ .e selection range 4 10
+ set x "abcdefghijklmn"
+ list [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {4 10}
+test spinbox-10.5 {SpinboxSetValue procedure, updating display position} -setup {
+ unset -nocomplain x
+ spinbox .e -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -width 10 -font {Courier -12} -textvariable x
+ .e insert 0 "abcdefghjklmnopqrstuvwxyz"
+ .e xview 10
+ update
+ set x "abcdefg"
+ update
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {0}
+test spinbox-10.6 {SpinboxSetValue procedure, updating display position} -setup {
+ unset -nocomplain x
+ spinbox .e -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -width 10 -font {Courier -12} -textvariable x
+ pack .e
+ .e insert 0 "abcdefghjklmnopqrstuvwxyz"
+ .e xview 10
+ update
+ set x "1234567890123456789012"
+ update
+ .e index @0
+} -cleanup {
+ destroy .e
+} -result {10}
+test spinbox-10.7 {SpinboxSetValue procedure, updating insertion cursor} -setup {
+ unset -nocomplain x
+ spinbox .e -highlightthickness 2 -bd 2
+ pack .e
+ update
+} -body {
+ .e configure -width 10 -font {Courier -12} -textvariable x
+ pack .e
+ .e insert 0 "abcdefghjklmnopqrstuvwxyz"
+ .e icursor 5
+ set x "123"
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {3}
+test spinbox-10.8 {SpinboxSetValue procedure, updating insertion cursor} -setup {
+ unset -nocomplain x
+ spinbox .e -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -width 10 -font {Courier -12} -textvariable x
+ pack .e
+ .e insert 0 "abcdefghjklmnopqrstuvwxyz"
+ .e icursor 5
+ set x "123456"
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {5}
+
+test spinbox-11.1 {SpinboxEventProc procedure} -setup {
+ spinbox .e -highlightthickness 2 -bd 2 -font {Helvetica -12}
+ pack .e
+} -body {
+ .e insert 0 abcdefg
+ destroy .e
+ update
+} -cleanup {
+ destroy .e
+} -result {}
+test spinbox-11.2 {SpinboxEventProc procedure} -setup {
+ set x {}
+} -body {
+ spinbox .e1 -fg #112233
+ rename .e1 .e2
+ lappend x [winfo children .]
+ lappend x [.e2 cget -fg]
+ destroy .e1
+ lappend x [info command .e*] [winfo children .]
+} -cleanup {
+ destroy .e1
+} -result {.e1 #112233 {} {}}
+
+test spinbox-12.1 {SpinboxCmdDeletedProc procedure} -body {
+ button .b -text "xyz_123"
+ rename .b {}
+ list [info command .b*] [winfo children .]
+} -cleanup {
+ destroy .b
+} -result {{} {}}
+
+
+test spinbox-13.1 {GetSpinboxIndex procedure} -setup {
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index end
+} -cleanup {
+ destroy .e
+} -result {21}
+test spinbox-13.2 {GetSpinboxIndex procedure} -body {
+ spinbox .e
+ .e index abogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "abogus"}
+test spinbox-13.3 {GetSpinboxIndex procedure} -setup {
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ .e index anchor
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-13.4 {GetSpinboxIndex procedure} -setup {
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 4
+ .e select to 1
+ .e index anchor
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-13.5 {GetSpinboxIndex procedure} -setup {
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 3
+ .e select to 15
+ .e select adjust 4
+ .e index anchor
+} -cleanup {
+ destroy .e
+} -result {15}
+test spinbox-13.6 {GetSpinboxIndex procedure} -setup {
+ spinbox .e
+} -body {
+ .e index ebogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "ebogus"}
+test spinbox-13.7 {GetSpinboxIndex procedure} -setup {
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e icursor 2
+ .e index insert
+} -cleanup {
+ destroy .e
+} -result {2}
+test spinbox-13.8 {GetSpinboxIndex procedure} -setup {
+ spinbox .e
+} -body {
+ .e index ibogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "ibogus"}
+test spinbox-13.9 {GetSpinboxIndex procedure} -setup {
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {1 6}
+
+test spinbox-13.10 {GetSpinboxIndex procedure} -constraints unix -body {
+# On unix, when selection is cleared, spinbox widget's internal
+# selection range is reset.
+# Previous settings:
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+
+test spinbox-13.11 {GetSpinboxIndex procedure} -constraints win -body {
+# On mac and pc, when selection is cleared, spinbox widget remembers
+# last selected range. When selection ownership is restored to
+# spinbox, the old range will be rehighlighted.
+# Previous settings:
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ catch {selection get}
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -result {1}
+
+test spinbox-13.12 {GetSpinboxIndex procedure} -constraints unix -body {
+# Previous settings:
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index sbogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+
+test spinbox-13.12.1 {GetSpinboxIndex procedure} -constraints unix -body {
+# Previous settings:
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index bogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "bogus"}
+
+test spinbox-13.13 {GetSpinboxIndex procedure} -constraints win -body {
+# Previous settings:
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index sbogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "sbogus"}
+
+test spinbox-13.14 {GetSpinboxIndex procedure} -constraints win -body {
+# On mac and pc, when selection is cleared, spinbox widget remembers
+# last selected range. When selection ownership is restored to
+# spinbox, the old range will be rehighlighted.
+# Previous settings:
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ selection get
+} -cleanup {
+ destroy .e
+} -returnCodes error -match glob -result {*}
+
+test spinbox-13.14.1 {GetSpinboxIndex procedure} -constraints win -body {
+# On mac and pc, when selection is cleared, spinbox widget remembers
+# last selected range. When selection ownership is restored to
+# spinbox, the old range will be rehighlighted.
+# Previous settings:
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ catch {selection get}
+ .e index sbogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -match glob -result {*}
+
+test spinbox-13.15 {GetSpinboxIndex procedure} -body {
+ spinbox .e
+ selection clear .e
+ .e index @xyz
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "@xyz"}
+
+test spinbox-13.16 {GetSpinboxIndex procedure} -constraints fonts -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @4
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-13.17 {GetSpinboxIndex procedure} -constraints fonts -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @11
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-13.18 {GetSpinboxIndex procedure} -constraints fonts -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @12
+} -cleanup {
+ destroy .e
+} -result {5}
+test spinbox-13.19 {GetSpinboxIndex procedure} -constraints fonts -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @[expr {[winfo width .e] - 6-11}]
+} -cleanup {
+ destroy .e
+} -result {8}
+test spinbox-13.20 {GetSpinboxIndex procedure} -constraints fonts -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @[expr {[winfo width .e] - 5}]
+} -cleanup {
+ destroy .e
+} -result {9}
+test spinbox-13.21 {GetSpinboxIndex procedure} -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @1000
+} -cleanup {
+ destroy .e
+} -result {9}
+test spinbox-13.22 {GetSpinboxIndex procedure} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e index 1xyz
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "1xyz"}
+test spinbox-13.23 {GetSpinboxIndex procedure} -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index -10
+} -cleanup {
+ destroy .e
+} -result {0}
+test spinbox-13.24 {GetSpinboxIndex procedure} -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index 12
+} -cleanup {
+ destroy .e
+} -result {12}
+test spinbox-13.25 {GetSpinboxIndex procedure} -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index 49
+} -cleanup {
+ destroy .e
+} -result {21}
+
+# XXX Still need to write tests for SpinboxScanTo and SpinboxSelectTo.
+
+test spinbox-14.1 {SpinboxFetchSelection procedure} -body {
+ spinbox .e
+ .e insert end "This is a test string"
+ .e select from 1
+ .e select to 18
+ selection get
+} -cleanup {
+ destroy .e
+} -result {his is a test str}
+test spinbox-14.3 {SpinboxFetchSelection procedure} -setup {
+ set x {}
+ for {set i 1} {$i <= 500} {incr i} {
+ append x "This is line $i, out of 500\n"
+}
+} -body {
+ spinbox .e
+ .e insert end $x
+ .e select from 0
+ .e select to end
+ string compare [selection get] $x
+} -cleanup {
+ destroy .e
+} -result {0}
+
+test spinbox-15.1 {SpinboxLostSelection} -body {
+ spinbox .e
+ .e insert 0 "Text"
+ .e select from 0
+ .e select to 4
+ set result [selection get]
+ selection clear
+ .e select from 0
+ .e select to 4
+ lappend result [selection get]
+} -cleanup {
+ destroy .e
+} -result {Text Text}
+
+
+test spinbox-16.1 {SpinboxVisibleRange procedure} -constraints fonts -body {
+ spinbox .e -width 10 -font {Helvetica -12}
+ pack .e
+ update
+ .e insert 0 "............................."
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.000000 0.827586}
+test spinbox-16.2 {SpinboxVisibleRange procedure} -body {
+ spinbox .e
+ format {%.6f %.6f} {*}[.e xview]
+} -cleanup {
+ destroy .e
+} -result {0.000000 1.000000}
+
+
+test spinbox-17.1 {SpinboxUpdateScrollbar procedure} -body {
+ spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12}
+ pack .e
+ .e delete 0 end
+ .e insert 0 123
+ update
+ format {%.6f %.6f} {*}$scrollInfo
+} -cleanup {
+ destroy .e
+} -result {0.000000 1.000000}
+test spinbox-17.2 {SpinboxUpdateScrollbar procedure} -body {
+ spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12}
+ pack .e
+ .e insert 0 0123456789abcdef
+ .e xview 3
+ update
+ format {%.6f %.6f} {*}$scrollInfo
+} -cleanup {
+ destroy .e
+} -result {0.187500 0.812500}
+test spinbox-17.3 {SpinboxUpdateScrollbar procedure} -body {
+ spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12}
+ pack .e
+ .e insert 0 abcdefghijklmnopqrs
+ .e xview 6
+ update
+ format {%.6f %.6f} {*}$scrollInfo
+} -cleanup {
+ destroy .e
+} -result {0.315789 0.842105}
+test spinbox-17.4 {SpinboxUpdateScrollbar procedure} -setup {
+ proc bgerror msg {
+ global x
+ set x $msg
+}
+} -body {
+ spinbox .e -width 5 -xscrollcommand thisisnotacommand
+ pack .e
+ update
+ list $x $errorInfo
+} -cleanup {
+ destroy .e
+ rename bgerror {}
+} -result {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand"
+ while executing
+"thisisnotacommand 0.0 1.0"
+ (horizontal scrolling command executed by .e)}}
+
+
+test spinbox-18.1 {Spinbox widget vs hiding} -setup {
+ spinbox .e
+} -body {
+ set l [interp hidden]
+ interp hide {} .e
+ destroy .e
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 == $res2}
+} -result {1}
+
+##
+## Spinbox widget VALIDATION tests
+##
+# The validation tests build each one upon the previous, so cascading
+# failures aren't good
+#
+# 19.* test cases in previous version highly depended on the previous
+# test cases. This was replaced by inserting recently set configurations
+# that matters for the test case
+test spinbox-19.1 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 a
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 1 0 a {} a all key}
+
+test spinbox-19.2 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 a ;# previous settings
+ .e insert 1 b
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 1 1 ab a b all key}
+
+test spinbox-19.3 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 ab ;# previous settings
+ .e insert end c
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 1 2 abc ab c all key}
+
+test spinbox-19.4 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 abc ;# previous settings
+ .e insert 1 123
+ list $::vVals $::e
+} -cleanup {
+ destroy .e
+} -result {{.e 1 1 a123bc abc 123 all key} a123bc}
+
+test spinbox-19.5 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 a123bc ;# previous settings
+ .e delete 2
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 0 2 a13bc a123bc 2 all key}
+
+test spinbox-19.6 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 a13bc ;# previous settings
+ .e configure -validate key
+ .e delete 1 3
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 0 1 abc a13bc 13 key key}
+
+test spinbox-19.7 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focus \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abc ;# previous settings
+ set ::vVals {}
+ .e insert end d
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {}
+
+test spinbox-19.8 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e configure -validate focus ;# previous settings
+ .e insert end abcd ;# previous settings
+ focus -force .e
+# update necessary to process FocusIn event
+ update
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focus focusin}
+
+test spinbox-19.9 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focus \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ focus -force .e ;# previous settings
+ update ;# previous settings
+# update necessary to process FocusIn event
+ focus -force .
+# update necessary to process FocusOut event
+ update
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focus focusout}
+
+test spinbox-19.10 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ focus -force .e
+# update necessary to process FocusIn event
+ update
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} all focusin}
+
+test spinbox-19.11 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ focus -force .e ;# previous settings
+# update necessary to process FocusIn event
+ update ;# previous settings
+ focus -force .
+# update necessary to process FocusOut event
+ update
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} all focusout}
+
+test spinbox-19.12 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focusin \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 abcd ;# previous settings
+ focus -force .e
+# update necessary to process FocusIn event
+ update
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focusin focusin}
+
+test spinbox-19.13 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focusin \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {}
+ focus -force .
+# update necessary to process FocusOut event
+ update
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {}
+
+test spinbox-19.14 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {} ;# previous settings
+ focus -force .e
+# update necessary to process FocusIn event
+ update
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {}
+
+test spinbox-19.15 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {} ;# previous settings
+ focus -force .e ;# previous settings
+# update necessary to process FocusIn event
+ update ;# previous settings
+ focus -force .
+# update necessary to process FocusOut event
+ update
+ set ::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focusout focusout}
+
+# the same as 19.16 but added [.e validate] to returned list
+test spinbox-19.16 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {} ;# previous settings
+ focus -force .e ;# previous settings
+# update necessary to process FocusIn event
+ update ;# previous settings
+ focus -force .
+# update necessary to process FocusOut event
+ update
+ list [.e validate] $::vVals
+} -cleanup {
+ destroy .e
+} -result {1 {.e -1 -1 abcd abcd {} all forced}}
+
+
+test spinbox-19.17 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::e newdata
+ list [.e cget -validate] $::vVals
+} -cleanup {
+ destroy .e
+} -result {focusout {.e -1 -1 newdata abcd {} focusout forced}}
+
+
+# proc doval changed - returns 0
+test spinbox-19.18 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ set ::e newdata ;# previous settings
+ .e configure -validate all
+ set ::e nextdata
+ list [.e cget -validate] $::vVals
+} -cleanup {
+ destroy .e
+} -result {none {.e -1 -1 nextdata newdata {} all forced}}
+
+
+## This sets validate to none because it shows that we prevent a possible
+## loop condition in the validation, when the spinbox textvar is also set
+# proc doval2 used
+test spinbox-19.19 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ set ::e nextdata ;# previous settings
+
+ .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V]
+ .e validate
+ list [.e cget -validate] [.e get] $::vVals
+} -cleanup {
+ destroy .e
+} -result {none mydata {.e -1 -1 nextdata nextdata {} all forced}}
+
+## 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 spinbox widget shown as is in the textvar.
+test spinbox-19.20 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ set ::e nextdata ;# previous settings
+ .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] ;# prev
+ .e validate ;# previous settings
+
+ .e configure -validate all
+ set ::e testdata
+ list [.e cget -validate] [.e get] $::e $::vVals
+} -cleanup {
+ destroy .e
+} -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}}
+##
+## End validation tests
+##
+
+test spinbox-20.1 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %2f
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.2 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %2.2f
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.3 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %.2f
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.4 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %2.f
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.5 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %2e-1f
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad spinbox format specifier "%2e-1f"}
+test spinbox-20.6 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format 2.2
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad spinbox format specifier "2.2"}
+test spinbox-20.7 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %2.-2f
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad spinbox format specifier "%2.-2f"}
+test spinbox-20.8 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %-2.02f
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.9 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format "% 2.02f"
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.10 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format "% -2.200f"
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.11 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format "%09.200f"
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.12 {spinbox config, -format specifier does something} -setup {
+ spinbox .e
+ set out {}
+} -body {
+ .e config -format "%02.f"
+ .e config -values {} -from 0 -to 10 -increment 1
+ lappend out [.e set 0]; # set currently doesn't force format
+ .e invoke buttonup
+ lappend out [.e set]; # but after invoke it should be formatted
+ lappend out [.e set 3]; # set currently doesn't force format
+ .e config -format "%03.f"
+ lappend out [.e set]; # changing -format should cause formatting
+} -cleanup {
+ destroy .e
+} -result {0 01 3 003}
+
+
+test spinbox-21.1 {spinbox button, out of range checking} -body {
+ spinbox .e -from -10 -to 20 -increment 2
+ set out {}
+ lappend out [.e get]; # -10
+ .e delete 0 end
+ .e insert 0 25; # set outside of range
+ .e invoke buttondown; # should constrain
+ lappend out [.e get]; # 20
+ .e delete 0 end
+ .e insert 0 25; # set outside of range
+ .e invoke buttonup; # should constrain
+ lappend out [.e get]; # 20
+ .e delete 0 end
+ .e insert 0 -100; # set outside of range
+ .e invoke buttonup; # should constrain
+ lappend out [.e get]; # -10
+ .e delete 0 end
+ .e insert 0 -100; # set outside of range
+ .e invoke buttondown; # should constrain
+ lappend out [.e get]; # -10
+ .e delete 0 end
+ .e insert 0 bogus; # set to a bogus value
+ .e invoke buttondown; # should use fromValue
+ lappend out [.e get]; # -10
+ .e delete 0 end
+ .e insert 0 19; # set just inside of range
+ .e invoke buttonup; # no wrap
+ lappend out [.e get]; # 20
+ .e invoke buttonup; # no wrap
+ lappend out [.e get]; # 20
+ .e invoke buttondown
+ lappend out [.e get]; # 18
+ .e delete 0 end
+ .e insert 0 -9; # set just inside of range
+ .e invoke buttondown; # no wrap
+ lappend out [.e get]; # -10
+ .e invoke buttondown; # no wrap
+ lappend out [.e get]; # -10
+ .e invoke buttonup; # no wrap
+ lappend out [.e get]; # -8
+
+ .e configure -wrap 1
+ .e delete 0 end
+ .e insert 0 19; # set just inside of range
+ .e invoke buttonup; # wrap
+ lappend out [.e get]; # -10
+ .e invoke buttonup
+ lappend out [.e get]; # -8
+ .e invoke buttondown
+ lappend out [.e get]; # -10
+ .e delete 0 end
+ .e insert 0 -9; # set just inside of range
+ .e invoke buttondown; # wrap
+ lappend out [.e get]; # 20
+ .e invoke buttondown
+ lappend out [.e get]; # 18
+ .e invoke buttonup; # no wrap
+ lappend out [.e get]; # 20
+} -cleanup {
+ destroy .e
+} -result {-10 20 20 -10 -10 -10 20 20 18 -10 -10 -8 -10 -8 -10 20 18 20}
+
+test spinbox-22.1 {spinbox config, -from changes SF bug 559078} -body {
+ set val 5
+ spinbox .e -from 1 -to 10 -textvariable val
+ set val
+} -cleanup {
+ destroy .e
+} -result {5}
+test spinbox-22.2 {spinbox config, -from changes SF bug 559078} -body {
+ set val 5
+ spinbox .e -from 1 -to 10 -textvariable val
+ .e configure -from 3 -to 10
+ set val
+} -cleanup {
+ destroy .e
+} -result {5}
+test spinbox-22.3 {spinbox config, -from changes SF bug 559078} -body {
+ set val 5
+ spinbox .e -from 3 -to 10 -textvariable val
+ .e configure -from 6 -to 10
+ set val
+} -cleanup {
+ destroy .e
+} -result {6}
+
+test spinbox-23.1 {selection present while disabled, bug 637828} -body {
+ spinbox .e
+ .e insert end 0123456789
+ .e select from 3
+ .e select to 6
+ set out [.e selection present]
+ .e configure -state disabled
+# still return 1 when disabled, because 'selection get' will work,
+# but selection cannot be changed (new behavior since 8.4)
+ .e select to 9
+ lappend out [.e selection present] [selection get]
+} -cleanup {
+ destroy .e
+} -result {1 1 345}
+
+test spinbox-24.1 {error in trace proc attached to the textvariable} -setup {
+ destroy .s
+} -body {
+ trace variable myvar w traceit
+ proc traceit args {error "Intentional error here!"}
+ spinbox .s -textvariable myvar -from 1 -to 10
+ catch {.s set mystring} result1
+ catch {.s insert 0 mystring} result2
+ catch {.s delete 0} result3
+ catch {.s invoke buttonup} result4
+ list $result1 $result2 $result3 $result4
+} -cleanup {
+ destroy .s
+} -result [list {can't set "myvar": Intentional error here!} \
+ {can't set "myvar": Intentional error here!} \
+ {can't set "myvar": Intentional error here!} \
+ {can't set "myvar": Intentional error here!}]
+
+test spinbox-25.1 {textvariable lives in a non-existing namespace} -setup {
+ destroy .s
+} -body {
+ catch {spinbox .s -textvariable thisnsdoesntexist::myvar} result1
+ set result1
+} -cleanup {
+ destroy .s
+} -result {can't trace "thisnsdoesntexist::myvar": parent namespace doesn't exist}
+
+# Collected comments about lacks from the test
+# XXX Still need to write tests for SpinboxBlinkProc, SpinboxFocusProc,
+# and SpinboxTextVarProc.
+# No tests for DisplaySpinbox.
+# XXX Still need to write tests for SpinboxScanTo and SpinboxSelectTo.
+# No tests for EventuallyRedraw
+
+# option clear
+# cleanup
+cleanupTests
+return
+
+
diff --git a/tk8.6/tests/teapot.ppm b/tk8.6/tests/teapot.ppm
new file mode 100644
index 0000000..b8ab85f
--- /dev/null
+++ b/tk8.6/tests/teapot.ppm
@@ -0,0 +1,31 @@
+P6
+256 256
+255
+\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À[7 eOLjQLmSMoTMnSMlRMhPL_9 \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀnSMtVMzYN~[N~[N\N\O€\O€]O€]O€]O€]O€\O€\O}[NyYNtVM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀG-wXN}[N€]O„^O†_O†`O‡`Oˆ`Oˆ`OˆaO‰aO‰aO‰aO‰aO‰aO‰aOˆaOˆ`O†_Oƒ^O\N \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀaMLyYN…_O‰aP‹bPcPŽcPŽdPŽdPdPdPdPdPdPdPdPeP‘eP’eP’eP‘ePdPcP…_OpUM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀwXN…_OdP“fP•gQ–hQ˜hQ˜iQ™iQ™iQšiQšiQšjQ›jQ›jQœjQœjQœjQœjQœjQ›jQœjQ™iQ“fP‡`O\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJiQL‹bP—hQkQ¡mR¤nR¥oR¥oR¥oR¥oR¥oR¥oR¦oR¦oR¦pR¨pS©qSªqS«rS¬rS«rS©qS¤oRœjQ€]O\KK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀfOLrUMcPŸlR©qS¯tS²uTµwT·xT¸xT¹yTºyT»zT»zU¼zU¼zU¼zU»zUºyT¸xT¶wT¯tS¡mR‰aOhPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\Àa0 cNLqUM€\O”fQ¦pS²wVºzV¿|VÂ}VÄVÆVÇ€VÉ‚WÌ…[Õeæ w÷³‹êª…Ĉg§qT“fQ{ZNYIK9\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀO1{G#‘JkRMqUMtVN–iS¨v\·€d¹bµzZ±vU°uT®sSªqS¤nRœjQ’eP„^OrUMHh>!T4\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀG-V5wE"~I#†M%U+¥e7²l:°g2®b*­a(­`(©^(¥])¡^-›]1ŠS,qC$`9 R3G-\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À@)J/i>!pA"tD"wF$yH&xH&tE$wE#yG%}M+ƒT4S5mE*Z7!K/B*;'\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À‰aO¦oR½{UÇ€VÏ…X<(F-a: e<!h>!j@#k@$h>"d<!c=$hD-fF2[<)K0@);'5$Ë‚VÇ€V¿|U_LKYIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À…_O·xTÉ‚Wó«€ûµ‹Ö’k¼|X×>µf-¨^(¡Z'šW&–T&œN>)F-J/b; g>#nD(jB&c<!b=%jH2_A/I0!<(8&5$”J¥Y’S%8&;'?)E,<:HA=HE?IJAISFJYIKXIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À£nRÁ}UܘqÊŠe±vU²e,™V&¥V†C €@ |> y< u: r9 o7 l6
+j5
+h4
+g3
+5$D,K/b; h>"wM1tK.e="a<#cA,U8&E-<(9&.!a0 b1 c1    
+
++3#@)46G<:HMCIXHK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀU*´vT¿~X¸{YÃk+›W&‰N$|> u: p8 k5
+f3
+a0 _/ ]. [- I¡\*ª_(‘LkRMmSMmSMnSMnSMD,R3W5mA"|O0|P1j?"c<!a=%Y7"N1F,;'NCJNCJNDJODJODJODJh>!a: X/K%
+g3
+a0 Z- \/ T*Q(ŠHµm8kRMmSMnTMoTMpTMpUM15G15G05G04G04GpUMpTM5^9 d<!yF#O+€N,rC#qB"pB#k?"a: Z7 6ODJPDJPEJQEJQEJREJREJREJRFJSFJSFJSFJSFJe<!X/
+^/ V+Q(L&I$r9  TlRMnSM46G47G47G46G46G46G46G46G36G36G25G25G15G04G/4F.3F
+
+X&pUMuWMwXNxXN<:H<:H<:H<:H<;H<;H<;H<;H=;H=;H=;H=;H>;H>;H?<H@<HA=HC>HG@ILBIREJ[JKcNLjQL§pR±uTºzUÃ~VÈWË‚XÖŽcäsÒŽe¼{V²vT¨pSžkR•gQŒbP†_O‚^O]O€\O€\O€\O€\O€]O]O]O]O]O]O]O]O]O]O]O€\O€\O~\N}[N|ZNxXN•T%H$
+›W&rVMvWNyYNzYN|ZN}[N}[N><H?<H?<H?<H?<H?<H@<H@<H@<HA=HA=HB=HC>HE?IG@IIAIKBIODJSFJWHK—hQŸlR§pR°b(¾i*Én+Ù|7Û|6Ïr,Íq+Êp-Ãl+»g)±b(®sS§pS lRšiQ•gQePcPŠaPˆaO‡`O‡`O†_O†_O…_O…_O…_O…_O…_O…_O…_O„_O„^O„^Oƒ^Oƒ^O‚]O]O€\O~[N{ZN•T%
+
+ 
+@%<-$G?@…pfdNLuWM\NdNL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀTFJvWN‰aP./01„E}[N]O…_Oˆ`O‰aP‹bPŒbPcPcPŽcPdPdPdPeP‘eP’eP’eP“fP“fQ”fQ•gQ•gQ–gQ–hQ—hQ˜hQ™iQšiQ›jQœjQkQkRžlRŸlRžY&¤\'¨^'µ^½bÀcÃeÇi ÄgÀc½b¼a¹`µ^´]¯X¢[' Z'žY&¢mR¡mR¡mR lRŸlRŸlRžkRkQœkQœjQ›jQšjQšiQ™iQ™iQ˜iQ˜hQ—hQ—hQ—hQ–gQ–gQ•gQ•gQ•gQ”fQ”fQ“fQ“fP’eP‘ePdPcP‰aP—O
+ B\À\À\À\À\À\À\À\À\À\À%7!!C*F#P) {dYœze»p€\OgPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ`LKvWNŠaPm6
+ 
+$5 ¬`(¶e)£nRœjQƒ^OJAI\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀXIK^KKdNLhPLuWM‚]OŒbP”fQeP m6
+†`OŽcP“fQ—hQ˜hQ™iQšiQšjQ›jQ›jQ›jQœjQœjQœjQœkQkQkQkRžkRžkRžkRžlRŸlRŸlRŸlR lR lR lR¡mR¡mR¡mR¡mRºg)³c(²c(±b(­V¿cÂeÅi!Åi!Àd¼bº`¹`·_·_¶^¢Q§]'ª_(­`(¹f)£nR£nR£nR£nR£nR£nR£nR¢nR¢nR¢nR¢nR¢nR¢nR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢nR¢mR¢mR£nR¢mR¢mR¡mR mRkR—hQˆGa0 ŠbP mRœjQ“fQ‰aP}[NrUMmSM…L$\À\À\À\À\À\À\À\À B B #C, 8&H.Z7 §pR›jQ{ZN\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀQEJ[JK`LKdNLhQLqUM{ZN…_OŽcP–gQ—hQ
+‹bP‘eP–hQšiQ›jQœjQkQkQkRžkRžkRžlRžlRŸlRŸlRŸlRŸlRŸlR lR lR lR mR¡mR¡mR¡mR¡mR¡mR¢mR¢mR¢mR¢nR£nRÀj*ºg)·e)¶d)Âd°XÅgÅhÂe¿c½b½b¾bªU­`(®a(¯a(³c(¾i*¤oR¤oR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤oR¤oR¥oR¥oR¥oR¥oR¥oR¥oR¦oR¦oR¥oR¥oR¤nR¡mR›jQŽQ%Z- œjQ£nRŸlR—hQŽdP…_OuWMpTMnSMkRLa: \À\À\À\À\À\À\À B B&D2 @*S6#G@IPDJ˜hQmSM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀVGJ]KKbMLeOLiQLlRMvWN\OˆaO‘eP—hQœjQ•gQ
+!C+E'0F.4F7%8%U/lG.SFJZIK]KKZIKB=H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀREJZJK`LKdNLgPLjQLlRMnSMpTMqUMtWMxXN{ZN~[N]O„^O†`O‰aO‹bPdP•gQ™iQœkQ lR¤nR§pSªrS­sS¯tT²uT´vT¶wT·xT¹yT¹yTºyTºyT¹yT¶xT´vT¬rS¢nR—hQ¿|U¿|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ}UÀ}UÁ}UÁ}UÁ}UÁ}UÂ}UÂ~UÃ~UÃ~VÃ~VÄVÅ€WÆX®a(ŸlRªrS´vT¸yT¼zU¾|UÁ~VÃXÆ‚[Ɇ_΋dÓ‘jÔ“mÔ“nБlÊŒhĆd½_¶{[°vWªsU¦pS¢nRžkRšiQ˜hQ•gQ“fQ‘ePdPŒbP‰aO†_Oƒ^O€\O|ZNxXNsVMpTMnTMmSMjQL€C B)D&/F-3F47G6%>" Y7 kA$YIK]KK^KKSFJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀVGJ\KKbMLeOLhPLkRLmSMnTMpTMrUMuWNyYN|ZN\N‚]O„_O‡`OŠaPŒbPŽcPeP“fP—hQ›jQžlR¢nR¥oS©qT¬sT¯uU²vU´wV¶xV¸yV¹yUºzU»zU¼{U½{U¾{U¾|U¿|U¿|U¿|U¿|U¾{U½{U¼{U¼zU»zTºyT¹yT¸xTµwT³vT´vT´vT´vT´wT´wTµwT·xT¹yTºzT¼zU½{U¾{U¿|UÀ|UÂ}UÄVÅ€WÇ‚YÉ„\͈_ÑŒdÙ”láuç£|쩂ſt명æ¦ÞŸ{Õ—sËŽl†d¹^³yZ­uW¨qU¤oSŸlRžkRœjQšiQ˜hQ–gQ”fQ‘ePdPcPŠaP‡`O„^O]O}[NyYNuWMpTMoTMmSMkRLgPL&D#.E,3F46G;'<(D"iB(VGJ]KK`LK[JKB>H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJYIK^LKcNLfOLiQLkRMmSMoTMqUMsVMvXNzYN}[N€\O‚^O…_Oˆ`OŠaPŒcPdP‘eP“fQ•gQ—hQ™iQkR mS¤oT¨rU¬tW°wY´zZ¸}\»]¾€^À^Á‚^‚^Â\Á€ZÁYÁXÁ~WÁ~WÂ~VÂ~VÂ~VÃ~VÃ~UÃ~UÄ~UÄ~UÄUÄUÅVÅVÅVÅVÆVÆ€VÆ€VÇ€WÇWÈ‚XɃZË…[͇^ЊaÓdØ’iÜ—nâtè£zî©ó¯‡ø´û¸‘üº“û¹“÷¶ñ±Œé©…à¡~Ö˜vËmÇf»€`´z[®vX©rU¥pT£oS¢nS lRžkRœkRšjQ˜iQ–hQ”fQ’ePdPcP‹bPˆ`O…_O‚]O~[NzYNvWNpTMoTMnSMkRMhQLo7 ,2F36G99HC+@ ]8 nA"\JK`ML_LKSFJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ[JK`LKdNLgPLjQLlRMnSMpTMqUMtVMwXNzZN}[N€]Oƒ^O†_OˆaO‹bPcPdP‘eP“fQ•gQ—hQ™iQ›jRžlR mS£oU§rW¬vZ²{]¹€a¿…fÅŠjËnГqÓ•sÕ–sÕ–rÕ–qÕ”oÓ’mÑjÏgÍŠcˈaɆ^È„\Ç‚[ÆYÅ€XÅ€WÅWÅWÅVÅVÅWÅ€WÆ€WÇXÈ‚YɃ[Ê…\͇_ÏŠaÒeÕ‘hÙ•mÝ™qávä¡zç¤}꧀멃몄騃奀ߠ|Ù›wÓ•rÌmƉh¿„c¸~^²yZ®vX¬tWªsV¨qU¦pT¤oS¢nS mRžlRœkR›jQ™iQ—hQ•gQ“fPePŽcP‹bPˆaO…_O‚^O\N{ZNwXNsVMoTMnSMlRMiQL~I#26G99G?<HA*E$ i@$ZIKaMLbML[JK;:H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀWHJ]KKbMLeOLhPLjRLlSMnTMpTMrUMuWMxXN{ZN~\N]O„^O†`O‰aO‹bPŽcPdP’eP”fQ–gQ˜hQšiQœkRžlS mT£oU¦rWªuZ¯y]´~aºƒfŠlË’sÔšzÜ¡€ã§†è«‰ë®‹í¯Œí®‹ë¬ˆè¨„ã£~ßžyÚ™tÖ•oÒjÎŒfˈbÈ…_ƃ\ÅZÄ€YÃXÂWÂ~WÂ~WÂ~WÃXÀXÄ€YÅZƃ\Ç…^Ɇ`ˈbÌŠdÍ‹fÎgÎŽiÎŽjÎŽjÍŽjËŒiljgÆd¿ƒaº^¸}]¶|\´{[²yZ°xY®vX¬tWªsV¨qU¦pT¤oS¢nS mRžlRkR›jQ™iQ—hQ•gQ“fP‘ePŽdPŒbP‰aO†_Oƒ^O€\O|ZNxXNtVMpTMnSMmSMjQLgPL99G?<HG-E&b;!YIK`MLdOM`LKNCJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀŸlRºyTÄ~UÊ‚XʃYÄXº{W­tUšW'¢[(—hQ lRcP€\OhQL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJYIK^LKcNLfOLiQLkRLmSMoTMqUMrVMvWNyYN|ZN\N‚]O„_O‡`O‰aPŒbPŽcPdP’fP”gQ–hQ˜iQšjRœkRžlS¡nT¤pU§sW«vZ°z]µb»„gŠlÉ‘sИyØžÞ¤…ã©Šè­ì±ï³‘ﳑ뭊穅⣀ݞzؘtÒ“nÎiɉdÆ…`Â]Á€[¿~Y¾}X½|W½|V¼{V¼{V¼{V¼{V¼{V¼|W¼|W½}X½}Y½~Z½~Z¼~Z»}[º}[º}[º~\º~\º~]º~]¹~]¸~]·}]¶|\´z[²yZ°wY®vX¬tWªsV¨rU¦pT¤oS¢nS mRŸlRkR›jQšiQ˜hQ–gQ“fQ‘ePdPŒcPŠaP‡`O„^O]O}[NyYNuWNpTMnTMmSMkRLhPL|H$D>IQ2P+XHK_LLfQOcNLXIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À©qSºyTÃ~VΈ`遲ޜv¾€]ªqS–LŽG|> g3
+S)?*%.—hQ—hQ‘eP‡`OuWM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ[JK`LKdNLgPLjQLlRMnSMoTMqUMsVMwXNzYN}[N€\O‚^O…_O‡`OŠaPŒbPŽdP‘eP“fP•gQ—hQ˜iQšjRœkRŸlS¡nT¤pV§sX«vZ°z^¶b¼…gËmÊ’sјzØŸ€Þ¤…ã©Šè­ê¯ë°ê¯Žè¬‹å¨‡à¤‚Ûž|Ö™wÑ“qÌŽlljgÃ…bÀ‚_½\»}Zº{X¹zW¸yV·yU·xU·xU·xT·xT·xU·xU·xU·yV·yV·yW¸zW¸{X¹{Y¹|Zº}[º}[º}\º~\¹~]¹~]¸}]·|\µ{\´z[²yZ°wY®vX¬tWªsV¨rU¦pT¤oS¢nS¡mRŸlRkRœjQšiQ˜hQ–gQ”fQ’ePdPcPŠbP‡`O…_O‚]O~[NzZNvWNrUMoTMmSMlRMiQLeOLJAIJ(h>!]KKfQOgQN_LKD>I\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À™iQ°tS¸yT¼{UÂYÎŒeï­ˆô´Õ—u¶|\ Z'™LˆD |>
+
+ &3#.$-% .% .& /&!,#,#@70A71XNHXNHWNHWNHZRLYQLYQLXQLWQLWPLUOLSNLQMKOLJMJJ0//.-.,,-&(+"(!'
+ %' %$#" ! !$ 
diff --git a/tk8.6/tests/text.test b/tk8.6/tests/text.test
new file mode 100644
index 0000000..720afbe
--- /dev/null
+++ b/tk8.6/tests/text.test
@@ -0,0 +1,7302 @@
+# This file is a Tcl script to test the code in the file tkText.c.
+# This file is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+# The statements below reset the main window; it's needed if the window
+# manager is mwm to make mwm forget about a previous minimum size setting.
+wm geometry . {}
+wm withdraw .
+wm minsize . 1 1
+wm positionfrom . user
+wm deiconify .
+
+test text-1.1 {configuration option: "autoseparators"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -autoseparators yes
+ .t cget -autoseparators
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-1.2 {configuration option: "autoseparators"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -autoseparators nah
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.3 {configuration option: "background"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -background #ff00ff
+ .t cget -background
+} -cleanup {
+ destroy .t
+} -result {#ff00ff}
+test text-1.4 {configuration option: "background"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -background <gorp>
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.5 {configuration option: "bd"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -bd 4
+ .t cget -bd
+} -cleanup {
+ destroy .t
+} -result {4}
+test text-1.6 {configuration option: "bd"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -bd foo
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.7 {configuration option: "bg"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -bg blue
+ .t cget -bg
+} -cleanup {
+ destroy .t
+} -result {blue}
+test text-1.8 {configuration option: "bg"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -bg #xx
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.9 {configuration option: "blockcursor"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -blockcursor 0
+ .t cget -blockcursor
+} -cleanup {
+ destroy .t
+} -result {0}
+test text-1.10 {configuration option: "blockcursor"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -blockcursor xx
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.11 {configuration option: "borderwidth"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -borderwidth 7
+ .t cget -borderwidth
+} -cleanup {
+ destroy .t
+} -result {7}
+test text-1.12 {configuration option: "borderwidth"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -borderwidth ++
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.13 {configuration option: "cursor"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -cursor watch
+ .t cget -cursor
+} -cleanup {
+ destroy .t
+} -result {watch}
+test text-1.14 {configuration option: "cursor"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -cursor lousy
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.15 {configuration option: "exportselection"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -exportselection no
+ .t cget -exportselection
+} -cleanup {
+ destroy .t
+} -result {0}
+test text-1.16 {configuration option: "exportselection"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -exportselection maybe
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.17 {configuration option: "fg"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -fg red
+ .t cget -fg
+} -cleanup {
+ destroy .t
+} -result {red}
+test text-1.18 {configuration option: "fg"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -fg stupid
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.19 {configuration option: "font"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -font fixed
+ .t cget -font
+} -cleanup {
+ destroy .t
+} -result {fixed}
+test text-1.20 {configuration option: "font"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -font {}
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.21 {configuration option: "foreground"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -foreground #012
+ .t cget -foreground
+} -cleanup {
+ destroy .t
+} -result {#012}
+test text-1.22 {configuration option: "foreground"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -foreground bogus
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.23 {configuration option: "height"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -height 5
+ .t cget -height
+} -cleanup {
+ destroy .t
+} -result {5}
+test text-1.24 {configuration option: "height"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -height bad
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.25 {configuration option: "highlightbackground"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -highlightbackground #123
+ .t cget -highlightbackground
+} -cleanup {
+ destroy .t
+} -result {#123}
+test text-1.26 {configuration option: "highlightbackground"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -highlightbackground bogus
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.27 {configuration option: "highlightcolor"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -highlightcolor #234
+ .t cget -highlightcolor
+} -cleanup {
+ destroy .t
+} -result {#234}
+test text-1.28 {configuration option: "highlightcolor"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -highlightcolor bogus
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.29 {configuration option: "highlightthickness"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -highlightthickness -2
+ .t cget -highlightthickness
+} -cleanup {
+ destroy .t
+} -result {0}
+test text-1.30 {configuration option: "highlightthickness"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -highlightthickness bad
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.31 {configuration option: "inactiveselectbackground"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -inactiveselectbackground #ffff01234567
+ .t cget -inactiveselectbackground
+} -cleanup {
+ destroy .t
+} -result {#ffff01234567}
+test text-1.32 {configuration option: "inactiveselectbackground"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -inactiveselectbackground bogus
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.33 {configuration option: "insertbackground"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -insertbackground green
+ .t cget -insertbackground
+} -cleanup {
+ destroy .t
+} -result {green}
+test text-1.34 {configuration option: "insertbackground"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -insertbackground <bogus>
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.35 {configuration option: "insertborderwidth"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -insertborderwidth 45
+ .t cget -insertborderwidth
+} -cleanup {
+ destroy .t
+} -result {45}
+test text-1.36 {configuration option: "insertborderwidth"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -insertborderwidth bogus
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.37 {configuration option: "insertofftime"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -insertofftime 100
+ .t cget -insertofftime
+} -cleanup {
+ destroy .t
+} -result {100}
+test text-1.38 {configuration option: "insertofftime"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -insertofftime 2.4
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.39 {configuration option: "insertontime"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -insertontime 47
+ .t cget -insertontime
+} -cleanup {
+ destroy .t
+} -result {47}
+test text-1.40 {configuration option: "insertontime"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -insertontime e1
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.41 {configuration option: "insertwidth"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -insertwidth 2.3
+ .t cget -insertwidth
+} -cleanup {
+ destroy .t
+} -result {2}
+test text-1.42 {configuration option: "insertwidth"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -insertwidth 47d
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.43 {configuration option: "maxundo"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -maxundo 5
+ .t cget -maxundo
+} -cleanup {
+ destroy .t
+} -result {5}
+test text-1.44 {configuration option: "maxundo"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -maxundo noway
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.45 {configuration option: "padx"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -padx 3.4
+ .t cget -padx
+} -cleanup {
+ destroy .t
+} -result {3}
+test text-1.46 {configuration option: "padx"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -padx 2.4.
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.47 {configuration option: "pady"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -pady 82
+ .t cget -pady
+} -cleanup {
+ destroy .t
+} -result {82}
+test text-1.48 {configuration option: "pady"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -pady bogus
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.49 {configuration option: "relief"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -relief raised
+ .t cget -relief
+} -cleanup {
+ destroy .t
+} -result {raised}
+test text-1.50 {configuration option: "relief"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -relief bumpy
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.51 {configuration option: "selectbackground"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -selectbackground #ffff01234567
+ .t cget -selectbackground
+} -cleanup {
+ destroy .t
+} -result {#ffff01234567}
+test text-1.52 {configuration option: "selectbackground"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -selectbackground bogus
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.53 {configuration option: "selectborderwidth"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -selectborderwidth 21
+ .t cget -selectborderwidth
+} -cleanup {
+ destroy .t
+} -result {21}
+test text-1.54 {configuration option: "selectborderwidth"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -selectborderwidth 3x
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.55 {configuration option: "selectforeground"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -selectforeground yellow
+ .t cget -selectforeground
+} -cleanup {
+ destroy .t
+} -result {yellow}
+test text-1.56 {configuration option: "selectforeground"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -selectforeground #12345
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.57 {configuration option: "spacing1"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -spacing1 20
+ .t cget -spacing1
+} -cleanup {
+ destroy .t
+} -result {20}
+test text-1.58 {configuration option: "spacing1"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -spacing1 1.3x
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.59 {configuration option: "spacing1"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -spacing1 -5
+ .t cget -spacing1
+} -cleanup {
+ destroy .t
+} -result {0}
+test text-1.60 {configuration option: "spacing1"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -spacing1 bogus
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.61 {configuration option: "spacing2"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -spacing2 5
+ .t cget -spacing2
+} -cleanup {
+ destroy .t
+} -result {5}
+test text-1.62 {configuration option: "spacing2"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -spacing2 bogus
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.63 {configuration option: "spacing2"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -spacing2 -1
+ .t cget -spacing2
+} -cleanup {
+ destroy .t
+} -result {0}
+test text-1.64 {configuration option: "spacing2"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -spacing2 bogus
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.65 {configuration option: "spacing3"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -spacing3 20
+ .t cget -spacing3
+} -cleanup {
+ destroy .t
+} -result {20}
+test text-1.66 {configuration option: "spacing3"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -spacing3 bogus
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.67 {configuration option: "spacing3"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -spacing3 -10
+ .t cget -spacing3
+} -cleanup {
+ destroy .t
+} -result {0}
+test text-1.68 {configuration option: "spacing3"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -spacing3 bogus
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.69 {configuration option: "state"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -state d
+ .t cget -state
+} -cleanup {
+ destroy .t
+} -result {disabled}
+test text-1.70 {configuration option: "state"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -state foo
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.71 {configuration option: "tabs"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -tabs {1i 2i 3i 4i}
+ .t cget -tabs
+} -cleanup {
+ destroy .t
+} -result {1i 2i 3i 4i}
+test text-1.72 {configuration option: "tabs"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -tabs bad_tabs
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.73 {configuration option: "tabstyle"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -tabstyle wordprocessor
+ .t cget -tabstyle
+} -cleanup {
+ destroy .t
+} -result {wordprocessor}
+test text-1.74 {configuration option: "tabstyle"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -tabstyle garbage
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.75 {configuration option: "undo"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -undo 1
+ .t cget -undo
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-1.76 {configuration option: "undo"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -undo eh
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.77 {configuration option: "width"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -width 73
+ .t cget -width
+} -cleanup {
+ destroy .t
+} -result {73}
+test text-1.78 {configuration option: "width"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -width 2.4
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.79 {configuration option: "wrap"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -wrap w
+ .t cget -wrap
+} -cleanup {
+ destroy .t
+} -result {word}
+test text-1.80 {configuration option: "wrap"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -wrap bad_wrap
+} -cleanup {
+ destroy .t
+} -match glob -returnCodes {error} -result {*}
+test text-1.81 {text options} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -takefocus "any old thing"
+ .t cget -takefocus
+} -cleanup {
+ destroy .t
+} -result {any old thing}
+test text-1.82 {text options} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -xscrollcommand "x scroll command"
+ .t configure -xscrollcommand
+} -cleanup {
+ destroy .t
+} -result {-xscrollcommand xScrollCommand ScrollCommand {} {x scroll command}}
+test text-1.83 {text options} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -yscrollcommand "test command"
+ .t configure -yscrollcommand
+} -cleanup {
+ destroy .t
+} -result {-yscrollcommand yScrollCommand ScrollCommand {} {test command}}
+test text-1.83.1 {configuration option: "insertunfocussed"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -insertunfocussed none
+ .t cget -insertunfocussed
+} -cleanup {
+ destroy .t
+} -result none
+test text-1.84 {configuration option: "insertunfocussed"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -insertunfocussed hollow
+ .t cget -insertunfocussed
+} -cleanup {
+ destroy .t
+} -result hollow
+test text-1.85 {configuration option: "insertunfocussed"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -body {
+ .t configure -insertunfocussed solid
+ .t cget -insertunfocussed
+} -cleanup {
+ destroy .t
+} -result solid
+test text-1.86 {configuration option: "insertunfocussed"} -setup {
+ text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
+ pack .t
+ update
+} -returnCodes error -body {
+ .t configure -insertunfocussed gorp
+} -cleanup {
+ destroy .t
+} -result {bad insertunfocussed "gorp": must be hollow, none, or solid}
+
+
+test text-2.1 {Tk_TextCmd procedure} -body {
+ text
+} -returnCodes {error} -result {wrong # args: should be "text pathName ?-option value ...?"}
+test text-2.2 {Tk_TextCmd procedure} -body {
+ text foobar
+} -returnCodes {error} -result {bad window path name "foobar"}
+test text-2.3 {Tk_TextCmd procedure} -body {
+ text .t -gorp nofun
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {unknown option "-gorp"}
+test text-2.4 {Tk_TextCmd procedure} -body {
+ catch {text .t -gorp nofun}
+ winfo exists .t
+} -cleanup {
+ destroy .t
+} -result 0
+test text-2.5 {Tk_TextCmd procedure} -body {
+ text .t -bd 2 -fg red
+} -cleanup {
+ destroy .t
+} -returnCodes ok -result {.t}
+test text-2.6 {Tk_TextCmd procedure} -body {
+ text .t -bd 2 -fg red
+ list [lindex [.t config -bd] 4] [lindex [.t config -fg] 4]
+} -cleanup {
+ destroy .t
+} -result {2 red}
+test text-2.7 {Tk_TextCmd procedure} -constraints {
+ win
+} -body {
+ catch {destroy .t}
+ text .t
+ .t tag cget sel -relief
+} -cleanup {
+ destroy .t
+} -result {flat}
+test text-2.8 {Tk_TextCmd procedure} -constraints {
+ aqua
+} -body {
+ catch {destroy .t}
+ text .t
+ .t tag cget sel -relief
+} -cleanup {
+ destroy .t
+} -result {solid}
+test text-2.9 {Tk_TextCmd procedure} -constraints {
+ unix
+} -body {
+ catch {destroy .t}
+ text .t
+ .t tag cget sel -relief
+} -cleanup {
+ destroy .t
+} -result {raised}
+test text-2.10 {Tk_TextCmd procedure} -body {
+ list [text .t] [winfo class .t]
+} -cleanup {
+ destroy .t
+} -result {.t Text}
+
+
+test text-3.1 {TextWidgetCmd procedure, basics} -setup {
+ text .t
+} -body {
+ .t
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t option ?arg ...?"}
+test text-3.2 {TextWidgetCmd procedure} -setup {
+ text .t
+} -body {
+ .t gorp 1.0 z 1.2
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad option "gorp": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview}
+
+test text-4.1 {TextWidgetCmd procedure, "bbox" option} -setup {
+ text .t
+} -body {
+ .t bbox
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t bbox index"}
+test text-4.2 {TextWidgetCmd procedure, "bbox" option} -setup {
+ text .t
+} -body {
+ .t bbox a b
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t bbox index"}
+test text-4.3 {TextWidgetCmd procedure, "bbox" option} -setup {
+ text .t
+} -body {
+ .t bbox bad_mark
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "bad_mark"}
+
+test text-5.1 {TextWidgetCmd procedure, "cget" option} -setup {
+ text .t
+} -body {
+ .t cget
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t cget option"}
+test text-5.2 {TextWidgetCmd procedure, "cget" option} -setup {
+ text .t
+} -body {
+ .t cget a b
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t cget option"}
+test text-5.3 {TextWidgetCmd procedure, "cget" option} -setup {
+ text .t
+} -body {
+ .t cget -gorp
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {unknown option "-gorp"}
+test text-5.4 {TextWidgetCmd procedure, "cget" option} -setup {
+ text .t
+} -body {
+ .t configure -bd 17
+ .t cget -bd
+} -cleanup {
+ destroy .t
+} -result {17}
+
+
+test text-6.1 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t compare a b
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t compare index1 op index2"}
+test text-6.2 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t compare a b c d
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t compare index1 op index2"}
+test text-6.3 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t compare @x == 1.0
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "@x"}
+test text-6.4 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t compare 1.0 < @y
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "@y"}
+test text-6.5 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ list [.t compare 1.1 < 1.0] [.t compare 1.1 < 1.1] [.t compare 1.1 < 1.2]
+} -cleanup {
+ destroy .t
+} -result {0 0 1}
+test text-6.6 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ list [.t compare 1.1 <= 1.0] [.t compare 1.1 <= 1.1] [.t compare 1.1 <= 1.2]
+} -cleanup {
+ destroy .t
+} -result {0 1 1}
+test text-6.7 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ list [.t compare 1.1 == 1.0] [.t compare 1.1 == 1.1] [.t compare 1.1 == 1.2]
+} -cleanup {
+ destroy .t
+} -result {0 1 0}
+test text-6.8 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ list [.t compare 1.1 >= 1.0] [.t compare 1.1 >= 1.1] [.t compare 1.1 >= 1.2]
+} -cleanup {
+ destroy .t
+} -result {1 1 0}
+test text-6.9 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ list [.t compare 1.1 > 1.0] [.t compare 1.1 > 1.1] [.t compare 1.1 > 1.2]
+} -cleanup {
+ destroy .t
+} -result {1 0 0}
+test text-6.10 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ list [.t com 1.1 != 1.0] [.t compare 1.1 != 1.1] [.t compare 1.1 != 1.2]
+} -cleanup {
+ destroy .t
+} -result {1 0 1}
+test text-6.11 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t compare 1.0 <x 1.2
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad comparison operator "<x": must be <, <=, ==, >=, >, or !=}
+test text-6.12 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t compare 1.0 >> 1.2
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad comparison operator ">>": must be <, <=, ==, >=, >, or !=}
+test text-6.13 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t compare 1.0 z 1.2
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad comparison operator "z": must be <, <=, ==, >=, >, or !=}
+test text-6.14 {TextWidgetCmd procedure, "compare" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t co 1.0 z 1.2
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {ambiguous option "co": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview}
+# "configure" option is already covered above
+
+test text-7.1 {TextWidgetCmd procedure, "debug" option} -setup {
+ text .t
+} -body {
+ .t debug 0 1
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t debug boolean"}
+test text-7.2 {TextWidgetCmd procedure, "debug" option} -setup {
+ text .t
+} -body {
+ .t de 0 1
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {ambiguous option "de": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview}
+test text-7.3 {TextWidgetCmd procedure, "debug" option} -setup {
+ text .t
+} -body {
+ .t debug true
+ .t deb
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-7.4 {TextWidgetCmd procedure, "debug" option} -setup {
+ text .t
+} -body {
+ .t debug false
+ .t debug
+} -cleanup {
+ destroy .t
+} -result {0}
+
+
+test text-8.1 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ .t delete
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t delete index1 ?index2 ...?"}
+test text-8.2 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ .t delete a b c
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "a"}
+test text-8.3 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ .t delete @x 2.2
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "@x"}
+test text-8.4 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345"
+ .t delete 2.3 @y
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "@y"}
+test text-8.5 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t configure -state disabled
+ .t delete 2.3
+ .t g 2.0 2.end
+} -cleanup {
+ destroy .t
+} -result {abcdefghijklm}
+test text-8.6 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t delete 2.3
+ .t get 2.0 2.end
+} -cleanup {
+ destroy .t
+} -result {abcefghijklm}
+test text-8.7 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t delete 2.1 2.3
+ .t get 2.0 2.end
+} -cleanup {
+ destroy .t
+} -result {adefghijklm}
+test text-8.8 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345"
+ # All indices are checked before we actually delete anything
+ .t delete 2.1 2.3 foo
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "foo"}
+test text-8.9 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345"
+# All indices are checked before we actually delete anything
+ catch {.t delete 2.1 2.3 foo}
+ .t get 2.0 2.end
+} -cleanup {
+ destroy .t
+} -result {abcdefghijklm}
+test text-8.10 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ # auto-forward one byte if the last "pair" is just one
+ .t delete 1.0 end
+ .t insert 1.0 "foo\nabcdefghijklm"
+ .t delete 2.1 2.3 2.3
+ .t get 1.0 end-1c
+} -cleanup {
+ destroy .t
+} -result {foo
+aefghijklm}
+test text-8.11 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ # all indices will be ordered before deletion
+ .t insert 1.0 "foo\nabcdefghijklm"
+ .t delete 2.0 2.3 2.7 2.9 2.4
+ .t get 1.0 end-1c
+} -cleanup {
+ destroy .t
+} -result {foo
+dfgjklm}
+test text-8.12 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ # and check again with even pairs
+ .t insert 1.0 "foo\nabcdefghijklm"
+ .t delete 2.0 2.2 2.7 2.9 2.4 2.5
+ .t get 1.0 end-1c
+} -cleanup {
+ destroy .t
+} -result {foo
+cdfgjklm}
+test text-8.13 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ # we should get the longest range on equal start indices
+ .t insert 1.0 "foo\nabcdefghijklm"
+ .t delete 2.0 2.2 2.0 2.5 2.0 2.3 2.8 2.7
+ .t get 1.0 end-1c
+} -cleanup {
+ destroy .t
+} -result {foo
+fghijklm}
+test text-8.14 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ # we should get the longest range on equal start indices
+ .t insert 1.0 "foo\nabcdefghijklm"
+ .t delete 2.0 2.2 1.2 2.6 2.0 2.5
+ .t get 1.0 end-1c
+} -cleanup {
+ destroy .t
+} -result {foghijklm}
+test text-8.15 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ # we should get the longest range on equal start indices
+ .t insert 1.0 "foo\nabcdefghijklm"
+ .t delete 2.0 2.2 2.0 2.5 1.1 2.3 2.8 2.7
+ .t get 1.0 end-1c
+} -cleanup {
+ destroy .t
+} -result {ffghijklm}
+test text-8.16 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ # we should get the watch for overlapping ranges - they should
+ # essentially be merged into one span.
+ .t insert 1.0 "foo\nabcdefghijklm"
+ .t delete 2.0 2.6 2.2 2.8
+ .t get 1.0 end-1c
+} -cleanup {
+ destroy .t
+} -result {foo
+ijklm}
+test text-8.17 {TextWidgetCmd procedure, "delete" option} -setup {
+ text .t
+} -body {
+ # we should get the watch for overlapping ranges - they should
+ # essentially be merged into one span.
+ .t insert 1.0 "foo\nabcdefghijklm"
+ .t delete 2.0 2.6 2.2 2.4
+ .t get 1.0 end-1c
+} -cleanup {
+ destroy .t
+} -result {foo
+ghijklm}
+test text-8.18 {TextWidgetCmd procedure, "replace" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345"
+ .t replace 1.3 2.3
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t replace index1 index2 chars ?tagList chars tagList ...?"}
+test text-8.19 {TextWidgetCmd procedure, "replace" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345"
+ .t replace 3.1 2.3 foo
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {index "2.3" before "3.1" in the text}
+test text-8.20 {TextWidgetCmd procedure, "replace" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t replace 2.1 2.3 foo
+} -cleanup {
+ destroy .t
+} -returnCodes ok -result {}
+test text-8.21 {TextWidgetCmd procedure, "replace" option with undo} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ set prevtext [.t get 1.0 end-1c]
+ .t configure -undo 0
+ .t configure -undo 1
+ # Ensure it is treated as a single undo action
+ .t replace 2.1 2.3 foo
+ .t edit undo
+ string equal [.t get 1.0 end-1c] $prevtext
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-8.22 {TextWidgetCmd procedure, "replace" option with undo} -setup {
+ text .t
+ set res {}
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t configure -undo 0
+ .t configure -undo 1
+ .t replace 2.1 2.3 foo
+ # Ensure we can override a text widget and intercept undo
+ # actions. If in the future a different mechanism is available
+ # to do this, then we should be able to change this test. The
+ # behaviour tested for here is not, strictly speaking, documented.
+ rename .t test.t
+ proc .t {args} { lappend ::res $args ; uplevel 1 test.t $args }
+ .t edit undo
+ return $res
+} -cleanup {
+ rename .t {}
+ rename test.t .t
+ destroy .t
+} -result {{edit undo} {delete 2.1 2.4} {mark set insert 2.1} {see insert} {insert 2.1 ef} {mark set insert 2.3} {see insert}}
+test text-8.23 {TextWidgetCmd procedure, "replace" option with undo} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ set prevtext [.t get 1.0 end-1c]
+ .t configure -undo 0
+ .t configure -undo 1
+ # Ensure that undo (even composite undo like 'replace')
+ # works when the widget shows nothing useful.
+ .t replace 2.1 2.3 foo
+ .t configure -start 1 -end 1
+ .t edit undo
+ .t configure -start {} -end {}
+ .t configure -undo 0
+ string equal [.t get 1.0 end-1c] $prevtext
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-8.24 {TextWidgetCmd procedure, "replace" option with peers, undo} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ set prevtext [.t get 1.0 end-1c]
+ .t configure -undo 0
+ .t configure -undo 1
+ .t peer create .tt -undo 1
+# Ensure that undo (even composite undo like 'replace')
+# works when the the event took place in one peer, which
+# is then deleted, before the undo takes place in another peer.
+ .tt replace 2.1 2.3 foo
+ .tt configure -start 1 -end 1
+ destroy .tt
+ .t edit undo
+ .t configure -start {} -end {}
+ .t configure -undo 0
+ string equal [.t get 1.0 end-1c] $prevtext
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-8.25 {TextWidgetCmd procedure, "replace" option with peers, undo} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ set prevtext [.t get 1.0 end-1c]
+ .t configure -undo 0
+ .t configure -undo 1
+ .t peer create .tt -undo 1
+# Ensure that undo (even composite undo like 'replace')
+# works when the the event took place in one peer, which
+# is then deleted, before the undo takes place in another peer
+# which isn't showing everything.
+ .tt replace 2.1 2.3 foo
+ set res [.tt get 2.1 2.4]
+ .tt configure -start 1 -end 1
+ destroy .tt
+ .t configure -start 3 -end 4
+# msg will actually be set to a silently ignored error message here,
+# (that the .tt command doesn't exist), but that is not important.
+ lappend res [catch {.t edit undo}]
+ .t configure -undo 0
+ .t configure -start {} -end {}
+ lappend res [string equal [.t get 1.0 end-1c] $prevtext]
+} -cleanup {
+ destroy .t
+} -result {foo 0 1}
+test text-8.26 {TextWidgetCmd procedure, "replace" option crash} -setup {
+ text .tt
+} -body {
+ .tt insert 0.0 foo\n
+ .tt replace end-1l end bar
+} -cleanup {
+ destroy .tt
+} -result {}
+
+
+test text-9.1 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t get
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t get ?-displaychars? ?--? index1 ?index2 ...?"}
+test text-9.2 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t get a b c
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "a"}
+test text-9.3 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t get @q 3.1
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "@q"}
+test text-9.4 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t get 3.1 @r
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "@r"}
+test text-9.5 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t get 5.7 5.3
+} -cleanup {
+ destroy .t
+} -result {}
+test text-9.6 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t get 5.3 5.5
+} -cleanup {
+ destroy .t
+} -result { G}
+test text-9.7 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t get 5.3 end
+} -cleanup {
+ destroy .t
+} -result { GIrl .#@? x_yz
+!@#$%
+Line 7
+}
+test text-9.8 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t get 5.2 5.7
+} -cleanup {
+ destroy .t
+} -result {y GIr}
+test text-9.9 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t get 5.2
+} -cleanup {
+ destroy .t
+} -result {y}
+test text-9.10 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t get 5.2 5.4
+} -cleanup {
+ destroy .t
+} -result {y }
+test text-9.11 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t get 5.2 5.4 5.4
+} -cleanup {
+ destroy .t
+} -result {{y } G}
+test text-9.12 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t get 5.2 5.4 5.4 5.5
+} -cleanup {
+ destroy .t
+} -result {{y } G}
+test text-9.13 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t get 5.2 5.4 5.5 "5.5+5c"
+} -cleanup {
+ destroy .t
+} -result {{y } {Irl .}}
+test text-9.14 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t get 5.2 5.4 5.4 5.5 end-3c
+} -cleanup {
+ destroy .t
+} -result {{y } G { }}
+test text-9.15 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t get 5.2 5.4 5.4 5.5 end-3c end
+} -cleanup {
+ destroy .t
+} -result {{y } G { 7
+}}
+test text-9.16 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t get 5.2 5.3 5.4 5.3
+} -cleanup {
+ destroy .t
+} -result {y}
+test text-9.17 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t index "5.2 +3 indices"
+} -cleanup {
+ destroy .t
+} -result {5.5}
+test text-9.18 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t index "5.2 +3chars"
+} -cleanup {
+ destroy .t
+} -result {5.5}
+test text-9.19 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t index "5.2 +3displayindices"
+} -cleanup {
+ destroy .t
+} -result {5.5}
+test text-9.20 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 5.2 5.4
+ .t get 5.2 5.4 5.5 foo
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "foo"}
+test text-9.21 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 5.2 5.4
+ .t get 5.2 5.4 5.4 5.5 end-3c end
+} -cleanup {
+ destroy .t
+} -result {{y } G { 7
+}}
+test text-9.22 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 5.2 5.4
+ .t get -displaychars 5.2 5.4 5.4 5.5 end-3c end
+} -cleanup {
+ destroy .t
+} -result {{} G { 7
+}}
+test text-9.23 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 5.2 5.4
+ list [.t index "5.1 +4indices"] [.t index "5.1+4d indices"]
+} -cleanup {
+ destroy .t
+} -result {5.5 5.7}
+test text-9.24 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 5.2 5.4
+ list [.t index "5.1 +4a chars"] [.t index "5.1+4d chars"]
+} -cleanup {
+ destroy .t
+} -result {5.5 5.7}
+test text-9.25 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 5.2 5.4
+ list [.t index "5.5 -4indices"] [.t index "5.7-4d indices"]
+} -cleanup {
+ destroy .t
+} -result {5.1 5.1}
+test text-9.26 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 5.2 5.4
+ list [.t index "5.5 -4a chars"] [.t index "5.7-4d chars"]
+} -cleanup {
+ destroy .t
+} -result {5.1 5.1}
+test text-9.27 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 5.2 5.4
+ .t window create 5.4
+ list [.t index "5.1 +4indices"] [.t index "5.1+4d indices"]
+} -cleanup {
+ destroy .t
+} -result {5.5 5.7}
+test text-9.28 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 5.2 5.4
+ .t window create 5.4
+ list [.t index "5.1 +4a chars"] [.t index "5.1+4d chars"]
+} -cleanup {
+ destroy .t
+} -result {5.6 5.8}
+test text-9.29 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 5.2 5.4
+ .t window create 5.4
+ list [.t index "5.5 -4indices"] [.t index "5.7-4d indices"]
+} -cleanup {
+ destroy .t
+} -result {5.1 5.1}
+test text-9.30 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 5.2 5.4
+ .t window create 5.4
+ list [.t index "5.6 -4a chars"] [.t index "5.8-4d chars"]
+} -cleanup {
+ destroy .t
+} -result {5.1 5.1}
+test text-9.31 {TextWidgetCmd procedure, "get" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 5.2 5.4
+ .t window create 5.4
+ .t delete 5.4
+ .t tag add elide 5.5 5.6
+ .t get -displaychars 5.2 5.8
+} -cleanup {
+ destroy .t
+} -result {Grl}
+
+
+test text-10.1 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t count
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t count ?-option value ...? index1 index2"}
+test text-10.2 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t count blah 1.0 2.0
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad option "blah" must be -chars, -displaychars, -displayindices, -displaylines, -indices, -lines, -update, -xpixels, or -ypixels}
+test text-10.3 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t count a b
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "a"}
+test text-10.4 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t count @q 3.1
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "@q"}
+test text-10.5 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t count 3.1 @r
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "@r"}
+test text-10.6 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+} -body {
+ .t count 5.7 5.3
+} -cleanup {
+ destroy .t
+} -result {-4}
+test text-10.7 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+} -body {
+ .t count 5.3 5.5
+} -cleanup {
+ destroy .t
+} -result {2}
+test text-10.8 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t count 5.3 end
+} -cleanup {
+ destroy .t
+} -result {29}
+test text-10.9 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+} -body {
+ .t count 5.2 5.7
+} -cleanup {
+ destroy .t
+} -result {5}
+test text-10.10 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+} -body {
+ .t count 5.2 5.3
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-10.11 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+} -body {
+ .t count 5.2 5.4
+} -cleanup {
+ destroy .t
+} -result {2}
+test text-10.12 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+} -body {
+ .t count 5.2 foo
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "foo"}
+test text-10.13 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t count -displayindices 2.0 3.0
+} -cleanup {
+ destroy .t
+} -result {2}
+test text-10.14 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t count -displayindices 2.2 3.0
+} -cleanup {
+ destroy .t
+} -result {0}
+test text-10.15 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t tag add elide 4.0 4.1
+ .t count -displayindices 2.0 4.2
+} -cleanup {
+ destroy .t
+} -result {5}
+test text-10.16 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+# Creating this window here means that the elidden text
+# now starts at 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ .t count -displayindices 2.0 3.0
+} -cleanup {
+ destroy .t
+} -result {3}
+test text-10.17 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+# Creating this window here means that the elidden text
+# now starts at 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ .t count -displayindices 2.2 3.0
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-10.18 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t tag add elide 4.0 4.1
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+ .t mark set a 2.2
+# Creating this window here means that the elidden text
+# now starts at 2.3, but 'a' is automatically moved to 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ .t count -displayindices a 3.0
+} -cleanup {
+ destroy .t
+} -result {0}
+test text-10.19 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t tag add elide 4.0 4.1
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+# Creating this window here means that the elidden text
+# now starts at 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ .t count -displayindices 2.0 4.2
+} -cleanup {
+ destroy .t
+} -result {6}
+test text-10.20 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t tag add elide 4.0 4.1
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+# Creating this window here means that the elidden text
+# now starts at 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ .t count -displaychars 2.0 3.0
+} -cleanup {
+ destroy .t
+} -result {2}
+test text-10.21 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t tag add elide 4.0 4.1
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+# Creating this window here means that the elidden text
+# now starts at 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ .t count -displaychars 2.2 3.0
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-10.22 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t tag add elide 4.0 4.1
+ .t mark set a 2.2
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+# Creating this window here means that the elidden text
+# now starts at 2.3, but 'a' is automatically moved to 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ .t count -displaychars a 3.0
+} -cleanup {
+ destroy .t
+} -result {0}
+test text-10.23 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t tag add elide 4.0 4.1
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+# Creating this window here means that the elidden text
+# now starts at 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ .t count -displaychars 2.0 4.2
+} -cleanup {
+ destroy .t
+} -result {5}
+test text-10.24 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t tag add elide 4.0 4.1
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+# Creating this window here means that the elidden text
+# now starts at 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ .t count -displaychars 2.0 4.2
+ list [.t count -indices 2.2 3.0] [.t count 2.2 3.0]
+} -cleanup {
+ destroy .t
+} -result {10 10}
+test text-10.25 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t tag add elide 4.0 4.1
+ .t mark set a 2.2
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+# Creating this window here means that the elidden text
+# now starts at 2.3, but 'a' is automatically moved to 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ list [.t count -indices a 3.0] [.t count a 3.0]
+} -cleanup {
+ destroy .t
+} -result {9 9}
+test text-10.26 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t tag add elide 4.0 4.1
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+# Creating this window here means that the elidden text
+# now starts at 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ .t count -displaychars 2.0 4.2
+ .t count -indices 2.0 4.2
+} -cleanup {
+ destroy .t
+} -result {21}
+test text-10.27 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t tag add elide 4.0 4.1
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+# Creating this window here means that the elidden text
+# now starts at 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ .t count -displaychars 2.0 4.2
+ .t count -chars 2.2 3.0
+} -cleanup {
+ destroy .t
+} -result {10}
+test text-10.28 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t tag add elide 4.0 4.1
+ .t mark set a 2.2
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+# Creating this window here means that the elidden text
+# now starts at 2.3, but 'a' is automatically moved to 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ .t count -chars a 3.0
+} -cleanup {
+ destroy .t
+} -result {9}
+test text-10.29 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t tag configure elide -elide 1
+ .t tag add elide 2.2 3.4
+ .t tag add elide 4.0 4.1
+# Create one visible and one invisible window
+ frame .t.w1
+ frame .t.w2
+# Creating this window here means that the elidden text
+# now starts at 2.3
+ .t window create 2.1 -window .t.w1
+ .t window create 3.1 -window .t.w2
+ .t count -displaychars 2.0 4.2
+ .t count -chars 2.0 4.2
+} -cleanup {
+ destroy .t
+} -result {19}
+test text-10.30 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert end [string repeat "abcde " 50]\n
+ .t insert end [string repeat "fghij " 50]\n
+ .t insert end [string repeat "klmno " 50]
+ .t count -lines 1.0 end
+} -cleanup {
+ destroy .t
+} -result {3}
+test text-10.31 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert end [string repeat "abcde " 50]\n
+ .t insert end [string repeat "fghij " 50]\n
+ .t insert end [string repeat "klmno " 50]
+ .t count -lines end 1.0
+} -cleanup {
+ destroy .t
+} -result {-3}
+test text-10.32 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert end [string repeat "abcde " 50]\n
+ .t insert end [string repeat "fghij " 50]\n
+ .t insert end [string repeat "klmno " 50]
+ .t count -lines 1.0 2.0 3.0
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad option "1.0" must be -chars, -displaychars, -displayindices, -displaylines, -indices, -lines, -update, -xpixels, or -ypixels}
+test text-10.33 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert end [string repeat "abcde " 50]\n
+ .t insert end [string repeat "fghij " 50]\n
+ .t insert end [string repeat "klmno " 50]
+ .t count -lines end end
+} -cleanup {
+ destroy .t
+} -result {0}
+test text-10.34 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert end [string repeat "abcde " 50]\n
+ .t insert end [string repeat "fghij " 50]\n
+ .t insert end [string repeat "klmno " 50]
+ .t count -lines 1.5 2.5
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-10.35 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert end [string repeat "abcde " 50]\n
+ .t insert end [string repeat "fghij " 50]\n
+ .t insert end [string repeat "klmno " 50]
+ .t count -lines 2.5 "2.5 lineend"
+} -cleanup {
+ destroy .t
+} -result {0}
+test text-10.36 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert end [string repeat "abcde " 50]\n
+ .t insert end [string repeat "fghij " 50]\n
+ .t insert end [string repeat "klmno " 50]
+ .t count -lines 2.7 "1.0 lineend"
+} -cleanup {
+ destroy .t
+} -result {-1}
+test text-10.37 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+} -body {
+ .t insert end [string repeat "abcde " 50]\n
+ .t insert end [string repeat "fghij " 50]\n
+ .t insert end [string repeat "klmno " 50]
+ .t configure -wrap none
+ .t count -displaylines 1.0 end
+} -cleanup {
+ destroy .t
+} -result {3}
+test text-10.38 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack append . .t {top expand fill}
+} -body {
+ .t configure -width 20 -height 10
+ update
+ .t insert end [string repeat "abcde " 50]\n
+ .t insert end [string repeat "fghij " 50]\n
+ .t insert end [string repeat "klmno " 50]
+ .t count -lines -chars -indices -displaylines 1.0 end
+} -cleanup {
+ destroy .t
+} -result {3 903 903 45}
+test text-10.39 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+ pack .t
+ update
+ set res {}
+} -body {
+ .t insert end "Line 1 - This is Line 1\n"
+ .t insert end "Line 2 - This is Line 2\n"
+ .t insert end "Line 3 - This is Line 3\n"
+ .t insert end "Line 4 - This is Line 4\n"
+ .t insert end "Line 5 - This is Line 5\n"
+ lappend res [.t count -displaylines 1.19 3.24] [.t count -displaylines 1.0 end]
+ .t tag add hidden 2.9 3.17
+ .t tag configure hidden -elide true
+ lappend res [.t count -displaylines 1.19 3.24] [.t count -displaylines 1.0 end]
+} -cleanup {
+ destroy .t
+} -result {2 6 1 5}
+test text-9.2.45 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+ pack .t
+ update
+ set res {}
+} -body {
+ for {set i 1} {$i < 5} {incr i} {
+ .t insert end "Line $i+++Line $i---Line $i///Line $i - This is Line [format %c [expr 64+$i]]\n"
+ }
+ .t tag configure hidden -elide true
+ .t tag add hidden 2.15 3.10
+ .t configure -wrap none
+ set res [.t count -displaylines 2.0 3.0]
+} -cleanup {
+ destroy .t
+} -result {0}
+test text-9.2.46 {TextWidgetCmd procedure, "count" option} -setup {
+ toplevel .mytop
+ pack [text .mytop.t -font TkFixedFont -bd 0 -padx 0 -wrap char]
+ set spec [font measure TkFixedFont "Line 1+++Line 1---Li"] ; # 20 chars
+ append spec x300+0+0
+ wm geometry .mytop $spec
+ .mytop.t delete 1.0 end
+ update
+ set res {}
+} -body {
+ for {set i 1} {$i < 5} {incr i} {
+ # 0 1 2 3 4
+ # 012345 678901234 567890123 456789012 34567890123456789
+ .mytop.t insert end "Line $i+++Line $i---Line $i///Line $i - This is Line [format %c [expr 64+$i]]\n"
+ }
+ .mytop.t tag configure hidden -elide true
+ .mytop.t tag add hidden 2.30 3.10
+ lappend res [.mytop.t count -displaylines 2.0 3.0]
+ lappend res [.mytop.t count -displaylines 2.0 3.50]
+} -cleanup {
+ destroy .mytop
+} -result {1 3}
+test text-9.2.47 {TextWidgetCmd procedure, "count" option} -setup {
+ text .t
+ pack .t
+ update
+ set res {}
+} -body {
+ for {set i 1} {$i < 25} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t tag configure hidden -elide true
+ .t tag add hidden 5.7 11.0
+ update
+ # next line to be fully sure that asynchronous line heights calculation is
+ # up-to-date otherwise this test may fail (depending on the computer
+ # performance), especially when the . toplevel has small height
+ .t sync
+ set y1 [lindex [.t yview] 1]
+ .t count -displaylines 5.0 11.0
+ set y2 [lindex [.t yview] 1]
+ .t count -displaylines 5.0 12.0
+ set y3 [lindex [.t yview] 1]
+ list [expr {$y1 == $y2}] [expr {$y1 == $y3}]
+} -cleanup {
+ destroy .t
+} -result {1 1}
+
+
+test text-11.1 {counting with tag priority eliding} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack append . .t {top expand fill}
+} -body {
+ .t insert end "hello"
+ .t configure -wrap none
+ list [.t count -displaychars 1.0 1.0] \
+ [.t count -displaychars 1.0 1.1] \
+ [.t count -displaychars 1.0 1.2] \
+ [.t count -displaychars 1.0 1.3] \
+ [.t count -displaychars 1.0 1.4] \
+ [.t count -displaychars 1.0 1.5] \
+ [.t count -displaychars 1.0 1.6] \
+ [.t count -displaychars 1.0 2.6] \
+} -cleanup {
+ destroy .t
+} -result {0 1 2 3 4 5 5 6}
+test text-11.2 {counting with tag priority eliding} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack append . .t {top expand fill}
+} -body {
+ .t insert end "hello"
+ .t tag configure elide1 -elide 0
+ .t tag add elide1 1.2 1.4
+ .t count -displaychars 1.0 1.5
+} -cleanup {
+ destroy .t
+} -result {5}
+test text-11.3 {counting with tag priority eliding} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+} -body {
+ .t insert end "hello"
+# Newer tags are higher priority
+ .t tag configure elide1 -elide 0
+ .t tag configure elide2 -elide 1
+ .t tag add elide1 1.2 1.4
+ .t tag add elide2 1.2 1.4
+ .t count -displaychars 1.0 1.5
+} -cleanup {
+ destroy .t
+} -result {3}
+test text-11.4 {counting with tag priority eliding} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ set res {}
+} -body {
+ .t insert end "hello"
+# Newer tags are higher priority
+ .t tag configure elide1 -elide 0
+ .t tag configure elide2 -elide 1
+ .t tag add elide1 1.2 1.4
+ .t tag add elide2 1.2 1.4
+ .t tag add elide1 1.2 1.4
+ lappend res [.t count -displaychars 1.0 1.5]
+ .t delete 1.0 end
+ .t insert end "hello"
+ .t tag add elide1 1.2 1.4
+ .t tag add elide2 1.2 1.4
+ lappend res [.t count -displaychars 1.0 1.5]
+} -cleanup {
+ destroy .t
+} -result {3 3}
+test text-11.5 {counting with tag priority eliding} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ set res {}
+} -body {
+ .t insert end "hello"
+# Newer tags are higher priority
+ .t tag configure elide1 -elide 0
+ .t tag configure elide2 -elide 1
+ .t tag configure elide3 -elide 0
+ .t tag add elide1 1.2 1.4
+ .t tag add elide2 1.2 1.4
+ .t tag add elide3 1.2 1.4
+ lappend res [.t count -displaychars 1.0 1.5]
+ .t delete 1.0 end
+ .t insert end "hello"
+ .t tag add elide3 1.2 1.4
+ .t tag add elide3 1.2 1.4
+ lappend res [.t count -displaychars 1.0 1.5]
+} -cleanup {
+ destroy .t
+} -result {5 5}
+test text-11.6 {counting with tag priority eliding} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ set res {}
+} -body {
+ .t insert end "hello"
+# Newer tags are higher priority
+ .t tag configure elide1 -elide 0
+ .t tag configure elide2 -elide 1
+ .t tag configure elide3 -elide 0
+ .t tag configure elide4 -elide 1
+ .t tag add elide2 1.2 1.4
+ .t tag add elide3 1.2 1.4
+ .t tag add elide4 1.2 1.4
+ .t tag add elide1 1.2 1.4
+ lappend res [.t count -displaychars 1.0 1.5]
+ .t delete 1.0 end
+ .t insert end "hello"
+ .t tag add elide1 1.2 1.4
+ .t tag add elide4 1.2 1.4
+ .t tag add elide2 1.2 1.4
+ .t tag add elide3 1.2 1.4
+ lappend res [.t count -displaychars 1.0 1.5]
+} -cleanup {
+ destroy .t
+} -result {3 3}
+test text-11.7 {counting with tag priority eliding} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ set res {}
+} -body {
+# Newer tags are higher priority
+ .t tag configure elide1 -elide 0
+ .t tag configure elide2 -elide 1
+ .t tag configure elide3 -elide 0
+ .t insert end "hello"
+ .t tag add elide2 1.2 1.4
+ .t tag add elide3 1.2 1.4
+ .t tag add elide1 1.2 1.4
+ lappend res [.t count -displaychars 1.0 1.5]
+ .t delete 1.0 end
+ .t insert end "hello"
+ .t tag add elide1 1.2 1.4
+ .t tag add elide2 1.2 1.4
+ .t tag add elide3 1.2 1.4
+ lappend res [.t count -displaychars 1.0 1.5]
+} -cleanup {
+ destroy .t
+} -result {5 5}
+test text-11.8 {counting with tag priority eliding} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack append . .t {top expand fill}
+ set res {}
+} -body {
+ .t insert end "hello"
+# Newer tags are higher priority
+ .t tag configure elide1 -elide 0
+ .t tag configure elide2 -elide 1
+ .t tag add elide2 1.0 1.5
+ .t tag add elide1 1.2 1.4
+ lappend res [.t count -displaychars 1.0 1.5]
+ lappend res [.t count -displaychars 1.1 1.5]
+ lappend res [.t count -displaychars 1.2 1.5]
+ lappend res [.t count -displaychars 1.3 1.5]
+ .t delete 1.0 end
+ .t insert end "hello"
+ .t tag add elide1 1.0 1.5
+ .t tag add elide2 1.2 1.4
+ lappend res [.t count -displaychars 1.0 1.5]
+ lappend res [.t count -displaychars 1.1 1.5]
+ lappend res [.t count -displaychars 1.2 1.5]
+ lappend res [.t count -displaychars 1.3 1.5]
+} -cleanup {
+ destroy .t
+} -result {0 0 0 0 3 2 1 1}
+test text-11.9 {counting with tag priority eliding} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack append . .t {top expand fill}
+ set res {}
+} -body {
+ .t tag configure WELCOME -elide 1
+ .t tag configure SYSTEM -elide 0
+ .t tag configure TRAFFIC -elide 1
+ .t insert end "\n" {SYSTEM TRAFFIC}
+ .t insert end "\n" WELCOME
+ lappend res [.t count -displaychars 1.0 end]
+ lappend res [.t count -displaychars 1.0 end-1c]
+ lappend res [.t count -displaychars 1.0 1.2]
+ lappend res [.t count -displaychars 2.0 end]
+ lappend res [.t count -displaychars 2.0 end-1c]
+ lappend res [.t index "1.0 +1 indices"]
+ lappend res [.t index "1.0 +1 display indices"]
+ lappend res [.t index "1.0 +1 display chars"]
+ lappend res [.t index end]
+ lappend res [.t index "end -1 indices"]
+ lappend res [.t index "end -1 display indices"]
+ lappend res [.t index "end -1 display chars"]
+ lappend res [.t index "end -2 indices"]
+ lappend res [.t index "end -2 display indices"]
+ lappend res [.t index "end -2 display chars"]
+} -cleanup {
+ destroy .t
+} -result {1 0 0 1 0 2.0 4.0 4.0 4.0 3.0 3.0 3.0 2.0 1.0 1.0}
+
+test text-11a.1 {TextWidgetCmd procedure, "pendingsync" option} -setup {
+ destroy .yt
+} -body {
+ text .yt
+ list [catch {.yt pendingsync mytext} msg] $msg
+} -cleanup {
+ destroy .yt
+} -result {1 {wrong # args: should be ".yt pendingsync"}}
+test text-11a.2 {TextWidgetCmd procedure, "pendingsync" option} -setup {
+ destroy .top.yt .top
+} -body {
+ toplevel .top
+ pack [text .top.yt]
+ set content {}
+ for {set i 1} {$i < 300} {incr i} {
+ append content [string repeat "$i " 15] \n
+ }
+ .top.yt insert 1.0 $content
+ # wait for end of line metrics calculation to get correct $fraction1
+ # as a reference
+ while {[.top.yt pendingsync]} {update}
+ .top.yt yview moveto 1
+ set fraction1 [lindex [.top.yt yview] 0]
+ set res [expr {$fraction1 > 0}]
+ .top.yt delete 1.0 end
+ .top.yt insert 1.0 $content
+ # ensure the test is relevant
+ lappend res [.top.yt pendingsync]
+ # asynchronously wait for completion of line metrics calculation
+ while {[.top.yt pendingsync]} {update}
+ .top.yt yview moveto $fraction1
+ set fraction2 [lindex [.top.yt yview] 0]
+ lappend res [expr {$fraction1 == $fraction2}]
+} -cleanup {
+ destroy .top.yt .top
+} -result {1 1 1}
+
+test text-11a.11 {TextWidgetCmd procedure, "sync" option} -setup {
+ destroy .yt
+} -body {
+ text .yt
+ list [catch {.yt sync mytext} msg] $msg
+} -cleanup {
+ destroy .yt
+} -result {1 {wrong # args: should be ".yt sync ?-command command?"}}
+test text-11a.12 {TextWidgetCmd procedure, "sync" option} -setup {
+ destroy .top.yt .top
+} -body {
+ toplevel .top
+ pack [text .top.yt]
+ set content {}
+ for {set i 1} {$i < 30} {incr i} {
+ append content [string repeat "$i " 15] \n
+ }
+ .top.yt insert 1.0 $content
+ # wait for end of line metrics calculation to get correct $fraction1
+ # as a reference
+ .top.yt sync
+ .top.yt yview moveto 1
+ set fraction1 [lindex [.top.yt yview] 0]
+ set res [expr {$fraction1 > 0}]
+ # first case: do not wait for completion of line metrics calculation
+ .top.yt delete 1.0 end
+ .top.yt insert 1.0 $content
+ .top.yt yview moveto $fraction1
+ set fraction2 [lindex [.top.yt yview] 0]
+ lappend res [expr {$fraction1 == $fraction2}]
+ # second case: wait for completion of line metrics calculation
+ .top.yt delete 1.0 end
+ .top.yt insert 1.0 $content
+ .top.yt sync
+ .top.yt yview moveto $fraction1
+ set fraction2 [lindex [.top.yt yview] 0]
+ lappend res [expr {$fraction1 == $fraction2}]
+} -cleanup {
+ destroy .top.yt .top
+} -result {1 0 1}
+
+test text-11a.21 {TextWidgetCmd procedure, "sync" option with -command} -setup {
+ destroy .yt
+} -body {
+ text .yt
+ list [catch {.yt sync -comx foo} msg] $msg
+} -cleanup {
+ destroy .yt
+} -result {1 {wrong option "-comx": should be "-command"}}
+test text-11a.22 {TextWidgetCmd procedure, "sync" option with -command} -setup {
+ destroy .top.yt .top
+} -body {
+ set res {}
+ set ::x 0
+ toplevel .top
+ pack [text .top.yt]
+ set content {}
+ for {set i 1} {$i < 30} {incr i} {
+ append content [string repeat "$i " 15] \n
+ }
+ .top.yt insert 1.0 $content
+ # first case: line metrics calculation still running when launching 'sync -command'
+ lappend res [.top.yt pendingsync]
+ .top.yt sync -command [list set ::x 1]
+ lappend res $::x
+ # now finish line metrics calculations
+ while {[.top.yt pendingsync]} {update}
+ lappend res [.top.yt pendingsync] $::x
+ # second case: line metrics calculation completed when launching 'sync -command'
+ .top.yt sync -command [list set ::x 2]
+ lappend res $::x
+ vwait ::x
+ lappend res $::x
+} -cleanup {
+ destroy .top.yt .top
+} -result {1 0 0 1 1 2}
+
+test text-11a.31 {"<<WidgetViewSync>>" event} -setup {
+ destroy .top.yt .top
+} -body {
+ toplevel .top
+ pack [text .top.yt]
+ set content {}
+ for {set i 1} {$i < 300} {incr i} {
+ append content [string repeat "$i " 15] \n
+ }
+ .top.yt insert 1.0 $content
+ update
+ bind .top.yt <<WidgetViewSync>> { if {%d} {set yud(%W) 1} }
+ # wait for end of line metrics calculation to get correct $fraction1
+ # as a reference
+ if {[.top.yt pendingsync]} {vwait yud(.top.yt)}
+ .top.yt yview moveto 1
+ set fraction1 [lindex [.top.yt yview] 0]
+ set res [expr {$fraction1 > 0}]
+ .top.yt delete 1.0 end
+ .top.yt insert 1.0 $content
+ # synchronously wait for completion of line metrics calculation
+ # and ensure the test is relevant
+ set waited 0
+ if {[.top.yt pendingsync]} {set waited 1 ; vwait yud(.top.yt)}
+ lappend res $waited
+ .top.yt yview moveto $fraction1
+ set fraction2 [lindex [.top.yt yview] 0]
+ lappend res [expr {$fraction1 == $fraction2}]
+} -cleanup {
+ destroy .top.yt .top
+} -result {1 1 1}
+
+test text-11a.41 {"sync" "pendingsync" and <<WidgetViewSync>>} -setup {
+ destroy .top.yt .top
+} -body {
+ set res {}
+ toplevel .top
+ pack [text .top.yt]
+ set content {}
+ for {set i 1} {$i < 300} {incr i} {
+ append content [string repeat "$i " 50] \n
+ }
+ bind .top.yt <<WidgetViewSync>> {lappend res Sync:%d}
+ .top.yt insert 1.0 $content
+ vwait res ; # event dealt with by the event loop, with %d==0 i.e. we're out of sync
+ # ensure the test is relevant
+ lappend res "Pending:[.top.yt pendingsync]"
+ # - <<WidgetViewSync>> fires when sync returns if there was pending syncs
+ # - there is no more any pending sync after running 'sync'
+ .top.yt sync
+ vwait res ; # event dealt with by the event loop, with %d==1 i.e. we're in sync again
+ lappend res "Pending:[.top.yt pendingsync]"
+ set res
+} -cleanup {
+ destroy .top.yt .top
+} -result {Sync:0 Pending:1 Sync:1 Pending:0}
+
+test text-11a.51 {<<WidgetViewSync>> calls TkSendVirtualEvent(),
+ NOT Tk_HandleEvent().
+ Bug [b362182e45704dd7bbd6aed91e48122035ea3d16]} -setup {
+ destroy .top.t .top
+} -body {
+ set res {}
+ toplevel .top
+ pack [text .top.t]
+ for {set i 1} {$i < 10000} {incr i} {
+ .top.t insert end "Hello world!\n"
+ }
+ bind .top.t <<WidgetViewSync>> {destroy .top.t}
+ .top.t tag add mytag 1.5 8000.8 ; # shall not crash
+ update
+ set res "Still doing fine!"
+} -cleanup {
+ destroy .top.t .top
+} -result {Still doing fine!}
+
+test text-12.1 {TextWidgetCmd procedure, "index" option} -setup {
+ text .t
+} -body {
+ .t index
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t index index"}
+test text-12.2 {TextWidgetCmd procedure, "index" option} -setup {
+ text .t
+} -body {
+ .t ind a b
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t index index"}
+test text-12.3 {TextWidgetCmd procedure, "index" option} -setup {
+ text .t
+} -body {
+ .t in a b
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {ambiguous option "in": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview}
+test text-12.4 {TextWidgetCmd procedure, "index" option} -setup {
+ text .t
+} -body {
+ .t index @xyz
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "@xyz"}
+test text-12.5 {TextWidgetCmd procedure, "index" option} -setup {
+ [text .t] insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+} -body {
+ .t index 1.2
+} -cleanup {
+ destroy .t
+} -result 1.2
+
+
+test text-13.1 {TextWidgetCmd procedure, "insert" option} -setup {
+ [text .t] insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+} -body {
+ .t insert 1.2
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t insert index chars ?tagList chars tagList ...?"}
+test text-13.2 {TextWidgetCmd procedure, "insert" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t config -state disabled
+ .t insert 1.2 xyzzy
+ .t get 1.0 1.end
+} -cleanup {
+ destroy .t
+} -result {Line 1}
+test text-13.3 {TextWidgetCmd procedure, "insert" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t insert 1.2 xyzzy
+ .t get 1.0 1.end
+} -cleanup {
+ destroy .t
+} -result {Lixyzzyne 1}
+test text-13.4 {TextWidgetCmd procedure, "insert" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Line 1
+aefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+ .t delete 1.0 end
+ .t insert 1.0 "Sample text" x
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {1.0 1.11}
+test text-13.5 {TextWidgetCmd procedure, "insert" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Sample text" x
+ .t insert 1.2 "XYZ" y
+ list [.t tag ranges x] [.t tag ranges y]
+} -cleanup {
+ destroy .t
+} -result {{1.0 1.2 1.5 1.14} {1.2 1.5}}
+test text-13.6 {TextWidgetCmd procedure, "insert" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Sample text" {x y z}
+ list [.t tag ranges x] [.t tag ranges y] [.t tag ranges z]
+} -cleanup {
+ destroy .t
+} -result {{1.0 1.11} {1.0 1.11} {1.0 1.11}}
+test text-13.7 {TextWidgetCmd procedure, "insert" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Sample text" {x y z}
+ .t insert 1.3 "A" {a b z}
+ list [.t tag ranges a] [.t tag ranges b] [.t tag ranges x] [.t tag ranges y] [.t tag ranges z]
+} -cleanup {
+ destroy .t
+} -result {{1.3 1.4} {1.3 1.4} {1.0 1.3 1.4 1.12} {1.0 1.3 1.4 1.12} {1.0 1.12}}
+test text-13.8 {TextWidgetCmd procedure, "insert" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "Sample text" "a \{b"
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {unmatched open brace in list}
+test text-13.9 {TextWidgetCmd procedure, "insert" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "First" bold " " {} second "x y z" " third"
+ list [.t get 1.0 1.end] [.t tag ranges bold] [.t tag ranges x] \
+ [.t tag ranges y] [.t tag ranges z]
+} -cleanup {
+ destroy .t
+} -result {{First second third} {1.0 1.5} {1.6 1.12} {1.6 1.12} {1.6 1.12}}
+test text-13.10 {TextWidgetCmd procedure, "insert" option} -setup {
+ text .t
+} -body {
+ .t insert 1.0 "First" bold " second" silly
+ list [.t get 1.0 1.end] [.t tag ranges bold] [.t tag ranges silly]
+} -cleanup {
+ destroy .t
+} -result {{First second} {1.0 1.5} {1.5 1.12}}
+
+# Edit, mark, scan, search, see, tag, window, xview, and yview actions are tested elsewhere.
+
+test text-14.1 {ConfigureText procedure} -setup {
+ text .t
+} -body {
+ .t configure -state foobar
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad state "foobar": must be disabled or normal}
+test text-14.2 {ConfigureText procedure} -setup {
+ text .t
+} -body {
+ .t configure -spacing1 -2 -spacing2 1 -spacing3 1
+ list [.t cget -spacing1] [.t cget -spacing2] [.t cget -spacing3]
+} -cleanup {
+ destroy .t
+} -result {0 1 1}
+test text-14.3 {ConfigureText procedure} -setup {
+ text .t
+} -body {
+ .t configure -spacing1 1 -spacing2 -1 -spacing3 1
+ list [.t cget -spacing1] [.t cget -spacing2] [.t cget -spacing3]
+} -cleanup {
+ destroy .t
+} -result {1 0 1}
+test text-14.4 {ConfigureText procedure} -setup {
+ text .t
+} -body {
+ .t configure -spacing1 1 -spacing2 1 -spacing3 -3
+ list [.t cget -spacing1] [.t cget -spacing2] [.t cget -spacing3]
+} -cleanup {
+ destroy .t
+} -result {1 1 0}
+test text-14.5 {ConfigureText procedure} -setup {
+ text .t
+} -body {
+ .t configure -tabs {30 foo}
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad tab alignment "foo": must be left, right, center, or numeric}
+test text-14.6 {ConfigureText procedure} -setup {
+ text .t
+} -body {
+ catch {.t configure -tabs {30 foo}}
+ .t configure -tabs {10 20 30}
+ return $errorInfo
+} -cleanup {
+ destroy .t
+} -result {bad tab alignment "foo": must be left, right, center, or numeric
+ (while processing -tabs option)
+ invoked from within
+".t configure -tabs {30 foo}"}
+test text-14.7 {ConfigureText procedure} -setup {
+ text .t
+} -body {
+ .t configure -tabs {10 20 30}
+ .t configure -tabs {}
+ .t cget -tabs
+} -cleanup {
+ destroy .t
+} -result {}
+test text-14.8 {ConfigureText procedure} -setup {
+ text .t
+} -body {
+ .t configure -wrap bogus
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad wrap "bogus": must be char, none, or word}
+test text-14.9 {ConfigureText procedure} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+} -body {
+ .t configure -selectborderwidth 17 -selectforeground #332211 \
+ -selectbackground #abc
+ list [lindex [.t tag config sel -borderwidth] 4] \
+ [lindex [.t tag config sel -foreground] 4] \
+ [lindex [.t tag config sel -background] 4]
+} -cleanup {
+ destroy .t
+} -result {17 #332211 #abc}
+test text-14.10 {ConfigureText procedure} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+} -body {
+ .t configure -selectborderwidth {}
+ .t tag cget sel -borderwidth
+} -cleanup {
+ destroy .t
+} -result {}
+test text-14.11 {ConfigureText procedure} -setup {
+ text .t
+} -body {
+ .t configure -selectborderwidth foo
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad screen distance "foo"}
+test text-14.12 {ConfigureText procedure} -body {
+ text .t
+ entry .t.e
+ .t.e insert end abcdefg
+ .t.e select from 0
+ .t.e select to 2
+ text .t2 -exportselection 1
+ selection get
+} -cleanup {
+ destroy .t .t2
+} -result {ab}
+test text-14.13 {ConfigureText procedure} -body {
+ text .t
+ entry .t.e
+ .t.e insert end abcdefg
+ .t.e select from 0
+ .t.e select to 2
+ text .t2 -exportselection 0
+ .t2 insert insert 1234657890
+ .t2 tag add sel 1.0 1.4
+ selection get
+} -cleanup {
+ destroy .t .t2
+} -result {ab}
+test text-14.14 {ConfigureText procedure} -body {
+ text .t
+ entry .t.e
+ .t.e insert end abcdefg
+ .t.e select from 0
+ .t.e select to 1
+ text .t2 -exportselection 1
+ .t2 insert insert 1234657890
+ .t2 tag add sel 1.0 1.4
+ selection get
+} -cleanup {
+ destroy .t .t2
+} -result {1234}
+test text-14.15 {ConfigureText procedure} -body {
+ text .t
+ entry .t.e
+ .t.e insert end abcdefg
+ .t.e select from 0
+ .t.e select to 1
+ text .t2 -exportselection 0
+ .t2 insert insert 1234657890
+ .t2 tag add sel 1.0 1.4
+ .t2 configure -exportselection 1
+ selection get
+} -cleanup {
+ destroy .t2 .t
+} -result {1234}
+test text-14.16 {ConfigureText procedure} -body {
+ text .t
+ entry .t.e
+ .t.e insert end abcdefg
+ .t.e select from 0
+ text .t2 -exportselection 1
+ .t2 insert insert 1234657890
+ .t2 tag add sel 1.0 1.4
+ selection get
+ .t2 configure -exportselection 0
+ selection get
+} -cleanup {
+ destroy .t .t2
+} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined}
+test text-14.17 {ConfigureText procedure} -body {
+ text .t
+ entry .t.e
+ .t.e insert end abcdefg
+ .t.e select from 0
+ text .t2 -exportselection 1
+ .t2 insert insert 1234657890
+ .t2 tag add sel 1.0 1.4
+ set result [selection get]
+ .t2 configure -exportselection 0
+ catch {selection get}
+ return $result
+} -cleanup {
+ destroy .t .t2
+} -result {1234}
+test text-14.18 {ConfigureText procedure} -constraints fonts -setup {
+ toplevel .top
+ text .top.t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+} -body {
+ .top.t configure -width 20 -height 10
+ pack append .top .top.t top
+ update
+ set geom [wm geometry .top]
+ set x [string range $geom 0 [string first + $geom]]
+} -cleanup {
+ destroy .top
+} -result {150x140+}
+# This test was failing Windows because the title bar on .t was a certain
+# minimum size and it was interfering with the size requested by the -setgrid.
+# The "overrideredirect" gets rid of the titlebar so the toplevel can shrink
+# to the appropriate size.
+test text-14.19 {ConfigureText procedure} -setup {
+ toplevel .top
+ text .top.t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+} -body {
+ .top.t configure -width 20 -height 10 -setgrid 1
+ wm overrideredirect .top 1
+ pack append .top .top.t top
+ wm geometry .top +0+0
+ update
+ wm geometry .top
+} -cleanup {
+ destroy .top
+} -result {20x10+0+0}
+# This test was failing on Windows because the title bar on .t was a certain
+# minimum size and it was interfering with the size requested by the -setgrid.
+# The "overrideredirect" gets rid of the titlebar so the toplevel can shrink
+# to the appropriate size.
+test text-14.20 {ConfigureText procedure} -setup {
+ toplevel .top
+ text .top.t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+} -body {
+ .top.t configure -width 20 -height 10 -setgrid 1
+ wm overrideredirect .top 1
+ pack append .top .top.t top
+ wm geometry .top +0+0
+ update
+ set result [wm geometry .top]
+ wm geometry .top 15x8
+ update
+ lappend result [wm geometry .top]
+ .top.t configure -wrap word
+ update
+ lappend result [wm geometry .top]
+} -cleanup {
+ destroy .top
+} -result {20x10+0+0 15x8+0+0 15x8+0+0}
+
+
+test text-15.1 {TextWorldChanged procedure, spacing options} -constraints {
+ fonts
+} -body {
+ text .t -width 20 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ set result [winfo reqheight .t]
+ .t configure -spacing1 2
+ lappend result [winfo reqheight .t]
+ .t configure -spacing3 1
+ lappend result [winfo reqheight .t]
+ .t configure -spacing1 0
+ lappend result [winfo reqheight .t]
+} -cleanup {
+ destroy .t
+} -result {140 160 170 150}
+
+
+test text-16.1 {TextEventProc procedure} -body {
+ text .tx1 -bg #543210
+ rename .tx1 .tx2
+ set x {}
+ lappend x [winfo exists .tx1]
+ lappend x [.tx2 cget -bg]
+ destroy .tx1
+ lappend x [info command .tx*] [winfo exists .tx1] [winfo exists .tx2]
+} -cleanup {
+ destroy .txt1
+} -result {1 #543210 {} 0 0}
+
+
+test text-17.1 {TextCmdDeletedProc procedure} -body {
+ text .tx1
+ rename .tx1 {}
+ list [info command .tx*] [winfo exists .tx1]
+} -cleanup {
+ destroy .txt1
+} -result {{} 0}
+test text-17.2 {TextCmdDeletedProc procedure, disabling -setgrid} -constraints {
+ fonts
+} -body {
+ toplevel .top
+ text .top.t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} \
+ -setgrid 1 -width 20 -height 10
+ pack .top.t
+ update
+ set geom [wm geometry .top]
+ set x [string range $geom 0 [string first + $geom]]
+ rename .top.t {}
+ update
+ set geom [wm geometry .top]
+ lappend x [string range $geom 0 [string first + $geom]]
+ return $x
+} -cleanup {
+ destroy .top
+} -result {20x10+ 150x140+}
+
+
+test text-18.1 {InsertChars procedure} -body {
+ text .t
+ .t insert 2.0 abcd\n
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result {abcd
+
+}
+test text-18.2 {InsertChars procedure} -body {
+ text .t
+ .t insert 1.0 abcd\n
+ .t insert end 123\n
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result {abcd
+123
+
+}
+test text-18.3 {InsertChars procedure} -body {
+ text .t
+ .t insert 1.0 abcd\n
+ .t insert 10.0 123
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result {abcd
+123
+}
+test text-18.4 {InsertChars procedure, inserting on top visible line} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .t
+} -body {
+ .t configure -width 20 -height 4 -wrap word
+ .t insert insert "Now is the time for all great men to come to the "
+ .t insert insert "aid of their party.\n"
+ .t insert insert "Now is the time for all great men.\n"
+ .t see end
+ update
+ .t insert 1.0 "Short\n"
+ .t index @0,0
+} -cleanup {
+ destroy .t
+} -result {2.56}
+test text-18.5 {InsertChars procedure, inserting on top visible line} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .t
+} -body {
+ .t configure -width 20 -height 4 -wrap word
+ .t insert insert "Now is the time for all great men to come to the "
+ .t insert insert "aid of their party.\n"
+ .t insert insert "Now is the time for all great men.\n"
+ .t see end
+ update
+ .t insert 1.55 "Short\n"
+ .t index @0,0
+} -cleanup {
+ destroy .t
+} -result {2.0}
+test text-18.6 {InsertChars procedure, inserting on top visible line} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .t
+} -body {
+ .t configure -width 20 -height 4 -wrap word
+ .t insert insert "Now is the time for all great men to come to the "
+ .t insert insert "aid of their party.\n"
+ .t insert insert "Now is the time for all great men.\n"
+ .t see end
+ update
+ .t insert 1.56 "Short\n"
+ .t index @0,0
+} -cleanup {
+ destroy .t
+} -result {1.56}
+test text-18.7 {InsertChars procedure, inserting on top visible line} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .t
+} -body {
+ .t configure -width 20 -height 4 -wrap word
+ .t insert insert "Now is the time for all great men to come to the "
+ .t insert insert "aid of their party.\n"
+ .t insert insert "Now is the time for all great men.\n"
+ .t see end
+ update
+ .t insert 1.57 "Short\n"
+ .t index @0,0
+} -cleanup {
+ destroy .t
+} -result {1.56}
+
+
+test text-19.1 {DeleteChars procedure} -body {
+ text .t
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result {
+}
+test text-19.2 {DeleteChars procedure} -body {
+ text .t
+ .t delete foobar
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "foobar"}
+test text-19.3 {DeleteChars procedure} -body {
+ text .t
+ .t delete 1.0 lousy
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "lousy"}
+test text-19.4 {DeleteChars procedure} -body {
+ text .t
+ .t insert 1.0 "Line 1
+abcde
+12345
+Line 4"
+ .t delete 2.1
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result {Line 1
+acde
+12345
+Line 4
+}
+test text-19.5 {DeleteChars procedure} -body {
+ text .t
+ .t insert 1.0 "Line 1
+abcde
+12345
+Line 4"
+ .t delete 2.3
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result {Line 1
+abce
+12345
+Line 4
+}
+test text-19.6 {DeleteChars procedure} -body {
+ text .t
+ .t insert 1.0 "Line 1
+abcde
+12345
+Line 4"
+ .t delete 2.end
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result {Line 1
+abcde12345
+Line 4
+}
+test text-19.7 {DeleteChars procedure} -body {
+ text .t
+ .t insert 1.0 "Line 1
+abcde
+12345
+Line 4"
+ .t tag add sel 4.2 end
+ .t delete 4.2 end
+ list [.t tag ranges sel] [.t get 1.0 end]
+} -cleanup {
+ destroy .t
+} -result {{} {Line 1
+abcde
+12345
+Li
+}}
+test text-19.8 {DeleteChars procedure} -body {
+ text .t
+ .t insert 1.0 "Line 1
+abcde
+12345
+Line 4"
+ .t tag add sel 1.0 end
+ .t delete 4.0 end
+ list [.t tag ranges sel] [.t get 1.0 end]
+} -cleanup {
+ destroy .t
+} -result {{1.0 3.5} {Line 1
+abcde
+12345
+}}
+test text-19.9 {DeleteChars procedure} -body {
+ text .t
+ .t insert 1.0 "Line 1
+abcde
+12345
+Line 4"
+ .t delete 2.2 2.2
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result {Line 1
+abcde
+12345
+Line 4
+}
+test text-19.10 {DeleteChars procedure} -body {
+ text .t
+ .t insert 1.0 "Line 1
+abcde
+12345
+Line 4"
+ .t delete 2.3 2.1
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result {Line 1
+abcde
+12345
+Line 4
+}
+test text-19.11 {DeleteChars procedure} -body {
+ toplevel .top
+ text .top.t -width 20 -height 5
+ pack append .top .top.t top
+ wm geometry .top +0+0
+ .top.t insert 1.0 "abc\n123\nx\ny\nz\nq\nr\ns"
+ update
+ .top.t delete 1.0 3.0
+ list [.top.t index @0,0] [.top.t get @0,0]
+} -cleanup {
+ destroy .top
+} -result {1.0 x}
+test text-19.12 {DeleteChars procedure} -body {
+ toplevel .top
+ text .top.t -width 20 -height 5
+ pack append .top .top.t top
+ wm geometry .top +0+0
+ .top.t insert 1.0 "abc\n123\nx\ny\nz\nq\nr\ns"
+ .top.t yview 3.0
+ update
+ .top.t delete 2.0 4.0
+ list [.top.t index @0,0] [.top.t get @0,0]
+} -cleanup {
+ destroy .top
+} -result {2.0 y}
+test text-19.13 {DeleteChars procedure, updates affecting topIndex} -setup {
+ toplevel .top
+ text .top.t -width 1 -height 10 -wrap char
+ pack .top.t -side left
+ wm geometry .top +0+0
+ update
+} -body {
+ .top.t insert end "abcde\n12345\nqrstuv"
+ .top.t yview 2.1
+ .top.t delete 1.4 2.3
+ .top.t index @0,0
+} -cleanup {
+ destroy .top
+} -result {1.2}
+test text-19.14 {DeleteChars procedure, updates affecting topIndex} -setup {
+ toplevel .top
+ text .top.t -width 1 -height 10 -wrap char
+ pack .top.t -side left
+ wm geometry .top +0+0
+ update
+} -body {
+ .top.t insert end "abcde\n12345\nqrstuv"
+ .top.t yview 2.1
+ .top.t delete 2.3 2.4
+ .top.t index @0,0
+} -cleanup {
+ destroy .top
+} -result {2.0}
+test text-19.15 {DeleteChars procedure, updates affecting topIndex} -setup {
+ toplevel .top
+ text .top.t -width 1 -height 10 -wrap char
+ pack .top.t -side left
+ wm geometry .top +0+0
+ update
+} -body {
+ .top.t insert end "abcde\n12345\nqrstuv"
+ .top.t yview 1.3
+ .top.t delete 1.0 1.2
+ .top.t index @0,0
+} -cleanup {
+ destroy .top
+} -result {1.1}
+test text-19.16 {DeleteChars procedure, updates affecting topIndex} -setup {
+ toplevel .top
+ text .top.t -width 6 -height 10 -wrap word
+ frame .top.f -width 200 -height 20 -relief raised -bd 2
+ pack .top.f .top.t -side left
+ wm geometry .top +0+0
+ update
+} -body {
+ .top.t insert end "abc def\n01 2345 678 9101112\nLine 3\nLine 4\nLine 5\n6\n7\n8\n"
+ .top.t yview 2.4
+ .top.t delete 2.5
+ set x [.top.t index @0,0]
+ .top.t delete 2.5
+ list $x [.top.t index @0,0]
+} -cleanup {
+ destroy .top
+} -result {2.3 2.0}
+
+
+test text-20.1 {TextFetchSelection procedure} -setup {
+ text .t -width 20 -height 10
+ pack append . .t {top expand fill}
+ update
+} -body {
+ foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ .t insert end $i.0$i.1$i.2$i.3$i.4\n
+ }
+ .t tag add sel 1.3 3.4
+ selection get
+} -cleanup {
+ destroy .t
+} -result {a.1a.2a.3a.4
+b.0b.1b.2b.3b.4
+c.0c}
+test text-20.2 {TextFetchSelection procedure} -setup {
+ text .t -width 20 -height 10
+ pack append . .t {top expand fill}
+ update
+} -body {
+ foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ .t insert end $i.0$i.1$i.2$i.3$i.4\n
+ }
+ .t tag add x 1.2
+ .t tag add x 1.4
+ .t tag add x 2.0
+ .t tag add x 2.3
+ .t tag remove sel 1.0 end
+ .t tag add sel 1.0 3.4
+ selection get
+} -cleanup {
+ destroy .t
+} -result {a.0a.1a.2a.3a.4
+b.0b.1b.2b.3b.4
+c.0c}
+test text-20.3 {TextFetchSelection procedure} -setup {
+ text .t -width 20 -height 10
+ pack append . .t {top expand fill}
+ update
+} -body {
+ foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ .t insert end $i.0$i.1$i.2$i.3$i.4\n
+ }
+ .t tag remove sel 1.0 end
+ .t tag add sel 13.3
+ selection get
+} -cleanup {
+ destroy .t
+} -result {m}
+test text-20.4 {TextFetchSelection procedure} -setup {
+ text .t -width 20 -height 10
+ pack append . .t {top expand fill}
+ update
+} -body {
+ foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ .t insert end $i.0$i.1$i.2$i.3$i.4\n
+ }
+ .t tag remove x 1.0 end
+ .t tag add sel 1.0 3.4
+ .t tag remove sel 1.0 end
+ .t tag add sel 1.2 1.5
+ .t tag add sel 2.4 3.1
+ .t tag add sel 10.0 10.end
+ .t tag add sel 13.3
+ selection get
+} -cleanup {
+ destroy .t
+} -result {0a..1b.2b.3b.4
+cj.0j.1j.2j.3j.4m}
+test text-20.5 {TextFetchSelection procedure, long selections} -setup {
+ text .t -width 20 -height 10
+ pack append . .t {top expand fill}
+ update
+ set x ""
+} -body {
+ for {set i 1} {$i < 200} {incr i} {
+ append x "This is line $i, padded to just about 53 characters.\n"
+ }
+ .t insert end $x
+ .t tag add sel 1.0 end
+ expr {[selection get] eq "$x\n"}
+} -cleanup {
+ destroy .t
+} -result {1}
+
+
+test text-21.1 {TkTextLostSelection procedure} -constraints unix -setup {
+ text .t
+ .t insert 1.0 "Line 1"
+ entry .t.e
+ .t.e insert end "abcdefg"
+ text .t2
+ .t2 insert 1.0 "abc\ndef\nghijk\n1234"
+} -body {
+ .t2 tag add sel 1.2 3.3
+ .t.e select from 0
+ .t.e select to 1
+ .t2 tag ranges sel
+} -cleanup {
+ destroy .t .t2
+} -result {}
+test text-21.2 {TkTextLostSelection procedure} -constraints win -setup {
+ text .t
+ .t insert 1.0 "Line 1"
+ entry .t.e
+ .t.e insert end "abcdefg"
+ text .t2
+ .t2 insert 1.0 "abc\ndef\nghijk\n1234"
+} -body {
+ .t2 tag add sel 1.2 3.3
+ .t.e select from 0
+ .t.e select to 1
+ .t2 tag ranges sel
+} -cleanup {
+ destroy .t .t2
+} -result {1.2 3.3}
+test text-21.3 {TkTextLostSelection procedure} -body {
+ text .t
+ .t insert 1.0 "abcdef\nghijk\n1234"
+ .t tag add sel 1.0 1.3
+ selection get
+ selection clear
+ selection get
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined}
+test text-21.4 {TkTextLostSelection procedure} -body {
+ text .t
+ .t insert 1.0 "abcdef\nghijk\n1234"
+ .t tag add sel 1.0 1.3
+ set x [selection get]
+ selection clear
+ catch {selection get}
+ .t tag add sel 1.0 1.3
+ lappend x [selection get]
+} -cleanup {
+ destroy .t
+} -result {abc abc}
+
+
+test text-22.1 {TextSearchCmd procedure, argument parsing} -body {
+ text .t
+ .t search -
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {ambiguous switch "-": must be --, -all, -backwards, -count, -elide, -exact, -forwards, -nocase, -nolinestop, -overlap, -regexp, or -strictlimits}
+test text-22.2 {TextSearchCmd procedure, -backwards option} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -backwards xyz 1.4
+} -cleanup {
+ destroy .t
+} -result {1.1}
+test text-22.3 {TextSearchCmd procedure, -all option} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -all xyz 1.4
+} -cleanup {
+ destroy .t
+} -result {1.5 3.0 3.5 1.1}
+test text-22.4 {TextSearchCmd procedure, -forwards option} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -forwards xyz 1.4
+} -cleanup {
+ destroy .t
+} -result {1.5}
+test text-22.5 {TextSearchCmd procedure, -exact option} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -f -exact x. 1.0
+} -cleanup {
+ destroy .t
+} -result {1.9}
+test text-22.6 {TextSearchCmd procedure, -regexp option} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -b -regexp x.z 1.4
+} -cleanup {
+ destroy .t
+} -result {1.1}
+test text-22.7 {TextSearchCmd procedure, -count option} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ set length unmodified
+ list [.t search -count length x. 1.4] $length
+} -cleanup {
+ destroy .t
+} -result {1.9 2}
+test text-22.8 {TextSearchCmd procedure, -count option} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -count
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {no value given for "-count" option}
+test text-22.9 {TextSearchCmd procedure, -nocase option} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ list [.t search -nocase BaR 1.1] [.t search BaR 1.1]
+} -cleanup {
+ destroy .t
+} -result {2.13 2.23}
+test text-22.10 {TextSearchCmd procedure, -n ambiguous option} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -n BaR 1.1
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {ambiguous switch "-n": must be --, -all, -backwards, -count, -elide, -exact, -forwards, -nocase, -nolinestop, -overlap, -regexp, or -strictlimits}
+test text-22.11 {TextSearchCmd procedure, -nocase option} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -noc BaR 1.1
+} -cleanup {
+ destroy .t
+} -result {2.13}
+test text-22.12 {TextSearchCmd procedure, -nolinestop option} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -nolinestop BaR 1.1
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {the "-nolinestop" option requires the "-regexp" option to be present}
+test text-22.13 {TextSearchCmd procedure, -nolinestop option} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ set msg ""
+ list [.t search -nolinestop -regexp -count msg e.*o 1.1] $msg
+} -cleanup {
+ destroy .t
+} -result {1.14 32}
+test text-22.14 {TextSearchCmd procedure, -- option} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -- -forward 1.0
+} -cleanup {
+ destroy .t
+} -result {2.4}
+test text-22.15 {TextSearchCmd procedure, argument parsing} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search abc
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t search ?switches? pattern index ?stopIndex?"}
+test text-22.16 {TextSearchCmd procedure, argument parsing} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search abc d e f
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t search ?switches? pattern index ?stopIndex?"}
+test text-22.17 {TextSearchCmd procedure, check index} -body {
+ text .t
+ .t search abc gorp
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "gorp"}
+test text-22.18 {TextSearchCmd procedure, startIndex == "end"} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search non-existent end
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.19 {TextSearchCmd procedure, startIndex == "end"} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search non-existent end
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.20 {TextSearchCmd procedure, bad stopIndex} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search abc 1.0 lousy
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "lousy"}
+test text-22.21 {TextSearchCmd procedure, pattern case conversion} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ list [.t search -nocase BAR 1.1] [.t search BAR 1.1]
+} -cleanup {
+ destroy .t
+} -result {2.13 {}}
+test text-22.22 {TextSearchCmd procedure, bad regular expression pattern} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -regexp a( 1.0
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {couldn't compile regular expression pattern: parentheses () not balanced}
+test text-22.23 {TextSearchCmd procedure, skip dummy last line} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -backwards BaR end 1.0
+} -cleanup {
+ destroy .t
+} -result {2.23}
+test text-22.24 {TextSearchCmd procedure, skip dummy last line} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -backwards \n end 1.0
+} -cleanup {
+ destroy .t
+} -result {3.9}
+test text-22.25 {TextSearchCmd procedure, skip dummy last line} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search \n end
+} -cleanup {
+ destroy .t
+} -result {1.15}
+test text-22.26 {TextSearchCmd procedure, skip dummy last line} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -back \n 1.0
+} -cleanup {
+ destroy .t
+} -result {3.9}
+test text-22.27 {TextSearchCmd procedure, extract line contents} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t tag add foo 1.2
+ .t tag add x 1.3
+ .t mark set silly 1.2
+ .t search xyz 3.6
+} -cleanup {
+ destroy .t
+} -result {1.1}
+test text-22.28 {TextSearchCmd procedure, stripping newlines} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search the\n 1.0
+} -cleanup {
+ destroy .t
+} -result {1.12}
+test text-22.29 {TextSearchCmd procedure, handling newlines} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -regexp the\n 1.0
+} -cleanup {
+ destroy .t
+} -result {1.12}
+test text-22.30 {TextSearchCmd procedure, stripping newlines} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -regexp {the$} 1.0
+} -cleanup {
+ destroy .t
+} -result {1.12}
+test text-22.31 {TextSearchCmd procedure, handling newlines} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -regexp \n 1.0
+} -cleanup {
+ destroy .t
+} -result {1.15}
+test text-22.32 {TextSearchCmd procedure, line case conversion} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ list [.t search -nocase bar 2.18] [.t search bar 2.18]
+} -cleanup {
+ destroy .t
+} -result {2.23 2.13}
+test text-22.33 {TextSearchCmd procedure, firstChar and lastChar} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -backwards xyz 1.6
+} -cleanup {
+ destroy .t
+} -result {1.5}
+test text-22.34 {TextSearchCmd procedure, firstChar and lastChar} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -backwards xyz 1.5
+} -cleanup {
+ destroy .t
+} -result {1.1}
+test text-22.35 {TextSearchCmd procedure, firstChar and lastChar} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search xyz 1.5
+} -cleanup {
+ destroy .t
+} -result {1.5}
+test text-22.36 {TextSearchCmd procedure, firstChar and lastChar} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search xyz 1.6
+} -cleanup {
+ destroy .t
+} -result {3.0}
+test text-22.37 {TextSearchCmd procedure, firstChar and lastChar} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search {} 1.end
+} -cleanup {
+ destroy .t
+} -result {1.15}
+test text-22.38 {TextSearchCmd procedure, firstChar and lastChar} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search f 1.end
+} -cleanup {
+ destroy .t
+} -result {2.0}
+test text-22.39 {TextSearchCmd procedure, firstChar and lastChar} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search {} end
+} -cleanup {
+ destroy .t
+} -result {1.0}
+test text-22.40 {TextSearchCmd procedure, regexp finds empty lines} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+# Test for fix of bug #1643
+ .t insert end "\n"
+ tk::TextSetCursor .t 4.0
+ .t search -forward -regexp {^$} insert end
+} -cleanup {
+ destroy .t
+} -result {4.0}
+test text-22.41 {TextSearchCmd procedure, firstChar and lastChar} -setup {
+ toplevel .top
+ text .top.t -width 30 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .top.t
+} -body {
+ .top.t insert 1.0 "This is a line\nand this is another"
+ .top.t insert end "\nand this is yet another"
+ frame .top.f -width 20 -height 20 -bd 2 -relief raised
+ .top.t window create 2.5 -window .top.f
+ .top.t search his 2.6
+} -cleanup {
+ destroy .top
+} -result {2.6}
+test text-22.42 {TextSearchCmd procedure, firstChar and lastChar} -setup {
+ toplevel .top
+ text .top.t -width 30 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .top.t
+} -body {
+ .top.t insert 1.0 "This is a line\nand this is another"
+ .top.t insert end "\nand this is yet another"
+ frame .top.f -width 20 -height 20 -bd 2 -relief raised
+ .top.t window create 2.5 -window .top.f
+ .top.t search this 2.6
+} -cleanup {
+ destroy .top
+} -result {3.4}
+test text-22.43 {TextSearchCmd procedure, firstChar and lastChar} -setup {
+ toplevel .top
+ text .top.t -width 30 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .top.t
+} -body {
+ .top.t insert 1.0 "This is a line\nand this is another"
+ .top.t insert end "\nand this is yet another"
+ frame .top.f -width 20 -height 20 -bd 2 -relief raised
+ .top.t window create 2.5 -window .top.f
+ .top.t search is 2.6
+} -cleanup {
+ destroy .top
+} -result {2.7}
+test text-22.44 {TextSearchCmd procedure, firstChar and lastChar} -setup {
+ toplevel .top
+ text .top.t -width 30 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .top.t
+} -body {
+ .top.t insert 1.0 "This is a line\nand this is another"
+ .top.t insert end "\nand this is yet another"
+ frame .top.f -width 20 -height 20 -bd 2 -relief raised
+ .top.t window create 2.5 -window .top.f
+ .top.t search his 2.7
+} -cleanup {
+ destroy .top
+} -result {3.5}
+test text-22.45 {TextSearchCmd procedure, firstChar and lastChar} -setup {
+ toplevel .top
+ text .top.t -width 30 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .top.t
+} -body {
+ .top.t insert 1.0 "This is a line\nand this is another"
+ .top.t insert end "\nand this is yet another"
+ frame .top.f -width 20 -height 20 -bd 2 -relief raised
+ .top.t window create 2.5 -window .top.f
+ .top.t search -backwards "his is another" 2.6
+} -cleanup {
+ destroy .top
+} -result {2.6}
+test text-22.46 {TextSearchCmd procedure, firstChar and lastChar} -setup {
+ toplevel .top
+ text .top.t -width 30 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .top.t
+} -body {
+ .top.t insert 1.0 "This is a line\nand this is another"
+ .top.t insert end "\nand this is yet another"
+ frame .top.f -width 20 -height 20 -bd 2 -relief raised
+ .top.t window create 2.5 -window .top.f
+ .top.t search -backwards "his is" 2.6
+} -cleanup {
+ destroy .top
+} -result {1.1}
+test text-22.47 {TextSearchCmd procedure, firstChar and lastChar} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -backwards forw 2.5
+} -cleanup {
+ destroy .t
+} -result {2.5}
+test text-22.48 {TextSearchCmd procedure, firstChar and lastChar} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search forw 2.5
+} -cleanup {
+ destroy .t
+} -result {2.5}
+test text-22.49 {TextSearchCmd procedure, firstChar and lastChar} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ catch {destroy .t}
+ text .t2
+ list [.t2 search a 1.0] [.t2 search -backward a 1.0]
+} -cleanup {
+ destroy .t .t2
+} -result {{} {}}
+test text-22.50 {TextSearchCmd procedure, regexp match length} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ set length unchanged
+ list [.t search -regexp -count length x(.)(.*)z 1.1] $length
+} -cleanup {
+ destroy .t
+} -result {1.1 7}
+test text-22.51 {TextSearchCmd procedure, regexp match length} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ set length unchanged
+ list [.t search -regexp -backward -count length fo* 2.5] $length
+} -cleanup {
+ destroy .t
+} -result {2.0 3}
+test text-22.52 {TextSearchCmd procedure, checking stopIndex} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ list [.t search bar 2.1 2.13] [.t search bar 2.1 2.14] \
+ [.t search bar 2.12 2.14] [.t search bar 2.14 2.14]
+} -cleanup {
+ destroy .t
+} -result {{} 2.13 2.13 {}}
+test text-22.53 {TextSearchCmd procedure, checking stopIndex} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ list [.t search -backwards bar 2.20 2.13] \
+ [.t search -backwards bar 2.20 2.14] \
+ [.t search -backwards bar 2.14 2.13] \
+ [.t search -backwards bar 2.13 2.13]
+} -cleanup {
+ destroy .t
+} -result {2.13 {} 2.13 {}}
+test text-22.54 {TextSearchCmd procedure, checking stopIndex} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ list [.t search -backwards -strict bar 2.20 2.13] \
+ [.t search -backwards -strict bar 2.20 2.14] \
+ [.t search -backwards -strict bar 2.14 2.13] \
+ [.t search -backwards -strict bar 2.13 2.13]
+} -cleanup {
+ destroy .t
+} -result {2.13 {} {} {}}
+test text-22.55 {TextSearchCmd procedure, embedded windows and index/count} -setup {
+ text .t
+ frame .t.f1 -width 20 -height 20 -relief raised -bd 2
+ frame .t.f2 -width 20 -height 20 -relief raised -bd 2
+ frame .t.f3 -width 20 -height 20 -relief raised -bd 2
+ frame .t.f4 -width 20 -height 20 -relief raised -bd 2
+ set result ""
+} -body {
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t window create 2.10 -window .t.f3
+ .t window create 2.8 -window .t.f2
+ .t window create 2.8 -window .t.f1
+ .t window create 2.1 -window .t.f4
+ lappend result [.t search -count x forward 1.0] $x
+ lappend result [.t search -count x wa 1.0] $x
+ return $result
+} -cleanup {
+ destroy .t
+} -result {2.6 10 2.11 2}
+test text-22.56 {TextSearchCmd procedure, error setting variable} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ set a 44
+ .t search -count a(2) xyz 1.0
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {can't set "a(2)": variable isn't array}
+test text-22.57 {TextSearchCmd procedure, wrap-around} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -backwards xyz 1.1
+} -cleanup {
+ destroy .t
+} -result {3.5}
+test text-22.58 {TextSearchCmd procedure, wrap-around} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -backwards xyz 1.1 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.59 {TextSearchCmd procedure, wrap-around} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search xyz 3.6
+} -cleanup {
+ destroy .t
+} -result {1.1}
+test text-22.60 {TextSearchCmd procedure, wrap-around} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search xyz 3.6 end
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.61 {TextSearchCmd procedure, no match} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search non_existent 3.5
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.62 {TextSearchCmd procedure, no match} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -regexp non_existent 3.5
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.63 {TextSearchCmd procedure, special cases} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -back x 1.1
+} -cleanup {
+ destroy .t
+} -result {1.0}
+test text-22.64 {TextSearchCmd procedure, special cases} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search -back x 1.0
+} -cleanup {
+ destroy .t
+} -result {3.8}
+test text-22.65 {TextSearchCmd procedure, special cases} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search \n {end-2c}
+} -cleanup {
+ destroy .t
+} -result {3.9}
+test text-22.66 {TextSearchCmd procedure, special cases} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search \n end
+} -cleanup {
+ destroy .t
+} -result {1.15}
+test text-22.67 {TextSearchCmd procedure, special cases} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+ .t search x 1.0
+} -cleanup {
+ destroy .t
+} -result {1.0}
+test text-22.68 {TextSearchCmd, freeing copy of pattern} -body {
+ text .t
+ .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx"
+# This test doesn't return a result, but it will generate
+# a core leak if the pattern copy isn't properly freed.
+# (actually in Tk 8.5 objectification means there is no
+# longer a copy of the pattern, but we leave this test in
+# anyway).
+ set p abcdefg1234567890
+ set p $p$p$p$p$p$p$p$p
+ set p $p$p$p$p$p
+ .t search -nocase $p 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.69 {TextSearchCmd, unicode} -body {
+ text .t
+ .t insert end "foo\u30c9\u30cabar"
+ .t search \u30c9\u30ca 1.0
+} -cleanup {
+ destroy .t
+} -result {1.3}
+test text-22.70 {TextSearchCmd, unicode} -body {
+ text .t
+ .t insert end "foo\u30c9\u30cabar"
+ list [.t search -count n \u30c9\u30ca 1.0] $n
+} -cleanup {
+ destroy .t
+} -result {1.3 2}
+test text-22.71 {TextSearchCmd, unicode with non-text segments} -body {
+ text .t
+ button .b1 -text baz
+ .t insert end "foo\u30c9"
+ .t window create end -window .b1
+ .t insert end "\u30cabar"
+ list [.t search -count n \u30c9\u30ca 1.0] $n
+} -cleanup {
+ destroy .t .b1
+} -result {1.3 3}
+test text-22.72 {TextSearchCmd, hidden text does not affect match index} -body {
+ pack [text .t]
+ .t insert end "12345H7890"
+ .t search 7 1.0
+} -cleanup {
+ destroy .t
+} -result {1.6}
+test text-22.73 {TextSearchCmd, hidden text does not affect match index} -body {
+ pack [text .t]
+ .t insert end "12345H7890"
+ .t tag configure hidden -elide true
+ .t tag add hidden 1.5
+ .t search 7 1.0
+} -cleanup {
+ destroy .t
+} -result {1.6}
+test text-22.74 {TextSearchCmd, hidden text does not affect match index} -body {
+ pack [text .t]
+ .t insert end "foobar\nbarbaz\nbazboo"
+ .t search boo 1.0
+} -cleanup {
+ destroy .t
+} -result {3.3}
+test text-22.75 {TextSearchCmd, hidden text does not affect match index} -body {
+ pack [text .t]
+ .t insert end "foobar\nbarbaz\nbazboo"
+ .t tag configure hidden -elide true
+ .t tag add hidden 2.0 3.0
+ .t search boo 1.0
+} -cleanup {
+ destroy .t
+} -result {3.3}
+test text-22.76 {TextSearchCmd, -regexp -nocase searches} -body {
+ pack [text .t]
+ .t insert end "word1 word2"
+ .t search -nocase -regexp {\mword.} 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.0}
+test text-22.77 {TextSearchCmd, -regexp -nocase searches} -body {
+ pack [text .t]
+ .t insert end "word1 word2"
+ .t search -nocase -regexp {word.\M} 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.0}
+test text-22.78 {TextSearchCmd, -regexp -nocase searches} -body {
+ pack [text .t]
+ .t insert end "word1 word2"
+ .t search -nocase -regexp {word.\W} 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.0}
+test text-22.79 {TextSearchCmd, hidden text and start index} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t search bar 1.3
+} -cleanup {
+ destroy .t
+} -result {1.3}
+test text-22.80 {TextSearchCmd, hidden text shouldn't influence start index} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t tag configure hidden -elide true
+ .t tag add hidden 1.0 1.2
+ .t search bar 1.3
+} -cleanup {
+ destroy .t
+} -result {1.3}
+test text-22.81 {TextSearchCmd, hidden text inside match must count in length} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t tag configure hidden -elide true
+ .t tag add hidden 1.2 1.4
+ list [.t search -count foo foar 1.3] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 6}
+test text-22.82 {TextSearchCmd, hidden text inside match must count in length} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t tag configure hidden -elide true
+ .t tag add hidden 1.2 1.4
+ list \
+ [.t search -strict -count foo foar 1.3] \
+ [.t search -strict -count foo foar 2.3] $foo
+} -cleanup {
+ destroy .t
+} -result {{} 1.0 6}
+test text-22.83 {TextSearchCmd, hidden text and start index} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t search -regexp bar 1.3
+} -cleanup {
+ destroy .t
+} -result {1.3}
+test text-22.84 {TextSearchCmd, hidden text shouldn't influence start index} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t tag configure hidden -elide true
+ .t tag add hidden 1.0 1.2
+ .t search -regexp bar 1.3
+} -cleanup {
+ destroy .t
+} -result {1.3}
+test text-22.85 {TextSearchCmd, hidden text inside match must count in length} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t tag configure hidden -elide true
+ .t tag add hidden 1.2 1.4
+ list [.t search -regexp -count foo foar 1.3] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 6}
+test text-22.86 {TextSearchCmd, hidden text inside match must count in length} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t tag configure hidden -elide true
+ .t tag add hidden 1.2 1.4
+ list [.t search -count foo foar 1.3] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 6}
+test text-22.87 {TextSearchCmd, hidden text inside match must count in length} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t tag configure hidden -elide true
+ .t tag add hidden 1.2 1.4
+ .t search -strict -count foo foar 1.3
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.88 {TextSearchCmd, hidden text inside match must count in length} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoar"
+ .t tag configure hidden -elide true
+ .t tag add hidden 1.2 1.4
+ .t tag add hidden 2.2 2.4
+ list [.t search -regexp -all -count foo foar 1.3] $foo
+} -cleanup {
+ destroy .t
+} -result {{2.0 3.0 1.0} {6 4 6}}
+test text-22.89 {TextSearchCmd, hidden text inside match must count in length} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoar"
+ .t tag configure hidden -elide true
+ .t tag add hidden 1.2 1.4
+ .t tag add hidden 2.2 2.4
+ list [.t search -all -count foo foar 1.3] $foo
+} -cleanup {
+ destroy .t
+} -result {{2.0 3.0 1.0} {6 4 6}}
+test text-22.90 {TextSearchCmd, hidden text inside match must count in length} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoar"
+ .t tag configure hidden -elide true
+ .t tag add hidden 1.2 1.4
+ .t tag add hidden 2.2 2.4
+ list [.t search -strict -all -count foo foar 1.3] $foo
+} -cleanup {
+ destroy .t
+} -result {{2.0 3.0} {6 4}}
+test text-22.91 {TextSearchCmd, single line with -all} -body {
+ pack [text .t]
+ .t insert end " X\n X\n X\n X\n X\n X\n"
+ .t search -all -regexp { +| *\n} 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.0 1.2 2.0 2.2 3.0 3.2 4.0 4.2 5.0 5.2 6.0 6.2 7.0}
+test text-22.92 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -count foo foobar\nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 10}
+test text-22.93 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -count foo bar\nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.3 7}
+test text-22.94 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -count foo \nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.6 4}
+test text-22.95 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -count foo bar\nfoobar\nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.3 14}
+test text-22.96 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t search -count foo bar\nfoobar\nfoobanearly 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.97 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -regexp -count foo foobar\nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 10}
+test text-22.98 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -regexp -count foo bar\nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.3 7}
+test text-22.99 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -regexp -count foo \nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.6 4}
+test text-22.100 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -regexp -count foo bar\nfoobar\nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.3 14}
+test text-22.101 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t search -regexp -count foo bar\nfoobar\nfoobanearly 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.102 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfaoobar\nfoobar"
+ .t search -regexp -count foo bar\nfoo 1.0
+} -cleanup {
+ destroy .t
+} -result {2.4}
+test text-22.103 {TextSearchCmd, multiline matching end of window} -body {
+ pack [text .t]
+ .t insert end "foobar\nfaoobar\nfoobar"
+ .t search -regexp -count foo bar\nfoobar\n\n 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.104 {TextSearchCmd, multiline matching end of window} -body {
+ pack [text .t]
+ .t search "\n\n" 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.105 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -backwards -count foo foobar\nfoo end] $foo
+} -cleanup {
+ destroy .t
+} -result {2.0 10}
+test text-22.106 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -backwards -count foo bar\nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {2.3 7}
+test text-22.107 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -backwards -count foo \nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {2.6 4}
+test text-22.108 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -backwards -count foo bar\nfoobar\nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.3 14}
+test text-22.109 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t search -backwards -count foo bar\nfoobar\nfoobanearly 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.110 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -backwards -regexp -count foo foobar\nfoo end] $foo
+} -cleanup {
+ destroy .t
+} -result {2.0 10}
+test text-22.111 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -backwards -regexp -count foo foobar\nfo end] $foo
+} -cleanup {
+ destroy .t
+} -result {2.0 9}
+test text-22.112 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -backwards -regexp -count foo bar\nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {2.3 7}
+test text-22.113 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -backwards -regexp -count foo \nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {2.6 4}
+test text-22.114 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ list [.t search -backwards -regexp -count foo bar\nfoobar\nfoo 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.3 14}
+test text-22.115 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t search -backwards -regexp -count foo bar\nfoobar\nfoobanearly 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.116 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfaoobar\nfoobar"
+ .t search -backwards -regexp -count foo bar\nfoo 1.0
+} -cleanup {
+ destroy .t
+} -result {2.4}
+test text-22.117 {TextSearchCmd, multiline matching end of window} -body {
+ pack [text .t]
+ .t insert end "foobar\nfaoobar\nfoobar"
+ .t search -backwards -regexp -count foo bar\nfoobar\n\n 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.118 {TextSearchCmd, multiline matching end of window} -body {
+ pack [text .t]
+ .t search -backwards "\n\n" 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.119 {TextSearchCmd, multiline regexp matching} -body {
+ pack [text .t]
+ .t insert 1.0 { Tcl_Obj *objPtr));
+static Tcl_Obj* FSNormalizeAbsolutePath
+ _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr));}
+ set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?"
+ append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)"
+ append markExpr "\[ \n\t\r\]*\\()"
+ .t search -forwards -regexp $markExpr 1.41 end
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.120 {TextSearchCmd, multiline regexp matching} -body {
+# Practical example which used to crash Tk, but only after the
+# search is complete. This is memory corruption caused by
+# a bug in Tcl's handling of string objects.
+# (Tcl bug 635200)
+ pack [text .t]
+ .t insert 1.0 {static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+static Tcl_Obj* FSNormalizeAbsolutePath
+ _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr));}
+ set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?"
+ append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)"
+ append markExpr "\[ \n\t\r\]*\\()"
+ .t search -forwards -regexp $markExpr 1.41 end
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.121 {TextSearchCmd, multiline regexp matching} -body {
+ pack [text .t]
+ .t insert 1.0 {
+static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+static Tcl_Obj* FSNormalizeAbsolutePath
+ _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr));}
+ set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?"
+ append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)"
+ append markExpr "\[ \n\t\r\]*\\()"
+ .t search -backwards -all -regexp $markExpr end
+} -cleanup {
+ destroy .t
+} -result {2.0}
+test text-22.122 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t search -all -regexp -count foo bar\nfoo 1.0
+} -cleanup {
+ destroy .t
+} -result {1.3 2.3}
+test text-22.123 {TextSearchCmd, multiline matching} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t search -all -backwards -regexp -count foo bar\nfoo 1.0
+} -cleanup {
+ destroy .t
+} -result {2.3 1.3}
+test text-22.124 {TextSearchCmd, wrapping and limits} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t search -- "blah" 3.3 1.3
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.125 {TextSearchCmd, wrapping and limits} -body {
+ pack [text .t]
+ .t insert end "foobar\nfoobar\nfoobar"
+ .t search -backwards -- "blah" 1.3 3.3
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.126 {TextSearchCmd, wrapping and limits} -body {
+ pack [text .t]
+ .t insert end "if (stringPtr->uallocated > 0) \{x"
+ .t search -backwards -regexp -- "\[\]\")\}\[(\{\]" "1.32" 1.0
+} -cleanup {
+ destroy .t
+} -result {1.31}
+test text-22.127 {TextSearchCmd, wrapping and limits} -body {
+ pack [text .t]
+ .t insert end "if (stringPtr->uallocated > 0) \{x"
+ .t search -regexp -- "\[\]\")\}\[(\{\]" 1.30 "1.0 lineend"
+} -cleanup {
+ destroy .t
+} -result {1.31}
+test text-22.128 {TextSearchCmd, wrapping and limits} -body {
+ pack [text .t]
+ .t insert end "if (stringPtr->uallocated > 0) \{x"
+ .t search -backwards -all -regexp -- "\[\]\")\}\[(\{\]" "1.32" 1.0
+} -cleanup {
+ destroy .t
+} -result {1.31 1.29 1.3}
+test text-22.129 {TextSearchCmd, wrapping and limits} -body {
+ pack [text .t]
+ .t insert end "if (stringPtr->uallocated > 0) \{x"
+ .t search -all -regexp -- "\[\]\")\}\[(\{\]" 1.0 "1.0 lineend"
+} -cleanup {
+ destroy .t
+} -result {1.3 1.29 1.31}
+test text-22.130 {TextSearchCmd, wrapping and limits} -body {
+ pack [text .t]
+ .t insert end "if (stringPtr->uallocated > 0) \{x"
+ .t search -backwards -- "\{" "1.32" 1.0
+} -cleanup {
+ destroy .t
+} -result {1.31}
+test text-22.131 {TextSearchCmd, wrapping and limits} -body {
+ pack [text .t]
+ .t insert end "if (stringPtr->uallocated > 0) \{x"
+ .t search -- "\{" 1.30 "1.0 lineend"
+} -cleanup {
+ destroy .t
+} -result {1.31}
+test text-22.132 {TextSearchCmd, multiline regexp matching} -body {
+ pack [text .t]
+ .t insert 1.0 {
+
+void
+Tcl_SetObjLength(objPtr, length)
+ register Tcl_Obj *objPtr; /* Pointer to object. This object must
+ * not currently be shared. */
+ register int length; /* Number of bytes desired for string
+ * representation of object, not including
+ * terminating null byte. */
+\{
+ char *new;
+}
+ set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?"
+ append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)"
+ append markExpr "\[ \n\t\r\]*\\()"
+ .t search -all -regexp -- $markExpr 1.0
+} -cleanup {
+ destroy .t
+} -result {4.0}
+test text-22.133 {TextSearchCmd, multiline regexp matching} -body {
+ pack [text .t]
+ .t insert 1.0 "first line\nlast line of text"
+ set markExpr {^[a-z]+}
+# This should not match, and should not wrap
+ .t search -regexp -- $markExpr end end
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.134 {TextSearchCmd, multiline regexp matching} -body {
+ pack [text .t]
+ .t insert 1.0 "first line\nlast line of text"
+ set markExpr {^[a-z]+}
+# This should not match, and should not wrap
+ .t search -regexp -- $markExpr end+10c end
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.135 {TextSearchCmd, multiline regexp matching} -body {
+ pack [text .t]
+ .t insert 1.0 "first line\nlast line of text"
+ set markExpr {^[a-z]+}
+# This should not match, and should not wrap
+ .t search -regexp -backwards -- $markExpr 1.0 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.136 {TextSearchCmd, regexp linestop} -body {
+ pack [text .t]
+ .t insert 1.0 "first line\nlast line of text"
+ .t search -regexp -- {i.*x} 1.0
+} -cleanup {
+ destroy .t
+} -result {2.6}
+test text-22.137 {TextSearchCmd, multiline regexp nolinestop matching} -body {
+ pack [text .t]
+ .t insert 1.0 "first line\nlast line of text"
+ .t search -regexp -nolinestop -- {i.*x} 1.0
+} -cleanup {
+ destroy .t
+} -result {1.1}
+test text-22.138 {TextSearchCmd, regexp linestop} -body {
+ pack [text .t]
+ .t insert 1.0 "first line\nlast line of text"
+ .t search -regexp -all -overlap -- {i.*x} 1.0
+} -cleanup {
+ destroy .t
+} -result {2.6}
+test text-22.139 {TextSearchCmd, regexp linestop} -body {
+ pack [text .t]
+ .t insert 1.0 "first line\nlast line of text"
+ .t search -regexp -all -- {i.*x} 1.0
+} -cleanup {
+ destroy .t
+} -result {2.6}
+test text-22.140 {TextSearchCmd, multiline regexp nolinestop matching} -body {
+ pack [text .t]
+ .t insert 1.0 "first line\nlast line of text"
+ list [.t search -regexp -all -overlap -count c -nolinestop -- {i.*x} 1.0] $c
+} -cleanup {
+ destroy .t
+} -result {{1.1 2.6} {26 10}}
+test text-22.141 {TextSearchCmd, multiline regexp nolinestop matching} -body {
+ pack [text .t]
+ .t insert 1.0 "first line\nlast line of text"
+ list [.t search -regexp -all -count c -nolinestop -- {i.*x} 1.0] $c
+} -cleanup {
+ destroy .t
+} -result {1.1 26}
+test text-22.142 {TextSearchCmd, stop at end of line} -body {
+ pack [text .t]
+ .t insert 1.0 " \t\n last line of text"
+ .t search -regexp -nolinestop -- {[^ \t]} 1.0
+} -cleanup {
+ destroy .t
+} -result {1.3}
+test text-22.143 {TextSearchCmd, overlapping all matches} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde abcde"
+ list [.t search -regexp -all -overlap -count c -- {\w+} 1.0] $c
+} -cleanup {
+ destroy .t
+} -result {{1.0 1.6} {5 5}}
+test text-22.144 {TextSearchCmd, non-overlapping all matches} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde abcde"
+ list [.t search -regexp -all -count c -- {\w+} 1.0] $c
+} -cleanup {
+ destroy .t
+} -result {{1.0 1.6} {5 5}}
+test text-22.145 {TextSearchCmd, stop at end of line} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde abcde"
+ list [.t search -backwards -regexp -all -count c -- {\w+} 1.0] $c
+} -cleanup {
+ destroy .t
+} -result {{1.6 1.0} {5 5}}
+test text-22.146 {TextSearchCmd, backwards search stop index } -body {
+ pack [text .t]
+ .t insert 1.0 "bla ZabcZdefZghi and some text again"
+ list [.t search -backwards -regexp -count c -- {Z\w+} 1.21 1.5] $c
+} -cleanup {
+ destroy .t
+} -result {1.8 8}
+test text-22.147 {TextSearchCmd, backwards search stop index } -body {
+ pack [text .t]
+ .t insert 1.0 "bla ZabcZdefZghi and some text again"
+ list [.t search -backwards -all -overlap -regexp -count c -- {Z\w+} 1.21 1.5] $c
+} -cleanup {
+ destroy .t
+} -result {1.8 8}
+test text-22.148 {TextSearchCmd, backwards search stop index } -body {
+ pack [text .t]
+ .t insert 1.0 "bla ZabcZdefZghi and some text again"
+ list [.t search -backwards -all -regexp -count c -- {Z\w+} 1.21 1.5] $c
+} -cleanup {
+ destroy .t
+} -result {1.8 8}
+test text-22.149 {TextSearchCmd, backwards search stop index } -body {
+ pack [text .t]
+ .t insert 1.0 "bla ZabcZdefZghi and some text again"
+ list [.t search -backwards -overlap -all -regexp -count c -- {Z\w+} 1.21 1.1] $c
+} -cleanup {
+ destroy .t
+} -result {1.4 12}
+test text-22.150 {TextSearchCmd, backwards search stop index } -body {
+ pack [text .t]
+ .t insert 1.0 "bla ZabcZdefZghi and some text again"
+ list [.t search -backwards -overlap -all -regexp -count c -- {Z[^Z]+Z} 1.21 1.1] $c
+} -cleanup {
+ destroy .t
+} -result {{1.8 1.4} {5 5}}
+test text-22.151 {TextSearchCmd, backwards search stop index } -body {
+ pack [text .t]
+ .t insert 1.0 "bla ZabcZdefZghi and some text again"
+ list [.t search -backwards -all -regexp -count c -- {Z\w+} 1.21 1.1] $c
+} -cleanup {
+ destroy .t
+} -result {1.4 12}
+test text-22.152 {TextSearchCmd, backwards search stop index } -body {
+ pack [text .t]
+ .t insert 1.0 "bla ZabcZdefZghi and some text again"
+ .t insert 1.0 "bla ZabcZdefZghi and some text again\n"
+ list [.t search -backwards -all -overlap -regexp -count c -- {Z\w+} 2.21 1.5] $c
+} -cleanup {
+ destroy .t
+} -result {{2.4 1.8} {12 8}}
+test text-22.153 {TextSearchCmd, backwards search stop index } -body {
+ pack [text .t]
+ .t insert 1.0 "bla ZabcZdefZghi and some text again"
+ .t insert 1.0 "bla ZabcZdefZghi and some text again\n"
+ list [.t search -backwards -all -regexp -count c -- {Z\w+} 2.21 1.5] $c
+} -cleanup {
+ destroy .t
+} -result {{2.4 1.8} {12 8}}
+test text-22.154 {TextSearchCmd, backwards search stop index } -body {
+ pack [text .t]
+ .t insert 1.0 "bla ZabcZdefZghi and some text again"
+ .t insert 1.0 "bla ZabcZdefZghi and some text again\n"
+ list [.t search -backwards -overlap -all -regexp -count c -- {Z\w+} 2.21 1.1] $c
+} -cleanup {
+ destroy .t
+} -result {{2.4 1.4} {12 12}}
+test text-22.155 {TextSearchCmd, backwards search stop index } -body {
+ pack [text .t]
+ .t insert 1.0 "bla ZabcZdefZghi and some text again"
+ .t insert 1.0 "bla ZabcZdefZghi and some text again\n"
+ list [.t search -backwards -all -regexp -count c -- {Z\w+} 2.21 1.1] $c
+} -cleanup {
+ destroy .t
+} -result {{2.4 1.4} {12 12}}
+test text-22.156 {TextSearchCmd, search -all example} -body {
+ pack [text .t]
+ .t insert 1.0 {
+
+See the package: supersearch for more information.
+
+
+See the package: incrementalSearch for more information.
+
+package: Brws .
+
+
+See the package: marks for more information.
+
+}
+ set pat {package: ([a-zA-Z0-9][-a-zA-Z0-9._+#/]*)}
+ list [.t search -nolinestop -regexp -nocase -all -forwards \
+ -count c -- $pat 1.0 end] $c
+} -cleanup {
+ destroy .t
+} -result {{3.8 6.8 8.0 11.8} {20 26 13 14}}
+test text-22.157 {TextSearchCmd, backwards search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
+ .t search -backwards -regexp {fooba+rfoo} end
+} -cleanup {
+ destroy .t
+} -result {1.6}
+test text-22.158 {TextSearchCmd, backwards search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
+ .t search -backwards -overlap -all -regexp {fooba+rfoo} end
+} -cleanup {
+ destroy .t
+} -result {1.6 1.0}
+test text-22.159 {TextSearchCmd, backwards search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
+ .t search -backwards -all -regexp {fooba+rfoo} end
+} -cleanup {
+ destroy .t
+} -result {1.6}
+test text-22.160 {TextSearchCmd, forwards search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
+ .t search -all -overlap -regexp {fooba+rfoo} end
+} -cleanup {
+ destroy .t
+} -result {1.0 1.6}
+test text-22.161 {TextSearchCmd, forwards search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
+ .t search -all -regexp {fooba+rfoo} end
+} -cleanup {
+ destroy .t
+} -result {1.0}
+test text-22.162 {TextSearchCmd, forward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abababab"
+ .t search -exact -overlap -all {abab} 1.0
+} -cleanup {
+ destroy .t
+} -result {1.0 1.2 1.4}
+test text-22.163 {TextSearchCmd, forward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abababab"
+ .t search -exact -all {abab} 1.0
+} -cleanup {
+ destroy .t
+} -result {1.0 1.4}
+test text-22.164 {TextSearchCmd, backward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "ababababab"
+ .t search -exact -overlap -backwards -all {abab} end
+} -cleanup {
+ destroy .t
+} -result {1.6 1.4 1.2 1.0}
+test text-22.165 {TextSearchCmd, backward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "ababababab"
+ .t search -exact -backwards -all {abab} end
+} -cleanup {
+ destroy .t
+} -result {1.6 1.2}
+test text-22.166 {TextSearchCmd, backward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abababababab"
+ .t search -exact -backwards -all {abab} end
+} -cleanup {
+ destroy .t
+} -result {1.8 1.4 1.0}
+test text-22.167 {TextSearchCmd, forward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
+ .t search -exact -overlap -all "foo\nbar\nfoo" 1.0
+} -cleanup {
+ destroy .t
+} -result {1.0 3.0 5.0}
+test text-22.168 {TextSearchCmd, forward exact search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
+ .t search -exact -all "foo\nbar\nfoo" 1.0
+} -cleanup {
+ destroy .t
+} -result {1.0 5.0}
+test text-22.169 {TextSearchCmd, backward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
+ .t search -exact -overlap -backward -all "foo\nbar\nfoo" end
+} -cleanup {
+ destroy .t
+} -result {5.0 3.0 1.0}
+test text-22.170 {TextSearchCmd, backward exact search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
+ .t search -exact -backward -all "foo\nbar\nfoo" end
+} -cleanup {
+ destroy .t
+} -result {5.0 1.0}
+test text-22.171 {TextSearchCmd, backward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
+ .t search -regexp -backward -overlap -all "foo\nbar\nfoo" end
+} -cleanup {
+ destroy .t
+} -result {5.0 3.0 1.0}
+test text-22.172 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
+ .t search -regexp -backward -all "foo\nbar\nfoo" end
+} -cleanup {
+ destroy .t
+} -result {5.0 1.0}
+test text-22.173 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -- {(\$)?[\w:_]+} 1.9
+} -cleanup {
+ destroy .t
+} -result {1.7}
+test text-22.174 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.5
+} -cleanup {
+ destroy .t
+} -result {1.7}
+test text-22.175 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.7
+} -cleanup {
+ destroy .t
+} -result {1.7}
+test text-22.176 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.8
+} -cleanup {
+ destroy .t
+} -result {1.8}
+test text-22.177 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -all -- {(\$)?[\w:_]+} 1.9 1.3
+} -cleanup {
+ destroy .t
+} -result {1.7 1.3}
+test text-22.178 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -all -- {(\$)?[\w:_]+} 1.9 1.13
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.179 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -all -- {(\$)?[\w:_]+} 2.0 1.3
+} -cleanup {
+ destroy .t
+} -result {1.12 1.7 1.3}
+test text-22.180 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -all -- {(\$)?[\w:_]+} 1.3
+} -cleanup {
+ destroy .t
+} -result {1.1 1.12 1.7 1.3}
+test text-22.181 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\n"
+ .t search -regexp -backward -all -- {(\w+\n)+} end
+} -cleanup {
+ destroy .t
+} -result {1.0}
+test text-22.182 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\n"
+ .t search -regexp -backward -all -- {(\w+\n)+} end 1.5
+} -cleanup {
+ destroy .t
+} -result {2.0}
+test text-22.183 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ .t search -regexp -backward -all -- {(\w+\n\w)+} end 1.5
+} -cleanup {
+ destroy .t
+} -result {2.0}
+test text-22.184 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -all -count foo -- {(\w+\n)+} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 20}
+test text-22.185 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ set res {}
+ lappend res \
+ [list [.t search -regexp -all -count foo -- {(\w+\n)+} 1.0] $foo] \
+ [list [.t search -regexp -all -count foo -- {(\w+)+} 1.0] $foo]
+} -cleanup {
+ destroy .t
+} -result {{1.0 20} {{1.0 2.0 3.0 4.0} {5 5 5 1}}}
+test text-22.186 {TextSearchCmd, regexp search greedy} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -all -nolinestop -count foo -- {.*} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 20}
+test text-22.187 {TextSearchCmd, regexp search greedy} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -all -count foo -- {.*} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {{1.0 2.0 3.0 4.0} {5 5 5 1}}
+test text-22.188 {TextSearchCmd, regexp search greedy multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -count foo -- {(\w+\n\w)+} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 19}
+test text-22.189 {TextSearchCmd, regexp search greedy multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -backwards -count foo -- {(\w+\n\w)+} end] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 19}
+test text-22.190 {TextSearchCmd, regexp search greedy multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -all -backwards -count foo -- {(\w+\n\w)+} end] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 19}
+test text-22.191 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ .t search -regexp -backward -all -- {(\w+\n\w)+} end 1.5
+} -cleanup {
+ destroy .t
+} -result {2.0}
+test text-22.192 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ .t search -regexp -backward -all -- {(\w+\n\w)+} end 1.3
+} -cleanup {
+ destroy .t
+} -result {1.3}
+test text-22.193 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -forward -count foo -- {(\w+\n\w)+} 1.3] $foo
+} -cleanup {
+ destroy .t
+} -result {1.3 16}
+test text-22.194 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -forward -all -count foo -- {(\w+\n\w)+} 1.3] $foo
+# This result is somewhat debatable -- the two results do overlap,
+# but only because the search has totally wrapped around back to
+# the start.
+} -cleanup {
+ destroy .t
+} -result {{1.3 1.0} {16 19}}
+test text-22.195 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -forward -all -count foo -- {(\w+\n\w)+} 1.0 1.3] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 19}
+test text-22.196 {TextSearchCmd, regexp search multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\naaaa\nbbbb\n"
+ list [.t search -regexp -forward -all -count foo -- {(a+\n(b+\n))+} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 20}
+test text-22.197 {TextSearchCmd, regexp search complex cases} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\naaaa\nbbbb\n"
+ list [.t search -regexp -forward -all -count foo \
+ -- {(a+\n(b+\n))+} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 20}
+test text-22.198 {TextSearchCmd, regexp search multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
+ set foo {}
+ list [.t search -regexp -forward -all -count foo \
+ -- {(b+\nc+\nb+)\na+} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {2.0 19}
+test text-22.199 {TextSearchCmd, regexp search multi-line} -constraints {
+ knownBug
+} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
+ set foo {}
+ list [.t search -regexp -forward -all -count foo \
+ -- {(a+|b+\nc+\nb+)\na+} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {2.0 19}
+test text-22.200 {TextSearchCmd, regexp search multi-line} -constraints {
+ knownBug
+} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
+ set foo {}
+ list [.t search -regexp -forward -all -count foo \
+ -- {(a+|b+\nc+\nb+)+\na+} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {2.0 19}
+test text-22.201 {TextSearchCmd, regexp search multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
+ set foo {}
+ list [.t search -regexp -forward -all -count foo \
+ -- {((a+|b+\nc+\nb+)+\n)+a+} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 24}
+test text-22.202 {TextSearchCmd, regexp search multi-line} -constraints {
+ knownBug
+} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n"
+ list [.t search -regexp -backward -all -count foo \
+ -- {b+\n|a+\n(b+\n)+} end] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 25}
+test text-22.203 {TextSearchCmd, regexp search multi-line} -constraints {
+ knownBug
+} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n"
+ .t search -regexp -backward -- {b+\n|a+\n(b+\n)+} end
+# Should match at 1.0 for a true greedy match
+} -cleanup {
+ destroy .t
+} -result {1.0}
+test text-22.204 {TextSearchCmd, regexp search multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "line0\nline1\nline1\nline1\nline1\nline2\nline2\nline2\nline3\n"
+ .t search -nolinestop -regexp -nocase -forwards -- {^(.*)\n(\1\n)+} 1.0 end
+# Matches at 6.0 currently
+} -cleanup {
+ destroy .t
+} -result {2.0}
+test text-22.205 {TextSearchCmd, regexp search multi-line} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ .t insert 1.0 "\naaaxxx\nyyy\n"
+ lappend res [.t search -count c -regexp -- {x*\ny*} 2.0] $c
+ lappend res [.t search -count c -regexp -- {x*\ny*} 2.1] $c
+ return $res
+} -cleanup {
+ destroy .t
+} -result {2.3 7 2.3 7}
+test text-22.206 {TextSearchCmd, regexp search multi-line} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ .t insert 1.0 "\naaa\n\n\n\n\nxxx\n"
+ lappend res [.t search -count c -regexp -- {\n+} 2.0] $c
+ lappend res [.t search -count c -regexp -- {\n+} 2.1] $c
+ return $res
+} -cleanup {
+ destroy .t
+} -result {2.3 5 2.3 5}
+test text-22.207 {TextSearchCmd, regexp search multi-line} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ .t insert 1.0 "\naaa\n\n\t \n\t\t\t \n\nxxx\n"
+ lappend res [.t search -count c -regexp -- {(\n+(\t+ *)*)+} 2.0] $c
+ return $res
+} -cleanup {
+ destroy .t
+} -result {2.3 13}
+test text-22.208 {TextSearchCmd, empty search range} -body {
+ pack [text .t]
+ .t insert 1.0 "a\na\na\n"
+ .t search -- a 2.0 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.209 {TextSearchCmd, empty search range} -body {
+ pack [text .t]
+ .t insert 1.0 "a\na\na\n"
+ .t search -backwards -- a 1.0 2.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.210 {TextSearchCmd, empty search range} -body {
+ pack [text .t]
+ .t insert 1.0 "a\na\na\n"
+ .t search -- a 1.0 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.211 {TextSearchCmd, empty search range} -body {
+ pack [text .t]
+ .t insert 1.0 "a\na\na\n"
+ .t search -backwards -- a 2.0 2.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.212 {TextSearchCmd, elide up to match} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ .t insert 1.0 "a\nb\nc"
+ .t tag configure e -elide 1
+ lappend res [.t search -regexp a 1.0]
+ lappend res [.t search -regexp b 1.0]
+ lappend res [.t search -regexp c 1.0]
+ .t tag add e 1.0 2.0
+ lappend res [.t search -regexp a 1.0]
+ lappend res [.t search -regexp b 1.0]
+ lappend res [.t search -regexp c 1.0]
+ lappend res [.t search -elide -regexp a 1.0]
+ lappend res [.t search -elide -regexp b 1.0]
+ lappend res [.t search -elide -regexp c 1.0]
+} -cleanup {
+ destroy .t
+} -result {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0}
+test text-22.213 {TextSearchCmd, elide up to match, backwards} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ .t insert 1.0 "a\nb\nc"
+ .t tag configure e -elide 1
+ lappend res [.t search -backward -regexp a 1.0]
+ lappend res [.t search -backward -regexp b 1.0]
+ lappend res [.t search -backward -regexp c 1.0]
+ .t tag add e 1.0 2.0
+ lappend res [.t search -backward -regexp a 1.0]
+ lappend res [.t search -backward -regexp b 1.0]
+ lappend res [.t search -backward -regexp c 1.0]
+ lappend res [.t search -backward -elide -regexp a 1.0]
+ lappend res [.t search -backward -elide -regexp b 1.0]
+ lappend res [.t search -backward -elide -regexp c 1.0]
+} -cleanup {
+ destroy .t
+} -result {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0}
+test text-22.214 {TextSearchCmd, elide up to match} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ .t insert 1.0 "a\nb\nc"
+ .t tag configure e -elide 1
+ lappend res [.t search a 1.0]
+ lappend res [.t search b 1.0]
+ lappend res [.t search c 1.0]
+ .t tag add e 1.0 2.0
+ lappend res [.t search a 1.0]
+ lappend res [.t search b 1.0]
+ lappend res [.t search c 1.0]
+ lappend res [.t search -elide a 1.0]
+ lappend res [.t search -elide b 1.0]
+ lappend res [.t search -elide c 1.0]
+} -cleanup {
+ destroy .t
+} -result {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0}
+test text-22.215 {TextSearchCmd, elide up to match, backwards} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ .t insert 1.0 "a\nb\nc"
+ .t tag configure e -elide 1
+ lappend res [.t search -backward a 1.0]
+ lappend res [.t search -backward b 1.0]
+ lappend res [.t search -backward c 1.0]
+ .t tag add e 1.0 2.0
+ lappend res [.t search -backward a 1.0]
+ lappend res [.t search -backward b 1.0]
+ lappend res [.t search -backward c 1.0]
+ lappend res [.t search -backward -elide a 1.0]
+ lappend res [.t search -backward -elide b 1.0]
+ lappend res [.t search -backward -elide c 1.0]
+} -cleanup {
+ destroy .t
+} -result {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0}
+test text-22.216 {TextSearchCmd, elide up to match} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ .t insert 1.0 "aa\nbb\ncc"
+ .t tag configure e -elide 1
+ lappend res [.t search ab 1.0]
+ lappend res [.t search bc 1.0]
+ .t tag add e 1.1 2.1
+ lappend res [.t search ab 1.0]
+ lappend res [.t search b 1.0]
+ .t tag remove e 1.0 end
+ .t tag add e 2.1 3.1
+ lappend res [.t search bc 1.0]
+ lappend res [.t search c 1.0]
+ .t tag remove e 1.0 end
+ .t tag add e 2.1 3.0
+ lappend res [.t search bc 1.0]
+ lappend res [.t search c 1.0]
+} -cleanup {
+ destroy .t
+} -result {{} {} 1.0 2.1 2.0 3.1 2.0 3.0}
+test text-22.217 {TextSearchCmd, elide up to match} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ .t insert 1.0 "aa\nbb\ncc"
+ .t tag configure e -elide 1
+ lappend res [.t search -regexp ab 1.0]
+ lappend res [.t search -regexp bc 1.0]
+ .t tag add e 1.1 2.1
+ lappend res [.t search -regexp ab 1.0]
+ lappend res [.t search -regexp b 1.0]
+ .t tag remove e 1.0 end
+ .t tag add e 2.1 3.1
+ lappend res [.t search -regexp bc 1.0]
+ lappend res [.t search -regexp c 1.0]
+ .t tag remove e 1.0 end
+ .t tag add e 2.1 3.0
+ lappend res [.t search -regexp bc 1.0]
+ lappend res [.t search -regexp c 1.0]
+} -cleanup {
+ destroy .t
+} -result {{} {} 1.0 2.1 2.0 3.1 2.0 3.0}
+test text-22.217.1 {elide up to match, with UTF-8 chars before the match} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ .t tag configure e -elide 0
+ .t insert end A {} xyz e bb\n
+ .t insert end \u00c4 {} xyz e bb
+ set res {}
+ lappend res [.t search bb 1.0 "1.0 lineend"]
+ lappend res [.t search bb 2.0 "2.0 lineend"]
+ lappend res [.t search -regexp bb 1.0 "1.0 lineend"]
+ lappend res [.t search -regexp bb 2.0 "2.0 lineend"]
+ .t tag configure e -elide 1
+ lappend res [.t search bb 1.0 "1.0 lineend"]
+ lappend res [.t search bb 2.0 "2.0 lineend"]
+ lappend res [.t search -regexp bb 1.0 "1.0 lineend"]
+ lappend res [.t search -regexp -elide bb 2.0 "2.0 lineend"]
+ lappend res [.t search -regexp bb 2.0 "2.0 lineend"]
+} -cleanup {
+ destroy .t
+} -result {1.4 2.4 1.4 2.4 1.4 2.4 1.4 2.4 2.4}
+test text-22.218 {TextSearchCmd, strict limits} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -strictlimits -- "world" 1.3 1.8
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.219 {TextSearchCmd, strict limits} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -strictlimits -- "world" 1.3 1.10
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.220 {TextSearchCmd, strict limits} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -strictlimits -- "world" 1.3 1.11
+} -cleanup {
+ destroy .t
+} -result {1.6}
+test text-22.221 {TextSearchCmd, strict limits backwards} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -strictlimits -backward -- "world" 2.3 1.8
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.222 {TextSearchCmd, strict limits backwards} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -strictlimits -backward -- "world" 2.3 1.6
+} -cleanup {
+ destroy .t
+} -result {1.6}
+test text-22.223 {TextSearchCmd, strict limits backwards} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -strictlimits -backward -- "world" 2.3 1.7
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.224 {TextSearchCmd, strict limits} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -regexp -strictlimits -- "world" 1.3 1.8
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.225 {TextSearchCmd, strict limits} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -regexp -strictlimits -backward -- "world" 2.3 1.8
+} -cleanup {
+ destroy .t
+} -result {}
+
+
+test text-23.1 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs "\{{}"
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {unmatched open brace in list}
+test text-23.2 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs xyz
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test text-23.3 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs {100 200}
+ update idletasks
+ list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0]
+} -cleanup {
+ destroy .t
+} -result {100 200}
+test text-23.4 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs {100 right 200 left 300 center 400 numeric}
+ update idletasks
+ list [expr [lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]] \
+ [lindex [.t bbox 1.4] 0] \
+ [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2] \
+ [lindex [.t bbox 1.10] 0]
+} -cleanup {
+ destroy .t
+} -result {100 200 300 400}
+test text-23.5 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs {105 r 205 l 305 c 405 n}
+ update idletasks
+ list [expr [lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]] \
+ [lindex [.t bbox 1.4] 0] \
+ [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2] \
+ [lindex [.t bbox 1.10] 0]
+} -cleanup {
+ destroy .t
+} -result {105 205 305 405}
+test text-23.6 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs {100 left 200 lork}
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad tab alignment "lork": must be left, right, center, or numeric}
+test text-23.7 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs {100 !44 200 lork}
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad screen distance "!44"}
+
+
+test text-24.1 {TextDumpCmd procedure, bad args} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t mark set insert 1.0
+ .t dump
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}
+test text-24.2 {TextDumpCmd procedure, bad args} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t mark set insert 1.0
+ .t dump -all
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}
+test text-24.3 {TextDumpCmd procedure, bad args} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t mark set insert 1.0
+ .t dump -command
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}
+test text-24.4 {TextDumpCmd procedure, bad args} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t mark set insert 1.0
+ .t dump -bogus
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad option "-bogus": must be -all, -command, -image, -mark, -tag, -text, or -window}
+test text-24.5 {TextDumpCmd procedure, bad args} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t mark set insert 1.0
+ .t dump bogus
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "bogus"}
+test text-24.6 {TextDumpCmd procedure, one index} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t dump -text 1.2
+} -cleanup {
+ destroy .t
+} -result {text e 1.2}
+test text-24.7 {TextDumpCmd procedure, two indices} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t dump -text 1.0 1.end
+} -cleanup {
+ destroy .t
+} -result {text {One Line} 1.0}
+test text-24.8 {TextDumpCmd procedure, "end" index} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t dump -text 1.end end
+} -cleanup {
+ destroy .t
+} -result {text {
+} 1.8}
+test text-24.9 {TextDumpCmd procedure, same indices} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t dump 1.5 1.5
+} -cleanup {
+ destroy .t
+} -result {}
+test text-24.10 {TextDumpCmd procedure, negative range} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t mark set insert 1.0
+ .t dump 1.5 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-24.11 {TextDumpCmd procedure, stop at begin-line} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t dump -text 1.0 2.0
+} -cleanup {
+ destroy .t
+} -result {text {Line One
+} 1.0}
+test text-24.12 {TextDumpCmd procedure, span multiple lines} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t dump -text 1.5 3.end
+} -cleanup {
+ destroy .t
+} -result {text {One
+} 1.5 text {Line Two
+} 2.0 text {Line Three} 3.0}
+test text-24.13 {TextDumpCmd procedure, tags only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t tag add x 2.0 2.end
+ .t tag add y 1.0 end
+ .t dump -tag 2.1 2.8
+} -cleanup {
+ destroy .t
+} -result {}
+test text-24.14 {TextDumpCmd procedure, tags only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t tag add x 2.0 2.end
+ .t tag add y 1.0 end
+ .t dump -tag 2.0 2.8
+} -cleanup {
+ destroy .t
+} -result {tagon x 2.0}
+test text-24.15 {TextDumpCmd procedure, tags only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t tag add x 2.0 2.end
+ .t tag add y 1.0 end
+ .t dump -tag 1.0 4.end
+} -cleanup {
+ destroy .t
+} -result {tagon y 1.0 tagon x 2.0 tagoff x 2.8}
+test text-24.16 {TextDumpCmd procedure, tags only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t tag add x 2.0 2.end
+ .t tag add y 1.0 end
+ .t dump -tag 1.0 end
+} -cleanup {
+ destroy .t
+} -result {tagon y 1.0 tagon x 2.0 tagoff x 2.8 tagoff y 5.0}
+test text-24.17 {TextDumpCmd procedure, marks only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t mark set insert 1.0
+ .t mark set current 1.0
+ .t mark set m 2.4
+ .t mark set n 4.0
+ .t mark set END end
+ .t dump -mark 1.1 1.8
+} -cleanup {
+ destroy .t
+} -result {}
+test text-24.18 {TextDumpCmd procedure, marks only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t mark set insert 1.0
+ .t mark set current 1.0
+ .t mark set m 2.4
+ .t mark set n 4.0
+ .t mark set END end
+ .t dump -mark 2.0 2.8
+} -cleanup {
+ destroy .t
+} -result {mark m 2.4}
+test text-24.19 {TextDumpCmd procedure, marks only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t mark set insert 1.0
+ .t mark set current 1.0
+ .t mark set m 2.4
+ .t mark set n 4.0
+ .t mark set END end
+ .t dump -mark 1.1 4.end
+} -cleanup {
+ destroy .t
+} -result {mark m 2.4 mark n 4.0}
+test text-24.20 {TextDumpCmd procedure, marks only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t mark set insert 1.0
+ .t mark set current 1.0
+ .t mark set m 2.4
+ .t mark set n 4.0
+ .t mark set END end
+ .t dump -mark 1.0 end
+} -cleanup {
+ destroy .t
+} -result {mark current 1.0 mark insert 1.0 mark m 2.4 mark n 4.0 mark END 5.0}
+test text-24.21 {TextDumpCmd procedure, windows only} -setup {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ for {set i 0} {$i < 100} {incr i} {.t insert end "-\n"}
+ button .hello -text Hello
+} -body {
+ .t window create 3.end -window .hello
+ .t window create 100.0 -create { }
+ .t dump -window 1.0 5.0
+} -cleanup {
+ destroy .t
+} -result {window .hello 3.10}
+test text-24.22 {TextDumpCmd procedure, windows only} -setup {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ for {set i 0} {$i < 100} {incr i} {.t insert end "-\n"}
+ button .hello -text Hello
+} -body {
+ .t window create 3.end -window .hello
+ .t window create 100.0 -create { }
+ .t dump -window 5.0 end
+} -cleanup {
+ destroy .t
+} -result {window {} 100.0}
+test text-24.23 {TextDumpCmd procedure, command script} -setup {
+ set x {}
+ pack [text .t]
+ proc Append {varName key value index} {
+ upvar #0 $varName x
+ lappend x $key $index $value
+ }
+} -body {
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t mark set insert 1.0
+ .t mark set current 1.0
+ .t tag add x 2.0 2.end
+ .t mark set m 2.4
+ .t dump -command {Append x} -all 1.0 end
+ return $x
+} -cleanup {
+ destroy .t
+ rename Append {}
+} -result {mark 1.0 current mark 1.0 insert text 1.0 {Line One
+} tagon 2.0 x text 2.0 Line mark 2.4 m text 2.4 { Two} tagoff 2.8 x text 2.8 {
+} text 3.0 {Line Three
+} text 4.0 {Line Four
+}}
+test text-24.24 {TextDumpCmd procedure, command script} -setup {
+ set x {}
+ pack [text .t]
+ proc Append {varName key value index} {
+ upvar #0 $varName x
+ lappend x $key $index $value
+ }
+} -body {
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t mark set insert 1.0
+ .t mark set current 1.0
+ .t mark set m 2.4
+ .t dump -mark -command {Append x} 1.0 end
+ return $x
+} -cleanup {
+ destroy .t
+ rename Append {}
+} -result {mark 1.0 current mark 1.0 insert mark 2.4 m}
+test text-24.25 {TextDumpCmd procedure, unicode characters} -body {
+ text .t
+ .t insert 1.0 \xb1\xb1\xb1
+ .t dump -all 1.0 2.0
+} -cleanup {
+ destroy .t
+} -result "text \xb1\xb1\xb1 1.0 mark insert 1.3 mark current 1.3 text {\n} 1.3"
+test text-24.26 {TextDumpCmd procedure, unicode characters} -body {
+ text .t
+ .t delete 1.0 end
+ .t insert 1.0 abc\xb1\xb1\xb1
+ .t dump -all 1.0 2.0
+} -cleanup {
+ destroy .t
+} -result "text abc\xb1\xb1\xb1 1.0 mark insert 1.6 mark current 1.6 text {\n} 1.6"
+test text-24.27 {TextDumpCmd procedure, peer present} -body {
+ text .t
+ .t peer create .t.t
+ .t dump -all 1.0 end
+} -cleanup {
+ destroy .t
+} -result "mark insert 1.0 mark current 1.0 text {\n} 1.0"
+
+test text-25.1 {text widget vs hidden commands} -body {
+ text .t
+ set y [list {} [interp hidden]]
+ interp hide {} .t
+ destroy .t
+ set x [list [winfo children .] [interp hidden]]
+ expr {$x eq $y}
+} -result {1}
+
+
+test text-26.1 {bug fix - 1642} -body {
+ pack [text .t]
+ .t insert end "line 1\n"
+ .t insert end "line 2\n"
+ .t insert end "line 3\n"
+ .t insert end "line 4\n"
+ .t insert end "line 5\n"
+ tk::TextSetCursor .t 3.0
+ .t search -backward -regexp "\$" insert 1.0
+} -cleanup {
+ destroy .t
+} -result {2.6}
+
+
+test text-27.1 {TextEditCmd procedure, argument parsing} -body {
+ pack [text .t]
+ .t edit
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t edit option ?arg ...?"}
+test text-27.2 {TextEditCmd procedure, argument parsing} -body {
+ pack [text .t]
+ .t edit gorp
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad edit option "gorp": must be canundo, canredo, modified, redo, reset, separator, or undo}
+test text-27.3 {TextEditUndo procedure, undoing changes} -body {
+ text .t -undo 1
+ pack .t
+ .t insert end "line 1\n"
+ .t delete 1.4 1.6
+ .t insert end "should be gone after undo\n"
+ .t edit undo
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result "line\n\n"
+test text-27.4 {TextEditRedo procedure, redoing changes} -body {
+ text .t -undo 1
+ pack .t
+ .t insert end "line 1\n"
+ .t delete 1.4 1.6
+ .t insert end "should be back after redo\n"
+ .t edit undo
+ .t edit redo
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result "line\nshould be back after redo\n\n"
+test text-27.5 {TextEditUndo procedure, resetting stack} -body {
+ text .t -undo 1
+ pack .t
+ .t insert end "line 1\n"
+ .t delete 1.4 1.6
+ .t insert end "should be back after redo\n"
+ .t edit reset
+ catch {.t edit undo} msg
+ return $msg
+} -cleanup {
+ destroy .t
+} -result "nothing to undo"
+test text-27.6 {TextEditCmd procedure, insert separator} -body {
+ text .t -undo 1
+ pack .t
+ .t insert end "line 1\n"
+ .t edit separator
+ .t insert end "line 2\n"
+ .t edit undo
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result "line 1\n\n"
+test text-27.7 {-autoseparators configuration option} -body {
+ text .t -undo 1 -autoseparators 0
+ pack .t
+ .t insert end "line 1\n"
+ .t delete 1.4 1.6
+ .t insert end "line 2\n"
+ .t edit undo
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result "\n"
+test text-27.8 {TextEditCmd procedure, modified flag} -body {
+ text .t
+ pack .t
+ .t insert end "line 1\n"
+ .t edit modified
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-27.9 {TextEditCmd procedure, reset modified flag} -body {
+ text .t
+ pack .t
+ .t insert end "line 1\n"
+ .t edit modified 0
+ .t edit modified
+} -cleanup {
+ destroy .t
+} -result {0}
+test text-27.10 {TextEditCmd procedure, set modified flag} -body {
+ text .t
+ pack .t
+ .t edit modified 1
+ .t edit modified
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-27.11 {TextEditCmd procedure, set modified flag repeat} -setup {
+ text .t
+ pack .t
+ set ::retval {}
+} -body {
+ bind .t <<Modified>> "lappend ::retval modified"
+# Shouldn't require [update idle] to trigger event [Bug 1809538]
+ lappend ::retval [.t edit modified]
+ .t edit modified 1
+ update
+ lappend ::retval [.t edit modified]
+ .t edit modified 1 ; # binding should only fire once [Bug 1799782]
+ update idletasks
+ lappend ::retval [.t edit modified]
+} -cleanup {
+ destroy .t
+} -result {0 modified 1 1}
+test text-27.12 {<<Modified>> virtual event} -body {
+ set ::retval unmodified
+ text .t -undo 1
+ pack .t
+ bind .t <<Modified>> "set ::retval modified"
+ update idletasks
+ .t insert end "nothing special\n"
+ update
+ return $::retval
+} -cleanup {
+ destroy .t
+} -result {modified}
+test text-27.13 {<<Modified>> virtual event - insert before Modified} -body {
+ set ::retval {}
+ pack [text .t -undo 1]
+ bind .t <<Modified>> { set ::retval [.t get 1.0 end-1c] }
+ update idletasks
+ .t insert end "nothing special"
+ update
+ return $::retval
+} -cleanup {
+ destroy .t
+} -result {nothing special}
+test text-27.14 {<<Modified>> virtual event - delete before Modified} -body {
+# Bug 1737288, make sure we delete chars before triggering <<Modified>>
+ set ::retval {}
+ pack [text .t -undo 1]
+ bind .t <<Modified>> { set ::retval [.t get 1.0 end-1c] }
+ .t insert end "nothing special"
+ .t edit modified 0
+ .t delete 1.0 1.2
+ update
+ set ::retval
+} -cleanup {
+ destroy .t
+} -result {thing special}
+test text-27.14a {<<Modified>> virtual event - propagation to peers} -body {
+# Bug [fd3a4dc111], <<Modified>> event is not always sent to peers
+ set ::retval 0
+ text .t -undo 1
+ .t peer create .tt
+ pack .t .tt
+ bind .t <<Modified>> {incr ::retval}
+ bind .tt <<Modified>> {incr ::retval}
+ .t insert end "This increments ::retval once for each peer, i.e. twice."
+ .t edit modified 0 ; # shall increment twice as well, not just once
+ update
+ set ::retval
+} -cleanup {
+ destroy .t .tt
+} -result {4}
+test text-27.15 {<<Selection>> virtual event} -body {
+ set ::retval no_selection
+ pack [text .t -undo 1]
+ bind .t <<Selection>> "set ::retval selection_changed"
+ update idletasks
+ .t insert end "nothing special\n"
+ .t tag add sel 1.0 1.1
+ update
+ set ::retval
+} -cleanup {
+ destroy .t
+} -result {selection_changed}
+test text-27.16 {-maxundo configuration option} -body {
+ text .t -undo 1 -autoseparators 1 -maxundo 2
+ pack .t
+ .t insert end "line 1\n"
+ .t delete 1.4 1.6
+ .t insert end "line 2\n"
+ catch {.t edit undo}
+ catch {.t edit undo}
+ catch {.t edit undo}
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result "line 1\n\n"
+test text-27.16a {undo configuration options with peers} -body {
+ text .t -undo 1 -autoseparators 0 -maxundo 100
+ .t peer create .tt
+ set res [.t cget -undo]
+ lappend res [.tt cget -undo]
+ lappend res [.t cget -autoseparators]
+ lappend res [.tt cget -autoseparators]
+ lappend res [.t cget -maxundo]
+ lappend res [.tt cget -maxundo]
+ .t insert end "The undo stack is common between peers"
+ lappend res [.t edit canundo]
+ lappend res [.tt edit canundo]
+} -cleanup {
+ destroy .t
+} -result {1 1 0 0 100 100 1 1}
+test text-27.17 {bug fix 1536735 - undo with empty text} -body {
+ text .t -undo 1
+ set r [.t edit modified]
+ .t delete 1.0
+ lappend r [.t edit modified]
+ lappend r [catch {.t edit undo}]
+ lappend r [.t edit modified]
+} -cleanup {
+ destroy .t
+} -result {0 0 1 0}
+test text-27.18 {patch 1469210 - inserting after undo} -setup {
+ destroy .t
+} -body {
+ text .t -undo 1
+ .t insert end foo
+ .t edit modified 0
+ .t edit undo
+ .t insert end bar
+ .t edit modified
+} -cleanup {
+ destroy .t
+} -result 1
+test text-27.19 {patch 1669632 (i) - undo after <Control-1>} -setup {
+ destroy .t
+} -body {
+ text .t -undo 1
+ .t insert end foo\nbar
+ .t edit reset
+ .t insert 2.2 WORLD
+ event generate .t <Control-1> -x 1 -y 1
+ .t insert insert HELLO
+ .t edit undo
+ .t get 2.2 2.7
+} -cleanup {
+ destroy .t
+} -result WORLD
+test text-27.20 {patch 1669632 (iv) - undo after <<SelectNone>>} -setup {
+ destroy .top .top.t
+} -body {
+ toplevel .top
+ pack [text .top.t -undo 1]
+ .top.t insert end "This is an example text"
+ .top.t edit reset
+ .top.t mark set insert 1.5
+ .top.t insert 1.5 HELLO
+ .top.t tag add sel 1.10 1.12
+ update
+ focus -force .top.t
+ event generate .top.t <<SelectNone>>
+ .top.t insert insert " WORLD "
+ .top.t edit undo
+ .top.t get 1.5 1.10
+} -cleanup {
+ destroy .top.t .top
+} -result HELLO
+test text-27.21 {patch 1669632 (vii) - <<Undo>> shall not remove separators} -setup {
+ destroy .t
+} -body {
+ text .t -undo 1
+ .t insert end "This is an example text"
+ .t edit reset
+ .t insert 1.5 "WORLD "
+ event generate .t <Control-1> -x 1 -y 1
+ .t insert insert HELLO
+ event generate .t <<Undo>>
+ .t insert insert E
+ event generate .t <<Undo>>
+ .t get 1.0 "1.0 lineend"
+} -cleanup {
+ destroy .t
+} -result "This WORLD is an example text"
+test text-27.22 {patch 1669632 (v) - <<Clear>> is atomic} -setup {
+ destroy .t
+} -body {
+ toplevel .top
+ pack [text .top.t -undo 1]
+ .top.t insert end "This is an example text"
+ .top.t edit reset
+ .top.t mark set insert 1.5
+ .top.t insert 1.5 "A"
+ update
+ focus -force .top.t
+ event generate .top.t <Delete>
+ event generate .top.t <<SelectNextChar>>
+ event generate .top.t <<Clear>>
+ event generate .top.t <Delete>
+ event generate .top.t <<Undo>>
+ .top.t get 1.0 "1.0 lineend"
+} -cleanup {
+ destroy .top.t .top
+} -result "This A an example text"
+ test text-27.23 {patch 1669632 (v) - <<Cut>> is atomic} -setup {
+ destroy .t
+} -body {
+ toplevel .top
+ pack [text .top.t -undo 1]
+ .top.t insert end "This is an example text"
+ .top.t edit reset
+ .top.t mark set insert 1.5
+ .top.t insert 1.5 "A"
+ update
+ focus -force .top.t
+ event generate .top.t <Delete>
+ event generate .top.t <<SelectNextChar>>
+ event generate .top.t <<Cut>>
+ event generate .top.t <Delete>
+ event generate .top.t <<Undo>>
+ .top.t get 1.0 "1.0 lineend"
+} -cleanup {
+ destroy .top.t .top
+} -result "This A an example text"
+test text-27.24 {TextEditCmd procedure, canundo and canredo} -setup {
+ destroy .t
+ set res {}
+} -body {
+ text .t -undo false -autoseparators false
+ lappend res [.t edit canundo] [.t edit canredo]
+ .t configure -undo true
+ lappend res [.t edit canundo] [.t edit canredo]
+ .t insert end "DO\n"
+ .t edit separator
+ .t insert end "IT\n"
+ .t insert end "YOURSELF\n"
+ .t edit separator
+ lappend res [.t edit canundo] [.t edit canredo]
+ .t edit undo
+ lappend res [.t edit canundo] [.t edit canredo]
+ .t configure -undo false
+ lappend res [.t edit canundo] [.t edit canredo]
+ .t configure -undo true
+ lappend res [.t edit canundo] [.t edit canredo]
+ .t edit redo
+ lappend res [.t edit canundo] [.t edit canredo]
+} -cleanup {
+ destroy .t
+} -result {0 0 0 0 1 0 1 1 0 0 1 1 1 0}
+test text-27.25 {<<UndoStack>> virtual event} -setup {
+ destroy .t
+ set res {}
+ set nbUS 0
+} -body {
+ text .t -undo false -autoseparators false
+ bind .t <<UndoStack>> {incr nbUS}
+ update ; lappend res $nbUS
+ .t configure -undo true
+ update ; lappend res $nbUS
+ .t insert end "DO\n"
+ .t edit separator
+ .t insert end "IT\n"
+ .t insert end "YOURSELF\n"
+ .t edit separator
+ .t insert end "MAN\n"
+ .t edit separator
+ update ; lappend res $nbUS
+ .t edit undo
+ update ; lappend res $nbUS
+ .t edit redo
+ update ; lappend res $nbUS
+ .t edit undo
+ update ; lappend res $nbUS
+ .t edit undo
+ update ; lappend res $nbUS
+ .t edit undo
+ update ; lappend res $nbUS
+ .t edit redo
+ update ; lappend res $nbUS
+ .t edit redo
+ update ; lappend res $nbUS
+ .t edit redo
+ update ; lappend res $nbUS
+ .t edit undo
+ update ; lappend res $nbUS
+ .t edit undo
+ update ; lappend res $nbUS
+ .t edit reset
+ update ; lappend res $nbUS
+} -cleanup {
+ destroy .t
+} -result {0 0 1 2 3 4 4 5 6 6 7 8 8 9}
+
+
+test text-28.1 {bug fix - 624372, ControlUtfProc long lines} -body {
+ pack [text .t -wrap none]
+ .t insert end [string repeat "\1" 500]
+} -cleanup {
+ destroy .t
+} -result {}
+
+
+test text-29.1 {tabs - must be positive and must be increasing} -body {
+ pack [text .t -wrap none]
+ .t configure -tabs {0}
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {tab stop "0" is not at a positive distance}
+test text-29.2 {tabs - must be positive and must be increasing} -body {
+ pack [text .t -wrap none]
+ .t configure -tabs {-5}
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {tab stop "-5" is not at a positive distance}
+test text-29.3 {tabs - must be positive and must be increasing} -constraints {
+ knownBug
+} -body {
+# This bug will be fixed in Tk 9.0, when we can allow a minor
+# incompatibility with Tk 8.x
+ pack [text .t -wrap none]
+ .t configure -tabs {10c 5c}
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {tabs must be monotonically increasing, but "5c" is smaller than or equal to the previous tab}
+test text-29.4 {tabs - must be positive and must be increasing} -body {
+ pack [text .t -wrap none]
+ .t insert end "a\tb\tc\td\te"
+ catch {.t configure -tabs {10c 5c}}
+ update ; update ; update
+# This test must simply not go into an infinite loop to succeed
+ set result 1
+} -cleanup {
+ destroy .t
+} -result {1}
+
+
+test text-30.1 {repeated insert and scroll} -body {
+ pack [text .t]
+ for {set i 0} {$i < 30} {incr i} {
+ .t insert end "blabla\n"
+ eval .t yview moveto 1
+ }
+# This test must simply not crash to succeed
+ set result 1
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-30.2 {repeated insert and scroll} -body {
+ pack [text .t]
+ for {set i 0} {$i < 30} {incr i} {
+ .t insert end "blabla\n"
+ eval .t yview scroll 1 pages
+ }
+# This test must simply not crash to succeed
+ set result 1
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-30.3 {repeated insert and scroll} -body {
+ pack [text .t]
+ for {set i 0} {$i < 30} {incr i} {
+ .t insert end "blabla\n"
+ eval .t yview scroll 100 pixels
+ }
+# This test must simply not crash to succeed
+ set result 1
+} -cleanup {
+ destroy .t
+} -result {1}
+test text-30.4 {repeated insert and scroll} -body {
+ pack [text .t]
+ for {set i 0} {$i < 30} {incr i} {
+ .t insert end "blabla\n"
+ eval .t yview scroll 10 units
+ }
+# This test must simply not crash to succeed
+ set result 1
+} -cleanup {
+ destroy .t
+} -result {1}
+
+
+test text-31.1 {peer widgets} -body {
+ toplevel .top
+ pack [text .t]
+ pack [.t peer create .top.t]
+ destroy .t .top
+} -result {}
+test text-31.2 {peer widgets} -body {
+ toplevel .top1
+ toplevel .top2
+ pack [text .t]
+ pack [.t peer create .top1.t]
+ pack [.t peer create .top2.t]
+ .t insert end "abcd\nabcd"
+ update
+ destroy .top1
+ update
+ .t insert end "abcd\nabcd"
+ update
+ destroy .t .top2
+ update
+} -result {}
+test text-31.3 {peer widgets} -body {
+ toplevel .top1
+ toplevel .top2
+ pack [text .t]
+ pack [.t peer create .top1.t]
+ pack [.t peer create .top2.t]
+ .t insert end "abcd\nabcd"
+ update
+ destroy .t
+ update
+ .top2.t insert end "abcd\nabcd"
+ update
+ destroy .t .top2
+ update
+} -result {}
+test text-31.4 {peer widgets} -body {
+ toplevel .top
+ pack [text .t]
+ for {set i 1} {$i < 20} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ pack [.t peer create .top.t -start 5 -end 11]
+ update
+ destroy .t .top
+} -result {}
+test text-31.5 {peer widgets} -body {
+ toplevel .top
+ pack [text .t]
+ for {set i 1} {$i < 20} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ pack [.t peer create .top.t -start 5 -end 11]
+ pack [.top.t peer create .top.t2]
+ set res [list [.top.t index end] [.top.t2 index end]]
+ update
+ return $res
+} -cleanup {
+ destroy .t .top
+} -result {7.0 7.0}
+test text-31.6 {peer widgets} -body {
+ toplevel .top
+ pack [text .t]
+ for {set i 1} {$i < 20} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ pack [.t peer create .top.t -start 5 -end 11]
+ pack [.top.t peer create .top.t2 -start {} -end {}]
+ set res [list [.top.t index end] [.top.t2 index end]]
+ update
+ return $res
+} -cleanup {
+ destroy .t .top
+} -result {7.0 21.0}
+test text-31.7 {peer widgets} -body {
+ toplevel .top
+ pack [text .t]
+ for {set i 1} {$i < 20} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ pack [.t peer create .top.t -start 5 -end 11]
+ update ; update
+ set p1 [.top.t count -update -ypixels 1.0 end]
+ set p2 [.t count -update -ypixels 5.0 11.0]
+ expr {$p1 eq $p2}
+} -cleanup {
+ destroy .t .top
+} -result {1}
+test text-31.8 {peer widgets} -body {
+ toplevel .top
+ pack [text .t]
+ for {set i 1} {$i < 20} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ pack [.t peer create .top.t -start 5 -end 11]
+ update ; update
+ .t delete 3.0 6.0
+ .top.t index end
+} -cleanup {
+ destroy .t .top
+} -result {6.0}
+test text-31.9 {peer widgets} -body {
+ toplevel .top
+ pack [text .t]
+ for {set i 1} {$i < 20} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ pack [.t peer create .top.t -start 5 -end 11]
+ update ; update
+ .t delete 8.0 12.0
+ .top.t index end
+} -cleanup {
+ destroy .t .top
+} -result {4.0}
+test text-31.10 {peer widgets} -body {
+ toplevel .top
+ pack [text .t]
+ for {set i 1} {$i < 20} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ pack [.t peer create .top.t -start 5 -end 11]
+ update ; update
+ .t delete 3.0 13.0
+ .top.t index end
+} -cleanup {
+ destroy .t .top
+} -result {1.0}
+test text-31.11 {peer widgets} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t tag add sel 1.0 end-1c
+ lappend res [.t tag ranges sel]
+ .t configure -start 10 -end 20
+ lappend res [.t tag ranges sel]
+ return $res
+} -cleanup {
+ destroy .t
+} -result {{1.0 100.0} {1.0 11.0}}
+test text-31.12 {peer widgets} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t tag add sel 1.0 end-1c
+ lappend res [.t tag ranges sel]
+ .t configure -start 11
+ lappend res [.t tag ranges sel]
+ return $res
+} -cleanup {
+ destroy .t
+} -result {{1.0 100.0} {1.0 90.0}}
+test text-31.13 {peer widgets} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t tag add sel 1.0 end-1c
+ lappend res [.t tag ranges sel]
+ .t configure -end 90
+ lappend res [.t tag ranges sel]
+ destroy .t
+ return $res
+} -cleanup {
+ destroy .t
+} -result {{1.0 100.0} {1.0 90.0}}
+test text-31.14 {peer widgets} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ for {set i 1} {$i < 20} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t tag add sel 1.0 3.0 5.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0
+ lappend res [.t tag prevrange sel 1.0]
+ .t configure -start 6 -end 12
+ lappend res [.t tag ranges sel]
+ lappend res "next" [.t tag nextrange sel 4.0] \
+ [.t tag nextrange sel 5.0] [.t tag nextrange sel 6.0] \
+ [.t tag nextrange sel 7.0]
+ lappend res "prev" [.t tag prevrange sel 1.0] \
+ [.t tag prevrange sel 2.0] [.t tag prevrange sel 3.0] \
+ [.t tag prevrange sel 4.0]
+ return $res
+} -cleanup {
+ destroy .t
+} -result {{} {1.0 2.0 4.0 6.0} next {4.0 6.0} {} {} {} prev {} {1.0 2.0} {1.0 2.0} {1.0 2.0}}
+test text-31.15 {peer widgets} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ for {set i 1} {$i < 20} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t tag add sel 1.0 3.0 9.0 11.0 13.0 15.0 17.0 19.0
+ .t configure -start 6 -end 12
+ lappend res [.t tag ranges sel]
+ lappend res "next" [.t tag nextrange sel 4.0] \
+ [.t tag nextrange sel 5.0] [.t tag nextrange sel 6.0] \
+ [.t tag nextrange sel 7.0]
+ lappend res "prev" [.t tag prevrange sel 1.0] \
+ [.t tag prevrange sel 2.0] [.t tag prevrange sel 3.0] \
+ [.t tag prevrange sel 4.0]
+ return $res
+} -cleanup {
+ destroy .t
+} -result {{4.0 6.0} next {4.0 6.0} {} {} {} prev {} {} {} {}}
+test text-31.16 {peer widgets} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ for {set i 1} {$i < 20} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t tag add sel 1.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0
+ .t configure -start 6 -end 12
+ lappend res [.t tag ranges sel]
+ lappend res "next" [.t tag nextrange sel 4.0] \
+ [.t tag nextrange sel 5.0] [.t tag nextrange sel 6.0] \
+ [.t tag nextrange sel 7.0]
+ lappend res "prev" [.t tag prevrange sel 1.0] \
+ [.t tag prevrange sel 2.0] [.t tag prevrange sel 3.0] \
+ [.t tag prevrange sel 4.0]
+ return $res
+} -cleanup {
+ destroy .t
+} -result {{1.0 2.0 4.0 6.0} next {4.0 6.0} {} {} {} prev {} {1.0 2.0} {1.0 2.0} {1.0 2.0}}
+test text-31.17 {peer widgets} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ for {set i 1} {$i < 20} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t tag add sel 1.0 11.0
+ lappend res [.t tag ranges sel]
+ lappend res [catch {.t configure -start 15 -end 10}]
+ lappend res [.t tag ranges sel]
+ .t configure -start 6 -end 12
+ lappend res [.t tag ranges sel]
+ .t configure -start {} -end {}
+ lappend res [.t tag ranges sel]
+ return $res
+} -cleanup {
+ destroy .t
+} -result {{1.0 11.0} 1 {1.0 11.0} {1.0 6.0} {1.0 11.0}}
+test text-31.18 {peer widgets} -setup {
+ pack [text .t]
+ set res {}
+} -body {
+ for {set i 1} {$i < 20} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t tag add sel 1.0 11.0
+ lappend res [.t index sel.first]
+ lappend res [.t index sel.last]
+ return $res
+} -cleanup {
+ destroy .t
+} -result {1.0 11.0}
+test text-31.19 {peer widgets} -body {
+ pack [text .t]
+ for {set i 1} {$i < 20} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t tag delete sel
+ .t index sel.first
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {text doesn't contain any characters tagged with "sel"}
+
+
+test text-32.1 {line heights on creation} -setup {
+ text .t
+ proc makeText {} {
+ set w .g
+ set font "Times 11"
+ destroy .g
+ toplevel .g
+ frame $w.f -highlightthickness 2 -borderwidth 2 -relief sunken
+ set t $w.f.text
+ text $t -yscrollcommand "$w.scroll set" -setgrid true -font $font \
+ -width 70 -height 35 -wrap word -highlightthickness 0 \
+ -borderwidth 0
+ pack $t -expand yes -fill both
+ scrollbar $w.scroll -command "$t yview"
+ pack $w.scroll -side right -fill y
+ pack $w.f -expand yes -fill both
+ $t tag configure center -justify center -spacing1 5m -spacing3 5m
+ $t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \
+ -spacing1 3m -spacing2 0 -spacing3 0
+ for {set i 0} {$i < 40} {incr i} {
+ $t insert end "${i}word "
+ }
+ return $t
+ }
+} -body {
+ set w [makeText]
+ update ; after 1000 ; update
+ set before [$w count -ypixels 1.0 2.0]
+ $w insert 1.0 "a"
+ update
+ set after [$w count -ypixels 1.0 2.0]
+ destroy .g
+ expr {$before eq $after}
+} -cleanup {
+ destroy .t
+} -result {1}
+
+
+test text-33.1 {TextWidgetCmd procedure, "peer" option} -setup {
+ text .t
+} -body {
+ .t peer foo 1
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad peer option "foo": must be create or names}
+test text-33.2 {TextWidgetCmd procedure, "peer" option} -setup {
+ text .t
+} -body {
+ .t peer names foo
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {wrong # args: should be ".t peer names"}
+test text-33.3 {TextWidgetCmd procedure, "peer" option} -setup {
+ text .t
+} -body {
+ .t pee names
+} -cleanup {
+ destroy .t
+} -returnCodes {ok} -result {}
+test text-33.4 {TextWidgetCmd procedure, "peer" option} -setup {
+ text .t
+} -body {
+ .t peer names
+} -cleanup {
+ destroy .t
+} -result {}
+test text-33.5 {TextWidgetCmd procedure, "peer" option} -setup {
+ text .t
+} -body {
+ .t peer create foo
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad window path name "foo"}
+test text-33.6 {TextWidgetCmd procedure, "peer" option} -setup {
+ text .t
+ set res {}
+} -body {
+ .t peer create .t2
+ lappend res [.t peer names]
+ lappend res [.t2 peer names]
+ destroy .t2
+ lappend res [.t peer names]
+} -cleanup {
+ destroy .t
+} -result {.t2 .t {}}
+test text-33.7 {peer widget -start, -end} -body {
+ text .t
+ set res [.t configure -start 10 -end 5]
+ return $res
+} -cleanup {
+ destroy .t
+} -returnCodes {2} -result {}
+test text-33.8 {peer widget -start, -end} -body {
+ text .t
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t configure -start 10 -end 5
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {-startline must be less than or equal to -endline}
+test text-33.9 {peer widget -start, -end} -body {
+ text .t
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t configure -start 5 -end 10
+} -cleanup {
+ destroy .t
+} -returnCodes {ok} -result {}
+test text-33.10 {peer widget -start, -end} -body {
+ text .t
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ set res [.t index end]
+ lappend res [catch {.t configure -start 5 -end 10 -tab foo}]
+ lappend res [.t index end]
+ lappend res [catch {.t configure -tab foo -start 15 -end 20}]
+ lappend res [.t index end]
+ .t configure -start {} -end {}
+ lappend res [.t index end]
+ return $res
+} -cleanup {
+ destroy .t
+} -result {101.0 1 101.0 1 101.0 101.0}
+test text-33.11 {peer widget -start, -end} -body {
+ text .t
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ set res [.t index end]
+ lappend res [catch {.t configure -start 5 -end 15}]
+ lappend res [.t index end]
+ lappend res [catch {.t configure -start 10 -end 40}]
+ lappend res [.t index end]
+ .t configure -start {} -end {}
+ lappend res [.t index end]
+ return $res
+} -cleanup {
+ destroy .t
+} -result {101.0 0 11.0 0 31.0 101.0}
+
+test text-34.1 {peer widget -start, -end and selection} -setup {
+ text .t
+ set res {}
+} -body {
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t tag add sel 10.0 20.0
+ lappend res [.t tag ranges sel]
+ .t configure -start 5 -end 30
+ lappend res [.t tag ranges sel]
+ .t configure -start 5 -end 15
+ lappend res [.t tag ranges sel]
+ .t configure -start 15 -end 30
+ lappend res [.t tag ranges sel]
+ .t configure -start 15 -end 16
+ lappend res [.t tag ranges sel]
+ .t configure -start 25 -end 30
+ lappend res [.t tag ranges sel]
+ .t configure -start {} -end {}
+ lappend res [.t tag ranges sel]
+ return $res
+} -cleanup {
+ destroy .t
+} -result {{10.0 20.0} {6.0 16.0} {6.0 11.0} {1.0 6.0} {1.0 2.0} {} {10.0 20.0}}
+
+test text-32.2 {peer widget -start, -end and deletion (bug 1630262)} -setup {
+ destroy .t .pt
+ set res {}
+} -body {
+ text .t
+ .t peer create .pt
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t configure -startline 5
+ # none of the following delete shall crash
+ # (all did before fixing bug 1630262)
+ # 1. delete on the same line: line1 == line2 in DeleteIndexRange,
+ # and resetView is true neither for .t not for .pt
+ .pt delete 2.0 2.2
+ # 2. delete just one line: line1 < line2 in DeleteIndexRange,
+ # and resetView is true only for .t, not for .pt
+ .pt delete 2.0 3.0
+ # 3. delete several lines: line1 < line2 in DeleteIndexRange,
+ # and resetView is true only for .t, not for .pt
+ .pt delete 2.0 5.0
+ # 4. delete to the end line: line1 < line2 in DeleteIndexRange,
+ # and resetView is true only for .t, not for .pt
+ .pt delete 2.0 end
+ # this test succeeds provided there is no crash
+ set res 1
+} -cleanup {
+ destroy .pt
+} -result {1}
+
+test text-32.3 {peer widget -start, -end and deletion (bug 1630262)} -setup {
+ destroy .t .pt
+ set res {}
+} -body {
+ text .t
+ .t peer create .pt
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t configure -startline 5
+ .pt configure -startline 3
+ # the following delete shall not crash
+ # (it did before fixing bug 1630262)
+ .pt delete 2.0 3.0
+ # moreover -startline shall be correct
+ # (was wrong before fixing bug 1630262)
+ lappend res [.t cget -start] [.pt cget -start]
+} -cleanup {
+ destroy .pt
+} -result {4 3}
+
+test text-32.4 {peer widget -start, -end and deletion (bug 1630262)} -setup {
+ destroy .t .pt
+ set res {}
+} -body {
+ text .t
+ .t peer create .pt
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t configure -startline 5 -endline 15
+ .pt configure -startline 8 -endline 12
+ # .pt now shows a range entirely inside the range of .pt
+ # from .t, delete lines located after [.pt cget -end]
+ .t delete 9.0 10.0
+ # from .t, delete lines straddling [.pt cget -end]
+ .t delete 6.0 9.0
+ lappend res [.t cget -start] [.t cget -end] [.pt cget -start] [.pt cget -end]
+ .t configure -startline 5 -endline 12
+ .pt configure -startline 8 -endline 12
+ # .pt now shows again a range entirely inside the range of .pt
+ # from .t, delete lines located before [.pt cget -start]
+ .t delete 2.0 3.0
+ # from .t, delete lines straddling [.pt cget -start]
+ .t delete 2.0 5.0
+ lappend res [.t cget -start] [.t cget -end] [.pt cget -start] [.pt cget -end]
+ .t configure -startline 22 -endline 31
+ .pt configure -startline 42 -endline 51
+ # .t now shows a range entirely before the range of .pt
+ # from .t, delete some lines, then do it from .pt
+ .t delete 2.0 3.0
+ .t delete 2.0 5.0
+ .pt delete 2.0 5.0
+ lappend res [.t cget -start] [.t cget -end] [.pt cget -start] [.pt cget -end]
+ .t configure -startline 55 -endline 75
+ .pt configure -startline 60 -endline 70
+ # .pt now shows a range entirely inside the range of .t
+ # from .t, delete a range straddling the entire range of .pt
+ .t delete 3.0 18.0
+ lappend res [.t cget -start] [.t cget -end] [.pt cget -start] [.pt cget -end]
+} -cleanup {
+ destroy .pt .t
+} -result {5 11 8 10 5 8 6 8 22 27 38 44 55 60 57 57}
+
+test text-35.1 {widget dump -command alters tags} -setup {
+ proc Dumpy {key value index} {
+#puts "KK: $key, $value"
+ .t tag add $value [list $index linestart] [list $index lineend]
+ }
+ text .t
+} -body {
+ .t insert end "abc\n" a "---" {} "def" b " \n" {} "ghi\n" c
+ .t tag configure b -background red
+ .t dump -all -command Dumpy 1.0 end
+ set result "ok"
+} -cleanup {
+ destroy .t
+} -result {ok}
+test text-35.2 {widget dump -command makes massive changes} -setup {
+ proc Dumpy {key value index} {
+#puts "KK: $key, $value"
+ .t delete 1.0 end
+ }
+ text .t
+} -body {
+ .t insert end "abc\n" a "---" {} "def" b " \n" {} "ghi\n" c
+ .t tag configure b -background red
+ .t dump -all -command Dumpy 1.0 end
+ set result "ok"
+} -cleanup {
+ destroy .t
+} -result {ok}
+test text-35.3 {widget dump -command destroys widget} -setup {
+ proc Dumpy {key value index} {
+#puts "KK: $key, $value"
+ destroy .t
+ }
+ text .t
+} -body {
+ .t insert end "abc\n" a "---" {} "def" b " \n" {} "ghi\n" c
+ .t tag configure b -background red
+ .t dump -all -command Dumpy 1.0 end
+ set result "ok"
+} -cleanup {
+ destroy .t
+} -result {ok}
+
+
+test text-36.1 "bug #1777362: event handling with hyphenated windows" -setup {
+ proc bgerror {m} {set ::my_error $m}
+ set ::my_error {}
+ pack [set w [text .t-1]]
+} -body {
+ tkwait visibility $w
+ event generate $w <1>
+ event generate $w <1>
+ update
+ set ::my_error
+} -cleanup {
+ destroy .t-1
+} -result {}
+test text-36.2 "bug #1777362: event handling with hyphenated windows" -setup {
+ proc bgerror {m} {set ::my_error $m}
+ set ::my_error {}
+ pack [set w [text .t+1]]
+} -body {
+ tkwait visibility $w
+ event generate $w <1>
+ event generate $w <1>
+ update
+ set ::my_error
+} -cleanup {
+ destroy $w
+} -result {}
+test text-36.3 "bug #1777362: event handling with hyphenated windows" -setup {
+ proc bgerror {m} {set ::my_error $m}
+ set ::my_error {}
+ pack [set w [text .t*1]]
+} -body {
+ tkwait visibility $w
+ event generate $w <1>
+ event generate $w <1>
+ update
+ set ::my_error
+} -cleanup {
+ destroy $w
+} -result {}
+
+# cleanup
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/textBTree.test b/tk8.6/tests/textBTree.test
new file mode 100644
index 0000000..ebd6c50
--- /dev/null
+++ b/tk8.6/tests/textBTree.test
@@ -0,0 +1,1247 @@
+# This file is a Tcl script to test out the B-tree facilities of
+# Tk's text widget (the contents of the file "tkTextBTree.c". There are
+# several file with additional tests for other features of text widgets.
+# This file is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+proc setup {} {
+ .t delete 1.0 100000.0
+ .t tag delete x y
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 1.1
+ .t tag add x 1.5 1.13
+ .t tag add x 2.2 2.6
+ .t tag add y 1.5
+}
+
+# setup procedure for tests 10.*, 11.*, 12.*
+proc msetup {} {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t mark set m1 1.2
+ .t mark set l1 1.2
+ .t mark gravity l1 left
+ .t mark set next 1.6
+ .t mark set x 1.6
+ .t mark set m2 2.0
+ .t mark set m3 2.100
+ .t tag add x 1.3 1.8
+}
+
+# setup procedure for tests 16.*, 17.*, 18.9
+proc setupBig {} {
+ .t delete 1.0 end
+ .t tag delete x y
+ .t tag configure x -foreground blue
+ .t tag configure y -underline true
+ # Create a Btree with 2002 lines (2000 + already existing + phantom at end)
+ # This generates a level 3 node with 9 children
+ # Most level 2 nodes cover 216 lines and have 6 children, except the last
+ # level 2 node covers 274 lines and has 7 children.
+ # Most level 1 nodes cover 36 lines and have 6 children, except the
+ # rightmost node has 58 lines and 9 children.
+ # Level 2: 2002 = 8*216 + 274
+ # Level 1: 2002 = 54*36 + 58
+ # Level 0: 2002 = 332*6 + 10
+ for {set i 0} {$i < 2000} {incr i} {
+ append x "Line $i abcd efgh ijkl\n"
+ }
+ .t insert insert $x
+ .t debug 1
+}
+
+# Widget used in tests 1.* - 13.*
+destroy .t
+text .t
+.t debug on
+
+test btree-1.1 {basic insertions} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-1.2 {basic insertions} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t insert 1.3 XXX
+ .t get 1.0 1000000.0
+} -result "LinXXXe 1\nLine 2\nLine 3\n"
+test btree-1.3 {basic insertions} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t insert 3.0 YYY
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\nYYYLine 3\n"
+test btree-1.4 {basic insertions} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t insert 2.1 X\nYY
+ .t get 1.0 1000000.0
+} -result "Line 1\nLX\nYYine 2\nLine 3\n"
+test btree-1.5 {basic insertions} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t insert 2.0 X\n\n\n
+ .t get 1.0 1000000.0
+} -result "Line 1\nX\n\n\nLine 2\nLine 3\n"
+test btree-1.6 {basic insertions} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t insert 2.6 X\n
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2X\n\nLine 3\n"
+test btree-1.7 {insertion before start of text} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t insert 0.4 XXX
+ .t get 1.0 1000000.0
+} -result "XXXLine 1\nLine 2\nLine 3\n"
+test btree-1.8 {insertion past end of text} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t insert 100.0 ZZ
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\nLine 3ZZ\n"
+test btree-1.9 {insertion before start of line} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t insert 2.-3 Q
+ .t get 1.0 1000000.0
+} -result "Line 1\nQLine 2\nLine 3\n"
+test btree-1.10 {insertion past end of line} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t insert 2.40 XYZZY
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2XYZZY\nLine 3\n"
+test btree-1.11 {insertion past end of last line} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t insert 3.40 ABC
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\nLine 3ABC\n"
+
+
+test btree-2.1 {basic deletions} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 1.0 1.3
+ .t get 1.0 1000000.0
+} -result "e 1\nLine 2\nLine 3\n"
+test btree-2.2 {basic deletions} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 2.2
+ .t get 1.0 1000000.0
+} -result "Line 1\nLie 2\nLine 3\n"
+test btree-2.3 {basic deletions} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 2.0 2.3
+ .t get 1.0 1000000.0
+} -result "Line 1\ne 2\nLine 3\n"
+test btree-2.4 {deleting whole lines} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 1.2 3.0
+ .t get 1.0 1000000.0
+} -result "LiLine 3\n"
+test btree-2.5 {deleting whole lines} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\n\n\nLine 5"
+ .t delete 1.0 5.2
+ .t get 1.0 1000000.0
+} -result "ne 5\n"
+test btree-2.6 {deleting before start of file} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 0.3 1.2
+ .t get 1.0 1000000.0
+} -result "ne 1\nLine 2\nLine 3\n"
+test btree-2.7 {deleting after end of file} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 10.3
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.8 {deleting before start of line} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 3.-1 3.3
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\ne 3\n"
+test btree-2.9 {deleting before start of line} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 1.-1 1.0
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.10 {deleting after end of line} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 1.8 2.1
+ .t get 1.0 1000000.0
+} -result "Line 1ine 2\nLine 3\n"
+test btree-2.11 {deleting after end of last line} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 3.8 4.1
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.12 {deleting before start of file} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 1.8 0.0
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.13 {deleting past end of file} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 1.8 4.0
+ .t get 1.0 1000000.0
+} -result "Line 1\n"
+test btree-2.14 {deleting with end before start of line} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 1.3 2.-3
+ .t get 1.0 1000000.0
+} -result "LinLine 2\nLine 3\n"
+test btree-2.15 {deleting past end of line} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 1.3 1.9
+ .t get 1.0 1000000.0
+} -result "Lin\nLine 2\nLine 3\n"
+test btree-2.16 {deleting past end of line} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 3.2 3.15
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\nLi\n"
+test btree-2.17 {deleting past end of line} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 3.0 3.15
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\n\n"
+test btree-2.18 {deleting past end of line} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 1.0 3.15
+ .t get 1.0 1000000.0
+} -result "\n"
+test btree-2.19 {deleting with negative range} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 3.2 2.4
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.20 {deleting with negative range} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 3.2 3.1
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.21 {deleting with negative range} -body {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ .t delete 3.2 3.2
+ .t get 1.0 1000000.0
+} -result "Line 1\nLine 2\nLine 3\n"
+
+
+test btree-3.1 {inserting with tags} -body {
+ setup
+ .t insert 1.0 XXX
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.4 1.5 1.8 1.16 2.2 2.6} {1.8 1.9}}
+test btree-3.2 {inserting with tags} -body {
+ setup
+ .t insert 1.15 YYY
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.1 1.2 1.5 1.13 2.2 2.6} {1.5 1.6}}
+test btree-3.3 {inserting with tags} -body {
+ setup
+ .t insert 1.7 ZZZZ
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.1 1.2 1.5 1.17 2.2 2.6} {1.5 1.6}}
+test btree-3.4 {inserting with tags} -body {
+ setup
+ .t insert 1.7 \n\n
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.1 1.2 1.5 3.6 4.2 4.6} {1.5 1.6}}
+test btree-3.5 {inserting with tags} -body {
+ setup
+ .t insert 1.5 A\n
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.1 1.2 2.0 2.8 3.2 3.6} {2.0 2.1}}
+test btree-3.6 {inserting with tags} -body {
+ setup
+ .t insert 1.13 A\n
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.1 1.2 1.5 1.13 3.2 3.6} {1.5 1.6}}
+
+
+test btree-4.1 {deleting with tags} -body {
+ setup
+ .t delete 1.6 1.9
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}}
+test btree-4.2 {deleting with tags} -body {
+ setup
+ .t delete 1.1 2.3
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.1 1.4} {}}
+test btree-4.3 {deleting with tags} -body {
+ setup
+ .t delete 1.4 2.1
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.1 1.2 1.5 1.9} {}}
+test btree-4.4 {deleting with tags} -body {
+ setup
+ .t delete 1.14 2.1
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.1 1.2 1.5 1.13 1.15 1.19} {1.5 1.6}}
+test btree-4.5 {deleting with tags} -body {
+ setup
+ .t delete 1.0 2.10
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{} {}}
+test btree-4.6 {deleting with tags} -body {
+ setup
+ .t delete 1.0 1.5
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.0 1.8 2.2 2.6} {1.0 1.1}}
+test btree-4.7 {deleting with tags} -body {
+ setup
+ .t delete 1.6 1.9
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}}
+test btree-4.8 {deleting with tags} -body {
+ setup
+ .t delete 1.5 1.13
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.1 1.2 2.2 2.6} {}}
+
+
+test btree-5.1 {very large inserts, with tags} -setup {
+ set bigText1 {}
+ for {set i 0} {$i < 10} {incr i} {
+ append bigText1 "Line $i\n"
+ }
+} -body {
+ setup
+ .t insert 1.0 $bigText1
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{11.1 11.2 11.5 11.13 12.2 12.6} {11.5 11.6}}
+test btree-5.2 {very large inserts, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
+ setup
+ .t insert 1.2 $bigText2
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.1 1.2 201.3 201.11 202.2 202.6} {201.3 201.4}}
+test btree-5.3 {very large inserts, with tags} -body {
+ setup
+ for {set i 0} {$i < 200} {incr i} {
+ .t insert 1.8 "longer line $i\n"
+ }
+ list [.t tag ranges x] [.t tag ranges y] [.t get 1.0 1.100] \
+ [.t get 198.0 198.100]
+} -result {{1.1 1.2 1.5 201.5 202.2 202.6} {1.5 1.6} {Text forlonger line 199} {longer line 2}}
+
+
+test btree-6.1 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
+ setup
+ .t insert 1.1 $bigText2
+ .t delete 1.2 201.2
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.4 1.12 2.2 2.6} {1.4 1.5}}
+test btree-6.2 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
+ setup
+ .t insert 1.1 $bigText2
+ for {set i 0} {$i < 200} {incr i} {
+ .t delete 1.2 2.2
+ }
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{1.4 1.12 2.2 2.6} {1.4 1.5}}
+test btree-6.3 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
+ setup
+ .t insert 1.1 $bigText2
+ .t delete 2.3 10000.0
+ .t get 1.0 1000.0
+} -result {TLine 0
+Lin
+}
+test btree-6.4 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
+ setup
+ .t insert 1.1 $bigText2
+ for {set i 0} {$i < 100} {incr i} {
+ .t delete 30.0 31.0
+ }
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{101.0 101.1 101.4 101.12 102.2 102.6} {101.4 101.5}}
+test btree-6.5 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
+ setup
+ .t insert 1.1 $bigText2
+ for {set i 0} {$i < 100} {incr i} {
+ set j [expr $i+2]
+ set k [expr 1+2*$i]
+ .t tag add x $j.1 $j.3
+ .t tag add y $k.1 $k.6
+ }
+ .t delete 2.0 200.0
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}}
+test btree-6.6 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
+ setup
+ .t insert 1.1 $bigText2
+ for {set i 0} {$i < 100} {incr i} {
+ set j [expr $i+2]
+ set k [expr 1+2*$i]
+ .t tag add x $j.1 $j.3
+ .t tag add y $k.1 $k.6
+ }
+ for {set i 199} {$i >= 2} {incr i -1} {
+ .t delete $i.0 [expr $i+1].0
+ }
+ list [.t tag ranges x] [.t tag ranges y]
+} -result {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}}
+
+
+test btree-7.1 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.3 1.6 1.7 2.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.3 1.6 1.7 2.0}
+test btree-7.2 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.3 1.6 1.6 2.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.3 2.0}
+test btree-7.3 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.3 1.6 1.4 2.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.3 2.0}
+test btree-7.4 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {2.0 4.3 1.4 1.10}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.4 1.10 2.0 4.3}
+test btree-7.5 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {2.0 4.3 1.4 1.end}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.4 1.19 2.0 4.3}
+test btree-7.6 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {2.0 4.3 1.4 2.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.4 4.3}
+test btree-7.7 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {2.0 4.3 1.4 3.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.4 4.3}
+test btree-7.8 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 4.2}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.1 4.2}
+test btree-7.9 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.3 4.2}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.2 4.2}
+test btree-7.10 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 3.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.1 4.0}
+test btree-7.11 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.2 3.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.2 4.0}
+
+
+test btree-8.1 {tag addition and removal, weird ranges} -body {
+ .t delete 1.0 100000.0
+ .t tag delete x
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 0.0 1.3
+ .t tag ranges x
+} -result {1.0 1.3}
+test btree-8.2 {tag addition and removal, weird ranges} -body {
+ .t delete 1.0 100000.0
+ .t tag delete x
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 1.40 2.4
+ .t tag ranges x
+} -result {1.19 2.4}
+test btree-8.3 {tag addition and removal, weird ranges} -body {
+ .t delete 1.0 100000.0
+ .t tag delete x
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 4.40 4.41
+ .t tag ranges x
+} -result {}
+test btree-8.4 {tag addition and removal, weird ranges} -body {
+ .t delete 1.0 100000.0
+ .t tag delete x
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 5.1 5.2
+ .t tag ranges x
+} -result {}
+test btree-8.5 {tag addition and removal, weird ranges} -body {
+ .t delete 1.0 100000.0
+ .t tag delete x
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 1.1 9.0
+ .t tag ranges x
+} -result {1.1 5.0}
+test btree-8.6 {tag addition and removal, weird ranges} -body {
+ .t delete 1.0 100000.0
+ .t tag delete x
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 1.1 1.90
+ .t tag ranges x
+} -result {1.1 1.19}
+test btree-8.7 {tag addition and removal, weird ranges} -body {
+ .t delete 1.0 100000.0
+ .t tag delete x
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 1.1 4.90
+ .t tag ranges x
+} -result {1.1 4.17}
+test btree-8.8 {tag addition and removal, weird ranges} -body {
+ .t delete 1.0 100000.0
+ .t tag delete x
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 3.0 3.0
+ .t tag ranges x
+} -result {}
+
+
+test btree-9.1 {tag names} -body {
+ setup
+ .t tag names
+} -result {sel x y}
+test btree-9.2 {tag names} -body {
+ setup
+ .t tag add tag1 1.8
+ .t tag add tag2 1.8
+ .t tag add tag3 1.7 1.9
+ .t tag names 1.8
+} -result {x tag1 tag2 tag3}
+test btree-9.3 {lots of tag names} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
+ setup
+ .t insert 1.2 $bigText2
+ foreach i {tag1 foo ThisOne {x space} q r s t} {
+ .t tag add $i 150.2
+ }
+ foreach i {u tagA tagB tagC and more {$} \{} {
+ .t tag add $i 150.1 150.3
+ }
+ .t tag names 150.2
+} -result {tag1 foo ThisOne {x space} q r s t u tagA tagB tagC and more {$} \{}
+test btree-9.4 {lots of tag names} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
+ setup
+ .t insert 1.2 $bigText2
+ .t tag delete tag1 foo ThisOne more {x space} q r s t u
+ .t tag delete tagA tagB tagC and {$} \{ more
+ foreach i {tag1 foo ThisOne more {x space} q r s t} {
+ .t tag add $i 150.2
+ }
+ foreach i {foo ThisOne u tagA tagB tagC and more {$} \{} {
+ .t tag add $i 150.4
+ }
+ .t tag delete tag1 more q r tagA
+ .t tag names 150.2
+} -result {foo ThisOne {x space} s t}
+
+
+test btree-10.1 {basic mark facilities} -body {
+ msetup
+ list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3]
+} -result {{current insert l1 m1 m2 m3 next x} 1.2 2.0 2.11}
+test btree-10.2 {basic mark facilities} -body {
+ msetup
+ .t mark unset m2
+ lsort [.t mark names]
+} -result {current insert l1 m1 m3 next x}
+test btree-10.3 {basic mark facilities} -body {
+ msetup
+ .t mark set m2 1.8
+ list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3]
+} -result {{current insert l1 m1 m2 m3 next x} 1.2 1.8 2.11}
+
+
+test btree-11.1 {marks and inserts} -body {
+ msetup
+ .t insert 1.1 abcde
+ list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
+} -result {1.7 1.7 1.11 1.11 2.0 2.11}
+test btree-11.2 {marks and inserts} -body {
+ msetup
+ .t insert 1.2 abcde
+ list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
+} -result {1.2 1.7 1.11 1.11 2.0 2.11}
+test btree-11.3 {marks and inserts} -body {
+ msetup
+ .t insert 1.3 abcde
+ list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
+} -result {1.2 1.2 1.11 1.11 2.0 2.11}
+test btree-11.4 {marks and inserts} -body {
+ msetup
+ .t insert 1.1 ab\n\ncde
+ list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
+} -result {3.4 3.4 3.8 3.8 4.0 4.11}
+test btree-11.5 {marks and inserts} -body {
+ msetup
+ .t insert 1.4 ab\n\ncde
+ list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
+} -result {1.2 1.2 3.5 3.5 4.0 4.11}
+test btree-11.6 {marks and inserts} -body {
+ msetup
+ .t insert 1.7 ab\n\ncde
+ list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
+} -result {1.2 1.2 1.6 1.6 4.0 4.11}
+
+
+test btree-12.1 {marks and deletes} -body {
+ msetup
+ .t delete 1.3 1.5
+ list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
+} -result {1.2 1.2 1.4 1.4 2.0 2.11}
+test btree-12.2 {marks and deletes} -body {
+ msetup
+ .t delete 1.3 1.8
+ list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
+} -result {1.2 1.2 1.3 1.3 2.0 2.11}
+test btree-12.3 {marks and deletes} -body {
+ msetup
+ .t delete 1.2 1.8
+ list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
+} -result {1.2 1.2 1.2 1.2 2.0 2.11}
+test btree-12.4 {marks and deletes} -body {
+ msetup
+ .t delete 1.1 1.8
+ list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
+} -result {1.1 1.1 1.1 1.1 2.0 2.11}
+test btree-12.5 {marks and deletes} -body {
+ msetup
+ .t delete 1.5 3.1
+ list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
+} -result {1.2 1.2 1.5 1.5 1.5 1.5}
+test btree-12.6 {marks and deletes} -body {
+ msetup
+ .t mark set m2 4.5
+ .t delete 1.5 4.1
+ list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
+} -result {1.2 1.2 1.5 1.5 1.9 1.5}
+test btree-12.7 {marks and deletes} -body {
+ msetup
+ .t mark set m2 4.5
+ .t mark set m3 4.5
+ .t mark set m1 4.7
+ .t delete 1.5 4.1
+ list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
+} -result {1.2 1.11 1.5 1.5 1.9 1.9}
+
+
+test btree-13.1 {tag searching} -setup {
+ .t delete 1.0 100000.0
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag next x 2.2 2.1
+} -result {}
+test btree-13.2 {tag searching} -setup {
+ .t delete 1.0 100000.0
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 2.2 2.4
+ .t tag next x 2.2 2.3
+} -result {2.2 2.4}
+test btree-13.3 {tag searching} -setup {
+ .t delete 1.0 100000.0
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 2.2 2.4
+ .t tag next x 2.3 2.6
+} -result {}
+test btree-13.4 {tag searching} -setup {
+ .t delete 1.0 100000.0
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 2.5 2.8
+ .t tag next x 2.1 2.6
+} -result {2.5 2.8}
+test btree-13.5 {tag searching} -setup {
+ .t delete 1.0 100000.0
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 2.5 2.8
+ .t tag next x 2.1 2.5
+} -result {}
+test btree-13.6 {tag searching} -setup {
+ .t delete 1.0 100000.0
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 2.1 2.4
+ .t tag next x 2.5 2.8
+} -result {}
+test btree-13.7 {tag searching} -setup {
+ .t delete 1.0 100000.0
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 2.5 2.8
+ .t tag next x 2.1 2.4
+} -result {}
+test btree-13.8 {tag searching} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
+ setup
+ .t insert 1.2 $bigText2
+ .t tag add x 190.3 191.2
+ .t tag next x 3.5
+} -result {190.3 191.2}
+destroy .t
+
+
+test btree-14.1 {check tag presence} -setup {
+ destroy .t
+ text .t
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
+ setup
+ .t insert 1.2 $bigText2
+ .t tag add x 3.5 3.7
+ .t tag add y 133.9 141.5
+ .t tag add z 1.5 180.2
+ .t tag add q 141.4 142.3
+ .t tag add x 130.2 145.1
+ .t tag add a 141.0
+ .t tag add b 4.3
+ .t tag add b 7.5
+ .t tag add b 140.3
+ for {set i 120} {$i < 160} {incr i} {
+ .t tag add c $i.4
+ }
+ foreach i {a1 a2 a3 a4 a5 a6 a7 a8 a9 10 a11 a12 a13} {
+ .t tag add $i 122.2
+ }
+ .t tag add x 141.3
+ .t tag names 141.1
+} -cleanup {
+ destroy .t
+} -result {x y z}
+test btree-14.2 {TkTextIsElided} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t delete 1.0 end
+ .t tag config hidden -elide 1
+ .t insert end "Line1\nLine2\nLine3\n"
+ .t tag add hidden 2.0 3.0
+ .t tag add sel 1.2 3.2
+ # next line used to panic because of "Bad tag priority being toggled on"
+ # (see bug [382da038c9])
+ .t index "2.0 - 1 display line linestart"
+} -cleanup {
+ destroy .t
+} -result {1.0}
+
+test btree-15.1 {rebalance with empty node} -setup {
+ destroy .t
+} -body {
+ text .t
+ .t debug 1
+ .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23"
+ .t delete 6.0 12.0
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result "1\n2\n3\n4\n5\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23\n"
+
+
+test btree-16.1 {add tag does not push root above level 0} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
+ .t debug 0
+ .t tag add x 1.1 1.10
+ .t tag add x 5.1 5.10
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {1.1 1.10 5.1 5.10}
+test btree-16.2 {add tag pushes root up to level 1 node} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
+ .t tag add x 1.1 1.10
+ .t tag add x 8.1 8.10
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {1.1 1.10 8.1 8.10}
+test btree-16.3 {add tag pushes root up to level 2 node} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
+ .t tag add x 8.1 9.10
+ .t tag add x 180.1 180.end
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {8.1 9.10 180.1 180.23}
+test btree-16.4 {add tag pushes root up to level 3 node} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
+ .t tag add y 1.1 2000.0
+ .t tag add x 1.1 8.10
+ .t tag add x 180.end 217.0
+ list [.t tag ranges x] [.t tag ranges y]
+} -cleanup {
+ destroy .t
+} -result {{1.1 8.10 180.23 217.0} {1.1 2000.0}}
+test btree-16.5 {add tag doesn't push root up} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
+ .t tag add x 1.1 8.10
+ .t tag add x 2000.0 2000.3
+ .t tag add x 180.end 217.0
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {1.1 8.10 180.23 217.0 2000.0 2000.3}
+test btree-16.6 {two node splits at once pushes root up} -setup {
+ destroy .t
+ text .t
+} -body {
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+ .t tag add x 8.0 8.end
+ .t tag add y 9.0 end
+ set x {}
+ for {} {$i < 50} {incr i} {
+ append x "Line $i\n"
+ }
+ .t insert end $x y
+ list [.t tag ranges x] [.t tag ranges y]
+} -cleanup {
+ destroy .t
+} -result {{8.0 8.6} {9.0 51.0}}
+# The following find bugs in the SearchStart procedures
+test btree-16.7 {Partial tag remove from before first range} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
+ .t tag add x 2.0 2.6
+ .t tag remove x 1.0 2.0
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {2.0 2.6}
+test btree-16.8 {Partial tag remove from before first range} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
+ .t tag add x 2.0 2.6
+ .t tag remove x 1.0 2.1
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {2.1 2.6}
+test btree-16.9 {Partial tag remove from before first range} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
+ .t tag add x 2.0 2.6
+ .t tag remove x 1.0 2.3
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {2.3 2.6}
+test btree-16.10 {Partial tag remove from before first range} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
+ .t tag add x 1.0 2.6
+ .t tag remove x 1.0 2.5
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {2.5 2.6}
+test btree-16.11 {StartSearchBack boundary case} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
+ .t tag add x 1.3 1.4
+ .t tag prevr x 2.0 1.4
+} -cleanup {
+ destroy .t
+} -result {}
+test btree-16.12 {StartSearchBack boundary case} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
+ .t tag add x 1.3 1.4
+ .t tag prevr x 2.0 1.3
+} -cleanup {
+ destroy .t
+} -result {1.3 1.4}
+test btree-16.13 {StartSearchBack boundary case} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
+ .t tag add x 1.0 1.4
+ .t tag prevr x 1.3
+} -cleanup {
+ destroy .t
+} -result {1.0 1.4}
+
+
+test btree-17.1 {remove tag does not push root down} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t debug 0
+ setupBig
+ .t tag add x 1.1 5.10
+ .t tag remove x 3.1 5.end
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {1.1 3.1}
+test btree-17.2 {remove tag pushes root from level 1 to level 0} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
+ .t tag add x 1.1 8.10
+ .t tag remove x 3.1 end
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {1.1 3.1}
+test btree-17.3 {remove tag pushes root from level 2 to level 1} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
+ .t tag add x 1.1 180.10
+ .t tag remove x 35.1 end
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {1.1 35.1}
+test btree-17.4 {remove tag doesn't change level 2} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
+ .t tag add x 1.1 180.10
+ .t tag remove x 35.1 180.0
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {1.1 35.1 180.0 180.10}
+test btree-17.5 {remove tag pushes root from level 3 to level 0} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
+ .t tag add x 1.1 1.10
+ .t tag add x 2000.1 2000.10
+ .t tag remove x 1.0 2000.0
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {2000.1 2000.10}
+test btree-17.6 {text deletion pushes root from level 3 to level 0} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
+ .t tag add x 1.1 1.10
+ .t tag add x 2000.1 2000.10
+ .t delete 1.0 "1000.0 lineend +1 char"
+ .t tag ranges x
+} -cleanup {
+ destroy .t
+} -result {1000.1 1000.10}
+
+
+test btree-18.1 {tag search back, no tag} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
+ .t tag prev x 1.1 1.1
+} -cleanup {
+ destroy .t
+} -result {}
+test btree-18.2 {tag search back, start at existing range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
+ .t tag add x 1.1 1.4
+ .t tag add x 1.8 1.11
+ .t tag add x 1.16
+ .t tag prev x 1.1
+} -cleanup {
+ destroy .t
+} -result {}
+test btree-18.3 {tag search back, end at existing range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
+ .t tag add x 1.1 1.4
+ .t tag add x 1.8 1.11
+ .t tag add x 1.16
+ .t tag prev x 1.3 1.1
+} -cleanup {
+ destroy .t
+} -result {1.1 1.4}
+test btree-18.4 {tag search back, start within range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
+ .t tag add x 1.1 1.4
+ .t tag add x 1.8 1.11
+ .t tag add x 1.16
+ .t tag prev x 1.10 1.0
+} -cleanup {
+ destroy .t
+} -result {1.8 1.11}
+test btree-18.5 {tag search back, start at end of range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
+ .t tag add x 1.1 1.4
+ .t tag add x 1.8 1.11
+ .t tag add x 1.16
+ list [.t tag prev x 1.4 1.0] [.t tag prev x 1.11 1.0]
+} -cleanup {
+ destroy .t
+} -result {{1.1 1.4} {1.8 1.11}}
+test btree-18.6 {tag search back, start beyond range, same level 0 node} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
+ .t tag add x 1.1 1.4
+ .t tag add x 1.8 1.11
+ .t tag add x 1.16
+ .t tag prev x 3.0
+} -cleanup {
+ destroy .t
+} -result {1.16 1.17}
+test btree-18.7 {tag search back, outside any range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
+ .t tag add x 1.1 1.4
+ .t tag add x 1.16
+ .t tag prev x 1.8 1.5
+} -cleanup {
+ destroy .t
+} -result {}
+test btree-18.8 {tag search back, start at start of node boundary} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
+ .t tag add x 2.5 2.8
+ .t tag prev x 19.0
+} -cleanup {
+ destroy .t
+} -result {2.5 2.8}
+test btree-18.9 {tag search back, large complex btree spans} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
+ .t tag add x 1.3 1.end
+ .t tag add x 200.0 220.0
+ .t tag add x 500.0 520.0
+ list [.t tag prev x end] [.t tag prev x 433.0]
+} -cleanup {
+ destroy .t
+} -result {{500.0 520.0} {200.0 220.0}}
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/textDisp.test b/tk8.6/tests/textDisp.test
new file mode 100644
index 0000000..99401c2
--- /dev/null
+++ b/tk8.6/tests/textDisp.test
@@ -0,0 +1,4249 @@
+# This file is a Tcl script to test the code in the file tkTextDisp.c.
+# This file is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+# The procedure below is used as the scrolling command for the text;
+# it just saves the scrolling information in a variable "scrollInfo".
+
+proc scroll args {
+ global scrollInfo
+ set scrollInfo $args
+}
+
+# The procedure below is used to generate errors during scrolling commands.
+
+proc scrollError args {
+ error "scrolling error"
+}
+
+# Create entries in the option database to be sure that geometry options
+# like border width have predictable values.
+set twbw 2
+set twht 2
+option add *Text.borderWidth $twbw
+option add *Text.highlightThickness $twht
+
+# The frame .f is needed to make sure that the overall window is always
+# fairly wide, even if the text window is very narrow. This is needed
+# because some window managers don't allow the overall width of a window
+# to get very narrow.
+
+catch {destroy .f .t}
+frame .f -width 100 -height 20
+pack append . .f left
+
+set fixedFont {Courier -12}
+# 15 on XP, 13 on Solaris 8
+set fixedHeight [font metrics $fixedFont -linespace]
+# 7 on all platforms
+set fixedWidth [font measure $fixedFont m]
+# 12 on XP
+set fixedAscent [font metrics $fixedFont -ascent]
+set fixedDiff [expr {$fixedHeight - 13}] ;# 2 on XP
+
+set varFont {Times -14}
+# 16 on XP, 15 on Solaris 8
+set varHeight [font metrics $varFont -linespace]
+# 13 on XP
+set varAscent [font metrics $varFont -ascent]
+set varDiff [expr {$varHeight - 15}] ;# 1 on XP
+
+set bigFont {Helvetica -24}
+# 27 on XP, 27 on Solaris 8
+set bigHeight [font metrics $bigFont -linespace]
+# 21 on XP
+set bigAscent [font metrics $bigFont -ascent]
+set ascentDiff [expr {$bigAscent - $fixedAscent}]
+
+text .t -font $fixedFont -width 20 -height 10 -yscrollcommand scroll
+pack append . .t {top expand fill}
+.t tag configure big -font $bigFont
+.t debug on
+wm geometry . {}
+
+# The statements below reset the main window; it's needed if the window
+# manager is mwm to make mwm forget about a previous minimum size setting.
+
+wm withdraw .
+wm minsize . 1 1
+wm positionfrom . user
+wm deiconify .
+update
+
+# Some window managers (like olwm under SunOS 4.1.3) misbehave in a way
+# that tends to march windows off the top and left of the screen. If
+# this happens, some tests will fail because parts of the window will
+# not need to be displayed (because they're off-screen). To keep this
+# from happening, move the window if it's getting near the left or top
+# edges of the screen.
+
+if {([winfo rooty .] < 50) || ([winfo rootx .] < 50)} {
+ wm geom . +50+50
+}
+
+test textDisp-0.1 {double tag elide transition} {
+ # Example from tkchat crash. For some reason can only
+ # get this test case to crash when first.
+ catch {destroy .top}
+ pack [text .top]
+
+ foreach val {0 1 2 3} {
+ .top insert 1.0 "hello\n"
+ .top tag configure tag$val
+ .top tag add tag$val 1.0 2.0
+ set ::Options(tag$val) 0
+ }
+
+ proc DoVis {tag} {
+ .top tag config $tag -elide $::Options($tag)
+ }
+
+ proc NickVis {val} {
+ foreach t [array names ::Options ] {
+ if {$::Options($t) != $val} {
+ set ::Options($t) $val
+ DoVis $t
+ }
+ }
+ }
+ NickVis 1
+ unset ::Options
+ destroy .top
+} {}
+
+test textDisp-0.2 {double tag elide transition} {
+ # Example from tkchat crash. For some reason can only
+ # get this test case to crash when first.
+ catch {destroy .top}
+ pack [text .top]
+
+ foreach val {0 1 2 3} {
+ .top insert 1.0 "hello"
+ .top tag configure tag$val
+ .top tag add tag$val 1.0 1.5
+ set ::Options(tag$val) 0
+ }
+
+ proc DoVis {tag} {
+ .top tag config $tag -elide $::Options($tag)
+ }
+
+ proc NickVis {val} {
+ foreach t [array names ::Options ] {
+ if {$::Options($t) != $val} {
+ set ::Options($t) $val
+ DoVis $t
+ }
+ }
+ }
+ NickVis 1
+ unset ::Options
+ destroy .top
+} {}
+
+test textDisp-0.3 {double tag elide transition} {
+ catch {destroy .txt}
+ pack [text .txt]
+ # Note that TRAFFIC should have a higher priority than SYSTEM
+ # in terms of the tag effects.
+ .txt tag configure SYSTEM -elide 0
+ .txt tag configure TRAFFIC -elide 1
+ .txt insert end "\n" {TRAFFIC SYSTEM}
+ update
+ destroy .txt
+} {}
+
+test textDisp-0.4 {double tag elide transition} {
+ catch {destroy .txt}
+ pack [text .txt]
+ # Note that TRAFFIC should have a higher priority than SYSTEM
+ # in terms of the tag effects.
+ .txt tag configure SYSTEM -elide 0
+ .txt tag configure TRAFFIC -elide 1
+ .txt insert end "\n" {SYSTEM TRAFFIC}
+ # Crash was here.
+ update
+ destroy .txt
+} {}
+
+test textDisp-0.5 {double tag elide transition} {
+ catch {destroy .txt}
+ pack [text .txt]
+ .txt tag configure WELCOME -elide 1
+ .txt tag configure SYSTEM -elide 0
+ .txt tag configure TRAFFIC -elide 1
+
+ .txt insert end "\n" {SYSTEM TRAFFIC}
+ .txt insert end "\n" WELCOME
+ # Crash was here.
+ update
+ destroy .txt
+} {}
+
+test textDisp-1.1 {GetStyle procedure, priorities and tab stops} {
+ .t delete 1.0 end
+ .t insert 1.0 "x\ty"
+ .t tag delete x y z
+ .t tag configure x -tabs {50}
+ .t tag configure y -foreground black
+ .t tag configure z -tabs {70}
+ .t tag add x 1.0 1.end
+ .t tag add y 1.0 1.end
+ .t tag add z 1.0 1.end
+ update idletasks
+ set x [lindex [.t bbox 1.2] 0]
+ .t tag configure z -tabs {}
+ lappend x [lindex [.t bbox 1.2] 0]
+ .t tag configure z -tabs {30}
+ .t tag raise x
+ update idletasks
+ lappend x [lindex [.t bbox 1.2] 0]
+} [list 75 55 55]
+.t tag delete x y z
+test textDisp-1.2 {GetStyle procedure, wrapmode} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "abcd\nefg hijkl mnop qrstuv wxyz"
+ .t tag configure x -wrap word
+ .t tag configure y -wrap none
+ .t tag raise y
+ update
+ set result [list [.t bbox 2.20]]
+ .t tag add x 2.0 2.1
+ lappend result [.t bbox 2.20]
+ .t tag add y 1.end 2.2
+ lappend result [.t bbox 2.20]
+} [list [list 5 [expr {5+2*$fixedHeight}] 7 $fixedHeight] [list 40 [expr {5+2*$fixedHeight}] 7 $fixedHeight] {}]
+.t tag delete x y
+
+test textDisp-2.1 {LayoutDLine, basics} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "This is some sample text for testing."
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list [expr 5 + $fixedWidth * 19] 5 $fixedWidth $fixedHeight] [list 5 [expr 5 + $fixedHeight] $fixedWidth $fixedHeight]]
+test textDisp-2.2 {LayoutDLine, basics} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "This isx some sample text for testing."
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 138 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-2.3 {LayoutDLine, basics} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "This isxxx some sample text for testing."
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 138 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-2.4 {LayoutDLine, word wrap} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "This is some sample text for testing."
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 138 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-2.5 {LayoutDLine, word wrap} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "This isx some sample text for testing."
+ list [.t bbox 1.13] [.t bbox 1.14] [.t bbox 1.19]
+} [list [list 96 5 49 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 40 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-2.6 {LayoutDLine, word wrap} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "This isxxx some sample text for testing."
+ list [.t bbox 1.15] [.t bbox 1.16]
+} [list [list 110 5 35 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-2.7 {LayoutDLine, marks and tags} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "This isxxx some sample text for testing."
+ .t tag add foo 1.4 1.6
+ .t mark set insert 1.8
+ list [.t bbox 1.2] [.t bbox 1.5] [.t bbox 1.11]
+} [list [list 19 5 7 $fixedHeight] [list 40 5 7 $fixedHeight] [list 82 5 7 $fixedHeight]]
+foreach m [.t mark names] {
+ catch {.t mark unset $m}
+}
+scan [wm geom .] %dx%d width height
+test textDisp-2.8 {LayoutDLine, extra chunk at end of dline} {textfonts} {
+ wm geom . [expr $width+1]x$height
+ update
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "This isxx some sample text for testing."
+ .t mark set foo 1.20
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 138 5 8 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+wm geom . {}
+update
+test textDisp-2.9 {LayoutDLine, marks and tags} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "This is a very_very_long_word_that_wraps."
+ list [.t bbox 1.9] [.t bbox 1.10] [.t bbox 1.25]
+} [list [list 68 5 77 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 110 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-2.10 {LayoutDLine, marks and tags} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "This is a very_very_long_word_that_wraps."
+ .t tag add foo 1.13
+ .t tag add foo 1.15
+ .t tag add foo 1.17
+ .t tag add foo 1.19
+ list [.t bbox 1.9] [.t bbox 1.10] [.t bbox 1.25]
+} [list [list 68 5 77 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 110 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-2.11 {LayoutDLine, newline width} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "a\nbb\nccc\ndddd"
+ list [.t bbox 2.2] [.t bbox 3.3]
+} [list [list 19 [expr {$fixedDiff + 18}] 126 $fixedHeight] [list 26 [expr {2*$fixedDiff + 31}] 119 $fixedHeight]]
+test textDisp-2.12 {LayoutDLine, justification} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "\na\nbb\nccc\ndddd"
+ .t tag configure x -justify center
+ .t tag add x 1.0 end
+ .t tag add y 3.0 3.2
+ list [.t bbox 1.0] [.t bbox 2.0] [.t bbox 4.0] [.t bbox 4.2]
+} [list [list 75 5 70 $fixedHeight] [list 71 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 64 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] [list 78 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]]
+test textDisp-2.13 {LayoutDLine, justification} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "\na\nbb\nccc\ndddd"
+ .t tag configure x -justify right
+ .t tag add x 1.0 end
+ .t tag add y 3.0 3.2
+ list [.t bbox 1.0] [.t bbox 2.0] [.t bbox 4.0] [.t bbox 4.2]
+} [list [list 145 5 0 $fixedHeight] [list 138 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 124 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] [list 138 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]]
+test textDisp-2.14 {LayoutDLine, justification} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "\na\nbb\nccc\ndddd"
+ .t tag configure x -justify center
+ .t tag add x 2.0 3.1
+ .t tag configure y -justify right
+ .t tag add y 3.0 4.0
+ .t tag raise y
+ list [.t bbox 2.0] [.t bbox 3.0] [.t bbox 3.end] [.t bbox 4.0]
+} [list [list 71 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 131 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 145 [expr {2*$fixedDiff + 31}] 0 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]]
+test textDisp-2.15 {LayoutDLine, justification} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "\na\nbb\nccc\ndddd"
+ .t tag configure x -justify center
+ .t tag add x 2.0 3.1
+ .t tag configure y -justify right
+ .t tag add y 3.0 4.0
+ .t tag lower y
+ list [.t bbox 2.0] [.t bbox 3.0] [.t bbox 3.end] [.t bbox 4.0]
+} [list [list 71 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 68 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 82 [expr {2*$fixedDiff + 31}] 63 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]]
+test textDisp-2.16 {LayoutDLine, justification} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "Lots of long words, enough to force word wrap\nThen\nmore lines"
+ .t tag configure x -justify center
+ .t tag add x 1.1 1.20
+ .t tag add x 1.21 1.end
+ list [.t bbox 1.0] [.t bbox 1.20] [.t bbox 1.36] [.t bbox 2.0]
+} [list [list 5 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 43 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]]
+test textDisp-2.17 {LayoutDLine, justification} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "Lots of long words, enough to force word wrap\nThen\nmore lines"
+ .t tag configure x -justify center
+ .t tag add x 1.20
+ list [.t bbox 1.0] [.t bbox 1.20] [.t bbox 1.36] [.t bbox 2.0]
+} [list [list 5 5 7 $fixedHeight] [list 19 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]]
+test textDisp-2.18 {LayoutDLine, justification} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert 1.0 "Lots of long words, enough to extend out of the window\n"
+ .t insert end "Then\nmore lines\nThat are shorter"
+ .t tag configure x -justify center
+ .t tag configure y -justify right
+ .t tag add x 2.0
+ .t tag add y 3.0
+ .t xview scroll 5 units
+ list [.t bbox 2.0] [.t bbox 3.0]
+} [list [list 26 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 40 [expr {2*$fixedDiff + 31}] 7 $fixedHeight]]
+.t tag delete x
+.t tag delete y
+test textDisp-2.19 {LayoutDLine, margins} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "Lots of long words, enough to force word wrap\nThen\nmore lines"
+ .t tag configure x -lmargin1 20 -lmargin2 40 -rmargin 15
+ .t tag add x 1.0 end
+ list [.t bbox 1.0] [.t bbox 1.12] [.t bbox 1.13] [.t bbox 2.0]
+} [list [list 25 5 7 $fixedHeight] [list 109 5 36 $fixedHeight] [list 45 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 25 [expr {5*$fixedDiff + 70}] 7 $fixedHeight]]
+test textDisp-2.20 {LayoutDLine, margins} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "Lots of long words, enough to force word wrap\nThen\nmore lines"
+ .t tag configure x -lmargin1 20 -lmargin2 10 -rmargin 3
+ .t tag configure y -lmargin1 15 -lmargin2 5 -rmargin 0
+ .t tag raise y
+ .t tag add x 1.0 end
+ .t tag add y 1.13
+ list [.t bbox 1.0] [.t bbox 1.13] [.t bbox 1.30] [.t bbox 2.0]
+} [list [list 25 5 7 $fixedHeight] [list 10 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 15 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 25 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]]
+test textDisp-2.21 {LayoutDLine, margins} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "Sample text"
+ .t tag configure x -lmargin1 80 -lmargin2 80 -rmargin 100
+ .t tag add x 1.0 end
+ list [.t bbox 1.0] [.t bbox 1.1] [.t bbox 1.2]
+} [list [list 85 5 60 $fixedHeight] [list 85 [expr {$fixedDiff + 18}] 60 $fixedHeight] [list 85 [expr {2*$fixedDiff + 31}] 60 $fixedHeight]]
+.t tag delete x
+.t tag delete y
+test textDisp-2.22 {LayoutDLine, spacing options} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t tag delete x y
+ .t insert end "Short line\nLine 2 is long enough "
+ .t insert end "to wrap around a couple of times"
+ .t insert end "\nLine 3\nLine 4"
+ set i [.t dlineinfo 1.0]
+ set b1 [expr [lindex $i 1] + [lindex $i 4]]
+ set i [.t dlineinfo 2.0]
+ set b2 [expr [lindex $i 1] + [lindex $i 4]]
+ set i [.t dlineinfo 2.end]
+ set b3 [expr [lindex $i 1] + [lindex $i 4]]
+ set i [.t dlineinfo 3.0]
+ set b4 [expr [lindex $i 1] + [lindex $i 4]]
+ .t configure -spacing1 2 -spacing2 1 -spacing3 3
+ set i [.t dlineinfo 1.0]
+ set b1 [expr [lindex $i 1] + [lindex $i 4] - $b1]
+ set i [.t dlineinfo 2.0]
+ set b2 [expr [lindex $i 1] + [lindex $i 4] - $b2]
+ set i [.t dlineinfo 2.end]
+ set b3 [expr [lindex $i 1] + [lindex $i 4] - $b3]
+ set i [.t dlineinfo 3.0]
+ set b4 [expr [lindex $i 1] + [lindex $i 4] - $b4]
+ list $b1 $b2 $b3 $b4
+} [list 2 7 10 15]
+.t configure -spacing1 0 -spacing2 0 -spacing3 0
+test textDisp-2.23 {LayoutDLine, spacing options} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t tag delete x y
+ .t insert end "Short line\nLine 2 is long enough "
+ .t insert end "to wrap around a couple of times"
+ .t insert end "\nLine 3\nLine 4"
+ set i [.t dlineinfo 1.0]
+ set b1 [expr [lindex $i 1] + [lindex $i 4]]
+ set i [.t dlineinfo 2.0]
+ set b2 [expr [lindex $i 1] + [lindex $i 4]]
+ set i [.t dlineinfo 2.end]
+ set b3 [expr [lindex $i 1] + [lindex $i 4]]
+ set i [.t dlineinfo 3.0]
+ set b4 [expr [lindex $i 1] + [lindex $i 4]]
+ .t configure -spacing1 4 -spacing2 4 -spacing3 4
+ .t tag configure x -spacing1 1 -spacing2 2 -spacing3 3
+ .t tag add x 1.0 end
+ .t tag configure y -spacing1 0 -spacing2 3
+ .t tag add y 2.19 end
+ .t tag raise y
+ set i [.t dlineinfo 1.0]
+ set b1 [expr [lindex $i 1] + [lindex $i 4] - $b1]
+ set i [.t dlineinfo 2.0]
+ set b2 [expr [lindex $i 1] + [lindex $i 4] - $b2]
+ set i [.t dlineinfo 2.end]
+ set b3 [expr [lindex $i 1] + [lindex $i 4] - $b3]
+ set i [.t dlineinfo 3.0]
+ set b4 [expr [lindex $i 1] + [lindex $i 4] - $b4]
+ list $b1 $b2 $b3 $b4
+} [list 1 5 13 16]
+.t configure -spacing1 0 -spacing2 0 -spacing3 0
+test textDisp-2.24 {LayoutDLine, tabs, saving from first chunk} {textfonts} {
+ .t delete 1.0 end
+ .t tag delete x y
+ .t tag configure x -tabs 70
+ .t tag configure y -tabs 80
+ .t insert 1.0 "ab\tcde"
+ .t tag add x 1.0 end
+ .t tag add y 1.1 end
+ lindex [.t bbox 1.3] 0
+} {75}
+test textDisp-2.25 {LayoutDLine, tabs, breaking chunks at tabs} {textfonts} {
+ .t delete 1.0 end
+ .t tag delete x
+ .t tag configure x -tabs [list 30 60 90 120]
+ .t insert 1.0 "a\tb\tc\td\te"
+ .t mark set dummy1 1.1
+ .t mark set dummy2 1.2
+ .t tag add x 1.0 end
+ list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0] \
+ [lindex [.t bbox 1.6] 0] [lindex [.t bbox 1.8] 0]
+} [list 35 65 95 125]
+test textDisp-2.26 {LayoutDLine, tabs, breaking chunks at tabs} {textfonts} {
+ .t delete 1.0 end
+ .t tag delete x
+ .t tag configure x -tabs [list 30 60 90 120] -justify right
+ .t insert 1.0 "a\tb\tc\td\te"
+ .t mark set dummy1 1.1
+ .t mark set dummy2 1.2
+ .t tag add x 1.0 end
+ list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0] \
+ [lindex [.t bbox 1.6] 0] [lindex [.t bbox 1.8] 0]
+} [list 117 124 131 138]
+test textDisp-2.27 {LayoutDLine, tabs, calling AdjustForTab} {textfonts} {
+ .t delete 1.0 end
+ .t tag delete x
+ .t tag configure x -tabs [list 30 60]
+ .t insert 1.0 "a\tb\tcd"
+ .t tag add x 1.0 end
+ list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0]
+} [list 35 65]
+test textDisp-2.28 {LayoutDLine, tabs, running out of space in dline} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 "a\tb\tc\td"
+ .t bbox 1.6
+} [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]
+test textDisp-2.29 {LayoutDLine, tabs, running out of space in dline} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 "a\tx\tabcd"
+ .t bbox 1.4
+} [list 117 5 7 $fixedHeight]
+test textDisp-2.30 {LayoutDLine, tabs, running out of space in dline} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 "a\tx\tabc"
+ .t bbox 1.4
+} [list 117 5 7 $fixedHeight]
+
+test textDisp-3.1 {different character sizes} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert end "Some sample text, including both large\n"
+ .t insert end "characters and\nsmall\n"
+ .t insert end "abc\nd\ne\nfghij"
+ .t tag add big 1.5 1.10
+ .t tag add big 2.11 2.14
+ list [.t bbox 1.1] [.t bbox 1.6] [.t dlineinfo 1.0] [.t dlineinfo 3.0]
+} [list [list 12 [expr {5+$ascentDiff}] 7 $fixedHeight] [list 52 5 13 27] [list 5 5 114 27 [font metrics $bigFont -ascent]] [list 5 [expr {2* $fixedDiff + 85}] 35 $fixedHeight [expr {$fixedDiff + 10}]]]
+.t configure -wrap char
+test textDisp-4.1 {UpdateDisplayInfo, basic} {textfonts} {
+ .t delete 1.0 end
+ .t insert end "Line 1\nLine 2\nLine 3\n"
+ update
+ .t delete 2.0 2.end
+ update
+ set res $tk_textRelayout
+ .t insert 2.0 "New Line 2"
+ update
+ lappend res [.t bbox 1.0] [.t bbox 2.0] [.t bbox 3.0] $tk_textRelayout
+} [list 2.0 [list 5 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] 2.0]
+test textDisp-4.2 {UpdateDisplayInfo, re-use tail of text line} {textfonts} {
+ .t delete 1.0 end
+ .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3"
+ update
+ .t mark set x 2.21
+ .t delete 2.2
+ update
+ set res $tk_textRelayout
+ .t insert 2.0 X
+ update
+ lappend res [.t bbox 2.0] [.t bbox x] [.t bbox 3.0] $tk_textRelayout
+} [list 2.0 2.20 [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 12 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] {2.0 2.20}]
+test textDisp-4.3 {UpdateDisplayInfo, tail of text line shifts} {textfonts} {
+ .t delete 1.0 end
+ .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3"
+ update
+ .t mark set x 2.21
+ .t delete 2.2
+ update
+ list [.t bbox 2.0] [.t bbox x] [.t bbox 3.0] $tk_textRelayout
+} [list [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] {2.0 2.20}]
+.t mark unset x
+test textDisp-4.4 {UpdateDisplayInfo, wrap-mode "none"} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3"
+ update
+ list [.t bbox 2.0] [.t bbox 2.25] [.t bbox 3.0] $tk_textRelayout
+} [list [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] {} [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] {1.0 2.0 3.0}]
+test textDisp-4.5 {UpdateDisplayInfo, tiny window} {textfonts} {
+ if {$tcl_platform(platform) == "windows"} {
+ wm overrideredirect . 1
+ }
+ wm geom . 103x$height
+ update
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3"
+ update
+ list [.t bbox 2.0] [.t bbox 2.1] [.t bbox 3.0] $tk_textRelayout
+} [list [list 5 [expr {$fixedDiff + 18}] 1 $fixedHeight] {} [list 5 [expr {2*$fixedDiff + 31}] 1 $fixedHeight] {1.0 2.0 3.0}]
+if {$tcl_platform(platform) == "windows"} {
+ wm overrideredirect . 0
+}
+test textDisp-4.6 {UpdateDisplayInfo, tiny window} {
+ # This test was failing on Windows because the title bar on .
+ # was a certain minimum size and it was interfering with the size
+ # requested. The "overrideredirect" gets rid of the titlebar so
+ # the toplevel can shrink to the appropriate size. On Unix, setting
+ # the overrideredirect on "." confuses the window manager and
+ # causes subsequent tests to fail.
+
+ if {$tcl_platform(platform) == "windows"} {
+ wm overrideredirect . 1
+ }
+ frame .f2 -width 20 -height 100
+ pack before .f .f2 top
+ wm geom . 103x103
+ update
+ .t configure -wrap none -borderwidth 2
+ .t delete 1.0 end
+ .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3"
+ update
+ set x [list [.t bbox 1.0] [.t bbox 2.0] $tk_textRelayout]
+ wm overrideredirect . 0
+ update
+ set x
+} [list [list 5 5 1 1] {} 1.0]
+catch {destroy .f2}
+.t configure -borderwidth 0 -wrap char
+wm geom . {}
+update
+set bw [.t cget -borderwidth]
+set px [.t cget -padx]
+set py [.t cget -pady]
+set hlth [.t cget -highlightthickness]
+test textDisp-4.7 {UpdateDisplayInfo, filling in extra vertical space} {
+ # This test was failing on Windows because the title bar on .
+ # was a certain minimum size and it was interfering with the size
+ # requested. The "overrideredirect" gets rid of the titlebar so
+ # the toplevel can shrink to the appropriate size. On Unix, setting
+ # the overrideredirect on "." confuses the window manager and
+ # causes subsequent tests to fail.
+
+ if {$tcl_platform(platform) == "windows"} {
+ wm overrideredirect . 1
+ }
+ .t delete 1.0 end
+ .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17"
+ .t yview 1.0
+ update
+ .t yview 16.0
+ update
+ set x [list [.t index @0,0] $tk_textRelayout $tk_textRedraw]
+ wm overrideredirect . 0
+ update
+ set x
+} {8.0 {16.0 17.0 15.0 14.0 13.0 12.0 11.0 10.0 9.0 8.0} {8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0 16.0 17.0}}
+test textDisp-4.8 {UpdateDisplayInfo, filling in extra vertical space} {
+ .t delete 1.0 end
+ .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17"
+ .t yview 16.0
+ update
+ .t delete 5.0 14.0
+ update
+ set x [list [.t index @0,0] $tk_textRelayout $tk_textRedraw]
+} {1.0 {5.0 4.0 3.0 2.0 1.0} {1.0 2.0 3.0 4.0 5.0 eof}}
+test textDisp-4.9 {UpdateDisplayInfo, filling in extra vertical space} {textfonts} {
+ .t delete 1.0 end
+ .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17"
+ .t yview 16.0
+ update
+ .t delete 15.0 end
+ list [.t bbox 7.0] [.t bbox 12.0]
+} [list [list [expr {$hlth + $px + $bw}] [expr {$hlth + $py + $bw + 2 * $fixedHeight}] $fixedWidth $fixedHeight] [list [expr {$hlth + $px + $bw}] [expr {$hlth + $py + $bw + 7 * $fixedHeight}] $fixedWidth $fixedHeight]]
+test textDisp-4.10 {UpdateDisplayInfo, filling in extra vertical space} {
+ .t delete 1.0 end
+ .t insert end "1\n2\n3\n4\n5\nLine 6 is such a long line that it wraps around.\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17"
+ .t yview end
+ update
+ .t delete 13.0 end
+ update
+ list [.t index @0,0] $tk_textRelayout $tk_textRedraw
+} {5.0 {12.0 7.0 6.40 6.20 6.0 5.0} {5.0 6.0 6.20 6.40 7.0 12.0}}
+test textDisp-4.11 {UpdateDisplayInfo, filling in extra vertical space} {
+ .t delete 1.0 end
+ .t insert end "1\n2\n3\n4\n5\nLine 6 is such a long line that it wraps around, not once but really quite a few times.\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17"
+ .t yview end
+ update
+ .t delete 14.0 end
+ update
+ list [.t index @0,0] $tk_textRelayout $tk_textRedraw
+} {6.40 {13.0 7.0 6.80 6.60 6.40} {6.40 6.60 6.80 7.0 13.0}}
+test textDisp-4.12 {UpdateDisplayInfo, filling in extra vertical space} {
+ .t delete 1.0 end
+ .t insert end "1\n2\n3\n4\n5\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16"
+ button .b -text "Test" -bd 2 -highlightthickness 2
+ .t window create 3.end -window .b
+ .t yview moveto 1
+ update
+ .t yview moveto 0
+ update
+ .t yview moveto 1
+ update
+ winfo ismapped .b
+} {0}
+.t configure -wrap word
+.t delete 1.0 end
+.t insert end "Line 1\nLine 2\nLine 3\nLine 4\nLine 5\nLine 6\nLine 7\n"
+.t insert end "Line 8\nLine 9\nLine 10\nLine 11\nLine 12\nLine 13\n"
+.t insert end "Line 14\nLine 15\nLine 16"
+.t tag delete x
+.t tag configure x -relief raised -borderwidth 2 -background white
+test textDisp-4.13 {UpdateDisplayInfo, special handling for top/bottom lines} {
+ .t tag add x 1.0 end
+ .t yview 1.0
+ update
+ .t yview scroll 3 units
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{11.0 12.0 13.0} {4.0 10.0 11.0 12.0 13.0}}
+test textDisp-4.14 {UpdateDisplayInfo, special handling for top/bottom lines} {
+ .t tag remove x 1.0 end
+ .t yview 1.0
+ update
+ .t yview scroll 3 units
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{11.0 12.0 13.0} {11.0 12.0 13.0}}
+test textDisp-4.15 {UpdateDisplayInfo, special handling for top/bottom lines} {
+ .t tag add x 1.0 end
+ .t yview 4.0
+ update
+ .t yview scroll -2 units
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{2.0 3.0} {2.0 3.0 4.0 11.0}}
+test textDisp-4.16 {UpdateDisplayInfo, special handling for top/bottom lines} {
+ .t tag remove x 1.0 end
+ .t yview 4.0
+ update
+ .t yview scroll -2 units
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{2.0 3.0} {2.0 3.0}}
+test textDisp-4.17 {UpdateDisplayInfo, horizontal scrolling} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally"
+ .t insert end "\nLine 3\nLine 4"
+ update
+ .t xview scroll 3 units
+ update
+ list $tk_textRelayout $tk_textRedraw [.t bbox 2.0] [.t bbox 2.5] \
+ [.t bbox 2.23]
+} [list {} {1.0 2.0 3.0 4.0} {} [list 17 [expr {$fixedDiff + 16}] 7 $fixedHeight] {}]
+test textDisp-4.18 {UpdateDisplayInfo, horizontal scrolling} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally"
+ .t insert end "\nLine 3\nLine 4"
+ update
+ .t xview scroll 100 units
+ update
+ list $tk_textRelayout $tk_textRedraw [.t bbox 2.25]
+} [list {} {1.0 2.0 3.0 4.0} [list 10 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-4.19 {UpdateDisplayInfo, horizontal scrolling} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally"
+ .t insert end "\nLine 3\nLine 4"
+ update
+ .t xview moveto 0
+ .t xview scroll -10 units
+ update
+ list $tk_textRelayout $tk_textRedraw [.t bbox 2.5]
+} [list {} {1.0 2.0 3.0 4.0} [list 38 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-4.20 {UpdateDisplayInfo, horizontal scrolling} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally"
+ .t insert end "\nLine 3\nLine 4"
+ .t xview moveto 0.0
+ .t xview scroll 100 units
+ update
+ .t delete 2.30 2.44
+ update
+ list $tk_textRelayout $tk_textRedraw [.t bbox 2.25]
+} [list 2.0 {1.0 2.0 3.0 4.0} [list 108 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-4.21 {UpdateDisplayInfo, horizontal scrolling} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally"
+ .t insert end "\nLine 3\nLine 4"
+ .t xview moveto .9
+ update
+ .t xview moveto .6
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{} {}}
+test textDisp-4.22 {UpdateDisplayInfo, no horizontal scrolling except for -wrap none} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally"
+ .t insert end "\nLine 3\nLine 4"
+ .t xview scroll 25 units
+ update
+ .t configure -wrap word
+ list [.t bbox 2.0] [.t bbox 2.16]
+} [list [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 10 [expr {2*$fixedDiff + 29}] 7 $fixedHeight]]
+test textDisp-4.23 {UpdateDisplayInfo, no horizontal scrolling except for -wrap none} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally"
+ .t insert end "\nLine 3\nLine 4"
+ .t xview scroll 25 units
+ update
+ .t configure -wrap char
+ list [.t bbox 2.0] [.t bbox 2.16]
+} [list [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 115 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-5.1 {DisplayDLine, handling of spacing} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "abcdefghijkl\nmnopqrstuvwzyz"
+ .t tag configure spacing -spacing1 8 -spacing3 2
+ .t tag add spacing 1.0 end
+ frame .t.f1 -width 10 -height 4 -bg black
+ frame .t.f2 -width 10 -height 4 -bg black
+ frame .t.f3 -width 10 -height 4 -bg black
+ frame .t.f4 -width 10 -height 4 -bg black
+ .t window create 1.3 -window .t.f1 -align top
+ .t window create 1.7 -window .t.f2 -align center
+ .t window create 2.1 -window .t.f3 -align bottom
+ .t window create 2.10 -window .t.f4 -align baseline
+ update
+ list [winfo geometry .t.f1] [winfo geometry .t.f2] \
+ [winfo geometry .t.f3] [winfo geometry .t.f4]
+} [list 10x4+24+11 10x4+55+[expr {$fixedDiff/2 + 15}] 10x4+10+[expr {2*$fixedDiff + 43}] 10x4+76+[expr {2*$fixedDiff + 40}]]
+.t tag delete spacing
+
+# Although the following test produces a useful result, its main
+# effect is to produce a core dump if Tk doesn't handle display
+# relayout that occurs during redisplay.
+
+test textDisp-5.2 {DisplayDLine, line resizes during display} {
+ .t delete 1.0 end
+ frame .t.f -width 20 -height 20 -bd 2 -relief raised
+ bind .t.f <Configure> {.t.f configure -width 30 -height 30}
+ .t window create insert -window .t.f
+ update
+ list [winfo width .t.f] [winfo height .t.f]
+} [list 30 30]
+
+.t configure -wrap char
+test textDisp-6.1 {scrolling in DisplayText, scroll up} {
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t delete 2.0 3.0
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{2.0 10.0} {2.0 10.0}}
+test textDisp-6.2 {scrolling in DisplayText, scroll down} {
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t insert 2.0 "New Line 2\n"
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{2.0 3.0} {2.0 3.0}}
+test textDisp-6.3 {scrolling in DisplayText, multiple scrolls} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t insert 2.end "is so long that it wraps"
+ .t insert 4.end "is so long that it wraps"
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{2.0 2.20 4.0 4.20} {2.0 2.20 4.0 4.20}}
+test textDisp-6.4 {scrolling in DisplayText, scrolls interfere} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t insert 2.end "is so long that it wraps around, not once but three times"
+ .t insert 4.end "is so long that it wraps"
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{2.0 2.20 2.40 2.60 4.0 4.20} {2.0 2.20 2.40 2.60 4.0 4.20 6.0}}
+test textDisp-6.5 {scrolling in DisplayText, scroll source obscured} {nonPortable} {
+ .t configure -wrap char
+ frame .f2 -bg red
+ place .f2 -in .t -relx 0.5 -rely 0.5 -relwidth 0.5 -relheight 0.5
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1 is so long that it wraps around, a couple of times"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t delete 1.6 1.end
+ update
+ destroy .f2
+ list $tk_textRelayout $tk_textRedraw
+} {{1.0 9.0 10.0} {1.0 4.0 5.0 9.0 10.0}}
+test textDisp-6.6 {scrolling in DisplayText, Expose events after scroll} {unix nonPortable} {
+ # this test depends on all of the expose events being handled at once
+ .t configure -wrap char
+ frame .f2 -bg #ff0000
+ place .f2 -in .t -relx 0.2 -rely 0.5 -relwidth 0.5 -relheight 0.5
+ .t configure -bd 2 -relief raised
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1 is so long that it wraps around, a couple of times"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t delete 1.6 1.end
+ destroy .f2
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{1.0 9.0 10.0} {borders 1.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0}}
+.t configure -bd 0
+test textDisp-6.7 {DisplayText, vertical scrollbar updates} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ update ; .t count -update -ypixels 1.0 end ; update
+ set scrollInfo
+} {0.0 1.0}
+test textDisp-6.8 {DisplayText, vertical scrollbar updates} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ update
+ set scrollInfo "unchanged"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13} {
+ .t insert end "\nLine $i"
+ }
+ update ; .t count -update -ypixels 1.0 end ; update
+ set scrollInfo
+} [list 0.0 [expr {10.0/13}]]
+.t configure -yscrollcommand {} -xscrollcommand scroll
+test textDisp-6.9 {DisplayText, horizontal scrollbar updates} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ update
+ set scrollInfo unchanged
+ .t insert end xxxxxxxxx\n
+ .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n
+ .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx
+ update
+ set scrollInfo
+} [list 0.0 [expr {4.0/11}]]
+
+# The following group of tests is marked non-portable because
+# they result in a lot of extra redisplay under Ultrix. I don't
+# know why this is so.
+
+.t configure -bd 2 -relief raised -wrap char
+.t delete 1.0 end
+.t insert 1.0 "Line 1 is so long that it wraps around, a couple of times"
+foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+}
+test textDisp-7.1 {TkTextRedrawRegion} {nonPortable} {
+ frame .f2 -bg #ff0000
+ place .f2 -in .t -relx 0.2 -relwidth 0.6 -rely 0.22 -relheight 0.55
+ update
+ destroy .f2
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{} {1.40 2.0 3.0 4.0 5.0 6.0}}
+test textDisp-7.2 {TkTextRedrawRegion} {nonPortable} {
+ frame .f2 -bg #ff0000
+ place .f2 -in .t -relx 0 -relwidth 0.5 -rely 0 -relheight 0.5
+ update
+ destroy .f2
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{} {borders 1.0 1.20 1.40 2.0 3.0}}
+test textDisp-7.3 {TkTextRedrawRegion} {nonPortable} {
+ frame .f2 -bg #ff0000
+ place .f2 -in .t -relx 0.5 -relwidth 0.5 -rely 0.5 -relheight 0.5
+ update
+ destroy .f2
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{} {borders 4.0 5.0 6.0 7.0 8.0}}
+test textDisp-7.4 {TkTextRedrawRegion} {nonPortable} {
+ frame .f2 -bg #ff0000
+ place .f2 -in .t -relx 0.4 -relwidth 0.2 -rely 0 -relheight 0.2 \
+ -bordermode ignore
+ update
+ destroy .f2
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{} {borders 1.0 1.20}}
+test textDisp-7.5 {TkTextRedrawRegion} {nonPortable} {
+ frame .f2 -bg #ff0000
+ place .f2 -in .t -relx 0.4 -relwidth 0.2 -rely 1.0 -relheight 0.2 \
+ -anchor s -bordermode ignore
+ update
+ destroy .f2
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{} {borders 7.0 8.0}}
+test textDisp-7.6 {TkTextRedrawRegion} {nonPortable} {
+ frame .f2 -bg #ff0000
+ place .f2 -in .t -relx 0 -relwidth 0.2 -rely 0.55 -relheight 0.2 \
+ -anchor w -bordermode ignore
+ update
+ destroy .f2
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{} {borders 3.0 4.0 5.0}}
+test textDisp-7.7 {TkTextRedrawRegion} {nonPortable} {
+ frame .f2 -bg #ff0000
+ place .f2 -in .t -relx 1.0 -relwidth 0.2 -rely 0.55 -relheight 0.2 \
+ -anchor e -bordermode ignore
+ update
+ destroy .f2
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{} {borders 3.0 4.0 5.0}}
+test textDisp-7.8 {TkTextRedrawRegion} {nonPortable} {
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2\nLine 3\nLine 4\nLine 5\nLine 6\n"
+ frame .f2 -bg #ff0000
+ place .f2 -in .t -relx 0.0 -relwidth 0.4 -rely 0.35 -relheight 0.4 \
+ -anchor nw -bordermode ignore
+ update
+ destroy .f2
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{} {borders 4.0 5.0 6.0 7.0 eof}}
+.t configure -bd 0
+
+test textDisp-8.1 {TkTextChanged: redisplay whole lines} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is so long that it wraps around, two times"
+ foreach i {3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t delete 2.36 2.38
+ update
+ list $tk_textRelayout $tk_textRedraw [.t bbox 2.32]
+} [list {2.0 2.18 2.38} {2.0 2.18 2.38} [list 101 [expr {2*$fixedDiff + 29}] 7 $fixedHeight]]
+.t configure -wrap char
+test textDisp-8.2 {TkTextChanged, redisplay whole lines} {
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1 is so long that it wraps around, two times"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t insert 1.2 xx
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{1.0 1.20 1.40} {1.0 1.20 1.40}}
+test textDisp-8.3 {TkTextChanged} {
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1 is so long that it wraps around, two times"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t insert 2.0 xx
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {2.0 2.0}
+test textDisp-8.4 {TkTextChanged} {
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1 is so long that it wraps around, two times"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t delete 1.5
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{1.0 1.20 1.40} {1.0 1.20 1.40}}
+test textDisp-8.5 {TkTextChanged} {
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1 is so long that it wraps around, two times"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t delete 1.40 1.44
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{1.0 1.20 1.40} {1.0 1.20 1.40}}
+test textDisp-8.6 {TkTextChanged} {
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1 is so long that it wraps around, two times"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t delete 1.41 1.44
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{1.0 1.20 1.40} {1.0 1.20 1.40}}
+test textDisp-8.7 {TkTextChanged} {
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1 is so long that it wraps around, two times"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t delete 1.2 1.end
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{1.0 9.0 10.0} {1.0 9.0 10.0}}
+test textDisp-8.8 {TkTextChanged} {
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1 is so long that it wraps around, two times"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t delete 2.2
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {2.0 2.0}
+test textDisp-8.9 {TkTextChanged} {
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1 is so long that it wraps around, two times"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ update
+ .t delete 2.0 3.0
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{2.0 8.0} {2.0 8.0}}
+test textDisp-8.10 {TkTextChanged} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4"
+ .t tag add big 2.19
+ update
+ .t delete 2.19
+ update
+ set tk_textRedraw
+} {2.0 2.20 eof}
+test textDisp-8.11 {TkTextChanged, scrollbar notification when changes are off-screen} {
+ .t delete 1.0 end
+ .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n"
+ .t configure -yscrollcommand scroll
+ update
+ set scrollInfo ""
+ .t insert end "a\nb\nc\n"
+ # We need to wait for our asychronous callbacks to update the
+ # scrollbar
+ update ; .t count -update -ypixels 1.0 end ; update
+ .t configure -yscrollcommand ""
+ set scrollInfo
+} {0.0 0.625}
+test textDisp-8.12 {TkTextChanged, moving the insert cursor redraws only past and new lines} {
+ .t delete 1.0 end
+ .t configure -wrap none
+ for {set i 1} {$i < 25} {incr i} {
+ .t insert end "Line $i Line $i\n"
+ }
+ .t tag add hidden 5.0 8.0
+ .t tag configure hidden -elide true
+ .t mark set insert 9.0
+ update
+ .t mark set insert 8.0 ; # up one line
+ update
+ set res [list $tk_textRedraw]
+ .t mark set insert 12.2 ; # in the visible text
+ update
+ lappend res $tk_textRedraw
+ .t mark set insert 6.5 ; # in the hidden text
+ update
+ lappend res $tk_textRedraw
+ .t mark set insert 3.5 ; # in the visible text again
+ update
+ lappend res $tk_textRedraw
+ .t mark set insert 3.8 ; # within the same line
+ update
+ lappend res $tk_textRedraw
+} {{8.0 9.0} {8.0 12.0} {8.0 12.0} {3.0 8.0} {3.0 4.0}}
+test textDisp-8.13 {TkTextChanged, used to crash, see [06c1433906]} {
+ .t delete 1.0 end
+ .t insert 1.0 \nLine2\nLine3\n
+ update
+ .t insert 3.0 ""
+ .t delete 1.0 2.0
+ update idletasks
+} {}
+
+test textDisp-9.1 {TkTextRedrawTag} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4"
+ update
+ .t tag add big 2.2 2.4
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{2.0 2.18} {2.0 2.18}}
+test textDisp-9.2 {TkTextRedrawTag} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4"
+ update
+ .t tag add big 1.2 2.4
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{1.0 2.0 2.17} {1.0 2.0 2.17}}
+test textDisp-9.3 {TkTextRedrawTag} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4"
+ update
+ .t tag add big 2.2 2.4
+ update
+ .t tag remove big 1.0 end
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{2.0 2.20} {2.0 2.20 eof}}
+test textDisp-9.4 {TkTextRedrawTag} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4"
+ update
+ .t tag add big 2.2 2.20
+ update
+ .t tag remove big 1.0 end
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{2.0 2.20} {2.0 2.20 eof}}
+test textDisp-9.5 {TkTextRedrawTag} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4"
+ update
+ .t tag add big 2.2 2.end
+ update
+ .t tag remove big 1.0 end
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{2.0 2.20} {2.0 2.20 eof}}
+test textDisp-9.6 {TkTextRedrawTag} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap"
+ update
+ .t tag add big 2.2 3.5
+ update
+ .t tag remove big 1.0 end
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{2.0 2.20 3.0 3.20} {2.0 2.20 3.0 3.20 eof}}
+test textDisp-9.7 {TkTextRedrawTag} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4"
+ .t tag add big 2.19
+ update
+ .t tag remove big 2.19
+ update
+ set tk_textRedraw
+} {2.0 2.20 eof}
+test textDisp-9.8 {TkTextRedrawTag} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4"
+ .t tag add big 1.0 2.0
+ update
+ .t tag add big 2.0 2.5
+ update
+ set tk_textRedraw
+} {2.0 2.17}
+test textDisp-9.9 {TkTextRedrawTag} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4"
+ .t tag add big 1.0 2.0
+ update
+ .t tag add big 1.5 2.5
+ update
+ set tk_textRedraw
+} {2.0 2.17}
+test textDisp-9.10 {TkTextRedrawTag} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4"
+ .t tag add big 1.0 2.0
+ update
+ set tk_textRedraw {none}
+ .t tag add big 1.3 1.5
+ update
+ set tk_textRedraw
+} {none}
+test textDisp-9.11 {TkTextRedrawTag} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4"
+ .t tag add big 1.0 2.0
+ update
+ .t tag add big 1.0 2.0
+ update
+ set tk_textRedraw
+} {}
+test textDisp-9.12 {TkTextRedrawTag} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ for {set i 1} {$i < 5} {incr i} {
+ .t insert end "Line $i+++Line $i\n"
+ }
+ .t tag configure hidden -elide true
+ .t tag add hidden 2.6 3.6
+ update
+ .t tag add hidden 3.11 4.6
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {2.0 {2.0 eof}}
+test textDisp-9.13 {TkTextRedrawTag} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i - This is Line [format %c [expr 64+$i]]\n"
+ }
+ .t tag add hidden 2.8 2.17
+ .t tag add hidden 6.8 7.17
+ .t tag configure hidden -background red
+ .t tag configure hidden -elide true
+ update
+ .t tag configure hidden -elide false
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{2.0 6.0 7.0} {2.0 6.0 7.0}}
+test textDisp-9.14 {TkTextRedrawTag} {
+ pack [text .tnocrash]
+ for {set i 1} {$i < 6} {incr i} {
+ .tnocrash insert end \nfoo$i
+ }
+ .tnocrash tag configure mytag1 -relief raised
+ .tnocrash tag configure mytag2 -relief solid
+ update
+ proc doit {} {
+ .tnocrash tag add mytag1 4.0 5.0
+ .tnocrash tag add mytag2 4.0 5.0
+ after idle {
+ .tnocrash tag remove mytag1 1.0 end
+ .tnocrash tag remove mytag2 1.0 end
+ }
+ .tnocrash delete 1.0 2.0
+ }
+ doit ; # must not crash
+ after 500 {
+ destroy .tnocrash
+ set done 1
+ }
+ vwait done
+} {}
+
+test textDisp-10.1 {TkTextRelayoutWindow} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4"
+ update
+ .t configure -bg black
+ update
+ list $tk_textRelayout $tk_textRedraw
+} {{1.0 2.0 2.20 3.0 3.20 4.0} {borders 1.0 2.0 2.20 3.0 3.20 4.0 eof}}
+.t configure -bg [lindex [.t configure -bg] 3]
+catch {destroy .top}
+test textDisp-10.2 {TkTextRelayoutWindow} {
+ toplevel .top -width 300 -height 200
+ wm geometry .top +0+0
+ text .top.t -font $fixedFont -width 20 -height 10 -relief raised -bd 2
+ place .top.t -x 0 -y 0 -width 20 -height 20
+ .top.t insert end "First line"
+ .top.t see insert
+ tkwait visibility .top.t
+ place .top.t -width 150 -height 100
+ update
+ .top.t index @0,0
+} {1.0}
+catch {destroy .top}
+
+.t delete 1.0 end
+.t insert end "Line 1"
+for {set i 2} {$i <= 200} {incr i} {
+ .t insert end "\nLine $i"
+}
+update
+test textDisp-11.1 {TkTextSetYView} {
+ .t yview 30.0
+ update
+ .t index @0,0
+} {30.0}
+test textDisp-11.2 {TkTextSetYView} {
+ .t yview 30.0
+ update
+ .t yview 32.0
+ update
+ list [.t index @0,0] $tk_textRedraw
+} {32.0 {40.0 41.0}}
+test textDisp-11.3 {TkTextSetYView} {
+ .t yview 30.0
+ update
+ .t yview 28.0
+ update
+ list [.t index @0,0] $tk_textRedraw
+} {28.0 {28.0 29.0}}
+test textDisp-11.4 {TkTextSetYView} {
+ .t yview 30.0
+ update
+ .t yview 31.4
+ update
+ list [.t index @0,0] $tk_textRedraw
+} {31.0 40.0}
+test textDisp-11.5 {TkTextSetYView} {
+ .t yview 30.0
+ update
+ set tk_textRedraw {}
+ .t yview -pickplace 31.0
+ update
+ list [.t index @0,0] $tk_textRedraw
+} {30.0 {}}
+test textDisp-11.6 {TkTextSetYView} {
+ .t yview 30.0
+ update
+ set tk_textRedraw {}
+ .t yview -pickplace 28.0
+ update
+ list [.t index @0,0] $tk_textRedraw
+} {28.0 {28.0 29.0}}
+test textDisp-11.7 {TkTextSetYView} {
+ .t yview 30.0
+ update ; update
+ set tk_textRedraw {}
+ .t yview -pickplace 26.0
+ update
+ list [.t index @0,0] $tk_textRedraw
+} {21.0 {21.0 22.0 23.0 24.0 25.0 26.0 27.0 28.0 29.0}}
+test textDisp-11.8 {TkTextSetYView} {
+ .t yview 30.0
+ update
+ set tk_textRedraw {}
+ .t yview -pickplace 41.0
+ update
+ list [.t index @0,0] $tk_textRedraw
+} {32.0 {40.0 41.0}}
+test textDisp-11.9 {TkTextSetYView} {
+ .t yview 30.0
+ update
+ set tk_textRedraw {}
+ .t yview -pickplace 43.0
+ update
+ list [.t index @0,0] $tk_textRedraw
+} {38.0 {40.0 41.0 42.0 43.0 44.0 45.0 46.0 47.0 48.0}}
+test textDisp-11.10 {TkTextSetYView} {
+ .t yview 30.0
+ update
+ set tk_textRedraw {}
+ .t yview 10000.0
+ update
+ list [.t index @0,0] $tk_textRedraw
+} {191.0 {191.0 192.0 193.0 194.0 195.0 196.0 197.0 198.0 199.0 200.0}}
+test textDisp-11.11 {TkTextSetYView} {
+ .t yview 195.0
+ update
+ set tk_textRedraw {}
+ .t yview 197.0
+ update
+ list [.t index @0,0] $tk_textRedraw
+} {191.0 {191.0 192.0 193.0 194.0 195.0 196.0}}
+test textDisp-11.12 {TkTextSetYView, wrapped line is off-screen} {
+ .t insert 10.0 "Long line with enough text to wrap\n"
+ .t yview 1.0
+ update
+ set tk_textRedraw {}
+ .t see 10.30
+ update
+ list [.t index @0,0] $tk_textRedraw
+} {2.0 10.20}
+.t delete 10.0 11.0
+test textDisp-11.13 {TkTestSetYView, partially visible last line} {
+ catch {destroy .top}
+ toplevel .top
+ wm geometry .top +0+0
+ text .top.t -width 20 -height 5
+ pack .top.t
+ .top.t insert end "Line 1"
+ for {set i 2} {$i <= 100} {incr i} {
+ .top.t insert end "\nLine $i"
+ }
+ update
+ scan [wm geometry .top] "%dx%d" w2 h2
+ wm geometry .top ${w2}x[expr $h2-2]
+ update
+ .top.t yview 1.0
+ update
+ set tk_textRedraw {}
+ .top.t see 5.0
+ update
+ # Note, with smooth scrolling, the results of this test
+ # have changed, and the old '2.0 {5.0 6.0}' is quite wrong.
+ list [.top.t index @0,0] $tk_textRedraw
+} {1.0 5.0}
+catch {destroy .top}
+toplevel .top
+wm geometry .top +0+0
+text .top.t -width 30 -height 3
+pack .top.t
+.top.t insert end "Line 1"
+for {set i 2} {$i <= 20} {incr i} {
+ .top.t insert end "\nLine $i"
+}
+update
+test textDisp-11.14 {TkTextSetYView, only a few lines visible} {
+ .top.t yview 5.0
+ update
+ .top.t see 10.0
+ .top.t index @0,0
+} {8.0}
+test textDisp-11.15 {TkTextSetYView, only a few lines visible} {
+ .top.t yview 5.0
+ update
+ .top.t see 11.0
+ .top.t index @0,0
+ # The index 9.0 should be just visible by a couple of pixels
+} {9.0}
+test textDisp-11.16 {TkTextSetYView, only a few lines visible} {
+ .top.t yview 8.0
+ update
+ .top.t see 5.0
+ .top.t index @0,0
+} {5.0}
+test textDisp-11.17 {TkTextSetYView, only a few lines visible} {
+ .top.t yview 8.0
+ update
+ .top.t see 4.0
+ .top.t index @0,0
+ # The index 2.0 should be just visible by a couple of pixels
+} {2.0}
+test textDisp-11.18 {TkTextSetYView, see in elided lines} {
+ .top.t delete 1.0 end
+ for {set i 1} {$i < 20} {incr i} {
+ .top.t insert end [string repeat "Line $i" 10]
+ .top.t insert end "\n"
+ }
+ .top.t yview 4.0
+ .top.t tag add hidden 4.10 "4.10 lineend"
+ .top.t tag add hidden 5.15 10.3
+ .top.t tag configure hidden -elide true
+ update
+ .top.t see "8.0 lineend"
+ # The index "8.0 lineend" is on screen despite elided -> no scroll
+ .top.t index @0,0
+} {4.0}
+test textDisp-11.19 {TkTextSetYView, see in elided lines} {
+ .top.t delete 1.0 end
+ for {set i 1} {$i < 50} {incr i} {
+ .top.t insert end "Line $i\n"
+ }
+ # button just for having a line with a larger height
+ button .top.t.b -text "Test" -bd 2 -highlightthickness 2
+ .top.t window create 21.0 -window .top.t.b
+ .top.t tag add hidden 15.36 21.0
+ .top.t tag configure hidden -elide true
+ .top.t configure -height 15
+ wm geometry .top 300x200+0+0
+ # Indices 21.0, 17.0 and 15.0 are all on the same display line
+ # therefore index @0,0 shall be the same for all of them
+ .top.t see end
+ update
+ .top.t see 21.0
+ update
+ set ind1 [.top.t index @0,0]
+ .top.t see end
+ update
+ .top.t see 17.0
+ update
+ set ind2 [.top.t index @0,0]
+ .top.t see end
+ update
+ .top.t see 15.0
+ update
+ set ind3 [.top.t index @0,0]
+ list [expr {$ind1 == $ind2}] [expr {$ind1 == $ind3}]
+} {1 1}
+test textDisp-11.20 {TkTextSetYView, see in elided lines} {
+ .top.t delete 1.0 end
+ .top.t configure -wrap none
+ for {set i 1} {$i < 5} {incr i} {
+ .top.t insert end [string repeat "Line $i " 50]
+ .top.t insert end "\n"
+ }
+ .top.t delete 3.11 3.14
+ .top.t tag add hidden 3.0 4.0
+ # this shall not crash (null chunkPtr in TkTextSeeCmd is tested)
+ .top.t see 3.0
+} {}
+test textDisp-11.21 {TkTextSetYView, window height smaller than the line height} {
+ .top.t delete 1.0 end
+ for {set i 1} {$i <= 10} {incr i} {
+ .top.t insert end "Line $i\n"
+ }
+ set lineheight [font metrics [.top.t cget -font] -linespace]
+ wm geometry .top 200x[expr {$lineheight / 2}]
+ update
+ .top.t see 1.0
+ .top.t index @0,[expr {$lineheight - 2}]
+} {1.0}
+
+.t configure -wrap word
+.t delete 50.0 51.0
+.t insert 50.0 "This is a long line, one that will wrap around twice.\n"
+test textDisp-12.1 {MeasureUp} {
+ .t yview 100.0
+ update
+ .t yview -pickplace 52.0
+ update
+ .t index @0,0
+} {49.0}
+test textDisp-12.2 {MeasureUp} {
+ .t yview 100.0
+ update
+ .t yview -pickplace 53.0
+ update
+ .t index @0,0
+} {50.0}
+test textDisp-12.3 {MeasureUp} {
+ .t yview 100.0
+ update
+ .t yview -pickplace 50.10
+ update
+ .t index @0,0
+} {45.0}
+.t configure -wrap none
+test textDisp-12.4 {MeasureUp} {
+ .t yview 100.0
+ update
+ .t yview -pickplace 53.0
+ update
+ .t index @0,0
+} {48.0}
+test textDisp-12.5 {MeasureUp} {
+ .t yview 100.0
+ update
+ .t yview -pickplace 50.10
+ update
+ .t index @0,0
+} {45.0}
+
+.t configure -wrap none
+.t delete 1.0 end
+for {set i 1} {$i < 99} {incr i} {
+ .t insert end "Line $i\n"
+}
+.t insert end "Line 100"
+.t insert 30.end { is quite long, so that it flows way off the end of the window and we can use it to test out the horizontal positioning features of the "see" command.}
+test textDisp-13.1 {TkTextSeeCmd procedure} {
+ list [catch {.t see} msg] $msg
+} {1 {wrong # args: should be ".t see index"}}
+test textDisp-13.2 {TkTextSeeCmd procedure} {
+ list [catch {.t see a b} msg] $msg
+} {1 {wrong # args: should be ".t see index"}}
+test textDisp-13.3 {TkTextSeeCmd procedure} {
+ list [catch {.t see badIndex} msg] $msg
+} {1 {bad text index "badIndex"}}
+test textDisp-13.4 {TkTextSeeCmd procedure} {
+ .t xview moveto 0
+ .t yview moveto 0
+ update
+ .t see 4.2
+ .t index @0,0
+} {1.0}
+test textDisp-13.5 {TkTextSeeCmd procedure} {
+ .t configure -wrap char
+ .t xview moveto 0
+ .t yview moveto 0
+ update
+ .t see 12.1
+ .t index @0,0
+} {3.0}
+test textDisp-13.6 {TkTextSeeCmd procedure} {
+ .t configure -wrap char
+ .t xview moveto 0
+ .t yview moveto 0
+ update
+ .t see 30.50
+ set x [.t index @0,0]
+ .t configure -wrap none
+ set x
+} {27.0}
+test textDisp-13.7 {TkTextSeeCmd procedure} {textfonts} {
+ .t xview moveto 0
+ .t yview moveto 0
+ .t tag add sel 30.20
+ .t tag add sel 30.40
+ update
+ .t see 30.50
+ .t yview 25.0
+ .t see 30.50
+ set x [list [.t bbox 30.50]]
+ .t see 30.39
+ lappend x [.t bbox 30.39]
+ .t see 30.38
+ lappend x [.t bbox 30.38]
+ .t see 30.20
+ lappend x [.t bbox 30.20]
+} [list [list 73 [expr {5*$fixedDiff + 68}] 7 $fixedHeight] [list 3 [expr {5*$fixedDiff + 68}] 7 $fixedHeight] [list 3 [expr {5*$fixedDiff + 68}] 7 $fixedHeight] [list 73 [expr {5*$fixedDiff + 68}] 7 $fixedHeight]]
+test textDisp-13.8 {TkTextSeeCmd procedure} {textfonts} {
+ .t xview moveto 0
+ .t yview moveto 0
+ .t tag add sel 30.20
+ .t tag add sel 30.50
+ update
+ .t see 30.50
+ set x [list [.t bbox 30.50]]
+ .t see 30.60
+ lappend x [.t bbox 30.60]
+ .t see 30.65
+ lappend x [.t bbox 30.65]
+ .t see 30.90
+ lappend x [.t bbox 30.90]
+} [list [list 73 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight] [list 136 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight] [list 136 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight] [list 73 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight]]
+test textDisp-13.9 {TkTextSeeCmd procedure} {textfonts} {
+ wm geom . [expr $width-2]x$height
+ .t xview moveto 0
+ .t yview moveto 0
+ .t tag add sel 30.20
+ .t tag add sel 30.50
+ update
+ .t see 30.50
+ set x [list [.t bbox 30.50]]
+ .t see 30.60
+ lappend x [.t bbox 30.60]
+ .t see 30.65
+ lappend x [.t bbox 30.65]
+ .t see 30.90
+ lappend x [.t bbox 30.90]
+} [list [list 74 [expr {9*$fixedDiff/2 + 66}] 7 $fixedHeight] [list 138 [expr {9*$fixedDiff/2 + 66}] 7 $fixedHeight] [list 138 [expr {9*$fixedDiff/2 + 66}] 7 $fixedHeight] [list 74 [expr {9*$fixedDiff/2 + 66}] 7 $fixedHeight]]
+test textDisp-13.10 {TkTextSeeCmd procedure} {} {
+ # SF Bug 641778
+ set w .tsee
+ destroy $w
+ text $w -font {Helvetica 8 normal} -bd 16
+ $w insert end Hello
+ $w see end
+ set res [$w bbox end]
+ destroy $w
+ set res
+} {}
+test textDisp-13.11 {TkTextSeeCmd procedure} {} {
+ # insertion of a character at end of a line containing multi-byte
+ # characters and calling see at the line end shall actually show
+ # this character
+ toplevel .top2
+ pack [text .top2.t2 -wrap none]
+ for {set i 1} {$i < 5} {incr i} {
+ .top2.t2 insert end [string repeat "Line $i: éèàçù" 5]\n
+
+ }
+ wm geometry .top2 300x200+0+0
+ update
+ .top2.t2 see "1.0 lineend"
+ update
+ set ref [.top2.t2 index @0,0]
+ .top2.t2 insert "1.0 lineend" ç
+ .top2.t2 see "1.0 lineend"
+ update
+ set new [.top2.t2 index @0,0]
+ set res [.top2.t2 compare $ref == $new]
+ destroy .top2
+ set res
+} {0}
+wm geom . {}
+
+.t configure -wrap none
+test textDisp-14.1 {TkTextXviewCmd procedure} {
+ .t delete 1.0 end
+ update
+ .t insert end xxxxxxxxx\n
+ .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n"
+ .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx"
+ .t xview moveto .5
+ .t xview
+} [list 0.5 [expr {6./7.}]]
+.t configure -wrap char
+test textDisp-14.2 {TkTextXviewCmd procedure} {
+ .t delete 1.0 end
+ update
+ .t insert end xxxxxxxxx\n
+ .t insert end "xxxxx\n"
+ .t insert end "xxxx"
+ .t xview
+} {0.0 1.0}
+.t configure -wrap none
+test textDisp-14.3 {TkTextXviewCmd procedure} {
+ .t delete 1.0 end
+ update
+ .t insert end xxxxxxxxx\n
+ .t insert end "xxxxx\n"
+ .t insert end "xxxx"
+ .t xview
+} {0.0 1.0}
+test textDisp-14.4 {TkTextXviewCmd procedure} {
+ list [catch {.t xview moveto} msg] $msg
+} {1 {wrong # args: should be ".t xview moveto fraction"}}
+test textDisp-14.5 {TkTextXviewCmd procedure} {
+ list [catch {.t xview moveto a b} msg] $msg
+} {1 {wrong # args: should be ".t xview moveto fraction"}}
+test textDisp-14.6 {TkTextXviewCmd procedure} {
+ list [catch {.t xview moveto a} msg] $msg
+} {1 {expected floating-point number but got "a"}}
+test textDisp-14.7 {TkTextXviewCmd procedure} {
+ .t delete 1.0 end
+ .t insert end xxxxxxxxx\n
+ .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n"
+ .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx"
+ .t xview moveto .3
+ .t xview
+} [list [expr {118.0/392}] [expr {258.0/392}]]
+test textDisp-14.8 {TkTextXviewCmd procedure} {
+ .t delete 1.0 end
+ .t insert end xxxxxxxxx\n
+ .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n"
+ .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx"
+ .t xview moveto -.4
+ .t xview
+} [list 0.0 [expr {5.0/14}]]
+test textDisp-14.9 {TkTextXviewCmd procedure} {
+ .t delete 1.0 end
+ .t insert end xxxxxxxxx\n
+ .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n"
+ .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx"
+ .t xview m 1.4
+ .t xview
+} [list [expr {9.0/14}] 1.0]
+test textDisp-14.10 {TkTextXviewCmd procedure} {
+ list [catch {.t xview scroll a} msg] $msg
+} {1 {wrong # args: should be ".t xview scroll number units|pages|pixels"}}
+test textDisp-14.11 {TkTextXviewCmd procedure} {
+ list [catch {.t xview scroll a b c} msg] $msg
+} {1 {wrong # args: should be ".t xview scroll number units|pages|pixels"}}
+test textDisp-14.12 {TkTextXviewCmd procedure} {
+ list [catch {.t xview scroll gorp units} msg] $msg
+} {1 {expected integer but got "gorp"}}
+test textDisp-14.13 {TkTextXviewCmd procedure} {
+ .t delete 1.0 end
+ .t insert end xxxxxxxxx\n
+ .t insert end "a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9\n"
+ .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx"
+ .t xview moveto 0
+ .t xview scroll 2 pa
+ set x [.t index @0,22]
+ .t xview scroll -1 pa
+ lappend x [.t index @0,22]
+ .t xview scroll -2 pages
+ lappend x [.t index @0,22]
+} {2.36 2.18 2.0}
+test textDisp-14.14 {TkTextXviewCmd procedure} {
+ .t delete 1.0 end
+ .t insert end xxxxxxxxx\n
+ .t insert end "a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9\n"
+ .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx"
+ .t xview moveto 0
+ .t xview scroll 21 u
+ set x [.t index @0,22]
+ .t xview scroll -1 u
+ lappend x [.t index @0,22]
+ .t xview scroll 100 units
+ lappend x [.t index @0,22]
+ .t xview scroll -15 units
+ lappend x [.t index @0,22]
+} {2.21 2.20 2.99 2.84}
+test textDisp-14.15 {TkTextXviewCmd procedure} {
+ list [catch {.t xview scroll 14 globs} msg] $msg
+} {1 {bad argument "globs": must be units, pages, or pixels}}
+test textDisp-14.16 {TkTextXviewCmd procedure} {
+ list [catch {.t xview flounder} msg] $msg
+} {1 {bad option "flounder": must be moveto or scroll}}
+
+.t configure -wrap char
+.t delete 1.0 end
+for {set i 1} {$i < 99} {incr i} {
+ .t insert end "Line $i\n"
+}
+.t insert end "Line 100"
+.t delete 50.0 51.0
+.t insert 50.0 "This is a long line, one that will wrap around twice.\n"
+test textDisp-15.1 {ScrollByLines procedure, scrolling backwards} {
+ .t yview 45.0
+ update
+ .t yview scroll -3 units
+ .t index @0,0
+} {42.0}
+test textDisp-15.2 {ScrollByLines procedure, scrolling backwards} {
+ .t yview 51.0
+ update
+ .t yview scroll -2 units
+ .t index @0,0
+} {50.20}
+test textDisp-15.3 {ScrollByLines procedure, scrolling backwards} {
+ .t yview 51.0
+ update
+ .t yview scroll -4 units
+ .t index @0,0
+} {49.0}
+test textDisp-15.4 {ScrollByLines procedure, scrolling backwards} {
+ .t yview 50.20
+ update
+ .t yview scroll -2 units
+ .t index @0,0
+} {49.0}
+test textDisp-15.5 {ScrollByLines procedure, scrolling backwards} {
+ .t yview 50.40
+ update
+ .t yview scroll -2 units
+ .t index @0,0
+} {50.0}
+test textDisp-15.6 {ScrollByLines procedure, scrolling backwards} {
+ .t yview 3.2
+ update
+ .t yview scroll -5 units
+ .t index @0,0
+} {1.0}
+test textDisp-15.7 {ScrollByLines procedure, scrolling forwards} {
+ .t yview 48.0
+ update
+ .t yview scroll 4 units
+ .t index @0,0
+} {50.40}
+
+test textDisp-15.8 {Scrolling near end of window} {
+ set textheight 12
+ set textwidth 30
+
+ toplevel .tf
+ frame .tf.f -relief sunken -borderwidth 2
+ pack .tf.f -padx 10 -pady 10
+
+ text .tf.f.t -font {Courier 9} -height $textheight \
+ -width $textwidth -yscrollcommand ".tf.f.sb set"
+ scrollbar .tf.f.sb -command ".tf.f.t yview"
+ pack .tf.f.t -side left -expand 1 -fill both
+ pack .tf.f.sb -side right -fill y
+
+ .tf.f.t tag configure Header -font {Helvetica 14 bold italic} \
+ -wrap word -spacing1 12 -spacing3 4
+
+ .tf.f.t insert end "Foo" Header
+ for {set i 1} {$i < $textheight} {incr i} {
+ .tf.f.t insert end "\nLine $i"
+ }
+ update ; after 1000 ; update
+ # Should scroll and should not crash!
+ .tf.f.t yview scroll 1 unit
+ # Check that it has scrolled
+ set res [.tf.f.t index @0,[expr [winfo height .tf.f.t] - 15]]
+ destroy .tf
+ set res
+} {12.0}
+
+.t configure -wrap char
+.t delete 1.0 end
+.t insert insert "Line 1"
+for {set i 2} {$i <= 200} {incr i} {
+ .t insert end "\nLine $i"
+}
+.t tag add big 100.0 105.0
+.t insert 151.end { has a lot of extra text, so that it wraps around on the screen several times over.}
+.t insert 153.end { also has enoug extra text to wrap.}
+update ; .t count -update -ypixels 1.0 end
+test textDisp-16.1 {TkTextYviewCmd procedure} {
+ .t yview 21.0
+ set x [.t yview]
+ .t yview 1.0
+ list [expr {int([lindex $x 0]*100)}] [expr {int ([lindex $x 1] * 100)}]
+} {9 14}
+test textDisp-16.2 {TkTextYviewCmd procedure} {
+ list [catch {.t yview 2 3} msg] $msg
+} {1 {bad option "2": must be moveto or scroll}}
+test textDisp-16.3 {TkTextYviewCmd procedure} {
+ list [catch {.t yview -pickplace} msg] $msg
+} {1 {wrong # args: should be ".t yview -pickplace lineNum|index"}}
+test textDisp-16.4 {TkTextYviewCmd procedure} {
+ list [catch {.t yview -pickplace 2 3} msg] $msg
+} {1 {wrong # args: should be ".t yview -pickplace lineNum|index"}}
+test textDisp-16.5 {TkTextYviewCmd procedure} {
+ list [catch {.t yview -bogus 2} msg] $msg
+} {1 {bad option "-bogus": must be moveto or scroll}}
+test textDisp-16.6 {TkTextYviewCmd procedure, integer position} {
+ .t yview 100.0
+ update
+ .t yview 98
+ .t index @0,0
+} {99.0}
+test textDisp-16.7 {TkTextYviewCmd procedure} {
+ .t yview 2.0
+ .t yv -pickplace 13.0
+ .t index @0,0
+} {4.0}
+test textDisp-16.8 {TkTextYviewCmd procedure} {
+ list [catch {.t yview bad_mark_name} msg] $msg
+} {1 {bad text index "bad_mark_name"}}
+test textDisp-16.9 {TkTextYviewCmd procedure, "moveto" option} {
+ list [catch {.t yview moveto a b} msg] $msg
+} {1 {wrong # args: should be ".t yview moveto fraction"}}
+test textDisp-16.10 {TkTextYviewCmd procedure, "moveto" option} {
+ list [catch {.t yview moveto gorp} msg] $msg
+} {1 {expected floating-point number but got "gorp"}}
+test textDisp-16.11 {TkTextYviewCmd procedure, "moveto" option} {
+ .t yview moveto 0.5
+ .t index @0,0
+} {103.0}
+test textDisp-16.12 {TkTextYviewCmd procedure, "moveto" option} {
+ .t yview moveto -1
+ .t index @0,0
+} {1.0}
+test textDisp-16.13 {TkTextYviewCmd procedure, "moveto" option} {
+ .t yview moveto 1.1
+ .t index @0,0
+} {191.0}
+test textDisp-16.14 {TkTextYviewCmd procedure, "moveto" option} {
+ .t yview moveto .75
+ .t index @0,0
+} {151.60}
+test textDisp-16.15 {TkTextYviewCmd procedure, "moveto" option} {
+ .t yview moveto .752
+ .t index @0,0
+} {151.60}
+test textDisp-16.16 {TkTextYviewCmd procedure, "moveto" option} {textfonts} {
+ set count [expr {5 * $bigHeight + 150 * $fixedHeight}]
+ set extra [expr {0.04 * double($fixedDiff * 150) / double($count)}]
+ .t yview moveto [expr {.753 - $extra}]
+ .t index @0,0
+} {151.60}
+test textDisp-16.17 {TkTextYviewCmd procedure, "moveto" option} {
+ .t yview moveto .755
+ .t index @0,0
+} {151.80}
+test textDisp-16.18 {TkTextYviewCmd procedure, "moveto" roundoff} {textfonts} {
+ catch {destroy .top1}
+ toplevel .top1
+ wm geometry .top1 +0+0
+ text .top1.t -height 3 -width 4 -wrap none -setgrid 1 -padx 6 \
+ -spacing3 6
+ pack .top1.t
+ update
+ .top1.t insert end "1\n2\n3\n4\n5\n6"
+ .top1.t yview moveto 0.3333
+ set result [.top1.t yview]
+ destroy .top1
+ set result
+} [list [expr {1.0/3}] [expr {5.0/6}]]
+test textDisp-16.19 {TkTextYviewCmd procedure, "scroll" option} {
+ list [catch {.t yview scroll a} msg] $msg
+} {1 {wrong # args: should be ".t yview scroll number units|pages|pixels"}}
+test textDisp-16.20 {TkTextYviewCmd procedure, "scroll" option} {
+ list [catch {.t yview scroll a b c} msg] $msg
+} {1 {wrong # args: should be ".t yview scroll number units|pages|pixels"}}
+test textDisp-16.21 {TkTextYviewCmd procedure, "scroll" option} {
+ list [catch {.t yview scroll badInt bogus} msg] $msg
+} {1 {bad argument "bogus": must be units, pages, or pixels}}
+test textDisp-16.21.2 {TkTextYviewCmd procedure, "scroll" option} {
+ list [catch {.t yview scroll badInt units} msg] $msg
+} {1 {expected integer but got "badInt"}}
+test textDisp-16.22 {TkTextYviewCmd procedure, "scroll" option, back pages} {
+ .t yview 50.0
+ update
+ .t yview scroll -1 pages
+ .t index @0,0
+} {42.0}
+test textDisp-16.22.1 {TkTextYviewCmd procedure, "scroll" option, back pages} {
+ list [catch {.t yview scroll -3 p} res] $res
+} {1 {ambiguous argument "p": must be units, pages, or pixels}}
+test textDisp-16.23 {TkTextYviewCmd procedure, "scroll" option, back pages} {
+ .t yview 50.0
+ update
+ .t yview scroll -3 pa
+ .t index @0,0
+} {26.0}
+test textDisp-16.24 {TkTextYviewCmd procedure, "scroll" option, back pages} {
+ .t yview 5.0
+ update
+ .t yview scroll -3 pa
+ .t index @0,0
+} {1.0}
+test textDisp-16.25 {TkTextYviewCmd procedure, "scroll" option, back pages} {
+ .t configure -height 1
+ update
+ .t yview 50.0
+ update
+ .t yview scroll -1 pages
+ set x [.t index @0,0]
+ .t configure -height 10
+ update
+ set x
+} {49.0}
+test textDisp-16.26 {TkTextYviewCmd procedure, "scroll" option, forward pages} {
+ .t yview 50.0
+ update
+ .t yview scroll 1 pages
+ .t index @0,0
+} {58.0}
+test textDisp-16.27 {TkTextYviewCmd procedure, "scroll" option, forward pages} {
+ .t yview 50.0
+ update
+ .t yview scroll 2 pages
+ .t index @0,0
+} {66.0}
+test textDisp-16.28 {TkTextYviewCmd procedure, "scroll" option, forward pages} {textfonts} {
+ .t yview 98.0
+ update
+ .t yview scroll 1 page
+ set res [expr int([.t index @0,0])]
+ if {$fixedDiff > 1} {
+ incr res -1
+ }
+ set res
+} {102}
+test textDisp-16.29 {TkTextYviewCmd procedure, "scroll" option, forward pages} {
+ .t configure -height 1
+ update
+ .t yview 50.0
+ update
+ .t yview scroll 1 pages
+ set x [.t index @0,0]
+ .t configure -height 10
+ update
+ set x
+} {51.0}
+test textDisp-16.30 {TkTextYviewCmd procedure, "scroll units" option} {
+ .t yview 45.0
+ update
+ .t yview scroll -3 units
+ .t index @0,0
+} {42.0}
+test textDisp-16.31 {TkTextYviewCmd procedure, "scroll units" option} {
+ .t yview 149.0
+ update
+ .t yview scroll 4 units
+ .t index @0,0
+} {151.40}
+test textDisp-16.32 {TkTextYviewCmd procedure} {
+ list [catch {.t yview scroll 12 bogoids} msg] $msg
+} {1 {bad argument "bogoids": must be units, pages, or pixels}}
+test textDisp-16.33 {TkTextYviewCmd procedure} {
+ list [catch {.t yview bad_arg 1 2} msg] $msg
+} {1 {bad option "bad_arg": must be moveto or scroll}}
+test textDisp-16.34 {TkTextYviewCmd procedure} {
+ set res {}
+ .t yview 1.0
+ lappend res [format %.12g [expr {[lindex [.t yview] 0]
+ * [.t count -ypixels 1.0 end]}]]
+ .t yview scroll 1 pixels
+ lappend res [format %.12g [expr {[lindex [.t yview] 0]
+ * [.t count -ypixels 1.0 end]}]]
+ .t yview scroll 1 pixels
+ lappend res [format %.12g [expr {[lindex [.t yview] 0]
+ * [.t count -ypixels 1.0 end]}]]
+ .t yview scroll 1 pixels
+ lappend res [format %.12g [expr {[lindex [.t yview] 0]
+ * [.t count -ypixels 1.0 end]}]]
+ .t yview scroll 1 pixels
+ lappend res [format %.12g [expr {[lindex [.t yview] 0]
+ * [.t count -ypixels 1.0 end]}]]
+ .t yview scroll 1 pixels
+ lappend res [format %.12g [expr {[lindex [.t yview] 0]
+ * [.t count -ypixels 1.0 end]}]]
+} {0 1 2 3 4 5}
+test textDisp-16.35 {TkTextYviewCmd procedure} {
+ set res {}
+ .t yview 1.0
+ lappend res [expr {round([lindex [.t yview] 0] * [.t count -ypixels 1.0 end])}]
+ .t yview scroll 13 pixels
+ lappend res [expr {round([lindex [.t yview] 0] * [.t count -ypixels 1.0 end])}]
+ .t yview scroll -4 pixels
+ lappend res [expr {round([lindex [.t yview] 0] * [.t count -ypixels 1.0 end])}]
+ .t yview scroll -9 pixels
+ lappend res [expr {round([lindex [.t yview] 0] * [.t count -ypixels 1.0 end])}]
+} {0 13 9 0}
+test textDisp-16.36 {TkTextYviewCmd procedure} {
+ set res {}
+ .t yview 1.0
+ .t yview scroll 5 pixels
+ .t yview scroll -1 pages
+ lappend res [expr {[lindex [.t yview] 0] * [.t count -ypixels 1.0 end]}]
+ .t yview scroll 5 pixels
+ .t yview scroll -1 units
+ lappend res [expr {[lindex [.t yview] 0] * [.t count -ypixels 1.0 end]}]
+} {0.0 0.0}
+test textDisp-16.37 {TkTextYviewCmd procedure} {
+ list [catch {.t yview scroll 1.3 pixels} msg] $msg
+} {0 {}}
+test textDisp-16.38 {TkTextYviewCmd procedure} {
+ list [catch {.t yview scroll 1.3blah pixels} msg] $msg
+} {1 {bad screen distance "1.3blah"}}
+test textDisp-16.39 {TkTextYviewCmd procedure} {
+ list [catch {.t yview scroll 1.3i pixels} msg] $msg
+} {0 {}}
+test textDisp-16.40 {text count -xpixels} {
+ set res {}
+ lappend res [.t count -xpixels 1.0 1.5] \
+ [.t count -xpixels 1.5 1.0] \
+ [.t count -xpixels 1.0 13.0] \
+ [.t count -xpixels 1.0 "1.0 displaylineend"] \
+ [.t count -xpixels 1.0 "1.0 lineend"] \
+ [.t count -xpixels 1.0 "1.0 displaylineend"] \
+ [.t count -xpixels 1.0 end]
+} {35 -35 0 42 42 42 0}
+test textDisp-16.41 {text count -xpixels with indices in elided lines} {
+ set res {}
+ .t delete 1.0 end
+ for {set i 1} {$i < 40} {incr i} {
+ .t insert end [string repeat "Line $i" 20]
+ .t insert end "\n"
+ }
+ .t configure -wrap none
+ .t tag add hidden 5.15 20.15
+ .t tag configure hidden -elide true
+ lappend res [.t count -xpixels 5.15 6.0] \
+ [.t count -xpixels 5.15 6.1] \
+ [.t count -xpixels 6.0 6.1] \
+ [.t count -xpixels 6.1 6.2] \
+ [.t count -xpixels 6.1 6.0] \
+ [.t count -xpixels 6.0 7.0] \
+ [.t count -xpixels 6.1 7.1] \
+ [.t count -xpixels 15.0 20.15] \
+ [.t count -xpixels 20.15 20.16] \
+ [.t count -xpixels 20.16 20.15]
+ .t tag remove hidden 20.0 20.15
+ lappend res [expr {[.t count -xpixels 5.0 20.0] != 0}]
+} [list 0 0 0 0 0 0 0 0 $fixedWidth -$fixedWidth 1]
+test textDisp-16.42 {TkTextYviewCmd procedure with indices in elided lines} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end [string repeat "Line $i" 20]
+ .t insert end "\n"
+ }
+ .t tag add hidden 5.15 20.15
+ .t tag configure hidden -elide true
+ .t yview 35.0
+ .t yview scroll [expr {- 15 * $fixedHeight}] pixels
+ update
+ .t index @0,0
+} {5.0}
+test textDisp-16.43 {TkTextYviewCmd procedure with indices in elided lines} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end [string repeat "Line $i" 20]
+ .t insert end "\n"
+ }
+ .t tag add hidden 5.15 20.15
+ .t tag configure hidden -elide true
+ .t yview 35.0
+ .t yview scroll -15 units
+ update
+ .t index @0,0
+} {5.0}
+test textDisp-16.44 {TkTextYviewCmd procedure, scroll down, with elided lines} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ foreach x [list 0 1 2 3 4 5 6 7 8 9 0] {
+ .t insert end "$x aaa1\n$x bbb2\n$x ccc3\n$x ddd4\n$x eee5\n$x fff6"
+ .t insert end "$x 1111\n$x 2222\n$x 3333\n$x 4444\n$x 5555\n$x 6666" hidden
+ }
+ .t tag configure hidden -elide true ; # 5 hidden lines
+ update
+ .t see [expr {5 + [winfo height .t] / $fixedHeight} + 1].0
+ update
+ .t index @0,0
+} {2.0}
+
+.t delete 1.0 end
+foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ .t insert end "\nLine $i 11111 $i 22222 $i 33333 $i 44444 $i 55555"
+ .t insert end " $i 66666 $i 77777 $i 88888 $i"
+}
+.t configure -wrap none
+test textDisp-17.1 {TkTextScanCmd procedure} {
+ list [catch {.t scan a b} msg] $msg
+} {1 {wrong # args: should be ".t scan mark x y" or ".t scan dragto x y ?gain?"}}
+test textDisp-17.2 {TkTextScanCmd procedure} {
+ list [catch {.t scan a b c d} msg] $msg
+} {1 {expected integer but got "b"}}
+test textDisp-17.3 {TkTextScanCmd procedure} {
+ list [catch {.t scan stupid b 20} msg] $msg
+} {1 {expected integer but got "b"}}
+test textDisp-17.4 {TkTextScanCmd procedure} {
+ list [catch {.t scan stupid -2 bogus} msg] $msg
+} {1 {expected integer but got "bogus"}}
+test textDisp-17.5 {TkTextScanCmd procedure} {
+ list [catch {.t scan stupid 123 456} msg] $msg
+} {1 {bad scan option "stupid": must be mark or dragto}}
+test textDisp-17.6 {TkTextScanCmd procedure} {textfonts} {
+ .t yview 1.0
+ .t xview moveto 0
+ .t scan mark 40 60
+ .t scan dragto 35 55
+ .t index @0,0
+} {4.7}
+test textDisp-17.7 {TkTextScanCmd procedure} {textfonts} {
+ .t yview 10.0
+ .t xview moveto 0
+ .t xview scroll 20 units
+ .t scan mark -10 60
+ .t scan dragto -5 65
+ .t index @0,0
+ set x [.t index @0,0]
+ .t scan dragto 0 [expr {70 + $fixedDiff}]
+ list $x [.t index @0,0]
+} {6.12 2.5}
+test textDisp-17.8 {TkTextScanCmd procedure} {textfonts} {
+ .t yview 1.0
+ .t xview moveto 0
+ .t scan mark 0 60
+ .t scan dragto 30 100
+ .t scan dragto 25 95
+ .t index @0,0
+} {4.7}
+test textDisp-17.9 {TkTextScanCmd procedure} {textfonts} {
+ .t yview end
+ .t xview moveto 0
+ .t xview scroll 100 units
+ .t scan mark 90 60
+ .t scan dragto 10 0
+ .t scan dragto 14 5
+ .t index @0,0
+} {18.44}
+.t configure -wrap word
+test textDisp-17.10 {TkTextScanCmd procedure, word wrapping} {textfonts} {
+ .t yview 10.0
+ .t scan mark -10 60
+ .t scan dragto -5 65
+ set x [.t index @0,0]
+ .t scan dragto 0 [expr {70 + $fixedDiff}]
+ list $x [.t index @0,0]
+} {9.15 8.31}
+.t configure -xscrollcommand scroll -yscrollcommand {}
+test textDisp-18.1 {GetXView procedure} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end xxxxxxxxx\n
+ .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n
+ .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx
+ update
+ set scrollInfo
+} [list 0.0 [expr {4.0/11}]]
+test textDisp-18.2 {GetXView procedure} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert end xxxxxxxxx\n
+ .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n
+ .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx
+ update
+ set scrollInfo
+} {0.0 1.0}
+test textDisp-18.3 {GetXView procedure} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ update
+ set scrollInfo
+} {0.0 1.0}
+test textDisp-18.4 {GetXView procedure} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end xxxxxxxxx\n
+ .t insert end xxxxxx\n
+ .t insert end xxxxxxxxxxxxxxxxx
+ update
+ set scrollInfo
+} {0.0 1.0}
+test textDisp-18.5 {GetXView procedure} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end xxxxxxxxx\n
+ .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n
+ .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx
+ .t xview scroll 31 units
+ update
+ set scrollInfo
+} [list [expr {31.0/55}] [expr {51.0/55}]]
+test textDisp-18.6 {GetXView procedure} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end xxxxxxxxx\n
+ .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n"
+ .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx"
+ .t xview moveto 0
+ .t xview scroll 31 units
+ update
+ set x {}
+ lappend x $scrollInfo
+ .t configure -wrap char
+ update
+ lappend x $scrollInfo
+ .t configure -wrap word
+ update
+ lappend x $scrollInfo
+ .t configure -wrap none
+ update
+ lappend x $scrollInfo
+} [list [list [expr {31.0/56}] [expr {51.0/56}]] {0.0 1.0} {0.0 1.0} [list 0.0 [expr {5.0/14}]]]
+test textDisp-18.7 {GetXView procedure} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ update
+ set scrollInfo unchanged
+ .t insert end xxxxxx\n
+ .t insert end xxx
+ update
+ set scrollInfo
+} {unchanged}
+test textDisp-18.8 {GetXView procedure} {
+ proc bgerror msg {
+ global x errorInfo
+ set x [list $msg $errorInfo]
+ }
+ proc bogus args {
+ error "bogus scroll proc"
+ }
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n
+ update
+ .t delete 1.0 end
+ .t configure -xscrollcommand scrollError
+ update
+ set x
+} {{scrolling error} {scrolling error
+ while executing
+"error "scrolling error""
+ (procedure "scrollError" line 2)
+ invoked from within
+"scrollError 0.0 1.0"
+ (horizontal scrolling command executed by text)}}
+catch {rename bgerror {}}
+catch {rename bogus {}}
+.t configure -xscrollcommand {} -yscrollcommand scroll
+
+.t configure -xscrollcommand {} -yscrollcommand scroll
+test textDisp-19.1 {GetYView procedure} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ update
+ set scrollInfo
+} {0.0 1.0}
+test textDisp-19.2 {GetYView procedure} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ update
+ set scrollInfo "unchanged"
+ .t insert 1.0 "Line1\nLine2"
+ update
+ set scrollInfo
+} {unchanged}
+test textDisp-19.3 {GetYView procedure} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ update; after 10 ; update
+ set scrollInfo "unchanged"
+ .t insert 1.0 "Line 1\nLine 2 is so long that it wraps around\nLine 3"
+ update
+ set scrollInfo
+} {unchanged}
+test textDisp-19.4 {GetYView procedure} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ update
+ set scrollInfo "unchanged"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13} {
+ .t insert end "\nLine $i"
+ }
+ update
+ set scrollInfo
+} [list 0.0 [expr {70.0/91}]]
+test textDisp-19.5 {GetYView procedure} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13} {
+ .t insert end "\nLine $i"
+ }
+ .t insert 2.end " is really quite long; in fact it's so long that it wraps three times"
+ update ; after 100
+ set x $scrollInfo
+} {0.0 0.625}
+test textDisp-19.6 {GetYView procedure} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13} {
+ .t insert end "\nLine $i"
+ }
+ .t insert 2.end " is really quite long; in fact it's so long that it wraps three times"
+ .t yview 4.0
+ update
+ set x $scrollInfo
+} {0.375 1.0}
+test textDisp-19.7 {GetYView procedure} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13} {
+ .t insert end "\nLine $i"
+ }
+ .t insert 2.end " is really quite long; in fact it's so long that it wraps three times"
+ .t yview 2.26
+ update; after 1; update
+ set x $scrollInfo
+} {0.125 0.75}
+test textDisp-19.8 {GetYView procedure} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13} {
+ .t insert end "\nLine $i"
+ }
+ .t insert 10.end " is really quite long; in fact it's so long that it wraps three times"
+ .t yview 2.0
+ update
+ .t count -update -ypixels 1.0 end
+ set x $scrollInfo
+} {0.0625 0.6875}
+test textDisp-19.9 {GetYView procedure} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ .t yview 3.0
+ update
+ set scrollInfo
+} [list [expr {4.0/30}] 0.8]
+test textDisp-19.10 {GetYView procedure} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ .t yview 11.0
+ update
+ set scrollInfo
+} [list [expr {1.0/3}] 1.0]
+test textDisp-19.10.1 {Widget manipulation causes height miscount} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ .t yview 11.0
+ update
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ .t insert end "\nThis last line wraps around four "
+ .t insert end "times with a bit left on the last line."
+ .t yview insert
+ update
+ .t count -update -ypixels 1.0 end
+ set scrollInfo
+} {0.5 1.0}
+test textDisp-19.11 {GetYView procedure} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ .t insert end "\nThis last line wraps around four "
+ .t insert end "times with a bit left on the last line."
+ .t yview insert
+ update
+ .t count -update -ypixels 1.0 end
+ set scrollInfo
+} {0.5 1.0}
+test textDisp-19.11.2 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t count -displaylines 1.0 end
+} {20}
+test textDisp-19.11.3 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t count -displaylines end 1.0
+} {-20}
+test textDisp-19.11.4 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t count -displaylines 1.1 1.3
+} {0}
+test textDisp-19.11.5 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t count -displaylines 16.0 16.1
+} {0}
+test textDisp-19.11.5.1 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t count -displaylines 16.0 16.5
+} {0}
+test textDisp-19.11.6 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t count -displaylines 16.0 16.20
+} {1}
+test textDisp-19.11.7 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t count -displaylines 16.0 16.40
+} {2}
+test textDisp-19.11.8 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t count -displaylines "16.0 displaylineend +1c" "16.0 lineend"
+} {3}
+test textDisp-19.11.9 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t count -displaylines 16.0 "16.0 lineend"
+} {4}
+test textDisp-19.11.10 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t count -displaylines 16.0 "16.0 +4displaylines"
+} {4}
+test textDisp-19.11.11 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t count -displaylines 16.0 "16.0 +2displaylines"
+} {2}
+test textDisp-19.11.12 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t count -displaylines "16.0 +1displayline" "16.0 +2displaylines -1c"
+} {0}
+.t tag configure elide -elide 1
+test textDisp-19.11.13 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t tag remove elide 1.0 end
+ .t tag add elide "16.0 +1displaylines" "16.0 +1displaylines +6c"
+ .t count -displaylines 16.0 "16.0 +4displaylines"
+} {4}
+test textDisp-19.11.14 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t tag remove elide 1.0 end
+ .t tag add elide "16.0 +1displaylines" "16.0 +1displaylines displaylineend"
+ .t count -displaylines 16.0 "16.0 +4displaylines"
+} {4}
+test textDisp-19.11.15 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t tag remove elide 1.0 end
+ .t tag add elide "16.0 +1displaylines" "16.0 +2displaylines"
+ .t count -displaylines 16.0 "16.0 +4displaylines -1c"
+} {3}
+test textDisp-19.11.15a {TextWidgetCmd procedure, "count -displaylines"} {
+ .t tag remove elide 1.0 end
+ .t tag add elide "16.0 +1displaylines" "16.0 +2displaylines"
+ .t count -displaylines 16.0 "16.0 +4displaylines"
+} {4}
+test textDisp-19.11.16 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t tag remove elide 1.0 end
+ .t tag add elide "12.0" "14.0"
+ .t count -displaylines 12.0 16.0
+} {2}
+test textDisp-19.11.17 {TextWidgetCmd procedure, "index +displaylines"} {
+ .t tag remove elide 1.0 end
+ .t tag add elide "12.0" "14.0"
+ list [.t index "11.5 +2d lines"] \
+ [.t index "12.0 +2d lines"] [.t index "11.0 +2d lines"] \
+ [.t index "13.0 +2d lines"] [.t index "13.1 +3d lines"] \
+ [.t index "13.0 +4d lines"]
+} {15.5 16.0 15.0 16.0 16.15 16.33}
+test textDisp-19.11.18 {TextWidgetCmd procedure, "index +displaylines"} {
+ .t tag remove elide 1.0 end
+ .t tag add elide "12.0" "14.0"
+ list [.t index "15.5 -2d lines"] \
+ [.t index "16.0 -2d lines"] [.t index "15.0 -2d lines"] \
+ [.t index "16.0 -3d lines"] [.t index "16.17 -4d lines"] \
+ [.t index "16.36 -5d lines"]
+} {11.5 14.0 11.0 11.0 11.2 11.3}
+test textDisp-19.11.19 {TextWidgetCmd procedure, "count -displaylines"} {
+ .t tag remove elide 1.0 end
+ .t tag add elide "12.0" "16.0 +1displaylines"
+ .t count -displaylines 12.0 17.0
+} {4}
+test textDisp-19.11.20 {TextWidgetCmd procedure, "index +displaylines"} {
+ .t tag remove elide 1.0 end
+ .t tag add elide "12.0" "16.0 +1displaylines"
+ list [.t index "11.5 +2d lines"] \
+ [.t index "12.0 +2d lines"] [.t index "11.0 +2d lines"] \
+ [.t index "13.0 +2d lines"] [.t index "13.0 +3d lines"] \
+ [.t index "13.0 +4d lines"]
+} {16.38 16.50 16.33 16.50 16.67 17.0}
+test textDisp-19.11.21 {TextWidgetCmd procedure, "index +displaylines"} {
+ .t tag remove elide 1.0 end
+ .t tag add elide "12.0" "16.0 +1displaylines"
+ list [.t index "16.38 -2d lines"] \
+ [.t index "16.50 -3d lines"] [.t index "16.33 -2d lines"] \
+ [.t index "16.53 -4d lines"] [.t index "16.69 -4d lines"] \
+ [.t index "17.1 -5d lines"]
+} {11.5 11.0 11.0 10.3 11.2 11.0}
+test textDisp-19.11.22 {TextWidgetCmd procedure, "index +displaylines"} {
+ .t tag remove elide 1.0 end
+ list [.t index "end +5d lines"] \
+ [.t index "end -3d lines"] [.t index "1.0 -2d lines"] \
+ [.t index "1.0 +4d lines"] [.t index "1.0 +50d lines"] \
+ [.t index "end -50d lines"]
+} {17.0 16.33 1.0 5.0 17.0 1.0}
+test textDisp-19.11.23 {TextWidgetCmd procedure, "index +displaylines"} {
+ .t tag remove elide 1.0 end
+ .t tag add elide "12.3" "16.0 +1displaylines"
+ list [.t index "11.5 +1d lines"] [.t index "11.5 +2d lines"] \
+ [.t index "12.0 +1d lines"] \
+ [.t index "12.0 +2d lines"] [.t index "11.0 +2d lines"] \
+ [.t index "13.0 +2d lines"] [.t index "13.0 +3d lines"] \
+ [.t index "13.0 +4d lines"]
+} {16.17 16.33 16.28 16.46 16.28 16.49 16.65 16.72}
+.t tag remove elide 1.0 end
+test textDisp-19.11.24 {TextWidgetCmd procedure, "index +/-displaylines"} {
+ list [.t index "11.5 + -1 display lines"] \
+ [.t index "11.5 + +1 disp lines"] \
+ [.t index "11.5 - -1 disp lines"] \
+ [.t index "11.5 - +1 disp lines"] \
+ [.t index "11.5 -1 disp lines"] \
+ [.t index "11.5 +1 disp lines"] \
+ [.t index "11.5 +0 disp lines"]
+} {10.5 12.5 12.5 10.5 10.5 12.5 11.5}
+.t tag remove elide 1.0 end
+test textDisp-19.12 {GetYView procedure, partially visible last line} {
+ catch {destroy .top}
+ toplevel .top
+ wm geometry .top +0+0
+ text .top.t -width 40 -height 5 -font $fixedFont
+ pack .top.t -expand yes -fill both
+ .top.t insert end "Line 1\nLine 2\nLine 3\nLine 4\nLine 5"
+ # Need to wait for asychronous calculations to complete.
+ update ; after 10
+ scan [wm geom .top] %dx%d twidth theight
+ wm geom .top ${twidth}x[expr $theight - 3]
+ update
+ .top.t yview
+} [list 0.0 [expr {(5.0 * $fixedHeight - 3.0)/ (5.0 * $fixedHeight)}]]
+test textDisp-19.13 {GetYView procedure, partially visible last line} {textfonts} {
+ catch {destroy .top}
+ toplevel .top
+ wm geometry .top +0+0
+ text .top.t -width 40 -height 5 -font $fixedFont
+ pack .top.t -expand yes -fill both
+ .top.t insert end "Line 1\nLine 2\nLine 3\nLine 4 has enough text to wrap around at least once"
+ # Need to wait for asychronous calculations to complete.
+ update ; after 10
+ scan [wm geom .top] %dx%d twidth theight
+ wm geom .top ${twidth}x[expr $theight - 3]
+ update
+ .top.t yview
+} [list 0.0 [expr {(5.0 * $fixedHeight - 3.0)/ (5.0 * $fixedHeight)}]]
+catch {destroy .top}
+test textDisp-19.14 {GetYView procedure} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ .t insert end "\nThis last line wraps around four "
+ .t insert end "times with a bit left on the last line."
+ # Need to update so everything is calculated.
+ update ; .t count -update -ypixels 1.0 end
+ update ; after 10 ; update
+ set scrollInfo "unchanged"
+ .t mark set insert 3.0
+ .t tag configure x -background red
+ .t tag add x 1.0 5.0
+ update
+ .t tag delete x
+ set scrollInfo
+} {unchanged}
+test textDisp-19.15 {GetYView procedure} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ .t insert end "\nThis last line wraps around four "
+ .t insert end "times with a bit left on the last line."
+ update
+ .t configure -yscrollcommand scrollError
+ proc bgerror args {
+ global x errorInfo errorCode
+ set x [list $args $errorInfo $errorCode]
+ }
+ .t delete 1.0 end
+ update
+ rename bgerror {}
+ .t configure -yscrollcommand scroll
+ set x
+} {{{scrolling error}} {scrolling error
+ while executing
+"error "scrolling error""
+ (procedure "scrollError" line 2)
+ invoked from within
+"scrollError 0.0 1.0"
+ (vertical scrolling command executed by text)} NONE}
+
+test textDisp-19.16 {count -ypixels} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1"
+ foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
+ .t insert end "\nLine $i"
+ }
+ .t insert end "\nThis last line wraps around four "
+ .t insert end "times with a bit left on the last line."
+ # Need to update so everything is calculated.
+ update ; .t count -update -ypixels 1.0 end ; update
+ set res {}
+ lappend res \
+ [.t count -ypixels 1.0 end] \
+ [.t count -update -ypixels 1.0 end] \
+ [.t count -ypixels 15.0 16.0] \
+ [.t count -ypixels 15.0 "16.0 displaylineend +1c"] \
+ [.t count -ypixels 16.0 "16.0 displaylineend +1c"] \
+ [.t count -ypixels "16.0 +1 displaylines" "16.0 +4 displaylines +3c"]
+} [list [expr {260 + 20 * $fixedDiff}] [expr {260 + 20 * $fixedDiff}] $fixedHeight [expr {2*$fixedHeight}] $fixedHeight [expr {3*$fixedHeight}]]
+test textDisp-19.17 {count -ypixels with indices in elided lines} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end [string repeat "Line $i" 20]
+ .t insert end "\n"
+ }
+ .t tag add hidden 5.15 20.15
+ .t tag configure hidden -elide true
+ set res {}
+ update
+ lappend res \
+ [.t count -ypixels 1.0 6.0] \
+ [.t count -ypixels 2.0 7.5] \
+ [.t count -ypixels 5.0 8.5] \
+ [.t count -ypixels 6.1 6.2] \
+ [.t count -ypixels 6.1 18.8] \
+ [.t count -ypixels 18.0 20.50] \
+ [.t count -ypixels 5.2 20.60] \
+ [.t count -ypixels 20.60 20.70] \
+ [.t count -ypixels 5.0 25.0] \
+ [.t count -ypixels 25.0 5.0] \
+ [.t count -ypixels 25.4 27.50] \
+ [.t count -ypixels 35.0 38.0]
+ .t yview 35.0
+ lappend res [.t count -ypixels 5.0 25.0]
+} [list [expr {4 * $fixedHeight}] [expr {3 * $fixedHeight}] 0 0 0 0 0 0 [expr {5 * $fixedHeight}] [expr {- 5 * $fixedHeight}] [expr {2 * $fixedHeight}] [expr {3 * $fixedHeight}] [expr {5 * $fixedHeight}]]
+test textDisp-19.18 {count -ypixels with indices in elided lines} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ for {set i 1} {$i < 100} {incr i} {
+ .t insert end [string repeat "Line $i" 20]
+ .t insert end "\n"
+ }
+ .t tag add hidden 5.15 20.15
+ .t tag configure hidden -elide true
+ .t yview 35.0
+ set res {}
+ update
+ lappend res [.t count -ypixels 5.0 25.0]
+ .t yview scroll [expr {- 15 * $fixedHeight}] pixels
+ update
+ lappend res [.t count -ypixels 5.0 25.0]
+} [list [expr {5 * $fixedHeight}] [expr {5 * $fixedHeight}]]
+test textDisp-19.19 {count -ypixels with indices in elided lines} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ for {set i 1} {$i < 25} {incr i} {
+ .t insert end [string repeat "Line $i -" 6]
+ .t insert end "\n"
+ }
+ .t tag add hidden 5.27 11.0
+ .t tag configure hidden -elide true
+ .t yview 5.0
+ update
+ set res [list [.t count -ypixels 5.0 11.0] [.t count -ypixels 5.0 11.20]]
+} [list [expr {1 * $fixedHeight}] [expr {2 * $fixedHeight}]]
+.t delete 1.0 end
+.t insert end "Line 1"
+for {set i 2} {$i <= 200} {incr i} {
+ .t insert end "\nLine $i"
+}
+.t configure -wrap word
+.t delete 50.0 51.0
+.t insert 50.0 "This is a long line, one that will wrap around twice.\n"
+test textDisp-20.1 {FindDLine} {textfonts} {
+ .t yview 48.0
+ list [.t dlineinfo 46.0] [.t dlineinfo 47.0] [.t dlineinfo 49.0] \
+ [.t dlineinfo 58.0]
+} [list {} {} [list 3 [expr {$fixedDiff + 16}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}]
+test textDisp-20.2 {FindDLine} {textfonts} {
+ .t yview 100.0
+ .t yview -pickplace 53.0
+ list [.t dlineinfo 50.0] [.t dlineinfo 50.14] [.t dlineinfo 50.15]
+} [list [list 3 [expr {-1 - $fixedDiff/2}] 105 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {-1 - $fixedDiff/2}] 105 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {12 + $fixedDiff/2}] 140 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]]
+test textDisp-20.3 {FindDLine} {textfonts} {
+ .t yview 100.0
+ .t yview 49.0
+ list [.t dlineinfo 50.0] [.t dlineinfo 50.20] [.t dlineinfo 57.0]
+} [list [list 3 [expr {$fixedDiff + 16}] 105 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {2*$fixedDiff + 29}] 140 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}]
+test textDisp-20.4 {FindDLine} {textfonts} {
+ .t yview 100.0
+ .t yview 42.0
+ list [.t dlineinfo 50.0] [.t dlineinfo 50.20] [.t dlineinfo 50.40]
+} [list [list 3 [expr {8*$fixedDiff + 107}] 105 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {9*$fixedDiff + 120}] 140 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}]
+.t config -wrap none
+test textDisp-20.5 {FindDLine} {textfonts} {
+ .t yview 100.0
+ .t yview 48.0
+ list [.t dlineinfo 50.0] [.t dlineinfo 50.20] [.t dlineinfo 50.40]
+} [list [list 3 [expr {3+2*$fixedHeight}] 371 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {3+2*$fixedHeight}] 371 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {3+2*$fixedHeight}] 371 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]]
+
+.t config -wrap word
+test textDisp-21.1 {TkTextPixelIndex} {textfonts} {
+ .t yview 48.0
+ list [.t index @-10,-10] [.t index @6,6] [.t index @22,6] \
+ [.t index @102,6] [.t index @38,[expr {$fixedHeight * 4 + 3}]] [.t index @44,67]
+} {48.0 48.0 48.2 48.7 50.40 50.40}
+.t insert end \n
+test textDisp-21.2 {TkTextPixelIndex} {textfonts} {
+ .t yview 195.0
+ list [.t index @11,[expr {$fixedHeight * 5 + 5}]] [.t index @11,[expr {$fixedHeight * 6 + 5}]] [.t index @11,[expr {$fixedHeight * 7 + 5}]] \
+ [.t index @11,1002]
+} {197.1 198.1 199.1 201.0}
+test textDisp-21.3 {TkTextPixelIndex, horizontal scrolling} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end "12345\n"
+ .t insert end "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ .t xview scroll 2 units
+ list [.t index @-5,7] [.t index @5,7] [.t index @33,20]
+} {1.2 1.2 2.6}
+test textDisp-21.4 {count -displaylines regression} {
+ set message {
+ QOTW: "C/C++, which is used by 16% of users, is the most popular programming language, but Tcl, used by 0%, seems to be the language of choice for the highest scoring users."
+(new line)
+Use the Up (cursor) key to scroll up one line at a time. At the second press, the cursor either gets locked or jumps several lines.
+
+Connect with Tkcon. The command
+.u count -displaylines \
+3.10 2.173
+should give answer -1; it gives me 5.
+
+Using 8.5a4 (ActiveState beta 4) under Linux. No problem with ActiveState beta 3.
+}
+
+toplevel .tt
+pack [text .tt.u] -side right
+.tt.u configure -width 30 -height 27 -wrap word -bg #FFFFFF
+.tt.u insert end $message
+.tt.u mark set insert 3.10
+tkwait visibility .tt.u
+set res [.tt.u count -displaylines 3.10 2.173]
+destroy .tt
+unset message
+set res
+} {-1}
+
+.t delete 1.0 end
+.t insert end "Line 1"
+for {set i 2} {$i <= 200} {incr i} {
+ .t insert end "\nLine $i"
+}
+.t configure -wrap word
+.t delete 50.0 51.0
+.t insert 50.0 "This is a long line, one that will wrap around twice.\n"
+update
+.t tag add x 50.1
+test textDisp-22.1 {TkTextCharBbox} {textfonts} {
+ .t config -wrap word
+ .t yview 48.0
+ list [.t bbox 47.2] [.t bbox 48.0] [.t bbox 50.5] [.t bbox 50.40] \
+ [.t bbox 58.0]
+} [list {} [list 3 3 7 $fixedHeight] [list 38 [expr {3+2*$fixedHeight}] 7 $fixedHeight] [list 38 [expr {3+4*$fixedHeight}] 7 $fixedHeight] {}]
+test textDisp-22.2 {TkTextCharBbox} {textfonts} {
+ .t config -wrap none
+ .t yview 48.0
+ list [.t bbox 50.5] [.t bbox 50.40] [.t bbox 57.0]
+} [list [list 38 [expr {3+2*$fixedHeight}] 7 $fixedHeight] {} [list 3 [expr {3+9*$fixedHeight}] 7 $fixedHeight]]
+test textDisp-22.3 {TkTextCharBbox, cut-off lines} {textfonts} {
+ .t config -wrap char
+ .t yview 10.0
+ wm geom . ${width}x[expr $height-1]
+ update
+ list [.t bbox 19.1] [.t bbox 20.1]
+} [list [list 10 [expr {3+9*$fixedHeight}] 7 $fixedHeight] [list 10 [expr {3+10*$fixedHeight}] 7 3]]
+test textDisp-22.4 {TkTextCharBbox, cut-off lines} {textfonts} {
+ .t config -wrap char
+ .t yview 10.0
+ wm geom . ${width}x[expr $height+1]
+ update
+ list [.t bbox 19.1] [.t bbox 20.1]
+} [list [list 10 [expr {3+9*$fixedHeight}] 7 $fixedHeight] [list 10 [expr {3+10*$fixedHeight}] 7 5]]
+test textDisp-22.5 {TkTextCharBbox, cut-off char} {textfonts} {
+ .t config -wrap none
+ .t yview 10.0
+ wm geom . [expr $width-95]x$height
+ update
+ .t bbox 15.6
+} [list 45 [expr {3+5*$fixedHeight}] 7 $fixedHeight]
+test textDisp-22.6 {TkTextCharBbox, line visible but not char} {textfonts} {
+ .t config -wrap char
+ .t yview 10.0
+ .t tag add big 20.2 20.5
+ wm geom . ${width}x[expr $height+3]
+ update
+ list [.t bbox 19.1] [.t bbox 20.1] [.t bbox 20.2]
+} [list [list 10 [expr {3+9*$fixedHeight}] 7 $fixedHeight] {} [list 17 [expr {3+10*$fixedHeight}] 14 7]]
+wm geom . {}
+update
+test textDisp-22.7 {TkTextCharBbox, different character sizes} {textfonts} {
+ .t config -wrap char
+ .t yview 10.0
+ .t tag add big 12.2 12.5
+ update
+ list [.t bbox 12.1] [.t bbox 12.2]
+} [list [list 10 [expr {3 + 2*$fixedHeight + $ascentDiff}] 7 $fixedHeight] [list 17 [expr {3+ 2*$fixedHeight}] 14 27]]
+.t tag remove big 1.0 end
+test textDisp-22.8 {TkTextCharBbox, horizontal scrolling} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert end "12345\n"
+ .t insert end "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ .t xview scroll 4 units
+ list [.t bbox 1.3] [.t bbox 1.4] [.t bbox 2.3] [.t bbox 2.4] \
+ [.t bbox 2.23] [.t bbox 2.24]
+} [list {} [list 3 3 7 $fixedHeight] {} [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 136 [expr {$fixedDiff + 16}] 7 $fixedHeight] {}]
+test textDisp-22.9 {TkTextCharBbox, handling of spacing} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "abcdefghijkl\nmnopqrstuvwzyz"
+ .t tag configure spacing -spacing1 8 -spacing3 2
+ .t tag add spacing 1.0 end
+ frame .t.f1 -width 10 -height 4 -bg black
+ frame .t.f2 -width 10 -height 4 -bg black
+ frame .t.f3 -width 10 -height 4 -bg black
+ frame .t.f4 -width 10 -height 4 -bg black
+ .t window create 1.3 -window .t.f1 -align top
+ .t window create 1.7 -window .t.f2 -align center
+ .t window create 2.1 -window .t.f3 -align bottom
+ .t window create 2.10 -window .t.f4 -align baseline
+ update
+ list [.t bbox .t.f1] [.t bbox .t.f2] [.t bbox .t.f3] [.t bbox .t.f4] \
+ [.t bbox 1.1] [.t bbox 2.9]
+} [list [list 24 11 10 4] [list 55 [expr {$fixedDiff/2 + 15}] 10 4] [list 10 [expr {2*$fixedDiff + 43}] 10 4] [list 76 [expr {2*$fixedDiff + 40}] 10 4] [list 10 11 7 $fixedHeight] [list 69 [expr {$fixedDiff + 34}] 7 $fixedHeight]]
+.t tag delete spacing
+test textDisp-22.10 {TkTextCharBbox, handling of elided lines} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i - Line [format %c [expr 64+$i]]\n"
+ }
+ .t tag add hidden 2.8 2.13
+ .t tag add hidden 6.8 7.13
+ .t tag configure hidden -elide true
+ update
+ list \
+ [expr {[lindex [.t bbox 2.9] 0] - [lindex [.t bbox 2.8] 0]}] \
+ [expr {[lindex [.t bbox 2.10] 0] - [lindex [.t bbox 2.8] 0]}] \
+ [expr {[lindex [.t bbox 2.13] 0] - [lindex [.t bbox 2.8] 0]}] \
+ [expr {[lindex [.t bbox 6.9] 0] - [lindex [.t bbox 6.8] 0]}] \
+ [expr {[lindex [.t bbox 6.10] 0] - [lindex [.t bbox 6.8] 0]}] \
+ [expr {[lindex [.t bbox 6.13] 0] - [lindex [.t bbox 6.8] 0]}] \
+ [expr {[lindex [.t bbox 6.14] 0] - [lindex [.t bbox 6.8] 0]}] \
+ [expr {[lindex [.t bbox 6.15] 0] - [lindex [.t bbox 6.8] 0]}] \
+ [expr {[lindex [.t bbox 7.0] 0] - [lindex [.t bbox 6.8] 0]}] \
+ [expr {[lindex [.t bbox 7.1] 0] - [lindex [.t bbox 6.8] 0]}] \
+ [expr {[lindex [.t bbox 7.12] 0] - [lindex [.t bbox 6.8] 0]}]
+} [list 0 0 0 0 0 0 0 0 0 0 0]
+test textDisp-22.11 {TkTextCharBbox, handling of wrapped elided lines} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i - Line _$i - Lines .$i - Line [format %c [expr 64+$i]]\n"
+ }
+ .t tag add hidden 1.30 2.5
+ .t tag configure hidden -elide true
+ update
+ list \
+ [expr {[lindex [.t bbox 1.30] 0] - [lindex [.t bbox 2.4] 0]}] \
+ [expr {[lindex [.t bbox 1.30] 0] - [lindex [.t bbox 2.5] 0]}]
+} [list 0 0]
+
+.t delete 1.0 end
+.t insert end "Line 1"
+for {set i 2} {$i <= 200} {incr i} {
+ .t insert end "\nLine $i"
+}
+.t configure -wrap word
+.t delete 50.0 51.0
+.t insert 50.0 "This is a long line, one that will wrap around twice.\n"
+update
+test textDisp-23.1 {TkTextDLineInfo} {textfonts} {
+ .t config -wrap word
+ .t yview 48.0
+ list [.t dlineinfo 47.3] [.t dlineinfo 48.0] [.t dlineinfo 50.40] \
+ [.t dlineinfo 56.0]
+} [list {} [list 3 3 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {4*$fixedDiff + 55}] 126 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}]
+test textDisp-23.2 {TkTextDLineInfo} {textfonts} {
+ .t config -bd 4 -wrap word
+ update
+ .t yview 48.0
+ .t dlineinfo 50.40
+} [list 7 [expr {4*$fixedDiff + 59}] 126 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]
+.t config -bd 0
+test textDisp-23.3 {TkTextDLineInfo} {textfonts} {
+ .t config -wrap none
+ update
+ .t yview 48.0
+ list [.t dlineinfo 50.40] [.t dlineinfo 57.3]
+} [list [list 3 [expr {2*$fixedDiff + 29}] 371 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {9*$fixedDiff + 120}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]]
+test textDisp-23.4 {TkTextDLineInfo, cut-off lines} {textfonts} {
+ .t config -wrap char
+ .t yview 10.0
+ wm geom . ${width}x[expr $height-1]
+ update
+ list [.t dlineinfo 19.0] [.t dlineinfo 20.0]
+} [list [list 3 [expr {9*$fixedDiff + 120}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {10*$fixedDiff + 133}] 49 3 [expr {$fixedDiff + 10}]]]
+test textDisp-23.5 {TkTextDLineInfo, cut-off lines} {textfonts} {
+ .t config -wrap char
+ .t yview 10.0
+ wm geom . ${width}x[expr $height+1]
+ update
+ list [.t dlineinfo 19.0] [.t dlineinfo 20.0]
+} [list [list 3 [expr {9*$fixedDiff + 120}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {10*$fixedDiff + 133}] 49 5 [expr {$fixedDiff + 10}]]]
+wm geom . {}
+update
+test textDisp-23.6 {TkTextDLineInfo, horizontal scrolling} {textfonts} {
+ .t config -wrap none
+ .t delete 1.0 end
+ .t insert end "First line\n"
+ .t insert end "Second line is a very long one that doesn't all fit.\n"
+ .t insert end "Third"
+ .t xview scroll 6 units
+ update
+ list [.t dlineinfo 1.0] [.t dlineinfo 2.0] [.t dlineinfo 3.0]
+} [list [list -39 3 70 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list -39 [expr {$fixedDiff + 16}] 364 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list -39 [expr {2*$fixedDiff + 29}] 35 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]]
+.t xview moveto 0
+test textDisp-23.7 {TkTextDLineInfo, centering} {textfonts} {
+ .t config -wrap word
+ .t delete 1.0 end
+ .t insert end "First line\n"
+ .t insert end "Second line is a very long one that doesn't all fit.\n"
+ .t insert end "Third"
+ .t tag configure x -justify center
+ .t tag configure y -justify right
+ .t tag add x 1.0
+ .t tag add y 3.0
+ list [.t dlineinfo 1.0] [.t dlineinfo 2.0] [.t dlineinfo 3.0]
+} [list [list 38 3 70 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {$fixedDiff + 16}] 119 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 108 [expr {4*$fixedDiff + 55}] 35 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]]
+.t tag delete x y
+
+test textDisp-24.1 {TkTextCharLayoutProc} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "abcdefghijklmnopqrstuvwxyz"
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 136 3 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-24.2 {TkTextCharLayoutProc} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "abcdefghijklmnopqrstuvwxyz"
+ wm geom . [expr $width+1]x$height
+ update
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 136 3 12 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-24.3 {TkTextCharLayoutProc} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "abcdefghijklmnopqrstuvwxyz"
+ wm geom . [expr $width-1]x$height
+ update
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 136 3 10 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-24.4 {TkTextCharLayoutProc, newline not visible} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 01234567890123456789\n012345678901234567890
+ wm geom . {}
+ update
+ list [.t bbox 1.19] [.t bbox 1.20] [.t bbox 2.20]
+} [list [list 136 3 7 $fixedHeight] [list 143 3 0 $fixedHeight] [list 3 [expr {2*$fixedDiff + 29}] 7 $fixedHeight]]
+test textDisp-24.5 {TkTextCharLayoutProc, char doesn't fit, newline not visible} {unix textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 0\n1\n
+ wm geom . 110x$height
+ update
+ list [.t bbox 1.0] [.t bbox 1.1] [.t bbox 2.0]
+} [list [list 3 3 4 $fixedHeight] [list 7 3 0 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 4 $fixedHeight]]
+test textDisp-24.6 {TkTextCharLayoutProc, line ends with space} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "a b c d e f g h i j k l m n o p"
+ wm geom . {}
+ update
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 136 3 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-24.7 {TkTextCharLayoutProc, line ends with space} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "a b c d e f g h i j k l m n o p"
+ wm geom . [expr $width+1]x$height
+ update
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 136 3 12 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-24.8 {TkTextCharLayoutProc, line ends with space} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "a b c d e f g h i j k l m n o p"
+ wm geom . [expr $width-1]x$height
+ update
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 136 3 10 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-24.9 {TkTextCharLayoutProc, line ends with space} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "a b c d e f g h i j k l m n o p"
+ wm geom . [expr $width-6]x$height
+ update
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 136 3 5 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-24.10 {TkTextCharLayoutProc, line ends with space} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "a b c d e f g h i j k l m n o p"
+ wm geom . [expr $width-7]x$height
+ update
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 136 3 4 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-24.11 {TkTextCharLayoutProc, line ends with space that doesn't quite fit} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "01234567890123456789 \nabcdefg"
+ wm geom . [expr $width-2]x$height
+ update
+ set result {}
+ lappend result [.t bbox 1.21] [.t bbox 2.0]
+ .t mark set insert 1.21
+ lappend result [.t bbox 1.21] [.t bbox 2.0]
+} [list [list 145 3 0 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 145 3 0 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-24.12 {TkTextCharLayoutProc, tab causes wrap} {textfonts} {
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "abcdefghi"
+ .t mark set insert 1.4
+ .t insert insert \t\t\t
+ list [.t bbox {insert -1c}] [.t bbox insert]
+} [list [list 115 3 30 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-24.13 {TkTextCharLayoutProc, -wrap none} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert 1.0 "abcdefghijklmnopqrstuvwxyz"
+ wm geom . {}
+ update
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 136 3 7 $fixedHeight] {}]
+test textDisp-24.14 {TkTextCharLayoutProc, -wrap none} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert 1.0 "abcdefghijklmnopqrstuvwxyz"
+ wm geom . [expr $width+1]x$height
+ update
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 136 3 7 $fixedHeight] [list 143 3 5 $fixedHeight]]
+test textDisp-24.15 {TkTextCharLayoutProc, -wrap none} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert 1.0 "abcdefghijklmnopqrstuvwxyz"
+ wm geom . [expr $width-1]x$height
+ update
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 136 3 7 $fixedHeight] [list 143 3 3 $fixedHeight]]
+test textDisp-24.16 {TkTextCharLayoutProc, no chars fit} {textfonts} {
+ if {$tcl_platform(platform) == "windows"} {
+ wm overrideredirect . 1
+ }
+ .t configure -wrap char
+ .t delete 1.0 end
+ .t insert 1.0 "abcdefghijklmnopqrstuvwxyz"
+ wm geom . 103x$height
+ update
+ list [.t bbox 1.0] [.t bbox 1.1] [.t bbox 1.2]
+} [list [list 3 3 1 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 1 $fixedHeight] [list 3 [expr {2*$fixedDiff + 29}] 1 $fixedHeight]]
+if {$tcl_platform(platform) == "windows"} {
+ wm overrideredirect . 0
+}
+test textDisp-24.17 {TkTextCharLayoutProc, -wrap word} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "This is a line that wraps around"
+ wm geom . {}
+ update
+ list [.t bbox 1.19] [.t bbox 1.20]
+} [list [list 136 3 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-24.18 {TkTextCharLayoutProc, -wrap word} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "xThis is a line that wraps around"
+ wm geom . {}
+ update
+ list [.t bbox 1.14] [.t bbox 1.15] [.t bbox 1.16]
+} [list [list 101 3 7 $fixedHeight] [list 108 3 35 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]]
+test textDisp-24.19 {TkTextCharLayoutProc, -wrap word} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "xxThis is a line that wraps around"
+ wm geom . {}
+ update
+ list [.t bbox 1.14] [.t bbox 1.15] [.t bbox 1.16]
+} [list [list 101 3 7 $fixedHeight] [list 108 3 7 $fixedHeight] [list 115 3 28 $fixedHeight]]
+test textDisp-24.20 {TkTextCharLayoutProc, vertical offset} {textfonts} {
+ .t configure -wrap none
+ .t delete 1.0 end
+ .t insert 1.0 "Line 1\nLine 2\nLine 3"
+ set result {}
+ lappend result [.t bbox 2.1] [.t dlineinfo 2.1]
+ .t tag configure up -offset 6
+ .t tag add up 2.1
+ lappend result [.t bbox 2.1] [.t dlineinfo 2.1]
+ .t tag configure up -offset -2
+ lappend result [.t bbox 2.1] [.t dlineinfo 2.1]
+ .t tag delete up
+ set result
+} [list [list 10 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 42 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 10 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 42 [expr {$fixedDiff + 19}] [expr {$fixedDiff + 16}]] [list 10 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 42 [expr {$fixedDiff + 15}] [expr {$fixedDiff + 10}]]]
+.t configure -width 30
+update
+test textDisp-24.21 {TkTextCharLayoutProc, word breaks} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ .t insert 1.0 "Sample text xxxxxxx yyyyy zzzzzzz qqqqq rrrr ssss tt u vvvvv"
+ frame .t.f -width 30 -height 20 -bg black
+ .t window create 1.36 -window .t.f
+ .t bbox 1.26
+} [list 3 [expr {$fixedDiff/2 + 19}] 7 $fixedHeight]
+test textDisp-24.22 {TkTextCharLayoutProc, word breaks} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ frame .t.f -width 30 -height 20 -bg black
+ .t insert 1.0 "Sample text xxxxxxx yyyyyyy"
+ .t window create end -window .t.f
+ .t insert end "zzzzzzz qqqqq rrrr ssss tt u vvvvv"
+ .t bbox 1.28
+} [list 33 [expr {$fixedDiff/2 + 19}] 7 $fixedHeight]
+test textDisp-24.23 {TkTextCharLayoutProc, word breaks} {textfonts} {
+ .t configure -wrap word
+ .t delete 1.0 end
+ frame .t.f -width 30 -height 20 -bg black
+ .t insert 1.0 "Sample text xxxxxxx yyyyyyy "
+ .t insert end "zzzzzzz qqqqq rrrr ssss tt"
+ .t window create end -window .t.f
+ .t insert end "u vvvvv"
+ .t bbox .t.f
+} [list 3 [expr {2*$fixedDiff + 29}] 30 20]
+catch {destroy .t.f}
+.t configure -width 20
+update
+test textDisp-24.24 {TkTextCharLayoutProc, justification and tabs} {textfonts} {
+ .t delete 1.0 end
+ .t tag configure x -justify center
+ .t insert 1.0 aa\tbb\tcc\tdd\t
+ .t tag add x 1.0 end
+ list [.t bbox 1.0] [.t bbox 1.10]
+} [list [list 45 3 7 $fixedHeight] [list 94 3 7 $fixedHeight]]
+
+.t configure -width 40 -bd 0 -relief flat -highlightthickness 0 -padx 0 \
+ -tabs 100
+update
+test textDisp-25.1 {CharBboxProc procedure, check tab width} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 abc\td\tfgh
+ list [.t bbox 1.3] [.t bbox 1.5] [.t bbox 1.6]
+} [list [list 21 1 79 $fixedHeight] [list 107 1 93 $fixedHeight] [list 200 1 7 $fixedHeight]]
+
+.t configure -width 40 -bd 0 -relief flat -highlightthickness 0 -padx 0 \
+ -tabs {}
+update
+test textDisp-26.1 {AdjustForTab procedure, no tabs} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 a\tbcdefghij\tc\td
+ list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.12] 0] \
+ [lindex [.t bbox 1.14] 0]
+} [list 56 126 168]
+test textDisp-26.1.2 {AdjustForTab procedure, no tabs} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 a\tbcdefghij\tc\td
+ .t configure -tabstyle wordprocessor
+ set res [list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.12] 0] \
+ [lindex [.t bbox 1.14] 0]]
+ .t configure -tabstyle tabular
+ set res
+} [list 56 168 224]
+test textDisp-26.2 {AdjustForTab procedure, not enough tabs specified} {
+ .t delete 1.0 end
+ .t insert 1.0 a\tb\tc\td
+ .t tag delete x
+ .t tag configure x -tabs 40
+ .t tag add x 1.0 end
+ list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0] \
+ [lindex [.t bbox 1.6] 0]
+} [list 40 80 120]
+test textDisp-26.3 {AdjustForTab procedure, not enough tabs specified} {
+ .t delete 1.0 end
+ .t insert 1.0 a\tb\tc\td\te
+ .t tag delete x
+ .t tag configure x -tabs {40 70 right}
+ .t tag add x 1.0 end
+ list [lindex [.t bbox 1.2] 0] \
+ [expr [lindex [.t bbox 1.4] 0] + [lindex [.t bbox 1.4] 2]] \
+ [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]] \
+ [expr [lindex [.t bbox 1.8] 0] + [lindex [.t bbox 1.8] 2]]
+} [list 40 70 100 130]
+test textDisp-26.4 {AdjustForTab procedure, different alignments} {
+ .t delete 1.0 end
+ .t insert 1.0 a\tbc\tde\tfg\thi
+ .t tag delete x
+ .t tag configure x -tabs {40 center 80 left 130 right}
+ .t tag add x 1.0 end
+ .t tag add y 1.2
+ .t tag add y 1.5
+ .t tag add y 1.8
+ list [lindex [.t bbox 1.3] 0] [lindex [.t bbox 1.5] 0] \
+ [lindex [.t bbox 1.10] 0]
+} [list 40 80 130]
+test textDisp-26.5 {AdjustForTab procedure, numeric alignment} {
+ .t delete 1.0 end
+ .t insert 1.0 a\t1.234
+ .t tag delete x
+ .t tag configure x -tabs {120 numeric}
+ .t tag add x 1.0 end
+ .t tag add y 1.2
+ .t tag add y 1.5
+ lindex [.t bbox 1.3] 0
+} {120}
+test textDisp-26.6 {AdjustForTab procedure, numeric alignment} {
+ .t delete 1.0 end
+ .t insert 1.0 a\t1,456.234
+ .t tag delete x
+ .t tag configure x -tabs {120 numeric}
+ .t tag add x 1.0 end
+ .t tag add y 1.2
+ lindex [.t bbox 1.7] 0
+} {120}
+test textDisp-26.7 {AdjustForTab procedure, numeric alignment} {
+ .t delete 1.0 end
+ .t insert 1.0 a\t1.456.234,7
+ .t tag delete x
+ .t tag configure x -tabs {120 numeric}
+ .t tag add x 1.0 end
+ .t tag add y 1.2
+ lindex [.t bbox 1.11] 0
+} {120}
+test textDisp-26.8 {AdjustForTab procedure, numeric alignment} {
+ .t delete 1.0 end
+ .t insert 1.0 a\ttest
+ .t tag delete x
+ .t tag configure x -tabs {120 numeric}
+ .t tag add x 1.0 end
+ .t tag add y 1.2
+ lindex [.t bbox 1.6] 0
+} {120}
+test textDisp-26.9 {AdjustForTab procedure, numeric alignment} {
+ .t delete 1.0 end
+ .t insert 1.0 a\t1234
+ .t tag delete x
+ .t tag configure x -tabs {120 numeric}
+ .t tag add x 1.0 end
+ .t tag add y 1.2
+ lindex [.t bbox 1.6] 0
+} {120}
+test textDisp-26.10 {AdjustForTab procedure, numeric alignment} {
+ .t delete 1.0 end
+ .t insert 1.0 a\t1.234567
+ .t tag delete x
+ .t tag configure x -tabs {120 numeric}
+ .t tag add x 1.0 end
+ .t tag add y 1.5
+ lindex [.t bbox 1.3] 0
+} {120}
+test textDisp-26.11 {AdjustForTab procedure, numeric alignment} {
+ .t delete 1.0 end
+ .t insert 1.0 a\tx=1.234567
+ .t tag delete x
+ .t tag configure x -tabs {120 numeric}
+ .t tag add x 1.0 end
+ .t tag add y 1.7
+ .t tag add y 1.9
+ lindex [.t bbox 1.5] 0
+} {120}
+test textDisp-26.12 {AdjustForTab procedure, adjusting chunks} {
+ .t delete 1.0 end
+ .t insert 1.0 a\tx1.234567
+ .t tag delete x
+ .t tag configure x -tabs {120 numeric}
+ .t tag add x 1.0 end
+ .t tag add y 1.7
+ .t tag add y 1.9
+ button .b -text "="
+ .t window create 1.3 -window .b
+ update
+ lindex [.t bbox 1.5] 0
+} {120}
+test textDisp-26.13 {AdjustForTab procedure, not enough space} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 "abc\txyz\tqrs\txyz\t0"
+ .t tag delete x
+ .t tag configure x -tabs {10 30 center 50 right 120}
+ .t tag add x 1.0 end
+ list [lindex [.t bbox 1.4] 0] [lindex [.t bbox 1.8] 0] \
+ [lindex [.t bbox 1.12] 0] [lindex [.t bbox 1.16] 0]
+} [list 28 56 84 120]
+test textDisp-26.13.2 {AdjustForTab procedure, not enough space} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 "abc\txyz\tqrs\txyz\t0"
+ .t tag delete x
+ .t tag configure x -tabs {10 30 center 50 right 120} -tabstyle wordprocessor
+ .t tag add x 1.0 end
+ set res [list [lindex [.t bbox 1.4] 0] [lindex [.t bbox 1.8] 0] \
+ [lindex [.t bbox 1.12] 0] [lindex [.t bbox 1.16] 0]]
+ .t tag configure x -tabstyle tabular
+ set res
+} [list 28 56 120 190]
+test textDisp-26.14 {AdjustForTab procedure, not enough space} {textfonts} {
+ .t delete 1.0 end
+ .t insert end "a \tb \tc \td \te \tf \tg\n"
+ .t insert end "Watch the \tX and the \t\t\tY\n"
+ .t tag configure moop -tabs [expr {8*$fixedWidth}]
+ .t insert end "Watch the \tX and the \t\t\tY\n" moop
+ list [lindex [.t bbox 2.11] 0] [lindex [.t bbox 2.24] 0] \
+ [lindex [.t bbox 3.11] 0] [lindex [.t bbox 3.24] 0]
+} [list 77 224 77 224]
+test textDisp-26.14.2 {AdjustForTab procedure, not enough space} {textfonts} {
+ .t delete 1.0 end
+ .t configure -tabstyle wordprocessor
+ .t insert end "a \tb \tc \td \te \tf \tg\n"
+ .t insert end "Watch the \tX and the \t\t\tY\n"
+ .t tag configure moop -tabs [expr {8*$fixedWidth}]
+ .t insert end "Watch the \tX and the \t\t\tY\n" moop
+ set res [list [lindex [.t bbox 2.11] 0] [lindex [.t bbox 2.24] 0] \
+ [lindex [.t bbox 3.11] 0] [lindex [.t bbox 3.24] 0]]
+ .t configure -tabstyle tabular
+ set res
+} [list 112 56 112 56]
+
+.t configure -width 20 -bd 2 -highlightthickness 2 -relief sunken -tabs {} \
+ -wrap char
+update
+test textDisp-27.1 {SizeOfTab procedure, old-style tabs} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 a\tbcdefghij\tc\td
+ list [.t bbox 1.2] [.t bbox 1.10] [.t bbox 1.12]
+} [list [list 60 5 7 $fixedHeight] [list 116 5 7 $fixedHeight] [list 130 5 7 $fixedHeight]]
+test textDisp-27.1.1 {SizeOfTab procedure, old-style tabs} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 a\tbcdefghij\tc\td
+ .t configure -tabstyle wordprocessor
+ set res [list [.t bbox 1.2] [.t bbox 1.10] [.t bbox 1.12]]
+ .t configure -tabstyle tabular
+ set res
+} [list [list 60 5 7 $fixedHeight] [list 116 5 7 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-27.2 {SizeOfTab procedure, choosing tabX and alignment} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 a\tbcd
+ .t tag delete x
+ .t tag configure x -tabs 120
+ .t tag add x 1.0 end
+ list [.t bbox 1.3] [.t bbox 1.4]
+} [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-27.3 {SizeOfTab procedure, choosing tabX and alignment} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 a\t\t\tbcd
+ .t tag delete x
+ .t tag configure x -tabs 40
+ .t tag add x 1.0 end
+ list [.t bbox 1.5] [.t bbox 1.6]
+} [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-27.4 {SizeOfTab procedure, choosing tabX and alignment} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 a\t\t\tbcd
+ .t tag delete x
+ .t tag configure x -tabs {20 center 70 left}
+ .t tag add x 1.0 end
+ list [.t bbox 1.5] [.t bbox 1.6]
+} [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-27.5 {SizeOfTab procedure, center alignment} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 a\txyzzyabc
+ .t tag delete x
+ .t tag configure x -tabs {120 center}
+ .t tag add x 1.0 end
+ list [.t bbox 1.6] [.t bbox 1.7]
+} [list [list 135 5 9 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-27.6 {SizeOfTab procedure, center alignment} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 a\txyzzyabc
+ .t tag delete x
+ .t tag configure x -tabs {150 center}
+ .t tag add x 1.0 end
+ list [.t bbox 1.6] [.t bbox 1.7]
+} [list [list 32 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 39 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-27.7 {SizeOfTab procedure, center alignment, wrap -none (potential numerical problems)} {textfonts} {
+ .t delete 1.0 end
+ set cm [winfo fpixels .t 1c]
+ .t configure -tabs {1c 2c center 3c 4c 5c 6c 7c 8c} -wrap none -width 40
+ .t insert 1.0 a\tb\tc\td\te\n012345678934567890a\tbb\tcc\tdd
+ set width [expr {$fixedWidth * 19}]
+ set tab $cm
+ while {$tab < $width} {
+ set tab [expr {$tab + $cm}]
+ }
+ # Now we've calculated to the end of the tab after 'a', add one
+ # more for 'bb\t' and we're there, with 4 for the border. Since
+ # Tk_GetPixelsFromObj uses the standard 'int(0.5 + float)' rounding,
+ # so must we.
+ set tab [expr {4 + int(0.5 + $tab + $cm)}]
+ update
+ set res [.t bbox 2.23]
+ lset res 0 [expr {[lindex $res 0] - $tab}]
+ set res
+} [list -28 [expr {$fixedDiff + 18}] 7 $fixedHeight]
+test textDisp-27.7.1 {SizeOfTab procedure, center alignment, wrap -none (potential numerical problems)} {textfonts} {
+ .t delete 1.0 end
+ .t configure -tabstyle wordprocessor
+ set cm [winfo fpixels .t 1c]
+ .t configure -tabs {1c 2c center 3c 4c 5c 6c 7c 8c} -wrap none -width 40
+ .t insert 1.0 a\tb\tc\td\te\n012345678934567890a\tbb\tcc\tdd
+ set width [expr {$fixedWidth * 19}]
+ set tab $cm
+ while {$tab < $width} {
+ set tab [expr {$tab + $cm}]
+ }
+ # Now we've calculated to the end of the tab after 'a', add one
+ # more for 'bb\t' and we're there, with 4 for the border. Since
+ # Tk_GetPixelsFromObj uses the standard 'int(0.5 + float)' rounding,
+ # so must we.
+ set tab [expr {4 + int(0.5 + $tab + $cm)}]
+ update
+ set res [.t bbox 2.23]
+ .t configure -tabstyle tabular
+ lset res 0 [expr {[lindex $res 0] - $tab}]
+ set res
+} [list 0 [expr {$fixedDiff + 18}] 7 $fixedHeight]
+test textDisp-27.7.2 {SizeOfTab procedure, fractional tab interpolation problem} {
+ .t delete 1.0 end
+ set interpolatetab {1c 2c}
+ set precisetab {}
+ for {set i 1} {$i < 20} {incr i} {
+ lappend precisetab "${i}c"
+ }
+ .t configure -tabs $interpolatetab -wrap none -width 150
+ .t insert 1.0 [string repeat "a\t" 20]
+ update
+ set res [.t bbox 1.20]
+ # Now, Tk's interpolated tabs should be the same as
+ # non-interpolated.
+ .t configure -tabs $precisetab
+ update
+ expr {[lindex $res 0] - [lindex [.t bbox 1.20] 0]}
+} {0}
+
+.t configure -wrap char -tabs {} -width 20
+update
+test textDisp-27.8 {SizeOfTab procedure, right alignment} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 a\t\txyzzyabc
+ .t tag delete x
+ .t tag configure x -tabs {100 left 140 right}
+ .t tag add x 1.0 end
+ list [.t bbox 1.6] [.t bbox 1.7]
+} [list [list 137 5 7 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-27.9 {SizeOfTab procedure, left alignment} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 a\txyzzyabc
+ .t tag delete x
+ .t tag configure x -tabs {120}
+ .t tag add x 1.0 end
+ list [.t bbox 1.3] [.t bbox 1.4]
+} [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-27.10 {SizeOfTab procedure, numeric alignment} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 a\t123.4
+ .t tag delete x
+ .t tag configure x -tabs {120 numeric}
+ .t tag add x 1.0 end
+ list [.t bbox 1.3] [.t bbox 1.4]
+} [list [list 117 5 27 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+test textDisp-27.11 {SizeOfTab procedure, making tabs at least as wide as a space} {textfonts} {
+ .t delete 1.0 end
+ .t insert 1.0 abc\tdefghijklmnopqrst
+ .t tag delete x
+ .t tag configure x -tabs {120}
+ .t tag add x 1.0 end
+ list [.t bbox 1.5] [.t bbox 1.6]
+} [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]]
+
+proc bizarre_scroll args {
+ .t2.t delete 5.0 end
+}
+test textDisp-28.1 {"yview" option with bizarre scroll command} {
+ catch {destroy .t2}
+ toplevel .t2
+ text .t2.t -width 40 -height 4
+ .t2.t insert end "1\n2\n3\n4\n5\n6\n7\n8\n"
+ pack .t2.t
+ wm geometry .t2 +0+0
+ update
+ .t2.t configure -yscrollcommand bizarre_scroll
+ .t2.t yview 100.0
+ set result [.t2.t index @0,0]
+ update
+ lappend result [.t2.t index @0,0]
+} {6.0 1.0}
+
+test textDisp-29.1 {miscellaneous: lines wrap but are still too long} {textfonts} {
+ catch {destroy .t2}
+ toplevel .t2
+ wm geometry .t2 +0+0
+ text .t2.t -width 20 -height 10 -font $fixedFont \
+ -wrap char -xscrollcommand ".t2.s set"
+ pack .t2.t -side top
+ scrollbar .t2.s -orient horizontal -command ".t2.t xview"
+ pack .t2.s -side bottom -fill x
+ .t2.t insert end 123
+ frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised
+ .t2.t window create 1.1 -window .t2.t.f
+ update
+ list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3]
+} [list [list 0.0 [expr {20.0*$fixedWidth/300}]] 300x50+[expr {$twbw + $twht + 1}]+[expr {$twbw + $twht + $fixedHeight + 1}] [list [expr {$twbw + $twht + $fixedWidth + 1}] [expr {$twbw + $twht + $fixedHeight + 50 + 1}] $fixedWidth $fixedHeight]]
+test textDisp-29.2 {miscellaneous: lines wrap but are still too long} {textfonts} {
+ catch {destroy .t2}
+ toplevel .t2
+ wm geometry .t2 +0+0
+ text .t2.t -width 20 -height 10 -font $fixedFont \
+ -wrap char -xscrollcommand ".t2.s set"
+ pack .t2.t -side top
+ scrollbar .t2.s -orient horizontal -command ".t2.t xview"
+ pack .t2.s -side bottom -fill x
+ .t2.t insert end 123
+ frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised
+ .t2.t window create 1.1 -window .t2.t.f
+ update
+ .t2.t xview scroll 1 unit
+ update
+ list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3]
+} [list [list [expr {1.0*$fixedWidth/300}] [expr {21.0*$fixedWidth/300}]] 300x50+[expr {$twbw + $twht + 1 - $fixedWidth}]+[expr {$twbw + $twht + $fixedHeight + 1}] [list [expr {$twbw + $twht + $fixedWidth + 1 - $fixedWidth}] [expr {$twbw + $twht + $fixedHeight + 50 + 1}] $fixedWidth $fixedHeight]]
+test textDisp-29.2.1 {miscellaneous: lines wrap but are still too long} {textfonts} {
+ catch {destroy .t2}
+ toplevel .t2
+ wm geometry .t2 +0+0
+ text .t2.t -width 20 -height 10 -font $fixedFont \
+ -wrap none -xscrollcommand ".t2.s set"
+ pack .t2.t -side top
+ scrollbar .t2.s -orient horizontal -command ".t2.t xview"
+ pack .t2.s -side bottom -fill x
+ .t2.t insert end 1\n
+ .t2.t insert end [string repeat "abc" 30]
+ update
+ .t2.t xview scroll 5 unit
+ update
+ .t2.t xview
+} [list [expr {5.0/90}] [expr {25.0/90}]]
+test textDisp-29.2.2 {miscellaneous: lines wrap but are still too long} {textfonts} {
+ catch {destroy .t2}
+ toplevel .t2
+ wm geometry .t2 +0+0
+ text .t2.t -width 20 -height 10 -font $fixedFont \
+ -wrap char -xscrollcommand ".t2.s set"
+ pack .t2.t -side top
+ scrollbar .t2.s -orient horizontal -command ".t2.t xview"
+ pack .t2.s -side bottom -fill x
+ .t2.t insert end 123
+ frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised
+ .t2.t window create 1.1 -window .t2.t.f
+ update
+ .t2.t xview scroll 2 unit
+ update
+ list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3]
+} [list [list [expr {2.0*$fixedWidth/300}] [expr {22.0*$fixedWidth/300}]] 300x50+[expr {$twbw + $twht + 1 - 2*$fixedWidth}]+[expr {$twbw + $twht + $fixedHeight + 1}] {}]
+test textDisp-29.2.3 {miscellaneous: lines wrap but are still too long} {textfonts} {
+ catch {destroy .t2}
+ toplevel .t2
+ wm geometry .t2 +0+0
+ text .t2.t -width 20 -height 10 -font $fixedFont \
+ -wrap char -xscrollcommand ".t2.s set"
+ pack .t2.t -side top
+ scrollbar .t2.s -orient horizontal -command ".t2.t xview"
+ pack .t2.s -side bottom -fill x
+ .t2.t insert end 123
+ frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised
+ .t2.t window create 1.1 -window .t2.t.f
+ update
+ .t2.t xview scroll 7 pixels
+ update
+ list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3]
+} [list [list [expr {7.0/300}] [expr {(20.0*$fixedWidth + 7)/300}]] 300x50+[expr {$twbw + $twht + 1 - 7}]+[expr {$twbw + $twht + $fixedHeight + 1}] [list [expr {$twbw + $twht + $fixedWidth + 1 - 7}] [expr {$twbw + $twht + $fixedHeight + 50 + 1}] $fixedWidth $fixedHeight]]
+test textDisp-29.2.4 {miscellaneous: lines wrap but are still too long} {textfonts} {
+ catch {destroy .t2}
+ toplevel .t2
+ wm geometry .t2 +0+0
+ text .t2.t -width 20 -height 10 -font $fixedFont \
+ -wrap char -xscrollcommand ".t2.s set"
+ pack .t2.t -side top
+ scrollbar .t2.s -orient horizontal -command ".t2.t xview"
+ pack .t2.s -side bottom -fill x
+ .t2.t insert end 123
+ frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised
+ .t2.t window create 1.1 -window .t2.t.f
+ update
+ .t2.t xview scroll 17 pixels
+ update
+ list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3]
+} [list [list [expr {17.0/300}] [expr {(20.0*$fixedWidth + 17)/300}]] 300x50+[expr {$twbw + $twht + 1 - 17}]+[expr {$twbw + $twht + $fixedHeight + 1}] {}]
+test textDisp-29.2.5 {miscellaneous: can show last character} {
+ catch {destroy .t2}
+ toplevel .t2
+ wm geometry .t2 121x141+200+200
+ text .t2.t -width 5 -height 5 -font {Arial 10} \
+ -wrap none -xscrollcommand ".t2.s set" \
+ -bd 2 -highlightthickness 0 -padx 1
+ .t2.t insert end "WWWWWWWWWWWWi"
+ scrollbar .t2.s -orient horizontal -command ".t2.t xview"
+ grid .t2.t -row 0 -column 0 -sticky nsew
+ grid .t2.s -row 1 -column 0 -sticky ew
+ grid columnconfigure .t2 0 -weight 1
+ grid rowconfigure .t2 0 -weight 1
+ grid rowconfigure .t2 1 -weight 0
+ update ; update
+ set xv [.t2.t xview]
+ set xd [expr {[lindex $xv 1] - [lindex $xv 0]}]
+ .t2.t xview moveto [expr {1.0-$xd}]
+ set iWidth [lindex [.t2.t bbox end-2c] 2]
+ .t2.t xview scroll 2 units
+ set iWidth2 [lindex [.t2.t bbox end-2c] 2]
+
+ if {($iWidth == $iWidth2) && $iWidth >= 2} {
+ set result "correct"
+ } else {
+ set result "last character is not completely visible when it should be"
+ }
+} {correct}
+test textDisp-29.3 {miscellaneous: lines wrap but are still too long} {textfonts} {
+ catch {destroy .t2}
+ toplevel .t2
+ wm geometry .t2 +0+0
+ text .t2.t -width 20 -height 10 -font $fixedFont \
+ -wrap char -xscrollcommand ".t2.s set"
+ pack .t2.t -side top
+ scrollbar .t2.s -orient horizontal -command ".t2.t xview"
+ pack .t2.s -side bottom -fill x
+ .t2.t insert end 123
+ frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised
+ .t2.t window create 1.1 -window .t2.t.f
+ update
+ .t2.t xview scroll 200 units
+ update
+ list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3]
+} [list [list [expr {16.0/30}] 1.0] 300x50+-155+[expr {$fixedDiff + 18}] {}]
+test textDisp-30.1 {elidden text joining multiple logical lines} {
+ .t2.t delete 1.0 end
+ .t2.t insert 1.0 "1111\n2222\n3333"
+ .t2.t tag configure elidden -elide 1 -background red
+ .t2.t tag add elidden 1.2 3.2
+ .t2.t count -displaylines 1.0 end
+} {1}
+test textDisp-30.2 {elidden text joining multiple logical lines} {
+ .t2.t delete 1.0 end
+ .t2.t insert 1.0 "1111\n2222\n3333"
+ .t2.t tag configure elidden -elide 1 -background red
+ .t2.t tag add elidden 1.2 2.2
+ .t2.t count -displaylines 1.0 end
+} {2}
+catch {destroy .t2}
+
+.t configure -height 1
+update
+
+test textDisp-31.1 {line embedded window height update} {
+ set res {}
+ .t delete 1.0 end
+ .t insert end "abcd\nefgh\nijkl\nmnop\nqrst\nuvwx\nyx"
+ frame .t.f -background red -width 100 -height 100
+ .t window create 3.0 -window .t.f
+ lappend res [.t count -update -ypixels 1.0 end]
+ .t.f configure -height 10
+ lappend res [.t count -ypixels 1.0 end]
+ lappend res [.t count -update -ypixels 1.0 end]
+ set res
+} [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 6}] [expr {$fixedHeight * 7}]]
+
+test textDisp-31.2 {line update index shifting} {
+ set res {}
+ .t.f configure -height 100
+ update
+ lappend res [.t count -update -ypixels 1.0 end]
+ .t.f configure -height 10
+ .t insert 1.0 "abc\n"
+ .t insert 1.0 "abc\n"
+ lappend res [.t count -ypixels 1.0 end]
+ lappend res [.t count -update -ypixels 1.0 end]
+ .t.f configure -height 100
+ .t delete 1.0 3.0
+ lappend res [.t count -ypixels 1.0 end]
+ lappend res [.t count -update -ypixels 1.0 end]
+ set res
+} [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 8}] [expr {$fixedHeight * 9}] [expr {$fixedHeight * 7}] [expr {100 + $fixedHeight * 6}]]
+
+test textDisp-31.3 {line update index shifting} {
+ # Should do exactly the same as the above, as long
+ # as we are correctly tagging the correct lines for
+ # recalculation. The 'update' and 'delay' must be
+ # long enough to ensure all asynchronous updates
+ # have been performed.
+ set res {}
+ .t.f configure -height 100
+ update
+ lappend res [.t count -update -ypixels 1.0 end]
+ .t.f configure -height 10
+ .t insert 1.0 "abc\n"
+ .t insert 1.0 "abc\n"
+ lappend res [.t count -ypixels 1.0 end]
+ update ; after 1000 ; update
+ lappend res [.t count -ypixels 1.0 end]
+ .t.f configure -height 100
+ .t delete 1.0 3.0
+ lappend res [.t count -ypixels 1.0 end]
+ update ; after 1000 ; update
+ lappend res [.t count -ypixels 1.0 end]
+ set res
+} [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 8}] [expr {$fixedHeight * 9}] [expr {$fixedHeight * 7}] [expr {100 + $fixedHeight * 6}]]
+
+test textDisp-31.4 {line embedded image height update} {
+ set res {}
+ image create photo textest -height 100 -width 10
+ .t delete 3.0
+ .t image create 3.0 -image textest
+ update
+ lappend res [.t count -update -ypixels 1.0 end]
+ textest configure -height 10
+ lappend res [.t count -ypixels 1.0 end]
+ lappend res [.t count -update -ypixels 1.0 end]
+ set res
+} [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 6}] [expr {$fixedHeight * 7}]]
+
+test textDisp-31.5 {line update index shifting} {
+ set res {}
+ textest configure -height 100
+ update ; after 1000 ; update
+ lappend res [.t count -update -ypixels 1.0 end]
+ textest configure -height 10
+ .t insert 1.0 "abc\n"
+ .t insert 1.0 "abc\n"
+ lappend res [.t count -ypixels 1.0 end]
+ lappend res [.t count -update -ypixels 1.0 end]
+ textest configure -height 100
+ .t delete 1.0 3.0
+ lappend res [.t count -ypixels 1.0 end]
+ lappend res [.t count -update -ypixels 1.0 end]
+ set res
+} [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 8}] [expr {$fixedHeight * 9}] [expr {$fixedHeight * 7}] [expr {100 + $fixedHeight * 6}]]
+
+test textDisp-31.6 {line update index shifting} {
+ # Should do exactly the same as the above, as long
+ # as we are correctly tagging the correct lines for
+ # recalculation. The 'update' and 'delay' must be
+ # long enough to ensure all asynchronous updates
+ # have been performed.
+ set res {}
+ textest configure -height 100
+ update ; after 1000 ; update
+ lappend res [.t count -update -ypixels 1.0 end]
+ textest configure -height 10
+ .t insert 1.0 "abc\n"
+ .t insert 1.0 "abc\n"
+ lappend res [.t count -ypixels 1.0 end]
+ update ; after 1000 ; update
+ lappend res [.t count -ypixels 1.0 end]
+ textest configure -height 100
+ .t delete 1.0 3.0
+ lappend res [.t count -ypixels 1.0 end]
+ update ; after 1000 ; update
+ lappend res [.t count -ypixels 1.0 end]
+ set res
+} [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 8}] [expr {$fixedHeight * 9}] [expr {$fixedHeight * 7}] [expr {100 + $fixedHeight * 6}]]
+
+test textDisp-31.7 {line update index shifting, elided} {
+ # The 'update' and 'delay' must be long enough to ensure all
+ # asynchronous updates have been performed.
+ set res {}
+ .t delete 1.0 end
+ lappend res [.t count -update -ypixels 1.0 end]
+ .t insert 1.0 "abc\nabc"
+ .t insert 1.0 "abc\n"
+ lappend res [.t count -update -ypixels 1.0 end]
+ .t tag configure elide -elide 1
+ .t tag add elide 1.3 2.1
+ lappend res [.t count -ypixels 1.0 end]
+ update ; after 1000 ; update
+ lappend res [.t count -ypixels 1.0 end]
+ .t delete 1.0 3.0
+ lappend res [.t count -ypixels 1.0 end]
+ update ; after 1000 ; update
+ lappend res [.t count -ypixels 1.0 end]
+ set res
+} [list [expr {$fixedHeight * 1}] [expr {$fixedHeight * 3}] [expr {$fixedHeight * 3}] [expr {$fixedHeight * 2}] [expr {$fixedHeight * 1}] [expr {$fixedHeight * 1}]]
+
+test textDisp-32.0 {everything elided} {
+ # Must not crash
+ pack [text .tt]
+ .tt insert 0.0 HELLO
+ .tt tag configure HIDE -elide 1
+ .tt tag add HIDE 0.0 end
+ update ; update ; update ; update
+ destroy .tt
+} {}
+test textDisp-32.1 {everything elided} {
+ # Must not crash
+ pack [text .tt]
+ update
+ .tt insert 0.0 HELLO
+ update
+ .tt tag configure HIDE -elide 1
+ update
+ .tt tag add HIDE 0.0 end
+ update ; update ; update ; update
+ destroy .tt
+} {}
+test textDisp-32.2 {elide and tags} {
+ pack [text .tt -height 30 -width 100 -bd 0 \
+ -highlightthickness 0 -padx 0]
+ .tt insert end \
+ {test text using tags 1 and 3 } \
+ {testtag1 testtag3} \
+ {[this bit here uses tags 2 and 3]} \
+ {testtag2 testtag3}
+ update
+ # indent left margin of tag 1 by 20 pixels
+ # text should be indented
+ .tt tag configure testtag1 -lmargin1 20 ; update
+ #1
+ set res {}
+ lappend res [list [.tt index "1.0 + 0 displaychars"] \
+ [lindex [.tt bbox 1.0] 0] \
+ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]]
+ # hide tag 1, remaining text should not be indented, since
+ # the indented tag and character is hidden.
+ .tt tag configure testtag1 -elide 1 ; update
+ #2
+ lappend res [list [.tt index "1.0 + 0 displaychars"] \
+ [lindex [.tt bbox 1.0] 0] \
+ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]]
+ # reset
+ .tt tag configure testtag1 -lmargin1 0
+ .tt tag configure testtag1 -elide 0
+ # indent left margin of tag 2 by 20 pixels
+ # text should not be indented, since tag1 has lmargin1 of 0.
+ .tt tag configure testtag2 -lmargin1 20 ; update
+ #3
+ lappend res [list [.tt index "1.0 + 0 displaychars"] \
+ [lindex [.tt bbox 1.0] 0] \
+ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]]
+ # hide tag 1, remaining text should now be indented, but
+ # the bbox of 1.0 should have zero width and zero indent,
+ # since it is elided at that position.
+ .tt tag configure testtag1 -elide 1 ; update
+ #4
+ lappend res [list [.tt index "1.0 + 0 displaychars"] \
+ [lindex [.tt bbox 1.0] 0] \
+ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]]
+ # reset
+ .tt tag configure testtag2 -lmargin1 {}
+ .tt tag configure testtag1 -elide 0
+ # indent left margin of tag 3 by 20 pixels
+ # text should be indented, since this tag takes
+ # precedence over testtag1, and is applied to the
+ # start of the text.
+ .tt tag configure testtag3 -lmargin1 20 ; update
+ #5
+ lappend res [list [.tt index "1.0 + 0 displaychars"] \
+ [lindex [.tt bbox 1.0] 0] \
+ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]]
+ # hide tag 1, remaining text should still be indented,
+ # since it still has testtag3 on it. Again the
+ # bbox of 1.0 should have 0.
+ .tt tag configure testtag1 -elide 1 ; update
+ #6
+ lappend res [list [.tt index "1.0 + 0 displaychars"] \
+ [lindex [.tt bbox 1.0] 0] \
+ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]]
+ .tt tag configure testtag3 -lmargin1 {} -elide 0
+ .tt tag configure testtag1 -elide 1 -lmargin1 20
+ #7
+ lappend res [list [.tt index "1.0 + 0 displaychars"] \
+ [lindex [.tt bbox 1.0] 0] \
+ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]]
+ destroy .tt
+ set res
+} {{1.0 20 20} {1.29 0 0} {1.0 0 0} {1.29 0 20}\
+ {1.0 20 20} {1.29 0 20} {1.0 20 20}}
+test textDisp-32.3 "NULL undisplayProc problems: #1791052" -setup {
+ set img [image create photo -data {
+ R0lGODlhEgASANUAAAAAAP/////iHP/mIPrWDPraEP/eGPfOAPbKAPbOBPrS
+ CP/aFPbGAPLCAPLGAN62ANauAMylAPbCAPW/APK+AN6uALKNAPK2APK5ANal
+ AOyzArGHBZp3B+6uAHFVBFVACO6qAOqqAOalAMGMAbF+Am1QBG5QBeuiAOad
+ AM6NAJ9vBW1MBFlACFQ9CVlBCuaZAOKVANyVAZlpBMyFAKZtBJVhBEAUEP//
+ /wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADcALAAAAAASABIAAAa+
+ wJtw+Ckah0iiZwNhODKk0icp/HAShEKBoEBgVFOkK0Iw2GyCs+BAGbGIlrIt
+ EJjXBYgL6X3zJMx1Z2d3EyEmNx9xaYGCdwgaNEUPBYt0do4XKUUOlAOCnmcD
+ CwcXMZsEAgOqq6oLBY+mHxUKBqysCwQSIDNFJAidtgKjFyeRfRQHB2ipAmZs
+ IDArVSTIyoI2bB0oxkIsIxcNyeIXICh7SR8yIhoXFxogJzE1YegrNCkoLzM0
+ K/RUiEY+tKASBAA7
+ }]
+ destroy .tt
+} -body {
+ text .tt
+ .tt tag configure emoticon -elide 1
+ .tt insert end X
+ .tt mark set MSGLEFT "end - 1 char"
+ .tt mark gravity MSGLEFT left
+ .tt insert end ":)" emoticon
+ .tt image create end -image $img
+ pack .tt
+ update; update; update
+} -cleanup {
+ image delete $img
+ destroy .tt
+}
+
+test textDisp-33.0 {one line longer than fits in the widget} {
+ pack [text .tt -wrap char]
+ .tt insert 1.0 [string repeat "more wrap + " 300]
+ update ; update ; update
+ .tt see 1.0
+ lindex [.tt yview] 0
+} {0.0}
+test textDisp-33.1 {one line longer than fits in the widget} {
+ destroy .tt
+ pack [text .tt -wrap char]
+ .tt insert 1.0 [string repeat "more wrap + " 300]
+ update ; update ; update
+ .tt yview "1.0 +1 displaylines"
+ if {[lindex [.tt yview] 0] > 0.1} {
+ set result "window should be scrolled to the top"
+ } else {
+ set result "ok"
+ }
+} {ok}
+test textDisp-33.2 {one line longer than fits in the widget} {
+ destroy .tt
+ pack [text .tt -wrap char]
+ .tt debug 1
+ set tk_textHeightCalc ""
+ .tt insert 1.0 [string repeat "more wrap + " 1]
+ after 100 ; update idletasks
+ # Nothing should have been recalculated.
+ set tk_textHeightCalc
+} {}
+test textDisp-33.3 {one line longer than fits in the widget} {
+ destroy .tt
+ pack [text .tt -wrap char]
+ .tt debug 1
+ set tk_textHeightCalc ""
+ .tt insert 1.0 [string repeat "more wrap + " 300]
+ update ; .tt count -update -ypixels 1.0 end ; update
+ # Each line should have been recalculated just once
+ .tt debug 0
+ expr {[llength $tk_textHeightCalc] == [.tt count -displaylines 1.0 end]}
+} {1}
+test textDisp-33.4 {one line longer than fits in the widget} {
+ destroy .tt
+ pack [text .tt -wrap char]
+ .tt debug 1
+ set tk_textHeightCalc ""
+ .tt insert 1.0 [string repeat "more wrap + " 300]
+ update ; update ; update
+ set idx [.tt index "1.0 + 1 displaylines"]
+ .tt yview $idx
+ if {[lindex [.tt yview] 0] > 0.1} {
+ set result "window should be scrolled to the top"
+ } else {
+ set result "ok"
+ }
+ set idx [.tt index "1.0 + 1 displaylines"]
+ .tt debug 0
+ set result
+} {ok}
+destroy .tt
+test textDisp-33.5 {bold or italic fonts} win {
+ destroy .tt
+ pack [text .tt -wrap char -font {{MS Sans Serif} 15}]
+ font create no -family [lindex [.tt cget -font] 0] -size 24
+ font create bi -family [lindex [.tt cget -font] 0] -size 24
+ font configure bi -weight bold -slant italic
+ .tt tag configure bi -font bi
+ .tt tag configure no -font no
+ .tt insert end abcd no efgh bi ijkl\n no
+ update
+ set bb {}
+ for {set i 0} {$i < 12} {incr i 4} {
+ lappend bb [lindex [.tt bbox 1.$i] 0]
+ }
+ foreach {a b c} $bb {}
+ unset bb
+ if {($b - $a) * 1.5 < ($c - $b)} {
+ set result "italic font has much too much space"
+ } else {
+ set result "italic font measurement ok"
+ }
+} {italic font measurement ok}
+destroy .tt
+
+test textDisp-34.1 {Line heights recalculation problem: bug 2677890} -setup {
+ pack [text .t1] -expand 1 -fill both
+ set txt ""
+ for {set i 1} {$i < 100} {incr i} {
+ append txt "Line $i\n"
+ }
+ set result {}
+} -body {
+ .t1 insert end $txt
+ .t1 debug 1
+ set ge [winfo geometry .]
+ scan $ge "%dx%d+%d+%d" width height left top
+ update
+ .t1 sync
+ set negative 0
+ bind .t1 <<WidgetViewSync>> { if {%d < 0} {set negative 1} }
+ # Without the fix for bug 2677890, changing the width of the toplevel
+ # will launch recomputation of the line heights, but will produce negative
+ # number of still remaining outdated lines, which is obviously wrong.
+ # Thus we use this way to check for regression regarding bug 2677890,
+ # i.e. to check that the fix for this bug really is still in.
+ wm geometry . "[expr {$width * 2}]x$height+$left+$top"
+ update
+ .t1 sync
+ set negative
+} -cleanup {
+ destroy .t1
+} -result {0}
+
+test textDisp-35.1 {Init value of charHeight - Dancing scrollbar bug 1499165} -setup {
+ pack [text .t1] -fill both -expand y -side left
+ .t insert end "[string repeat a\nb\nc\n 500000]THE END\n"
+ set res {}
+} -body {
+ .t see 10000.0
+ after 300 {set fr1 [.t yview] ; set done 1}
+ vwait done
+ after 300 {set fr2 [.t yview] ; set done 1}
+ vwait done
+ lappend res [expr {[lindex $fr1 0] == [lindex $fr2 0]}]
+ lappend res [expr {[lindex $fr1 1] == [lindex $fr2 1]}]
+} -cleanup {
+ destroy .t1
+} -result {1 1}
+
+deleteWindows
+option clear
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/textImage.test b/tk8.6/tests/textImage.test
new file mode 100644
index 0000000..4bb190c
--- /dev/null
+++ b/tk8.6/tests/textImage.test
@@ -0,0 +1,473 @@
+# textImage.test -- test images embedded in text widgets
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+imageInit
+
+# One time setup. Create a font to insure the tests are font metric invariant.
+destroy .t
+font create test_font -family courier -size 14
+text .t -font test_font
+destroy .t
+
+test textImage-1.1 {basic argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image option ?arg ...?"}
+
+test textImage-1.2 {basic argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image c
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {ambiguous option "c": must be cget, configure, create, or names}
+
+test textImage-1.3 {cget argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image cget
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image cget index option"}
+
+test textImage-1.4 {cget argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image cget blurf -flurp
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad text index "blurf"}
+
+test textImage-1.5 {cget argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image cget 1.1 -flurp
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {no embedded image at index "1.1"}
+
+test textImage-1.6 {configure argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image configure
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image configure index ?-option value ...?"}
+
+test textImage-1.7 {configure argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image configure blurf
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad text index "blurf"}
+
+test textImage-1.8 {configure argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image configure 1.1
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {no embedded image at index "1.1"}
+
+test textImage-1.9 {create argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image create index ?-option value ...?"}
+
+test textImage-1.10 {create argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create blurf
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad text index "blurf"}
+
+test textImage-1.11 {basic argument checking} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create 1000.1000 -image small
+} -cleanup {
+ destroy .t
+ image delete small
+} -returnCodes ok -result {small}
+
+test textImage-1.12 {names argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image names dates places
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image names"}
+
+
+test textImage-1.13 {names argument checking} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ lappend result [.t image names]
+ .t image create insert -image small
+ lappend result [.t image names]
+ .t image create insert -image small
+ lappend result [lsort [.t image names]]
+ .t image create insert -image small -name little
+ lappend result [lsort [.t image names]]
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {{} small {small small#1} {little small small#1}}
+
+test textImage-1.14 {basic argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image huh
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad option "huh": must be cget, configure, create, or names}
+
+test textImage-1.15 {align argument checking} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small -align wrong
+} -cleanup {
+ destroy .t
+ image delete small
+} -returnCodes error -result {bad align "wrong": must be baseline, bottom, center, or top}
+
+test textImage-1.16 {configure} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small
+ .t image configure small
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {{-align {} {} center center} {-padx {} {} 0 0} {-pady {} {} 0 0} {-image {} {} {} small} {-name {} {} {} {}}}
+
+test textImage-1.17 {basic cget options} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small
+ foreach i {align padx pady image name} {
+ lappend result $i:[.t image cget small -$i]
+ }
+ return $result
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {align:center padx:0 pady:0 image:small name:}
+
+test textImage-1.18 {basic configure options} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small
+ foreach {option value} {align top padx 5 pady 7 image large name none} {
+ .t image configure small -$option $value
+ }
+ update
+ .t image configure small
+} -cleanup {
+ destroy .t
+ image delete small large
+} -result {{-align {} {} center top} {-padx {} {} 0 5} {-pady {} {} 0 7} {-image {} {} {} large} {-name {} {} {} none}}
+
+test textImage-1.19 {basic image naming} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small
+ .t image create end -image small -name small
+ .t image create end -image small -name small#6342
+ .t image create end -image small -name small
+ lsort [.t image names]
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {small small#1 small#6342 small#6343}
+
+test textImage-2.1 {debug} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t debug 1
+ .t insert end front
+ .t image create end -image small
+ .t insert end back
+ .t delete small
+ .t image names
+ .t debug 0
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {}
+
+
+test textImage-3.1 {image change propagation} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo vary -width 5 -height 5
+ vary put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image vary -align top
+ update
+ lappend result base:[.t bbox vary]
+ foreach i {10 20 40} {
+ vary configure -width $i -height $i
+ update
+ lappend result $i:[.t bbox vary]
+ }
+ return $result
+} -cleanup {
+ destroy .t
+ image delete vary
+} -result {{base:0 0 5 5} {10:0 0 10 10} {20:0 0 20 20} {40:0 0 40 40}}
+
+test textImage-3.2 {delayed image management, see also bug 1591493} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -name test
+ update
+ foreach {x1 y1 w1 h1} [.t bbox test] {}
+ lappend result [list $x1 $w1 $h1]
+ .t image configure test -image small -align top
+ update
+ foreach {x2 y2 w2 h2} [.t bbox test] {}
+ lappend result [list [expr {$x1==$x2}] [expr {$w2>0}] [expr {$h2>0}]]
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {{0 0 0} {1 1 1}}
+
+
+# some temporary random tests
+
+test textImage-4.1 {alignment checking - except baseline} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image large
+ .t image create end -image small
+ .t insert end test
+ update
+ lappend result default:[.t bbox small]
+ foreach i {top bottom center} {
+ .t image configure small -align $i
+ update
+ lappend result [.t image cget small -align]:[.t bbox small]
+ }
+ return $result
+} -cleanup {
+ destroy .t
+ image delete small large
+} -result {{default:50 22 5 5} {top:50 0 5 5} {bottom:50 45 5 5} {center:50 22 5 5}}
+
+test textImage-4.2 {alignment checking - baseline} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
+ }
+ font create test_font2 -size 5
+ text .t -font test_font2 -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image large
+ .t image create end -image small -align baseline
+ .t insert end test
+ # Sizes larger than 25 can be too big and lead to a negative 'norm',
+ # at least on Windows XP with certain settings.
+ foreach size {10 15 20 25} {
+ font configure test_font2 -size $size
+ array set Metrics [font metrics test_font2]
+ update
+ foreach {x y w h} [.t bbox small] {}
+ set norm [expr {
+ (([image height large] - $Metrics(-linespace))/2
+ + $Metrics(-ascent) - [image height small] - $y)
+ }]
+ lappend result "$size $norm"
+ }
+ return $result
+} -cleanup {
+ destroy .t
+ image delete small large
+ font delete test_font2
+ unset Metrics
+} -result {{10 0} {15 0} {20 0} {25 0}}
+
+test textImage-4.3 {alignment and padding checking} -constraints {
+ fonts
+} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image large
+ .t image create end -image small -padx 5 -pady 10
+ .t insert end test
+ update
+ lappend result default:[.t bbox small]
+ foreach i {top bottom center baseline} {
+ .t image configure small -align $i
+ update
+ lappend result $i:[.t bbox small]
+ }
+ return $result
+} -cleanup {
+ destroy .t
+ image delete small large
+} -result {{default:55 22 5 5} {top:55 10 5 5} {bottom:55 35 5 5} {center:55 22 5 5} {baseline:55 22 5 5}}
+
+
+test textImage-5.1 {peer widget images} -setup {
+ destroy .t .tt
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
+ }
+ pack [text .t]
+ toplevel .tt
+ pack [.t peer create .tt.t]
+ .t image create end -image large
+ .t image create end -image small -padx 5 -pady 10
+ .t insert end test
+ update
+ destroy .t .tt
+} -cleanup {
+ image delete small large
+} -result {}
+
+# cleanup
+destroy .t
+font delete test_font
+imageFinish
+
+# cleanup
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/textIndex.test b/tk8.6/tests/textIndex.test
new file mode 100644
index 0000000..83a249e
--- /dev/null
+++ b/tk8.6/tests/textIndex.test
@@ -0,0 +1,963 @@
+# This file is a Tcl script to test the code in the file tkTextIndex.c.
+# This file is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+catch {destroy .t}
+text .t -font {Courier -12} -width 20 -height 10
+pack append . .t {top expand fill}
+update
+.t debug on
+wm geometry . {}
+
+# The statements below reset the main window; it's needed if the window
+# manager is mwm to make mwm forget about a previous minimum size setting.
+
+wm withdraw .
+wm minsize . 1 1
+wm positionfrom . user
+wm deiconify .
+
+.t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+b\u4e4fy GIrl .#@? x_yz
+!@#$%
+Line 7"
+
+image create photo textimage -width 10 -height 10
+textimage put red -to 0 0 9 9
+
+test textIndex-1.1 {TkTextMakeByteIndex} {testtext} {
+ # (lineIndex < 0)
+ testtext .t byteindex -1 3
+} {1.0 0}
+test textIndex-1.2 {TkTextMakeByteIndex} {testtext} {
+ # (lineIndex < 0), because lineIndex == strtol(argv[2]) - 1
+ testtext .t byteindex 0 3
+} {1.0 0}
+test textIndex-1.3 {TkTextMakeByteIndex} {testtext} {
+ # not (lineIndex < 0)
+ testtext .t byteindex 1 3
+} {1.3 3}
+test textIndex-1.4 {TkTextMakeByteIndex} {testtext} {
+ # (byteIndex < 0)
+ testtext .t byteindex 3 -1
+} {3.0 0}
+test textIndex-1.5 {TkTextMakeByteIndex} {testtext} {
+ # not (byteIndex < 0)
+ testtext .t byteindex 3 3
+} {3.3 3}
+test textIndex-1.6 {TkTextMakeByteIndex} {testtext} {
+ # (indexPtr->linePtr == NULL)
+ testtext .t byteindex 9 2
+} {8.0 0}
+test textIndex-1.7 {TkTextMakeByteIndex} {testtext} {
+ # not (indexPtr->linePtr == NULL)
+ testtext .t byteindex 7 2
+} {7.2 2}
+test textIndex-1.8 {TkTextMakeByteIndex: shortcut for 0} {testtext} {
+ # (byteIndex == 0)
+ testtext .t byteindex 1 0
+} {1.0 0}
+test textIndex-1.9 {TkTextMakeByteIndex: shortcut for 0} {testtext} {
+ # not (byteIndex == 0)
+ testtext .t byteindex 3 80
+} {3.5 5}
+test textIndex-1.10 {TkTextMakeByteIndex: verify index is in range} {testtext} {
+ # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
+ # one segment
+
+ testtext .t byteindex 3 5
+} {3.5 5}
+test textIndex-1.11 {TkTextMakeByteIndex: verify index is in range} {testtext} {
+ # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
+ # index += segPtr->size
+ # Multiple segments, make sure add segment size to index.
+
+ .t mark set foo 3.2
+ set x [testtext .t byteindex 3 7]
+ .t mark unset foo
+ set x
+} {3.5 5}
+test textIndex-1.12 {TkTextMakeByteIndex: verify index is in range} {testtext} {
+ # (segPtr == NULL)
+ testtext .t byteindex 3 7
+} {3.5 5}
+test textIndex-1.13 {TkTextMakeByteIndex: verify index is in range} {testtext} {
+ # not (segPtr == NULL)
+ testtext .t byteindex 3 4
+} {3.4 4}
+test textIndex-1.14 {TkTextMakeByteIndex: verify index is in range} {testtext} {
+ # (index + segPtr->size > byteIndex)
+ # in this segment.
+
+ testtext .t byteindex 3 4
+} {3.4 4}
+test textIndex-1.15 {TkTextMakeByteIndex: verify index is in range} {testtext} {
+ # (index + segPtr->size > byteIndex), index != 0
+ # in this segment.
+
+ .t mark set foo 3.2
+ set x [testtext .t byteindex 3 4]
+ .t mark unset foo
+ set x
+} {3.4 4}
+test textIndex-1.16 {TkTextMakeByteIndex: UTF-8 characters} {testtext} {
+ testtext .t byteindex 5 100
+} {5.18 20}
+test textIndex-1.17 {TkTextMakeByteIndex: prevent splitting UTF-8 character} \
+ {testtext} {
+ # ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType))
+ # Wrong answer would be \xb9 (the 2nd byte of UTF rep of 0x4e4f).
+
+ set x [testtext .t byteindex 5 2]
+ list $x [.t get insert]
+} {{5.2 4} y}
+test textIndex-1.18 {TkTextMakeByteIndex: prevent splitting UTF-8 character} \
+ {testtext} {
+ # ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType))
+ testtext .t byteindex 5 1
+ .t get insert
+} "\u4e4f"
+
+test textIndex-2.1 {TkTextMakeCharIndex} {
+ # (lineIndex < 0)
+ .t index -1.3
+} 1.0
+test textIndex-2.2 {TkTextMakeCharIndex} {
+ # (lineIndex < 0), because lineIndex == strtol(argv[2]) - 1
+ .t index 0.3
+} 1.0
+test textIndex-2.3 {TkTextMakeCharIndex} {
+ # not (lineIndex < 0)
+ .t index 1.3
+} 1.3
+test textIndex-2.4 {TkTextMakeCharIndex} {
+ # (charIndex < 0)
+ .t index 3.-1
+} 3.0
+test textIndex-2.5 {TkTextMakeCharIndex} {
+ # (charIndex < 0)
+ .t index 3.3
+} 3.3
+test textIndex-2.6 {TkTextMakeCharIndex} {
+ # (indexPtr->linePtr == NULL)
+ .t index 9.2
+} 8.0
+test textIndex-2.7 {TkTextMakeCharIndex} {
+ # not (indexPtr->linePtr == NULL)
+ .t index 7.2
+} 7.2
+test textIndex-2.8 {TkTextMakeCharIndex: verify index is in range} {
+ # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
+ # one segment
+
+ .t index 3.5
+} 3.5
+test textIndex-2.9 {TkTextMakeCharIndex: verify index is in range} {
+ # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
+ # Multiple segments, make sure add segment size to index.
+
+ .t mark set foo 3.2
+ set x [.t index 3.7]
+ .t mark unset foo
+ set x
+} 3.5
+test textIndex-2.10 {TkTextMakeCharIndex: verify index is in range} {
+ # (segPtr == NULL)
+ .t index 3.7
+} 3.5
+test textIndex-2.11 {TkTextMakeCharIndex: verify index is in range} {
+ # not (segPtr == NULL)
+ .t index 3.4
+} 3.4
+test textIndex-2.12 {TkTextMakeCharIndex: verify index is in range} {
+ # (segPtr->typePtr == &tkTextCharType)
+ # Wrong answer would be \xb9 (the 2nd byte of UTF rep of 0x4e4f).
+
+ .t mark set insert 5.2
+ .t get insert
+} y
+test textIndex-2.13 {TkTextMakeCharIndex: verify index is in range} {
+ # not (segPtr->typePtr == &tkTextCharType)
+
+ .t image create 5.2 -image textimage
+ .t mark set insert 5.5
+ set x [.t get insert]
+ .t delete 5.2
+ set x
+} "G"
+test textIndex-2.14 {TkTextMakeCharIndex: verify index is in range} {
+ # (charIndex < segPtr->size)
+
+ .t image create 5.0 -image textimage
+ set x [.t index 5.0]
+ .t delete 5.0
+ set x
+} 5.0
+
+.t mark set foo 3.2
+.t tag add x 2.8 2.11
+.t tag add x 6.0 6.2
+set weirdTag "funny . +- 22.1\n\t{"
+.t tag add $weirdTag 2.1 2.6
+set weirdMark "asdf \n{-+ 66.2\t"
+.t mark set $weirdMark 4.0
+.t tag config y -relief raised
+set weirdImage "foo-1"
+.t image create 2.1 -image [image create photo $weirdImage]
+set weirdEmbWin ".t.bar-1"
+entry $weirdEmbWin
+.t window create 3.1 -window $weirdEmbWin
+test textIndex-3.1 {TkTextGetIndex, weird mark names} {
+ list [catch {.t index $weirdMark} msg] $msg
+} {0 4.0}
+test textIndex-3.2 {TkTextGetIndex, weird mark names} knownBug {
+ list [catch {.t index "$weirdMark -1char"} msg] $msg
+} {0 4.0}
+test textIndex-3.3 {TkTextGetIndex, weird embedded window names} {
+ list [catch {.t index $weirdEmbWin} msg] $msg
+} {0 3.1}
+test textIndex-3.4 {TkTextGetIndex, weird embedded window names} knownBug {
+ list [catch {.t index "$weirdEmbWin -1char"} msg] $msg
+} {0 3.0}
+test textIndex-3.5 {TkTextGetIndex, weird image names} {
+ list [catch {.t index $weirdImage} msg] $msg
+} {0 2.1}
+test textIndex-3.6 {TkTextGetIndex, weird image names} knownBug {
+ list [catch {.t index "$weirdImage -1char"} msg] $msg
+} {0 2.0}
+.t delete 3.1 ; # remove the weirdEmbWin
+.t delete 2.1 ; # remove the weirdImage
+
+test textIndex-4.1 {TkTextGetIndex, tags} {
+ list [catch {.t index x.first} msg] $msg
+} {0 2.8}
+test textIndex-4.2 {TkTextGetIndex, tags} {
+ list [catch {.t index x.last} msg] $msg
+} {0 6.2}
+test textIndex-4.3 {TkTextGetIndex, weird tags} {
+ list [.t index $weirdTag.first+1c] [.t index $weirdTag.last+2c]
+} {2.2 2.8}
+test textIndex-4.4 {TkTextGetIndex, tags} {
+ list [catch {.t index x.gorp} msg] $msg
+} {1 {bad text index "x.gorp"}}
+test textIndex-4.5 {TkTextGetIndex, tags} {
+ list [catch {.t index foo.last} msg] $msg
+} {1 {bad text index "foo.last"}}
+test textIndex-4.6 {TkTextGetIndex, tags} {
+ list [catch {.t index y.first} msg] $msg
+} {1 {text doesn't contain any characters tagged with "y"}}
+test textIndex-4.7 {TkTextGetIndex, tags} {
+ list [catch {.t index x.last,} msg] $msg
+} {1 {bad text index "x.last,"}}
+test textIndex-4.8 {TkTextGetIndex, tags} {
+ .t tag add z 1.0
+ set result [list [.t index z.first] [.t index z.last]]
+ .t tag delete z
+ set result
+} {1.0 1.1}
+
+test textIndex-5.1 {TkTextGetIndex, "@"} {nonPortable fonts} {
+ .t index @12,9
+} 1.1
+test textIndex-5.2 {TkTextGetIndex, "@"} {fonts} {
+ .t index @-2,7
+} 1.0
+test textIndex-5.3 {TkTextGetIndex, "@"} {fonts} {
+ .t index @10,-7
+} 1.0
+test textIndex-5.4 {TkTextGetIndex, "@"} {fonts} {
+ list [catch {.t index @x} msg] $msg
+} {1 {bad text index "@x"}}
+test textIndex-5.5 {TkTextGetIndex, "@"} {fonts} {
+ list [catch {.t index @10q} msg] $msg
+} {1 {bad text index "@10q"}}
+test textIndex-5.6 {TkTextGetIndex, "@"} {fonts} {
+ list [catch {.t index @10,} msg] $msg
+} {1 {bad text index "@10,"}}
+test textIndex-5.7 {TkTextGetIndex, "@"} {fonts} {
+ list [catch {.t index @10,a} msg] $msg
+} {1 {bad text index "@10,a"}}
+test textIndex-5.8 {TkTextGetIndex, "@"} {fonts} {
+ list [catch {.t index @10,9,} msg] $msg
+} {1 {bad text index "@10,9,"}}
+
+test textIndex-6.1 {TkTextGetIndex, numeric} {
+ list [catch {.t index 2.3} msg] $msg
+} {0 2.3}
+test textIndex-6.2 {TkTextGetIndex, numeric} {
+ list [catch {.t index -} msg] $msg
+} {1 {bad text index "-"}}
+test textIndex-6.3 {TkTextGetIndex, numeric} {
+ list [catch {.t index 2.end} msg] $msg
+} {0 2.13}
+test textIndex-6.4 {TkTextGetIndex, numeric} {
+ list [catch {.t index 2.x} msg] $msg
+} {1 {bad text index "2.x"}}
+test textIndex-6.5 {TkTextGetIndex, numeric} {
+ list [catch {.t index 2.3x} msg] $msg
+} {1 {bad text index "2.3x"}}
+
+test textIndex-7.1 {TkTextGetIndex, miscellaneous other bases} {
+ list [catch {.t index end} msg] $msg
+} {0 8.0}
+test textIndex-7.2 {TkTextGetIndex, miscellaneous other bases} {
+ list [catch {.t index foo} msg] $msg
+} {0 3.2}
+test textIndex-7.3 {TkTextGetIndex, miscellaneous other bases} {
+ list [catch {.t index foo+1c} msg] $msg
+} {0 3.3}
+
+test textIndex-8.1 {TkTextGetIndex, modifiers} {
+ list [catch {.t index 2.1+1char} msg] $msg
+} {0 2.2}
+test textIndex-8.2 {TkTextGetIndex, modifiers} {
+ list [catch {.t index "2.1 +1char"} msg] $msg
+} {0 2.2}
+test textIndex-8.3 {TkTextGetIndex, modifiers} {
+ list [catch {.t index 2.1-1char} msg] $msg
+} {0 2.0}
+test textIndex-8.4 {TkTextGetIndex, modifiers} {
+ list [catch {.t index {2.1 }} msg] $msg
+} {0 2.1}
+test textIndex-8.5 {TkTextGetIndex, modifiers} {
+ list [catch {.t index {2.1+foo bar}} msg] $msg
+} {1 {bad text index "2.1+foo bar"}}
+test textIndex-8.6 {TkTextGetIndex, modifiers} {
+ list [catch {.t index {2.1 foo bar}} msg] $msg
+} {1 {bad text index "2.1 foo bar"}}
+
+test textIndex-9.1 {TkTextIndexCmp} {
+ list [.t compare 3.1 < 3.2] [.t compare 3.1 == 3.2]
+} {1 0}
+test textIndex-9.2 {TkTextIndexCmp} {
+ list [.t compare 3.2 < 3.2] [.t compare 3.2 == 3.2]
+} {0 1}
+test textIndex-9.3 {TkTextIndexCmp} {
+ list [.t compare 3.3 < 3.2] [.t compare 3.3 == 3.2]
+} {0 0}
+test textIndex-9.4 {TkTextIndexCmp} {
+ list [.t compare 2.1 < 3.2] [.t compare 2.1 == 3.2]
+} {1 0}
+test textIndex-9.5 {TkTextIndexCmp} {
+ list [.t compare 4.1 < 3.2] [.t compare 4.1 == 3.2]
+} {0 0}
+
+test textIndex-10.1 {ForwBack} {
+ list [catch {.t index {2.3 + x}} msg] $msg
+} {1 {bad text index "2.3 + x"}}
+test textIndex-10.2 {ForwBack} {
+ list [catch {.t index {2.3 + 2 chars}} msg] $msg
+} {0 2.5}
+test textIndex-10.3 {ForwBack} {
+ list [catch {.t index {2.3 + 2c}} msg] $msg
+} {0 2.5}
+test textIndex-10.4 {ForwBack} {
+ list [catch {.t index {2.3 - 3ch}} msg] $msg
+} {0 2.0}
+test textIndex-10.5 {ForwBack} {
+ list [catch {.t index {1.3 + 3 lines}} msg] $msg
+} {0 4.3}
+test textIndex-10.6 {ForwBack} {
+ list [catch {.t index {2.3 -1l}} msg] $msg
+} {0 1.3}
+test textIndex-10.7 {ForwBack} {
+ list [catch {.t index {2.3 -1 gorp}} msg] $msg
+} {1 {bad text index "2.3 -1 gorp"}}
+test textIndex-10.8 {ForwBack} {
+ list [catch {.t index {2.3 - 4 lines}} msg] $msg
+} {0 1.3}
+test textIndex-10.9 {ForwBack} {
+ .t mark set insert 2.0
+ list [catch {.t index {insert -0 chars}} msg] $msg
+} {0 2.0}
+test textIndex-10.10 {ForwBack} {
+ .t mark set insert 2.end
+ list [catch {.t index {insert +0 chars}} msg] $msg
+} {0 2.13}
+
+test textIndex-11.1 {TkTextIndexForwBytes} {testtext} {
+ testtext .t forwbytes 2.3 -7
+} {1.3 3}
+test textIndex-11.2 {TkTextIndexForwBytes} {testtext} {
+ testtext .t forwbytes 2.3 5
+} {2.8 8}
+test textIndex-11.3 {TkTextIndexForwBytes} {testtext} {
+ testtext .t forwbytes 2.3 10
+} {2.13 13}
+test textIndex-11.4 {TkTextIndexForwBytes} {testtext} {
+ testtext .t forwbytes 2.3 11
+} {3.0 0}
+test textIndex-11.5 {TkTextIndexForwBytes} {testtext} {
+ testtext .t forwbytes 2.3 57
+} {7.6 6}
+test textIndex-11.6 {TkTextIndexForwBytes} {testtext} {
+ testtext .t forwbytes 2.3 58
+} {8.0 0}
+test textIndex-11.7 {TkTextIndexForwBytes} {testtext} {
+ testtext .t forwbytes 2.3 59
+} {8.0 0}
+
+test textIndex-12.1 {TkTextIndexForwChars} {
+ # (charCount < 0)
+ .t index {2.3 + -7 chars}
+} 1.3
+test textIndex-12.2 {TkTextIndexForwChars} {
+ # not (charCount < 0)
+ .t index {2.3 + 5 chars}
+} 2.8
+test textIndex-12.3 {TkTextIndexForwChars: find index} {
+ # for ( ; segPtr != NULL; segPtr = segPtr->nextPtr)
+ # one loop
+ .t index {2.3 + 9 chars}
+} 2.12
+test textIndex-12.4 {TkTextIndexForwChars: find index} {
+ # for ( ; segPtr != NULL; segPtr = segPtr->nextPtr)
+ # multiple loops
+ .t mark set foo 2.5
+ set x [.t index {2.3 + 9 chars}]
+ .t mark unset foo
+ set x
+} 2.12
+test textIndex-12.5 {TkTextIndexForwChars: find index} {
+ # for ( ; segPtr != NULL; segPtr = segPtr->nextPtr)
+ # border condition: last char
+
+ .t index {2.3 + 10 chars}
+} 2.13
+test textIndex-12.6 {TkTextIndexForwChars: find index} {
+ # for ( ; segPtr != NULL; segPtr = segPtr->nextPtr)
+ # border condition: segPtr == NULL -> beginning of next line
+
+ .t index {2.3 + 11 chars}
+} 3.0
+test textIndex-12.7 {TkTextIndexForwChars: find index} {
+ # (segPtr->typePtr == &tkTextCharType)
+ .t index {2.3 + 2 chars}
+} 2.5
+test textIndex-12.8 {TkTextIndexForwChars: find index} {
+ # (charCount == 0)
+ # No more chars, so we found byte offset.
+
+ .t index {2.3 + 2 chars}
+} 2.5
+test textIndex-12.9 {TkTextIndexForwChars: find index} {
+ # not (segPtr->typePtr == &tkTextCharType)
+
+ .t image create 2.4 -image textimage
+ set x [.t get {2.3 + 3 chars}]
+ .t delete 2.4
+ set x
+} "f"
+test textIndex-12.10 {TkTextIndexForwChars: find index} {
+ # dstPtr->byteIndex += segPtr->size - byteOffset
+ # When moving to next segment, account for bytes in last segment.
+ # Wrong answer would be 2.4
+
+ .t mark set foo 2.4
+ set x [.t index {2.3 + 5 chars}]
+ .t mark unset foo
+ set x
+} 2.8
+test textIndex-12.11 {TkTextIndexForwChars: go to next line} {
+ # (linePtr == NULL)
+ .t index {7.6 + 3 chars}
+} 8.0
+test textIndex-12.12 {TkTextIndexForwChars: go to next line} {
+ # Reset byteIndex to 0 now that we are on a new line.
+ # Wrong answer would be 2.9
+ .t index {1.3 + 6 chars}
+} 2.2
+test textIndex-12.13 {TkTextIndexForwChars} {
+ # right to end
+ .t index {2.3 + 56 chars}
+} 8.0
+test textIndex-12.14 {TkTextIndexForwChars} {
+ # try to go past end
+ .t index {2.3 + 57 chars}
+} 8.0
+
+test textIndex-13.1 {TkTextIndexBackBytes} {testtext} {
+ testtext .t backbytes 3.2 -10
+} {4.6 6}
+test textIndex-13.2 {TkTextIndexBackBytes} {testtext} {
+ testtext .t backbytes 3.2 2
+} {3.0 0}
+test textIndex-13.3 {TkTextIndexBackBytes} {testtext} {
+ testtext .t backbytes 3.2 3
+} {2.13 13}
+test textIndex-13.4 {TkTextIndexBackBytes} {testtext} {
+ testtext .t backbytes 3.2 22
+} {1.1 1}
+test textIndex-13.5 {TkTextIndexBackBytes} {testtext} {
+ testtext .t backbytes 3.2 23
+} {1.0 0}
+test textIndex-13.6 {TkTextIndexBackBytes} {testtext} {
+ testtext .t backbytes 3.2 24
+} {1.0 0}
+
+test textIndex-14.1 {TkTextIndexBackChars} {
+ # (charCount < 0)
+ .t index {3.2 - -10 chars}
+} 4.6
+test textIndex-14.2 {TkTextIndexBackChars} {
+ # not (charCount < 0)
+ .t index {3.2 - 2 chars}
+} 3.0
+test textIndex-14.3 {TkTextIndexBackChars: find starting segment} {
+ # for (segPtr = dstPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
+ # single loop
+
+ .t index {3.2 - 3 chars}
+} 2.13
+test textIndex-14.4 {TkTextIndexBackChars: find starting segment} {
+ # for (segPtr = dstPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
+ # multiple loop
+
+ .t mark set foo1 2.5
+ .t mark set foo2 2.7
+ .t mark set foo3 2.10
+ set x [.t index {2.9 - 1 chars}]
+ .t mark unset foo1 foo2 foo3
+ set x
+} 2.8
+test textIndex-14.5 {TkTextIndexBackChars: find starting seg and offset} {
+ # for (segPtr = dstPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr)
+ # Make sure segSize was decremented. Wrong answer would be 2.10
+
+ .t mark set foo 2.2
+ set x [.t index {2.9 - 1 char}]
+ .t mark unset foo
+ set x
+} 2.8
+test textIndex-14.6 {TkTextIndexBackChars: back over characters} {
+ # (segPtr->typePtr == &tkTextCharType)
+
+ .t index {3.2 - 22 chars}
+} 1.1
+test textIndex-14.7 {TkTextIndexBackChars: loop backwards over chars} {
+ # (charCount == 0)
+ # No more chars, so we found byte offset.
+
+ .t index {3.4 - 2 chars}
+} 3.2
+test textIndex-14.8 {TkTextIndexBackChars: loop backwards over chars} {
+ # (p == start)
+ # Still more chars, but we reached beginning of segment
+
+ .t image create 5.6 -image textimage
+ set x [.t index {5.8 - 3 chars}]
+ .t delete 5.6
+ set x
+} 5.5
+test textIndex-14.9 {TkTextIndexBackChars: back over image} {
+ # not (segPtr->typePtr == &tkTextCharType)
+
+ .t image create 5.6 -image textimage
+ set x [.t get {5.8 - 4 chars}]
+ .t delete 5.6
+ set x
+} "G"
+test textIndex-14.10 {TkTextIndexBackChars: move to previous segment} {
+ # (segPtr != oldPtr)
+ # More segments to go
+
+ .t mark set foo 3.4
+ set x [.t index {3.5 - 2 chars}]
+ .t mark unset foo
+ set x
+} 3.3
+test textIndex-14.11 {TkTextIndexBackChars: move to previous segment} {
+ # not (segPtr != oldPtr)
+ # At beginning of line.
+
+ .t mark set foo 3.4
+ set x [.t index {3.5 - 10 chars}]
+ .t mark unset foo
+ set x
+} 2.9
+test textIndex-14.12 {TkTextIndexBackChars: move to previous line} {
+ # (lineIndex == 0)
+ .t index {1.5 - 10 chars}
+} 1.0
+test textIndex-14.13 {TkTextIndexBackChars: move to previous line} {
+ # not (lineIndex == 0)
+ .t index {2.5 - 10 chars}
+} 1.2
+test textIndex-14.14 {TkTextIndexBackChars: move to previous line} {
+ # for (segPtr = oldPtr; segPtr != NULL; segPtr = segPtr->nextPtr)
+ # Set byteIndex to end of previous line so we can subtract more
+ # bytes from it. Otherwise we get an TkTextIndex with a negative
+ # byteIndex.
+
+ .t index {2.5 - 6 chars}
+} 1.6
+test textIndex-14.15 {TkTextIndexBackChars: UTF} {
+ .t get {5.3 - 1 chars}
+} y
+test textIndex-14.16 {TkTextIndexBackChars: UTF} {
+ .t get {5.3 - 2 chars}
+} \u4e4f
+test textIndex-14.17 {TkTextIndexBackChars: UTF} {
+ .t get {5.3 - 3 chars}
+} b
+
+proc getword index {
+ .t get [.t index "$index wordstart"] [.t index "$index wordend"]
+}
+test textIndex-15.1 {StartEnd} {
+ list [catch {.t index {2.3 lineend}} msg] $msg
+} {0 2.13}
+test textIndex-15.2 {StartEnd} {
+ list [catch {.t index {2.3 linee}} msg] $msg
+} {0 2.13}
+test textIndex-15.3 {StartEnd} {
+ list [catch {.t index {2.3 line}} msg] $msg
+} {1 {bad text index "2.3 line"}}
+test textIndex-15.4 {StartEnd} {
+ list [catch {.t index {2.3 linestart}} msg] $msg
+} {0 2.0}
+test textIndex-15.5 {StartEnd} {
+ list [catch {.t index {2.3 lines}} msg] $msg
+} {0 2.0}
+test textIndex-15.6 {StartEnd} {
+ getword 5.3
+} { }
+test textIndex-15.7 {StartEnd} {
+ getword 5.4
+} GIrl
+test textIndex-15.8 {StartEnd} {
+ getword 5.7
+} GIrl
+test textIndex-15.9 {StartEnd} {
+ getword 5.8
+} { }
+test textIndex-15.10 {StartEnd} {
+ getword 5.14
+} x_yz
+test textIndex-15.11 {StartEnd} {
+ getword 6.2
+} #
+test textIndex-15.12 {StartEnd} {
+ getword 3.4
+} 12345
+.t tag add x 2.8 2.11
+test textIndex-15.13 {StartEnd} {
+ list [catch {.t index {2.2 worde}} msg] $msg
+} {0 2.13}
+test textIndex-15.14 {StartEnd} {
+ list [catch {.t index {2.12 words}} msg] $msg
+} {0 2.0}
+test textIndex-15.15 {StartEnd} {
+ list [catch {.t index {2.12 word}} msg] $msg
+} {1 {bad text index "2.12 word"}}
+
+test textIndex-16.1 {TkTextPrintIndex} {
+ set t [text .t2]
+ $t insert end \n
+ $t window create end -window [button $t.b]
+ set result [$t index end-2c]
+ pack $t
+ catch {destroy $t}
+} 0
+
+test textIndex-16.2 {TkTextPrintIndex} {
+ set t [text .t2]
+ $t insert end \n
+ $t window create end -window [button $t.b]
+ set result [$t tag add {} end-2c]
+ pack $t
+ catch {destroy $t}
+} 0
+
+test textIndex-17.1 {Object indices} {
+ set res {}
+ set t [text .t2 -height 20]
+ for {set i 0} {$i < 100} {incr i} {
+ $t insert end $i\n
+ }
+ pack $t
+ update
+ set idx @0,0
+ lappend res $idx [$t index $idx]
+ $t yview scroll 2 pages
+ lappend res $idx [$t index $idx]
+ catch {destroy $t}
+ unset i
+ unset idx
+ list $res
+} {{@0,0 1.0 @0,0 37.0}}
+
+test textIndex-18.1 {Object indices don't cache mark names} {
+ set res {}
+ text .t2
+ .t2 insert 1.0 1234\n1234\n1234
+ set pos "insert"
+ lappend res [.t2 index $pos]
+ .t2 mark set $pos 3.0
+ lappend res [.t2 index $pos]
+ .t2 mark set $pos 1.0
+ lappend res [.t2 index $pos]
+ catch {destroy .t2}
+ set res
+} {3.4 3.0 1.0}
+
+frame .f -width 100 -height 20
+pack append . .f left
+
+set fixedFont {Courier -12}
+set fixedHeight [font metrics $fixedFont -linespace]
+set fixedWidth [font measure $fixedFont m]
+
+set varFont {Times -14}
+set bigFont {Helvetica -24}
+destroy .t
+text .t -font $fixedFont -width 20 -height 10 -wrap char
+pack append . .t {top expand fill}
+.t tag configure big -font $bigFont
+.t debug on
+wm geometry . {}
+
+# The statements below reset the main window; it's needed if the window
+# manager is mwm to make mwm forget about a previous minimum size setting.
+
+wm withdraw .
+wm minsize . 1 1
+wm positionfrom . user
+wm deiconify .
+update
+
+# Some window managers (like olwm under SunOS 4.1.3) misbehave in a way
+# that tends to march windows off the top and left of the screen. If
+# this happens, some tests will fail because parts of the window will
+# not need to be displayed (because they're off-screen). To keep this
+# from happening, move the window if it's getting near the left or top
+# edges of the screen.
+
+if {([winfo rooty .] < 50) || ([winfo rootx .] < 50)} {
+ wm geom . +50+50
+}
+
+set str [string repeat "hello " 20]
+
+.t insert end "$str one two three four five six seven height nine ten\n"
+.t insert end "$str one two three four five six seven height nine ten\n"
+.t insert end "$str one two three four five six seven height nine ten\n"
+
+test textIndex-19.1 {Display lines} {
+ .t index "2.7 displaylinestart"
+} {2.0}
+
+test textIndex-19.2 {Display lines} {
+ .t index "2.7 displaylineend"
+} {2.19}
+
+test textIndex-19.3 {Display lines} {
+ .t index "2.30 displaylinestart"
+} {2.20}
+
+test textIndex-19.4 {Display lines} {
+ .t index "2.30 displaylineend"
+} {2.39}
+
+test textIndex-19.5 {Display lines} {
+ .t index "2.40 displaylinestart"
+} {2.40}
+
+test textIndex-19.6 {Display lines} {
+ .t index "2.40 displaylineend"
+} {2.59}
+
+test textIndex-19.7 {Display lines} {
+ .t index "2.7 +1displaylines"
+} {2.27}
+
+test textIndex-19.8 {Display lines} {
+ .t index "2.7 -1displaylines"
+} {1.167}
+
+test textIndex-19.9 {Display lines} {
+ .t index "2.30 +1displaylines"
+} {2.50}
+
+test textIndex-19.10 {Display lines} {
+ .t index "2.30 -1displaylines"
+} {2.10}
+
+test textIndex-19.11 {Display lines} {
+ .t index "2.40 +1displaylines"
+} {2.60}
+
+test textIndex-19.12 {Display lines} {
+ .t index "2.40 -1displaylines"
+} {2.20}
+
+test textIndex-19.13 {Display lines} {
+ destroy {*}[pack slaves .]
+ text .txt -height 1 -wrap word -yscroll ".sbar set" -width 400
+ scrollbar .sbar -command ".txt yview"
+ grid .txt .sbar -sticky news
+ grid configure .sbar -sticky ns
+ grid rowconfigure . 0 -weight 1
+ grid columnconfigure . 0 -weight 1
+ .txt configure -width 10
+ .txt tag config STAMP -elide 1
+ .txt tag config NICK-tick -elide 0
+ .txt insert end "+++++ Loading History ++++++++++++++++\n"
+ .txt mark set HISTORY {2.0 - 1 line}
+ .txt insert HISTORY { } STAMP
+ .txt insert HISTORY {tick } {NICK NICK-tick}
+ .txt insert HISTORY "\n" {NICK NICK-tick}
+ .txt insert HISTORY {[23:51] } STAMP
+ .txt insert HISTORY "\n" {NICK NICK-tick}
+ # Must not crash
+ .txt index "2.0 - 2 display lines"
+ destroy .txt .sbar
+} {}
+
+proc text_test_word {startend chars start} {
+ destroy .t
+ text .t
+ .t insert end $chars
+ if {[regexp {end} $start]} {
+ set start [.t index "${start}chars -2c"]
+ } else {
+ set start [.t index "1.0 + ${start}chars"]
+ }
+ if {[.t compare $start >= "end-1c"]} {
+ set start "end-2c"
+ }
+ set res [.t index "$start $startend"]
+ .t count 1.0 $res
+}
+
+# Following tests copied from tests from string wordstart/end in Tcl
+
+test textIndex-21.4 {text index wordend} {
+ text_test_word wordend abc. -1
+} 3
+test textIndex-21.5 {text index wordend} {
+ text_test_word wordend abc. 100
+} 4
+test textIndex-21.6 {text index wordend} {
+ text_test_word wordend "word_one two three" 2
+} 8
+test textIndex-21.7 {text index wordend} {
+ text_test_word wordend "one .&# three" 5
+} 6
+test textIndex-21.8 {text index wordend} {
+ text_test_word worde "x.y" 0
+} 1
+test textIndex-21.9 {text index wordend} {
+ text_test_word worde "x.y" end-1
+} 2
+test textIndex-21.10 {text index wordend, unicode} {
+ text_test_word wordend "xyz\u00c7de fg" 0
+} 6
+test textIndex-21.11 {text index wordend, unicode} {
+ text_test_word wordend "xyz\uc700de fg" 0
+} 6
+test textIndex-21.12 {text index wordend, unicode} {
+ text_test_word wordend "xyz\u203fde fg" 0
+} 6
+test textIndex-21.13 {text index wordend, unicode} {
+ text_test_word wordend "xyz\u2045de fg" 0
+} 3
+test textIndex-21.14 {text index wordend, unicode} {
+ text_test_word wordend "\uc700\uc700 abc" 8
+} 6
+
+test textIndex-22.5 {text index wordstart} {
+ text_test_word wordstart "one two three_words" 400
+} 8
+test textIndex-22.6 {text index wordstart} {
+ text_test_word wordstart "one two three_words" 2
+} 0
+test textIndex-22.7 {text index wordstart} {
+ text_test_word wordstart "one two three_words" -2
+} 0
+test textIndex-22.8 {text index wordstart} {
+ text_test_word wordstart "one .*&^ three" 6
+} 6
+test textIndex-22.9 {text index wordstart} {
+ text_test_word wordstart "one two three" 4
+} 4
+test textIndex-22.10 {text index wordstart} {
+ text_test_word wordstart "one two three" end-5
+} 7
+test textIndex-22.11 {text index wordstart, unicode} {
+ text_test_word wordstart "one tw\u00c7o three" 7
+} 4
+test textIndex-22.12 {text index wordstart, unicode} {
+ text_test_word wordstart "ab\uc700\uc700 cdef ghi" 12
+} 10
+test textIndex-22.13 {text index wordstart, unicode} {
+ text_test_word wordstart "\uc700\uc700 abc" 8
+} 3
+test textIndex-22.14 {text index wordstart, unicode, start index at internal segment start} {
+ catch {destroy .t}
+ text .t
+ .t insert end "C'est du texte en fran\u00e7ais\n"
+ .t insert end "\u042D\u0442\u043E\u0020\u0442\u0435\u043A\u0441\u0442\u0020\u043D\u0430\u0020\u0440\u0443\u0441\u0441\u043A\u043E\u043C"
+ .t mark set insert 1.23
+ set res [.t index "1.23 wordstart"]
+ .t mark set insert 2.16
+ lappend res [.t index "2.16 wordstart"] [.t index "2.15 wordstart"]
+} {1.18 2.13 2.13}
+test textIndex-22.15 {text index display wordstart} {
+ catch {destroy .t}
+ text .t
+ .t index "1.0 display wordstart" ; # used to crash
+} 1.0
+
+test textIndex-23.1 {text paragraph start} {
+ pack [text .t2]
+ .t2 insert end " Text"
+ set res 2.0
+ for {set i 0} {$i < 2} {incr i} {
+ lappend res [::tk::TextPrevPara .t2 [lindex $res end]]
+ }
+ destroy .t2
+ set res
+} {2.0 1.1 1.1}
+
+test textIndex-24.1 {text mark prev} {
+ pack [text .t2]
+ .t2 insert end [string repeat "1 2 3 4 5 6 7 8 9 0\n" 12]
+ .t2 mark set 1.0 10.0
+ update
+ # then this crash Tk:
+ set res [.t2 mark previous 10.10]
+ destroy .t2
+ set res
+} {1.0}
+
+test textIndex-25.1 {IndexCountBytesOrdered, bug [3f1f79abcf]} {
+ pack [text .t2]
+ .t2 tag configure elided -elide 1
+ .t2 insert end "01\n02\n03\n04\n05\n06\n07\n08\n09\n10\n"
+ .t2 insert end "11\n12\n13\n14\n15\n16\n17\n18\n19\n20\n"
+ .t2 insert end "21\n22\n23\n25\n26\n27\n28\n29\n30\n31"
+ .t2 insert end "32\n33\n34\n36\n37\n38\n39" elided
+ # then this used to crash Tk:
+ .t2 see end
+ focus -force .t2 ; # to see the cursor blink
+ destroy .t2
+} {}
+
+# cleanup
+rename textimage {}
+catch {destroy .t}
+cleanupTests
+return
diff --git a/tk8.6/tests/textMark.test b/tk8.6/tests/textMark.test
new file mode 100644
index 0000000..edd0e92
--- /dev/null
+++ b/tk8.6/tests/textMark.test
@@ -0,0 +1,306 @@
+# This file is a Tcl script to test the code in the file tkTextMark.c.
+# This file is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+
+destroy .t
+text .t -width 20 -height 10
+pack append . .t {top expand fill}
+update
+.t debug on
+wm geometry . {}
+entry .t.e
+.t peer create .pt
+
+.t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+
+# The statements below reset the main window; it's needed if the window
+# manager is mwm to make mwm forget about a previous minimum size setting.
+
+wm withdraw .
+wm minsize . 1 1
+wm positionfrom . user
+wm deiconify .
+
+test textMark-1.1 {TkTextMarkCmd - missing option} -returnCodes error -body {
+ .t mark
+} -result {wrong # args: should be ".t mark option ?arg ...?"}
+test textMark-1.2 {TkTextMarkCmd - bogus option} -returnCodes error -body {
+ .t mark gorp
+} -match glob -result {bad mark option "gorp": must be *}
+test textMark-1.3 {TkTextMarkCmd - "gravity" option} -returnCodes error -body {
+ .t mark gravity foo
+} -result {there is no mark named "foo"}
+test textMark-1.4 {TkTextMarkCmd - "gravity" option} -body {
+ .t mark set x 1.3
+ .t insert 1.3 x
+ list [.t mark gravity x] [.t index x]
+} -result {right 1.4}
+test textMark-1.5 {TkTextMarkCmd - "gravity" option} -body {
+ .t mark set x 1.3
+ .t mark g x left
+ .t insert 1.3 x
+ list [.t mark gravity x] [.t index x]
+} -result {left 1.3}
+test textMark-1.6 {TkTextMarkCmd - "gravity" option} -body {
+ .t mark set x 1.3
+ .t mark gravity x right
+ .t insert 1.3 x
+ list [.t mark gravity x] [.t index x]
+} -result {right 1.4}
+test textMark-1.7 {TkTextMarkCmd - "gravity" option} -returnCodes error -body {
+ .t mark set x 1.3
+ .t mark gravity x gorp
+} -result {bad mark gravity "gorp": must be left or right}
+test textMark-1.8 {TkTextMarkCmd - "gravity" option} -returnCodes error -body {
+ .t mark gravity
+} -result {wrong # args: should be ".t mark gravity markName ?gravity?"}
+
+test textMark-2.1 {TkTextMarkCmd - "names" option} -body {
+ .t mark names 2
+} -returnCodes error -result {wrong # args: should be ".t mark names"}
+test textMark-2.2 {TkTextMarkCmd - "names" option} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ lsort [.t mark na]
+} -result {current insert}
+test textMark-2.3 {TkTextMarkCmd - "names" option} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set a 1.1
+ .t mark set "b c" 2.3
+ lsort [.t mark names]
+} -result {a {b c} current insert}
+
+test textMark-3.1 {TkTextMarkCmd - "set" option} -returnCodes error -body {
+ .t mark set a
+} -result {wrong # args: should be ".t mark set markName index"}
+test textMark-3.2 {TkTextMarkCmd - "set" option} -returnCodes error -body {
+ .t mark s a b c
+} -result {wrong # args: should be ".t mark set markName index"}
+test textMark-3.3 {TkTextMarkCmd - "set" option} -body {
+ .t mark set a @x
+} -returnCodes error -result {bad text index "@x"}
+test textMark-3.4 {TkTextMarkCmd - "set" option} -body {
+ .t mark set a 1.2
+ .t index a
+} -result 1.2
+test textMark-3.5 {TkTextMarkCmd - "set" option} -body {
+ .t mark set a end
+ .t index a
+} -result {8.0}
+
+test textMark-4.1 {TkTextMarkCmd - "unset" option} -body {
+ .t mark unset
+} -result {}
+test textMark-4.2 {TkTextMarkCmd - "unset" option} -body {
+ .t mark set a 1.2
+ .t mark set b 2.3
+ .t mark unset a b
+ .t index a
+} -returnCodes error -result {bad text index "a"}
+test textMark-4.2.1 {TkTextMarkCmd - "unset" option} -body {
+ .t mark set a 1.2
+ .t mark set b 2.3
+ .t mark unset a b
+ .t index b
+} -returnCodes error -result {bad text index "b"}
+test textMark-4.3 {TkTextMarkCmd - "unset" option} -body {
+ .t mark set a 1.2
+ .t mark set b 2.3
+ .t mark set 49ers 3.1
+ .t mark unset {*}[.t mark names]
+ lsort [.t mark names]
+} -result {current insert}
+
+test textMark-5.1 {TkTextMarkCmd - miscellaneous} -returnCodes error -body {
+ .t mark
+} -result {wrong # args: should be ".t mark option ?arg ...?"}
+test textMark-5.2 {TkTextMarkCmd - miscellaneous} -returnCodes error -body {
+ .t mark foo
+} -result {bad mark option "foo": must be gravity, names, next, previous, set, or unset}
+
+test textMark-6.1 {TkTextMarkSegToIndex} -body {
+ .t mark set a 1.2
+ .t mark set b 1.2
+ .t mark set c 1.2
+ .t mark set d 1.4
+ list [.t index a] [.t index b] [.t index c ] [.t index d]
+} -result {1.2 1.2 1.2 1.4}
+test textMark-6.2 {TkTextMarkNameToIndex, with mark outside -startline/-endline range - bug 1630271} -body {
+ .t mark set insert 1.0
+ .t configure -startline 2
+ set res [list [.t index insert] [.t index insert-1c] [.t get insert]]
+ .t mark set insert end
+ .t configure -endline 4
+ lappend res [.t index insert]
+} -cleanup {
+ .t configure -startline {} -endline {}
+} -result {1.0 1.0 a 2.5}
+test textMark-6.3 {TkTextMarkNameToIndex, with mark outside -startline/-endline range - bug 1630271} -body {
+ .t mark set mymark 1.0
+ .t configure -startline 2
+ list [catch {.t index mymark} msg] $msg
+} -cleanup {
+ .t configure -startline {} -endline {}
+ .t mark unset mymark
+} -result {1 {bad text index "mymark"}}
+test textMark-6.4 {TkTextMarkNameToIndex, with mark outside -startline/-endline range - bug 1630271} -body {
+ .t mark set mymark 1.0
+ .t configure -startline 2
+ set res [list [catch {.t index mymark} msg] $msg]
+ lappend res [.pt index mymark]
+ .t configure -startline {}
+ .pt configure -startline 4
+ lappend res [.t index mymark]
+ lappend res [catch {.pt index mymark} msg] $msg
+ lappend res [.t get mymark]
+ lappend res [catch {.pt get mymark} msg] $msg
+} -cleanup {
+ .t configure -startline {} -endline {}
+ .pt configure -startline {} -endline {}
+ .t mark unset mymark
+} -result {1 {bad text index "mymark"} 1.0 1.0 1 {bad text index "mymark"} L 1 {bad text index "mymark"}}
+test textMark-6.5 {insert and current marks in an empty peer - bug 3487407} -body {
+ .t mark set insert 1.0
+ .t configure -start 5 -end 5
+ set res [.t index insert]
+} -cleanup {
+ .t configure -startline {} -endline {}
+} -result {1.0}
+
+test textMark-7.1 {MarkFindNext - invalid mark name} -body {
+ .t mark next bogus
+} -returnCodes error -result {bad text index "bogus"}
+test textMark-7.2 {MarkFindNext - marks at same location} -body {
+ .t mark set insert 2.0
+ .t mark set current 2.0
+ .t mark next current
+} -result {insert}
+test textMark-7.3 {MarkFindNext - numerical starting mark} -body {
+ .t mark set current 1.0
+ .t mark set insert 1.0
+ .t mark next 1.0
+} -result {insert}
+test textMark-7.4 {MarkFindNext - mark on the same line} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set current 1.0
+ .t mark set insert 1.1
+ .t mark next current
+} -result {insert}
+test textMark-7.5 {MarkFindNext - mark on the next line} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set current 1.end
+ .t mark set insert 2.0
+ .t mark next current
+} -result {insert}
+test textMark-7.6 {MarkFindNext - mark far away} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set current 1.2
+ .t mark set insert 7.0
+ .t mark next current
+} -result {insert}
+test textMark-7.7 {MarkFindNext - mark on top of end} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set current end
+ .t mark next end
+} -result {current}
+test textMark-7.8 {MarkFindNext - no next mark} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set current 1.0
+ .t mark set insert 3.0
+ .t mark next insert
+} -result {}
+test textMark-7.9 {MarkFindNext - mark set in a text widget and retrieved from a peer} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set mymark 1.0
+ lsort [list [.pt mark next 1.0] [.pt mark next mymark] [.pt mark next insert]]
+} -result {current insert mymark}
+
+test textMark-8.1 {MarkFindPrev - invalid mark name} -body {
+ .t mark prev bogus
+} -returnCodes error -result {bad text index "bogus"}
+test textMark-8.2 {MarkFindPrev - marks at same location} -body {
+ .t mark set insert 2.0
+ .t mark set current 2.0
+ .t mark prev insert
+} -result {current}
+test textMark-8.3 {MarkFindPrev - numerical starting mark} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set current 1.0
+ .t mark set insert 1.0
+ .t mark prev 1.1
+} -result {current}
+test textMark-8.4 {MarkFindPrev - mark on the same line} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set current 1.0
+ .t mark set insert 1.1
+ .t mark prev insert
+} -result {current}
+test textMark-8.5 {MarkFindPrev - mark on the previous line} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set current 1.end
+ .t mark set insert 2.0
+ .t mark prev insert
+} -result {current}
+test textMark-8.6 {MarkFindPrev - mark far away} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set current 1.2
+ .t mark set insert 7.0
+ .t mark prev insert
+} -result {current}
+test textMark-8.7 {MarkFindPrev - mark on top of end} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set insert 3.0
+ .t mark set current end
+ .t mark prev end
+} -result {insert}
+test textMark-8.8 {MarkFindPrev - no previous mark} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set current 1.0
+ .t mark set insert 3.0
+ .t mark prev current
+} -result {}
+test textMark-8.9 {MarkFindPrev - mark set in a text widget and retrieved from a peer} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
+ .t mark set mymark 1.0
+ lsort [list [.pt mark prev end] [.pt mark prev current] [.pt mark prev insert]]
+} -result {current insert mymark}
+
+destroy .pt
+destroy .t
+
+# cleanup
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/textTag.test b/tk8.6/tests/textTag.test
new file mode 100644
index 0000000..88081d0
--- /dev/null
+++ b/tk8.6/tests/textTag.test
@@ -0,0 +1,1775 @@
+# This file is a Tcl script to test the code in the file tkTextTag.c.
+# This file is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+destroy .t
+text .t -width 20 -height 10
+testConstraint haveCourier12 [expr {[catch {
+ .t configure -font {Courier 12}
+}] == 0}]
+
+pack append . .t {top expand fill}
+update
+.t debug on
+
+wm geometry . {}
+set bigFont {Helvetica 24}
+
+# The statements below reset the main window; it's needed if the window
+# manager is mwm, to make mwm forget about a previous minimum size setting.
+
+wm withdraw .
+wm minsize . 1 1
+wm positionfrom . user
+wm deiconify .
+
+.t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+
+test textTag-1.1 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -background #012345
+ .t tag cget x -background
+} -cleanup {
+ .t tag configure x -background [lindex [.t tag configure x -background] 3]
+} -result {#012345}
+test textTag-1.2 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -background non-existent
+} -cleanup {
+ .t tag configure x -background [lindex [.t tag configure x -background] 3]
+} -returnCodes error -result {unknown color name "non-existent"}
+test textTag-1.3 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -bgstipple gray50
+ .t tag cget x -bgstipple
+} -cleanup {
+ .t tag configure x -bgstipple [lindex [.t tag configure x -bgstipple] 3]
+} -result {gray50}
+test textTag-1.4 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -bgstipple badStipple
+} -cleanup {
+ .t tag configure x -bgstipple [lindex [.t tag configure x -bgstipple] 3]
+} -returnCodes error -result {bitmap "badStipple" not defined}
+test textTag-1.5 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -borderwidth 2
+ .t tag cget x -borderwidth
+} -cleanup {
+ .t tag configure x -borderwidth [lindex [.t tag configure x -borderwidth] 3]
+} -result {2}
+test textTag-1.6 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -borderwidth 46q
+} -cleanup {
+ .t tag configure x -borderwidth [lindex [.t tag configure x -borderwidth] 3]
+} -returnCodes error -result {bad screen distance "46q"}
+test textTag-1.7 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -fgstipple gray25
+ .t tag cget x -fgstipple
+} -cleanup {
+ .t tag configure x -fgstipple [lindex [.t tag configure x -fgstipple] 3]
+} -result {gray25}
+test textTag-1.8 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -fgstipple bogus
+} -cleanup {
+ .t tag configure x -fgstipple [lindex [.t tag configure x -fgstipple] 3]
+} -returnCodes error -result {bitmap "bogus" not defined}
+test textTag-1.9 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -font fixed
+ .t tag cget x -font
+} -cleanup {
+ .t tag configure x -font [lindex [.t tag configure x -font] 3]
+} -result {fixed}
+test textTag-1.10 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -foreground #001122
+ .t tag cget x -foreground
+} -cleanup {
+ .t tag configure x -foreground [lindex [.t tag configure x -foreground] 3]
+} -result {#001122}
+test textTag-1.11 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -foreground {silly color}
+} -cleanup {
+ .t tag configure x -foreground [lindex [.t tag configure x -foreground] 3]
+} -returnCodes error -result {unknown color name "silly color"}
+test textTag-1.12 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -justify left
+ .t tag cget x -justify
+} -cleanup {
+ .t tag configure x -justify [lindex [.t tag configure x -justify] 3]
+} -result {left}
+test textTag-1.13 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -justify middle
+} -cleanup {
+ .t tag configure x -justify [lindex [.t tag configure x -justify] 3]
+} -returnCodes error -result {bad justification "middle": must be left, right, or center}
+test textTag-1.14 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -lmargin1 10
+ .t tag cget x -lmargin1
+} -cleanup {
+ .t tag configure x -lmargin1 [lindex [.t tag configure x -lmargin1] 3]
+} -result {10}
+test textTag-1.15 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -lmargin1 bad
+} -cleanup {
+ .t tag configure x -lmargin1 [lindex [.t tag configure x -lmargin1] 3]
+} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.16 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -lmargin2 10
+ .t tag cget x -lmargin2
+} -cleanup {
+ .t tag configure x -lmargin2 [lindex [.t tag configure x -lmargin2] 3]
+} -result {10}
+test textTag-1.17 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -lmargin2 bad
+} -cleanup {
+ .t tag configure x -lmargin2 [lindex [.t tag configure x -lmargin2] 3]
+} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.17a {tag configuration options} -body {
+ .t tag configure x -lmargincolor lightgreen
+ .t tag cget x -lmargincolor
+} -cleanup {
+ .t tag configure x -lmargincolor [lindex [.t tag configure x -lmargincolor] 3]
+} -result {lightgreen}
+test textTag-1.17b {configuration options} -body {
+ .t tag configure x -lmargincolor non-existent
+} -cleanup {
+ .t tag configure x -lmargincolor [lindex [.t tag configure x -lmargincolor] 3]
+} -returnCodes error -result {unknown color name "non-existent"}
+test textTag-1.18 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -offset 2
+ .t tag cget x -offset
+} -cleanup {
+ .t tag configure x -offset [lindex [.t tag configure x -offset] 3]
+} -result {2}
+test textTag-1.19 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -offset 100xyz
+} -cleanup {
+ .t tag configure x -offset [lindex [.t tag configure x -offset] 3]
+} -returnCodes error -result {bad screen distance "100xyz"}
+test textTag-1.20 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -overstrike on
+ .t tag cget x -overstrike
+} -cleanup {
+ .t tag configure x -overstrike [lindex [.t tag configure x -overstrike] 3]
+} -result {on}
+test textTag-1.21 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -overstrike stupid
+} -cleanup {
+ .t tag configure x -overstrike [lindex [.t tag configure x -overstrike] 3]
+} -returnCodes error -result {expected boolean value but got "stupid"}
+test textTag-1.21a {tag configuration options} -body {
+ .t tag configure x -overstrikefg red
+ .t tag cget x -overstrikefg
+} -cleanup {
+ .t tag configure x -overstrikefg [lindex [.t tag configure x -overstrikefg] 3]
+} -result {red}
+test textTag-1.21b {configuration options} -body {
+ .t tag configure x -overstrikefg stupid
+} -cleanup {
+ .t tag configure x -overstrikefg [lindex [.t tag configure x -overstrikefg] 3]
+} -returnCodes error -result {unknown color name "stupid"}
+test textTag-1.22 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -relief raised
+ .t tag cget x -relief
+} -cleanup {
+ .t tag configure x -relief [lindex [.t tag configure x -relief] 3]
+} -result {raised}
+test textTag-1.23 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -relief stupid
+} -cleanup {
+ .t tag configure x -relief [lindex [.t tag configure x -relief] 3]
+} -returnCodes error -result {bad relief "stupid": must be flat, groove, raised, ridge, solid, or sunken}
+test textTag-1.24 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -rmargin 10
+ .t tag cget x -rmargin
+} -cleanup {
+ .t tag configure x -rmargin [lindex [.t tag configure x -rmargin] 3]
+} -result {10}
+test textTag-1.25 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -rmargin bad
+} -cleanup {
+ .t tag configure x -rmargin [lindex [.t tag configure x -rmargin] 3]
+} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.25a {tag configuration options} -body {
+ .t tag configure x -rmargincolor darkblue
+ .t tag cget x -rmargincolor
+} -cleanup {
+ .t tag configure x -rmargincolor [lindex [.t tag configure x -rmargincolor] 3]
+} -result {darkblue}
+test textTag-1.25b {configuration options} -body {
+ .t tag configure x -rmargincolor non-existent
+} -cleanup {
+ .t tag configure x -rmargincolor [lindex [.t tag configure x -rmargincolor] 3]
+} -returnCodes error -result {unknown color name "non-existent"}
+test textTag-1.25c {tag configuration options} -body {
+ .t tag configure x -selectbackground #012345
+ .t tag cget x -selectbackground
+} -cleanup {
+ .t tag configure x -selectbackground [lindex [.t tag configure x -selectbackground] 3]
+} -result {#012345}
+test textTag-1.25d {configuration options} -body {
+ .t tag configure x -selectbackground non-existent
+} -cleanup {
+ .t tag configure x -selectbackground [lindex [.t tag configure x -selectbackground] 3]
+} -returnCodes error -result {unknown color name "non-existent"}
+test textTag-1.25e {tag configuration options} -body {
+ .t tag configure x -selectforeground #012345
+ .t tag cget x -selectforeground
+} -cleanup {
+ .t tag configure x -selectforeground [lindex [.t tag configure x -selectforeground] 3]
+} -result {#012345}
+test textTag-1.25f {configuration options} -body {
+ .t tag configure x -selectforeground non-existent
+} -cleanup {
+ .t tag configure x -selectforeground [lindex [.t tag configure x -selectforeground] 3]
+} -returnCodes error -result {unknown color name "non-existent"}
+test textTag-1.26 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -spacing1 10
+ .t tag cget x -spacing1
+} -cleanup {
+ .t tag configure x -spacing1 [lindex [.t tag configure x -spacing1] 3]
+} -result {10}
+test textTag-1.27 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -spacing1 bad
+} -cleanup {
+ .t tag configure x -spacing1 [lindex [.t tag configure x -spacing1] 3]
+} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.28 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -spacing2 10
+ .t tag cget x -spacing2
+} -cleanup {
+ .t tag configure x -spacing2 [lindex [.t tag configure x -spacing2] 3]
+} -result {10}
+test textTag-1.29 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -spacing2 bad
+} -cleanup {
+ .t tag configure x -spacing2 [lindex [.t tag configure x -spacing2] 3]
+} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.30 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -spacing3 10
+ .t tag cget x -spacing3
+} -cleanup {
+ .t tag configure x -spacing3 [lindex [.t tag configure x -spacing3] 3]
+} -result {10}
+test textTag-1.31 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -spacing3 bad
+} -cleanup {
+ .t tag configure x -spacing3 [lindex [.t tag configure x -spacing3] 3]
+} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.32 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -tabs {10 20 30}
+ .t tag cget x -tabs
+} -cleanup {
+ .t tag configure x -tabs [lindex [.t tag configure x -tabs] 3]
+} -result {10 20 30}
+test textTag-1.33 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -tabs {10 fork}
+} -cleanup {
+ .t tag configure x -tabs [lindex [.t tag configure x -tabs] 3]
+} -returnCodes error -result {bad tab alignment "fork": must be left, right, center, or numeric}
+test textTag-1.34 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -underline no
+ .t tag cget x -underline
+} -cleanup {
+ .t tag configure x -underline [lindex [.t tag configure x -underline] 3]
+} -result {no}
+test textTag-1.35 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -underline stupid
+} -cleanup {
+ .t tag configure x -underline [lindex [.t tag configure x -underline] 3]
+} -returnCodes error -result {expected boolean value but got "stupid"}
+test textTag-1.36 {tag configuration options} -body {
+ .t tag configure x -underlinefg red
+ .t tag cget x -underlinefg
+} -cleanup {
+ .t tag configure x -underlinefg [lindex [.t tag configure x -underlinefg] 3]
+} -result {red}
+test textTag-1.37 {configuration options} -body {
+ .t tag configure x -underlinefg stupid
+} -cleanup {
+ .t tag configure x -underlinefg [lindex [.t tag configure x -underlinefg] 3]
+} -returnCodes error -result {unknown color name "stupid"}
+
+
+test textTag-2.1 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag
+} -returnCodes error -result {wrong # args: should be ".t tag option ?arg ...?"}
+test textTag-2.2 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag gorp
+} -returnCodes error -result {bad tag option "gorp": must be add, bind, cget, configure, delete, lower, names, nextrange, prevrange, raise, ranges, or remove}
+test textTag-2.3 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag add foo
+} -returnCodes error -result {wrong # args: should be ".t tag add tagName index1 ?index2 index1 index2 ...?"}
+test textTag-2.4 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag add x gorp
+} -returnCodes error -result {bad text index "gorp"}
+test textTag-2.5 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag add x 1.2 gorp
+} -returnCodes error -result {bad text index "gorp"}
+test textTag-2.6 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete sel
+} -body {
+ .t tag add sel 3.2 3.4
+ .t tag add sel 3.2 3.0
+ .t tag ranges sel
+} -result {3.2 3.4}
+test textTag-2.7 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 1.0 1.end
+ .t tag ranges x
+} -cleanup {
+ .t tag delete x
+} -result {1.0 1.6}
+test textTag-2.8 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag remove x 1.0 end
+} -body {
+ .t tag add x 1.2
+ .t tag ranges x
+} -cleanup {
+ .t tag delete x
+} -result {1.2 1.3}
+test textTag-2.9 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -setup {
+ destroy .t.e
+} -body {
+ entry .t.e
+ .t.e insert 0 "Text"
+ .t.e select from 0
+ .t.e select to 4
+ .t tag add sel 3.2 3.4
+ selection get
+} -cleanup {
+ destroy .t.e
+} -result 34
+test textTag-2.10 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -setup {
+ destroy .t.e
+} -body {
+ entry .t.e
+ .t.e insert 0 "Text"
+ .t.e select from 0
+ .t.e select to 4
+ .t configure -exportselection 0
+ .t tag add sel 3.2 3.4
+ selection get
+} -cleanup {
+ destroy .t.e
+} -result {Text}
+test textTag-2.11 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag remove sel 1.0 end
+ .t tag add sel 1.1 1.5 2.4 3.1 4.2 4.4
+ .t tag ranges sel
+} -result {1.1 1.5 2.4 3.1 4.2 4.4}
+test textTag-2.12 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag remove sel 1.0 end
+ .t tag add sel 1.1 1.5 2.4
+ .t tag ranges sel
+} -cleanup {
+ .t tag remove sel 1.0 end
+} -result {1.1 1.5 2.4 2.5}
+test textTag-2.14 {tag add before -startline - Bug 1615425} haveCourier12 {
+ text .tt
+ for {set i 1} {$i <10} {incr i} {
+ .tt insert end "Line $i\n"
+ }
+ .tt tag configure mytag -font {Courier 12 bold}
+ .tt peer create .ptt
+ .ptt configure -startline 3 -endline 7
+ # the test succeeds if next line does not crash
+ .tt tag add mytag 1.0 1.end
+ destroy .ptt .tt
+ set res 1
+} {1}
+
+
+test textTag-3.1 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag bind
+} -returnCodes error -result {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}
+test textTag-3.2 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag bind 1 2 3 4
+} -returnCodes error -result {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}
+test textTag-3.3 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag bind x <Enter> script1
+ .t tag bind x <Enter>
+} -cleanup {
+ .t tag delete x
+} -result {script1}
+test textTag-3.4 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag bind x <Gorp> script2
+} -returnCodes error -result {bad event type or keysym "Gorp"}
+test textTag-3.5 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag bind x <Enter> script1
+ .t tag bind x <FocusIn> script2
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {requested illegal events; only key, button, motion, enter, leave, and virtual events may be used}
+test textTag-3.6 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag bind x <Enter> script1
+ catch {.t tag bind x <FocusIn> script2}
+ .t tag bind x
+} -cleanup {
+ .t tag delete x
+} -result {<Enter>}
+test textTag-3.7 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag bind x <Enter> script1
+ .t tag bind x <Leave> script2
+ .t tag bind x a xyzzy
+ list [lsort [.t tag bind x]] [.t tag bind x <Enter>] [.t tag bind x a]
+} -cleanup {
+ .t tag delete x
+} -result {{<Enter> <Leave> a} script1 xyzzy}
+test textTag-3.8 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag bind x <Enter> script1
+ .t tag bind x <Enter> +script2
+ .t tag bind x <Enter>
+} -cleanup {
+ .t tag delete x
+} -result {script1
+script2}
+test textTag-3.9 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag bind x <Enter>
+} -cleanup {
+ .t tag delete x
+} -returnCodes ok -result {}
+test textTag-3.10 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag bind x <
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {no event type or button # or keysym}
+
+
+test textTag-4.1 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag cget a
+} -returnCodes error -result {wrong # args: should be ".t tag cget tagName option"}
+test textTag-4.2 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag cget a b c
+} -returnCodes error -result {wrong # args: should be ".t tag cget tagName option"}
+test textTag-4.3 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete foo
+ .t tag cget foo bar
+} -returnCodes error -result {tag "foo" isn't defined in text widget}
+test textTag-4.4 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag cget sel bogus
+} -returnCodes error -result {unknown option "bogus"}
+test textTag-4.5 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -background red
+ .t tag cget x -background
+} -cleanup {
+ .t tag delete x
+} -result {red}
+
+
+test textTag-5.1 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure
+} -returnCodes error -result {wrong # args: should be ".t tag configure tagName ?-option? ?value? ?-option value ...?"}
+test textTag-5.2 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -foo
+} -returnCodes error -result {unknown option "-foo"}
+test textTag-5.3 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -background red -underline
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {value for "-underline" missing}
+test textTag-5.4 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -underline yes
+ .t tag configure x -underline
+} -cleanup {
+ .t tag delete x
+} -result {-underline {} {} {} yes}
+test textTag-5.4a {TkTextTagCmd - "configure" option} -body {
+ .t tag delete x
+ .t tag configure x -underlinefg lightgreen
+ .t tag configure x -underlinefg
+} -cleanup {
+ .t tag delete x
+} -result {-underlinefg {} {} {} lightgreen}
+test textTag-5.5 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -overstrike on
+ .t tag cget x -overstrike
+} -cleanup {
+ .t tag delete x
+} -result {on}
+test textTag-5.5a {TkTextTagCmd - "configure" option} -body {
+ .t tag delete x
+ .t tag configure x -overstrikefg lightgreen
+ .t tag configure x -overstrikefg
+} -cleanup {
+ .t tag delete x
+} -result {-overstrikefg {} {} {} lightgreen}
+test textTag-5.6 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -overstrike foo
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {expected boolean value but got "foo"}
+test textTag-5.7 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -underline stupid
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {expected boolean value but got "stupid"}
+test textTag-5.8 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -justify left
+ .t tag configure x -justify
+} -cleanup {
+ .t tag delete x
+} -result {-justify {} {} {} left}
+test textTag-5.9 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -justify bogus
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad justification "bogus": must be left, right, or center}
+test textTag-5.10 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -justify fill
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad justification "fill": must be left, right, or center}
+test textTag-5.11 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -offset 2
+ .t tag configure x -offset
+} -cleanup {
+ .t tag delete x
+} -result {-offset {} {} {} 2}
+test textTag-5.12 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -offset 1.0q
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "1.0q"}
+test textTag-5.13 {TkTextTagCmd - "configure" option} -body {
+ .t tag delete x
+ .t tag configure x -lmargin1 2 -lmargin2 4 -rmargin 5 \
+ -lmargincolor darkblue -rmargincolor lightgreen
+ list [.t tag configure x -lmargin1] [.t tag configure x -lmargin2] \
+ [.t tag configure x -rmargin] [.t tag configure x -lmargincolor] \
+ [.t tag configure x -rmargincolor]
+} -cleanup {
+ .t tag delete x
+} -result [list {-lmargin1 {} {} {} 2} {-lmargin2 {} {} {} 4} \
+ {-rmargin {} {} {} 5} \
+ {-lmargincolor {} {} {} darkblue} {-rmargincolor {} {} {} lightgreen} \
+ ]
+test textTag-5.14 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -lmargin1 2.0x
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "2.0x"}
+test textTag-5.15 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -lmargin2 gorp
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "gorp"}
+test textTag-5.15a {TkTextTagCmd - "configure" option} -body {
+ .t tag delete x
+ .t tag configure x -lmargincolor rainbow
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {unknown color name "rainbow"}
+test textTag-5.16 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -rmargin 140.1.1
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "140.1.1"}
+test textTag-5.16a {TkTextTagCmd - "configure" option} -body {
+ .t tag delete x
+ .t tag configure x -rmargincolor rainbow
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {unknown color name "rainbow"}
+.t tag delete x
+test textTag-5.17 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -spacing1 2 -spacing2 4 -spacing3 6
+ list [.t tag configure x -spacing1] [.t tag configure x -spacing2] \
+ [.t tag configure x -spacing3]
+} -cleanup {
+ .t tag delete x
+} -result {{-spacing1 {} {} {} 2} {-spacing2 {} {} {} 4} {-spacing3 {} {} {} 6}}
+test textTag-5.18 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -spacing1 2.0x
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "2.0x"}
+test textTag-5.19 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -spacing1 lousy
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "lousy"}
+test textTag-5.20 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -spacing1 4.2.3
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "4.2.3"}
+test textTag-5.21 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t configure -selectborderwidth 2 -selectforeground blue \
+ -selectbackground black
+ .t tag configure sel -borderwidth 4 -foreground green -background yellow
+ set x {}
+ foreach i {-selectborderwidth -selectforeground -selectbackground} {
+ lappend x [lindex [.t configure $i] 4]
+ }
+ return $x
+} -result {4 green yellow}
+test textTag-5.22 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t configure -selectborderwidth 20
+ .t tag configure sel -borderwidth {}
+ .t cget -selectborderwidth
+} -result {}
+test textTag-5.23 {TkTextTagCmd - "configure" option} -body {
+ set x {}
+ # when [.t tag cget sel -selectbackground] == "", mirroring happens between
+ # the text widget option -selectbackground
+ # and the tag option -background
+ .t tag configure sel -selectbackground {}
+ .t configure -selectbackground black
+ .t tag configure sel -background yellow
+ lappend x [.t cget -selectbackground]
+ .t tag configure sel -background orange
+ .t configure -selectbackground blue
+ lappend x [.t tag cget sel -background]
+ # when [.t tag cget sel -selectbackground] != "", mirroring happens between
+ # the text widget option -selectbackground
+ # and the tag option -selectbackground
+ .t tag configure sel -selectbackground green
+ .t configure -selectbackground red
+ lappend x [.t tag cget sel -selectbackground]
+ .t configure -selectbackground black
+ .t tag configure sel -selectbackground white
+ lappend x [.t cget -selectbackground]
+ return $x
+} -result {yellow blue red white}
+test textTag-5.24 {TkTextTagCmd - "configure" option} -body {
+ set x {}
+ # when [.t tag cget sel -selectforeground] == "", mirroring happens between
+ # the text widget option -selectforeground
+ # and the tag option -foreground
+ .t tag configure sel -selectforeground {}
+ .t configure -selectforeground black
+ .t tag configure sel -foreground yellow
+ lappend x [.t cget -selectforeground]
+ .t tag configure sel -foreground orange
+ .t configure -selectforeground blue
+ lappend x [.t tag cget sel -foreground]
+ # when [.t tag cget sel -selectforeground] != "", mirroring happens between
+ # the text widget option -selectforeground
+ # and the tag option -selectforeground
+ .t tag configure sel -selectforeground green
+ .t configure -selectforeground red
+ lappend x [.t tag cget sel -selectforeground]
+ .t configure -selectforeground black
+ .t tag configure sel -selectforeground white
+ lappend x [.t cget -selectforeground]
+ return $x
+} -result {yellow blue red white}
+
+test textTag-6.1 {TkTextTagCmd - "delete" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete
+} -returnCodes error -result {wrong # args: should be ".t tag delete tagName ?tagName ...?"}
+test textTag-6.2 {TkTextTagCmd - "delete" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete zork
+} -returnCodes ok -result {}
+test textTag-6.3 {TkTextTagCmd - "delete" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+} -body {
+ .t tag config x -background black
+ .t tag config y -foreground white
+ .t tag config z -background black
+ .t tag delete y z
+ lsort [.t tag names]
+} -cleanup {
+ .t tag delete x
+} -result {sel x}
+test textTag-6.4 {TkTextTagCmd - "delete" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+} -body {
+ .t tag config x -background black
+ .t tag config y -foreground white
+ .t tag config z -background black
+ eval .t tag delete [.t tag names]
+ .t tag names
+} -result {sel}
+test textTag-6.5 {TkTextTagCmd - "delete" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag bind x <Enter> foo
+ .t tag delete x
+ .t tag configure x -background black
+ .t tag bind x
+} -cleanup {
+ .t tag delete x
+} -result {}
+
+
+test textTag-7.1 {TkTextTagCmd - "lower" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag lower
+} -returnCodes error -result {wrong # args: should be ".t tag lower tagName ?belowThis?"}
+test textTag-7.2 {TkTextTagCmd - "lower" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag lower foo
+} -returnCodes error -result {tag "foo" isn't defined in text widget}
+test textTag-7.3 {TkTextTagCmd - "lower" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag lower sel bar
+} -returnCodes error -result {tag "bar" isn't defined in text widget}
+test textTag-7.4 {TkTextTagCmd - "lower" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
+ .t tag lower c
+ .t tag names
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {c sel a b d}
+test textTag-7.5 {TkTextTagCmd - "lower" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
+ .t tag lower d b
+ .t tag names
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {sel a d b c}
+test textTag-7.6 {TkTextTagCmd - "lower" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
+ .t tag lower a c
+ .t tag names
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {sel b a c d}
+
+
+test textTag-8.1 {TkTextTagCmd - "names" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag names a b
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -returnCodes error -result {wrong # args: should be ".t tag names ?index?"}
+test textTag-8.2 {TkTextTagCmd - "names" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
+ .t tag names
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {sel a b c d}
+test textTag-8.3 {TkTextTagCmd - "names" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
+ .t tag add "a b" 2.1 2.6
+ .t tag add c 2.4 2.7
+ .t tag names 2.5
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {c {a b}}
+
+
+test textTag-9.1 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag nextrange x
+} -returnCodes error -result {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}
+test textTag-9.2 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag nextrange x 1 2 3
+} -returnCodes error -result {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}
+test textTag-9.3 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag nextrange foo 1.0
+} -returnCodes ok -result {}
+test textTag-9.4 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag nextrange x foo
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad text index "foo"}
+test textTag-9.5 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag nextrange x 1.0 bar
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad text index "bar"}
+test textTag-9.6 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag nextrange x 1.0
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-9.7 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag nextrange x 2.2
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-9.8 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag nextrange x 2.3
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-9.9 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag nextrange x 2.4
+} -cleanup {
+ .t tag delete x
+} -result {2.9 3.1}
+test textTag-9.10 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag nextrange x 2.4 2.9
+} -cleanup {
+ .t tag delete x
+} -result {}
+test textTag-9.11 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag nextrange x 2.4 2.10
+} -cleanup {
+ .t tag delete x
+} -result {2.9 3.1}
+test textTag-9.12 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag nextrange x 2.4 2.11
+} -cleanup {
+ .t tag delete x
+} -result {2.9 3.1}
+test textTag-9.13 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag nextrange x 7.0
+} -cleanup {
+ .t tag delete x
+} -result {7.2 7.3}
+test textTag-9.14 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag nextrange x 7.3
+} -cleanup {
+ .t tag delete x
+} -result {}
+
+
+test textTag-10.1 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag prevrange x
+} -returnCodes error -result {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"}
+test textTag-10.2 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag prevrange x 1 2 3
+} -returnCodes error -result {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"}
+test textTag-10.3 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag prevrange foo end
+} -cleanup {
+ .t tag delete x
+} -returnCodes ok -result {}
+test textTag-10.4 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag prevrange x foo
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad text index "foo"}
+test textTag-10.5 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag prevrange x end bar
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad text index "bar"}
+test textTag-10.6 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag prevrange x end
+} -cleanup {
+ .t tag delete x
+} -result {7.2 7.3}
+test textTag-10.7 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag prevrange x 2.4
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-10.8 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag prevrange x 2.5
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-10.9 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag prevrange x 2.9
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-10.10 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag prevrange x 2.9 2.6
+} -cleanup {
+ .t tag delete x
+} -result {}
+test textTag-10.11 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag prevrange x 2.9 2.5
+} -cleanup {
+ .t tag delete x
+} -result {}
+test textTag-10.12 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag prevrange x 2.9 2.3
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-10.13 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag prevrange x 7.0
+} -cleanup {
+ .t tag delete x
+} -result {2.9 3.1}
+test textTag-10.14 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag prevrange x 2.3
+} -cleanup {
+ .t tag delete x
+} -result {}
+
+
+test textTag-11.1 {TkTextTagCmd - "raise" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag raise
+} -returnCodes error -result {wrong # args: should be ".t tag raise tagName ?aboveThis?"}
+test textTag-11.2 {TkTextTagCmd - "raise" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag raise foo
+} -returnCodes error -result {tag "foo" isn't defined in text widget}
+test textTag-11.3 {TkTextTagCmd - "raise" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag raise sel bar
+} -returnCodes error -result {tag "bar" isn't defined in text widget}
+test textTag-11.4 {TkTextTagCmd - "raise" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
+ .t tag raise c
+ .t tag names
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {sel a b d c}
+test textTag-11.5 {TkTextTagCmd - "raise" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
+ .t tag raise d b
+ .t tag names
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {sel a b d c}
+test textTag-11.6 {TkTextTagCmd - "raise" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
+ .t tag raise a c
+ .t tag names
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {sel b c a d}
+
+
+test textTag-12.1 {TkTextTagCmd - "ranges" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag ranges
+} -returnCodes error -result {wrong # args: should be ".t tag ranges tagName"}
+test textTag-12.2 {TkTextTagCmd - "ranges" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag ranges x
+} -result {}
+test textTag-12.3 {TkTextTagCmd - "ranges" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.2
+ .t tag add x 2.7 4.15
+ .t tag add x 5.2 5.5
+ .t tag ranges x
+} -cleanup {
+ .t tag delete x
+} -result {2.2 2.3 2.7 4.6 5.2 5.5}
+test textTag-12.4 {TkTextTagCmd - "ranges" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 1.0 3.0
+ .t tag add x 4.0 end
+ .t tag ranges x
+} -cleanup {
+ .t tag delete x
+} -result {1.0 3.0 4.0 8.0}
+
+
+test textTag-13.1 {TkTextTagCmd - "remove" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag remove
+} -returnCodes error -result {wrong # args: should be ".t tag remove tagName index1 ?index2 index1 index2 ...?"}
+test textTag-13.2 {TkTextTagCmd - "remove" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.2 2.11
+ .t tag remove x 2.3 2.7
+ .t tag ranges x
+} -cleanup {
+ .t tag delete x
+} -result {2.2 2.3 2.7 2.11}
+test textTag-13.3 {TkTextTagCmd - "remove" option} -constraints {
+ haveCourier12
+} -setup {
+ destroy .t.e
+} -body {
+ entry .t.e
+ .t.e insert 0 "Text"
+ .t configure -exportselection 1
+ .t tag remove sel 1.0 end
+ .t tag add sel 2.4 3.3
+ .t.e select to 4
+ .t tag remove sel 2.7 3.1
+ selection get
+} -cleanup {
+ destroy .t.e
+} -result {Text}
+
+
+test textTag-14.1 {SortTags} -constraints haveCourier12 -setup {
+ .t tag delete a b c d
+} -body {
+ foreach i {a b c d} {
+ .t tag add $i 2.0 2.2
+ }
+ .t tag names 2.1
+} -cleanup {
+ .t tag delete a b c d
+} -result {a b c d}
+.t tag delete a b c d
+test textTag-14.2 {SortTags} -constraints haveCourier12 -setup {
+ .t tag delete a b c d
+} -body {
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+ foreach i {d c b a} {
+ .t tag add $i 2.0 2.2
+ }
+ .t tag names 2.1
+} -cleanup {
+ .t tag delete a b c d
+} -result {a b c d}
+test textTag-14.3 {SortTags} -constraints haveCourier12 -setup {
+ .t tag delete {*}[.t tag names]
+} -body {
+ for {set i 0} {$i < 30} {incr i} {
+ .t tag add x$i 2.0 2.2
+ }
+ .t tag names 2.1
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29}
+test textTag-14.4 {SortTags} -constraints haveCourier12 -setup {
+ .t tag delete {*}[.t tag names]
+} -body {
+ for {set i 0} {$i < 30} {incr i} {
+ .t tag configure x$i -background black
+ }
+ for {set i 29} {$i >= 0} {incr i -1} {
+ .t tag add x$i 2.0 2.2
+ }
+ .t tag names 2.1
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29}
+
+
+
+set c [.t bbox 2.1]
+set x1 [expr [lindex $c 0] + [lindex $c 2]/2]
+set y1 [expr [lindex $c 1] + [lindex $c 3]/2]
+set c [.t bbox 3.2]
+set x2 [expr [lindex $c 0] + [lindex $c 2]/2]
+set y2 [expr [lindex $c 1] + [lindex $c 3]/2]
+set c [.t bbox 4.3]
+set x3 [expr [lindex $c 0] + [lindex $c 2]/2]
+set y3 [expr [lindex $c 1] + [lindex $c 3]/2]
+
+test textTag-15.1 {TkTextBindProc} -constraints haveCourier12 -setup {
+ .t tag delete x y
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ bind .t <ButtonRelease> {lappend x up}
+ .t tag bind x <ButtonRelease> {lappend x x-up}
+ .t tag bind y <ButtonRelease> {lappend x y-up}
+ set x {}
+ .t tag add x 2.0 2.4
+ .t tag add y 4.3
+ event gen .t <Button> -x $x1 -y $y1
+ event gen .t <Motion> -x $x1 -y $y1
+ event gen .t <ButtonRelease> -x $x1 -y $y1
+ event gen .t <Button> -x $x1 -y $y1
+ event gen .t <Motion> -x $x2 -y $y2
+ event gen .t <ButtonRelease> -x $x2 -y $y2
+ event gen .t <Button> -x $x2 -y $y2
+ event gen .t <Motion> -x $x3 -y $y3
+ event gen .t <ButtonRelease> -x $x3 -y $y3
+ return $x
+} -cleanup {
+ .t tag delete x y
+ bind .t <ButtonRelease> {}
+} -result {x-up up up y-up up}
+
+test textTag-15.2 {TkTextBindProc} -constraints haveCourier12 -setup {
+ .t tag delete x y
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ .t tag bind x <Enter> {lappend x x-enter}
+ .t tag bind x <ButtonPress> {lappend x x-down}
+ .t tag bind x <ButtonRelease> {lappend x x-up}
+ .t tag bind x <Leave> {lappend x x-leave}
+ .t tag bind y <Enter> {lappend x y-enter}
+ .t tag bind y <ButtonPress> {lappend x y-down}
+ .t tag bind y <ButtonRelease> {lappend x y-up}
+ .t tag bind y <Leave> {lappend x y-leave}
+ event gen .t <Motion> -x 0 -y 0
+ set x {}
+ .t tag add x 2.0 2.4
+ .t tag add y 4.3
+ event gen .t <Motion> -x $x1 -y $y1
+ lappend x |
+ event gen .t <Button> -x $x1 -y $y1
+ lappend x |
+ event gen .t <Motion> -x $x3 -y $y3 -state 0x100
+ lappend x |
+ event gen .t <ButtonRelease> -x $x3 -y $y3
+ return $x
+} -cleanup {
+ .t tag delete x y
+} -result {x-enter | x-down | | x-up x-leave y-enter}
+
+test textTag-15.3 {TkTextBindProc} -constraints haveCourier12 -setup {
+ .t tag delete x y
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ .t tag bind x <Enter> {lappend x x-enter}
+ .t tag bind x <Any-ButtonPress-1> {lappend x x-down}
+ .t tag bind x <Any-ButtonRelease-1> {lappend x x-up}
+ .t tag bind x <Leave> {lappend x x-leave}
+ .t tag bind y <Enter> {lappend x y-enter}
+ .t tag bind y <Any-ButtonPress-1> {lappend x y-down}
+ .t tag bind y <Any-ButtonRelease-1> {lappend x y-up}
+ .t tag bind y <Leave> {lappend x y-leave}
+ event gen .t <Motion> -x 0 -y 0
+ set x {}
+ .t tag add x 2.0 2.4
+ .t tag add y 4.3
+ event gen .t <Motion> -x $x1 -y $y1
+ lappend x |
+ event gen .t <Button-1> -x $x1 -y $y1
+ lappend x |
+ event gen .t <Button-2> -x $x1 -y $y1 -state 0x100
+ lappend x |
+ event gen .t <Motion> -x $x3 -y $y3 -state 0x300
+ lappend x |
+ event gen .t <ButtonRelease-1> -x $x3 -y $y3 -state 0x300
+ lappend x |
+ event gen .t <ButtonRelease-2> -x $x3 -y $y3 -state 0x200
+ return $x
+} -cleanup {
+ .t tag delete x y
+} -result {x-enter | x-down | | | x-up | x-leave y-enter}
+
+
+test textTag-16.1 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1
+ set x [.t index current]
+ event gen .t <Motion> -x $x2 -y $y2
+ lappend x [.t index current]
+ event gen .t <Button-1> -x $x2 -y $y2
+ lappend x [.t index current]
+ event gen .t <Motion> -x $x3 -y $y3 -state 0x100
+ lappend x [.t index current]
+ event gen .t <Button-3> -state 0x100 -x $x3 -y $y3
+ lappend x [.t index current]
+ event gen .t <ButtonRelease-3> -state 0x300 -x $x3 -y $y3
+ lappend x [.t index current]
+ event gen .t <ButtonRelease-1> -state 0x100 -x $x3 -y $y3
+ lappend x [.t index current]
+} -result {2.1 3.2 3.2 3.2 3.2 3.2 4.3}
+
+test textTag-16.2 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ .t tag configure big -font $bigFont
+ event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1
+ event gen .t <Motion> -x $x2 -y $y2
+ set x [.t index current]
+ .t tag add big 3.0
+ update
+ lappend x [.t index current]
+} -cleanup {
+ .t tag delete big
+} -result {3.2 3.1}
+
+test textTag-16.3 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ foreach i {a b c d} {
+ .t tag remove $i 1.0 end
+ }
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ foreach i {a b c d} {
+ .t tag bind $i <Enter> "lappend x enter-$i"
+ .t tag bind $i <Leave> "lappend x leave-$i"
+ }
+ .t tag lower b
+ .t tag lower a
+ set x {}
+ event gen .t <Motion> -x $x1 -y $y1
+ .t tag add a 2.1 3.3
+ .t tag add b 2.1
+ .t tag add c 3.2
+ update
+ lappend x |
+ event gen .t <Motion> -x $x2 -y $y2
+ lappend x |
+ event gen .t <Motion> -x $x3 -y $y3
+ return $x
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {enter-a enter-b | leave-b enter-c | leave-a leave-c}
+
+test textTag-16.4 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ foreach i {a b c d} {
+ .t tag remove $i 1.0 end
+ }
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ foreach i {a b c d} {
+ .t tag bind $i <Enter> "lappend x enter-$i"
+ .t tag bind $i <Leave> "lappend x leave-$i"
+ }
+ .t tag lower b
+ .t tag lower a
+ set x {}
+ event gen .t <Motion> -x $x1 -y $y1
+ .t tag add a 2.1 3.3
+ .t tag add b 2.1
+ .t tag add c 2.1
+ update
+ lappend x |
+ .t tag lower c
+ event gen .t <Motion> -x $x2 -y $y2
+ return $x
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {enter-a enter-b enter-c | leave-c leave-b}
+
+test textTag-16.5 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ foreach i {big a b c d} {
+ .t tag remove $i 1.0 end
+ }
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ .t tag configure big -font $bigFont
+ event gen .t <Motion> -x $x1 -y $y1
+ .t tag bind a <Enter> {.t tag add big 3.0 3.2}
+ .t tag add a 3.2
+ event gen .t <Motion> -x $x2 -y $y2
+ .t index current
+} -cleanup {
+ .t tag delete a big
+} -result {3.2}
+
+test textTag-16.6 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ foreach i {big a b c d} {
+ .t tag remove $i 1.0 end
+ }
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ .t tag configure big -font $bigFont
+ event gen .t <Motion> -x $x1 -y $y1
+ .t tag bind a <Enter> {.t tag add big 3.0 3.2}
+ .t tag add a 3.2
+ event gen .t <Motion> -x $x2 -y $y2
+ update
+ .t index current
+} -cleanup {
+ .t tag delete a big
+} -result {3.1}
+
+test textTag-16.7 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ foreach i {big a b c d} {
+ .t tag remove $i 1.0 end
+ }
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ .t tag configure big -font $bigFont
+ .t tag bind a <Enter> {.t tag add big 3.0 3.2}
+ .t tag add a 3.2
+
+ event gen .t <Motion> -x $x1 -y $y1
+ .t tag bind a <Leave> {.t tag add big 3.0 3.2}
+ .t tag add a 2.1
+ event gen .t <Motion> -x $x2 -y $y2
+ update
+ .t index current
+} -cleanup {
+ .t tag delete a big
+} -result {3.1}
+
+
+test textTag-17.1 {insert procedure inserts tags} -setup {
+ .t delete 1.0 end
+} -body {
+ # Objectification of the text widget had a problem
+ # with inserting tags when using 'end'. Check that
+ # bug has been fixed.
+ .t insert end abcd {x} \n {} efgh {y} \n {}
+ .t dump -tag 1.0 end
+} -result {tagon x 1.0 tagoff x 1.4 tagon y 2.0 tagoff y 2.4}
+
+
+test textTag-18.1 {TkTextPickCurrent tag bindings} -setup {
+ destroy .t
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ text .t -width 30 -height 4 -relief sunken -borderwidth 10 \
+ -highlightthickness 10 -pady 2
+ pack .t
+
+ .t insert end " Tag here " TAG " no tag here"
+ .t tag configure TAG -borderwidth 4 -relief raised
+ .t tag bind TAG <Enter> {lappend res "%x %y tag-Enter"}
+ .t tag bind TAG <Leave> {lappend res "%x %y tag-Leave"}
+ bind .t <Enter> {lappend res Enter}
+ bind .t <Leave> {lappend res Leave}
+
+ set res {}
+ # Bindings must not trigger on the widget border, only over
+ # the actual tagged characters themselves.
+ event gen .t <Motion> -warp 1 -x 0 -y 0 ; update
+ event gen .t <Motion> -warp 1 -x 10 -y 10 ; update
+ event gen .t <Motion> -warp 1 -x 25 -y 25 ; update
+ event gen .t <Motion> -warp 1 -x 20 -y 20 ; update
+ event gen .t <Motion> -warp 1 -x 10 -y 10 ; update
+ event gen .t <Motion> -warp 1 -x 25 -y 25 ; update
+ return $res
+} -cleanup {
+ destroy .t
+} -result {Enter {25 25 tag-Enter} {20 20 tag-Leave} {25 25 tag-Enter}}
+
+destroy .t
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/textWind.test b/tk8.6/tests/textWind.test
new file mode 100644
index 0000000..27b7309
--- /dev/null
+++ b/tk8.6/tests/textWind.test
@@ -0,0 +1,1482 @@
+# This file is a Tcl script to test the code in the file tkTextWind.c.
+# This file is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+
+# Create entries in the option database to be sure that geometry options
+# like border width have predictable values.
+
+option add *Text.borderWidth 2
+option add *Text.highlightThickness 2
+option add *Text.font {Courier -12}
+
+
+deleteWindows
+# Widget used in tests 1.* - 16.*
+text .t -width 30 -height 6 -bd 2 -highlightthickness 2
+pack append . .t {top expand fill}
+update
+.t debug on
+
+# 15 on XP, 13 on Solaris 8
+set fixedHeight [font metrics {Courier -12} -linespace]
+set fixedDiff [expr {$fixedHeight - 13}] ;# 2 on XP
+set color [expr {[winfo depth .t] > 1 ? "green" : "black"}]
+
+wm geometry . {}
+
+# The statements below reset the main window; it's needed if the window
+# manager is mwm to make mwm forget about a previous minimum size setting.
+
+wm withdraw .
+wm minsize . 1 1
+wm positionfrom . user
+wm deiconify .
+
+# ----------------------------------------------------------------------
+
+test textWind-1.1 {basic tests of options} -constraints fonts -setup {
+ .t delete 1.0 end
+} -body {
+ .t insert end "This is the first line"
+ .t insert end "\nAnd this is a second line, which wraps around"
+ frame .f -width 3 -height 3 -bg $color
+ .t window create 2.2 -window .f
+ update
+ list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] \
+ [.t window configure .f -window]
+} -result {1 3x3+19+23 {19 23 3 3} {-window {} {} {} .f}}
+test textWind-1.2 {basic tests of options} -constraints fonts -setup {
+ .t delete 1.0 end
+} -body {
+ .t insert end "This is the first line"
+ .t insert end "\nAnd this is a second line, which wraps around"
+ frame .f -width 3 -height 3 -bg $color
+ .t window create 2.2 -window .f -align top
+ update
+ list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] \
+ [.t window configure .f -align]
+} -result {1 3x3+19+18 {19 18 3 3} {-align {} {} center top}}
+test textWind-1.3 {basic tests of options} -setup {
+ .t delete 1.0 end
+} -body {
+ .t insert end "This is the first line"
+ .t insert end "\nAnd this is a second line, which wraps around"
+ .t window create 2.2 -create "Test script"
+ .t window configure 2.2 -create
+} -result {-create {} {} {} {Test script}}
+test textWind-1.4 {basic tests of options} -constraints fonts -setup {
+ .t delete 1.0 end
+} -body {
+ .t insert end "This is the first line"
+ .t insert end "\nAnd this is a second line, which wraps around"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 2.2 -window .f -padx 5
+ update
+ list [winfo geom .f] [.t window configure .f -padx] [.t bbox 2.3]
+} -result {10x20+24+18 {-padx {} {} 0 5} {39 21 7 13}}
+test textWind-1.5 {basic tests of options} -constraints fonts -setup {
+ .t delete 1.0 end
+} -body {
+ .t insert end "This is the first line"
+ .t insert end "\nAnd this is a second line, which wraps around"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 2.2 -window .f -pady 4
+ update
+ list [winfo geom .f] [.t window configure .f -pady] [.t bbox 2.31]
+} -result {10x20+19+22 {-pady {} {} 0 4} {19 46 7 13}}
+test textWind-1.6 {basic tests of options} -constraints fonts -setup {
+ .t delete 1.0 end
+} -body {
+ .t insert end "This is the first line"
+ .t insert end "\nAnd this is a second line, which wraps around"
+ frame .f -width 5 -height 5 -bg $color
+ .t window create 2.2 -window .f -stretch 1
+ update
+ list [winfo geom .f] [.t window configure .f -stretch]
+} -result {5x13+19+18 {-stretch {} {} 0 1}}
+
+
+.t delete 1.0 end
+.t insert end "This is the first line"
+test textWind-2.1 {TkTextWindowCmd procedure} -body {
+ .t window
+} -returnCodes error -result {wrong # args: should be ".t window option ?arg ...?"}
+test textWind-2.2 {TkTextWindowCmd procedure, "cget" option} -body {
+ .t window cget
+} -returnCodes error -result {wrong # args: should be ".t window cget index option"}
+test textWind-2.3 {TkTextWindowCmd procedure, "cget" option} -body {
+ .t window cget a b c
+} -returnCodes error -result {wrong # args: should be ".t window cget index option"}
+test textWind-2.4 {TkTextWindowCmd procedure, "cget" option} -body {
+ .t window cget gorp -padx
+} -returnCodes error -result {bad text index "gorp"}
+test textWind-2.5 {TkTextWindowCmd procedure, "cget" option} -body {
+ .t window cget 1.2 -padx
+} -returnCodes error -result {no embedded window at index "1.2"}
+test textWind-2.6 {TkTextWindowCmd procedure, "cget" option} -setup {
+ destroy .f
+} -body {
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 1.3 -window .f -padx 1 -pady 2
+ .t window cget .f -bogus
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {unknown option "-bogus"}
+test textWind-2.7 {TkTextWindowCmd procedure, "cget" option} -setup {
+ destroy .f
+} -body {
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 1.3 -window .f -padx 1 -pady 2
+ .t window cget .f -pady
+} -cleanup {
+ destroy .f
+} -returnCodes ok -result {2}
+test textWind-2.8 {TkTextWindowCmd procedure} -body {
+ .t window co
+} -returnCodes error -result {wrong # args: should be ".t window configure index ?-option value ...?"}
+test textWind-2.9 {TkTextWindowCmd procedure} -body {
+ .t window configure gorp
+} -returnCodes error -result {bad text index "gorp"}
+test textWind-2.10 {TkTextWindowCmd procedure} -body {
+ .t delete 1.0 end
+ .t window configure 1.0
+} -returnCodes error -result {no embedded window at index "1.0"}
+test textWind-2.11 {TkTextWindowCmd procedure} -setup {
+# I kept this as it "influenced" the test case in previous releases
+ destroy .f
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 1.3 -window .f -padx 1 -pady 2
+ .t delete 1.0 end
+} -body {
+ .t insert end "This is the first line"
+ .t insert end "\nAnd this is a second line, which wraps around"
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo
+ update
+ .t window configure .f
+} -cleanup {
+ destroy .f
+} -result {{-align {} {} center baseline} {-create {} {} {} foo} {-padx {} {} 0 1} {-pady {} {} 0 2} {-stretch {} {} 0 0} {-window {} {} {} .f}}
+test textWind-2.12 {TkTextWindowCmd procedure} -setup {
+# I kept this as it "influenced" the test case in previous releases
+ destroy .f
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo
+ .t delete 1.0 end
+} -body {
+ .t insert end "This is the first line"
+ .t insert end "\nAnd this is a second line, which wraps around"
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo
+ update
+ list [.t window configure .f -padx 33] [.t window configure .f -padx]
+} -cleanup {
+ destroy .f
+} -result {{} {-padx {} {} 0 33}}
+test textWind-2.13 {TkTextWindowCmd procedure} -setup {
+# I kept this as it "influenced" the test case in previous releases
+ destroy .f
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo
+ .t delete 1.0 end
+} -body {
+ .t insert end "This is the first line"
+ .t insert end "\nAnd this is a second line, which wraps around"
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 2.2 -window .f -align baseline -padx 1 -pady 2
+ update
+ list [.t window configure .f -padx 14 -pady 15] \
+ [.t window configure .f -padx] [.t window configure .f -pady]
+} -cleanup {
+ destroy .f
+} -result {{} {-padx {} {} 0 14} {-pady {} {} 0 15}}
+test textWind-2.14 {TkTextWindowCmd procedure} -setup {
+ .t delete 1.0 end
+} -body {
+ .t window create
+} -returnCodes error -result {wrong # args: should be ".t window create index ?-option value ...?"}
+test textWind-2.15 {TkTextWindowCmd procedure} -setup {
+ .t delete 1.0 end
+} -body {
+ .t window create gorp
+} -returnCodes error -result {bad text index "gorp"}
+test textWind-2.16 {TkTextWindowCmd procedure, don't insert after end} -setup {
+# I kept this as it "influenced" the test case in previous releases
+ destroy .f
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 2.2 -window .f -align baseline -padx 1 -pady 2
+ .t delete 1.0 end
+} -body {
+ .t insert end "Line 1\nLine 2"
+ frame .f -width 20 -height 10 -bg $color
+ .t window create end -window .f
+ .t index .f
+} -result {2.6}
+test textWind-2.17 {TkTextWindowCmd procedure} -setup {
+ .t delete 1.0 end
+} -body {
+ list [catch {.t window create 1.0} msg] $msg [.t window configure 1.0]
+} -result {0 {} {{-align {} {} center center} {-create {} {} {} {}} {-padx {} {} 0 0} {-pady {} {} 0 0} {-stretch {} {} 0 0} {-window {} {} {} {}}}}
+test textWind-2.18 {TkTextWindowCmd procedure} -setup {
+# I kept this as it "influenced" the test case in previous releases
+ destroy .f
+ frame .f -width 20 -height 10 -bg $color
+ .t window create end -window .f
+ .t delete 1.0 end
+} -body {
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 1.0 -window .f -gorp stupid
+} -returnCodes error -result {unknown option "-gorp"}
+test textWind-2.19 {TkTextWindowCmd procedure} -setup {
+# I kept this as it "influenced" the test case in previous releases
+ destroy .f
+ frame .f -width 20 -height 10 -bg $color
+ .t window create end -window .f
+ .t delete 1.0 end
+} -body {
+ frame .f -width 10 -height 6 -bg $color
+ catch {.t window create 1.0 -window .f -gorp stupid}
+ list [winfo exists .f] [.t index 1.end] [catch {.t index .f}]
+} -result {0 1.0 1}
+test textWind-2.20 {TkTextWindowCmd procedure} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 1.0 -gorp -window .f stupid
+} -returnCodes error -result {unknown option "-gorp"}
+test textWind-2.21 {TkTextWindowCmd procedure} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ frame .f -width 10 -height 6 -bg $color
+ catch {.t window create 1.0 -gorp -window .f stupid}
+ list [winfo exists .f] [.t index 1.end] [catch {.t index .f}]
+} -result {1 1.0 1}
+test textWind-2.22 {TkTextWindowCmd procedure} -setup {
+ .t delete 1.0 end
+} -body {
+ .t window c
+} -returnCodes error -result {ambiguous window option "c": must be cget, configure, create, or names}
+destroy .f
+test textWind-2.23 {TkTextWindowCmd procedure, "names" option} -setup {
+ .t delete 1.0 end
+} -body {
+ .t window names foo
+} -returnCodes error -result {wrong # args: should be ".t window names"}
+test textWind-2.24 {TkTextWindowCmd procedure, "names" option} -setup {
+ .t delete 1.0 end
+} -body {
+ .t window names
+} -result {}
+test textWind-2.25 {TkTextWindowCmd procedure, "names" option} -setup {
+ .t delete 1.0 end
+ destroy .f .f2 .t.f .t.f2
+} -body {
+ foreach i {.f .f2 .t.f .t.f2} {
+ frame $i -width 20 -height 20
+ .t window create end -window $i
+ }
+ lsort [.t window names]
+} -cleanup {
+ destroy .f .f2 .t.f .t.f2
+} -result {.f .f2 .t.f .t.f2}
+
+
+test textWind-3.1 {EmbWinConfigure procedure} -setup {
+ destroy .f
+} -body {
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 1.0 -window .f
+ .t window configure 1.0 -foo bar
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {unknown option "-foo"}
+test textWind-3.2 {EmbWinConfigure procedure} -constraints fonts -setup {
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.3 -window .f
+ update
+ .t window configure 1.3 -window {}
+ update
+ .t index .f
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {bad text index ".f"}
+test textWind-3.3 {EmbWinConfigure procedure} -constraints fonts -setup {
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.3 -window .f
+ update
+ .t window configure 1.3 -window {}
+ update
+ catch {.t index .f}
+ list [winfo ismapped .f] [.t bbox 1.4]
+} -cleanup {
+ destroy .f
+} -result {0 {26 5 7 13}}
+test textWind-3.4 {EmbWinConfigure procedure} -constraints fonts -setup {
+ destroy .t.f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .t.f -width 10 -height 20 -bg $color
+ .t window create 1.3 -window .t.f
+ update
+ .t window configure 1.3 -window {}
+ update
+ .t index .t.f
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad text index ".t.f"}
+test textWind-3.5 {EmbWinConfigure procedure} -constraints fonts -setup {
+ destroy .t.f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .t.f -width 10 -height 20 -bg $color
+ .t window create 1.3 -window .t.f
+ update
+ .t window configure 1.3 -window {}
+ update
+ catch {.t index .t.f}
+ list [winfo ismapped .t.f] [.t bbox 1.4]
+} -cleanup {
+ destroy .t.f
+} -result {0 {26 5 7 13}}
+test textWind-3.6 {EmbWinConfigure procedure} -constraints fonts -setup {
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.3
+ update
+ .t window configure 1.3 -window .f
+ update
+ list [catch {.t index .f} msg] $msg [winfo ismapped .f] [.t bbox 1.4]
+} -cleanup {
+ destroy .f
+} -result {0 1.3 1 {36 8 7 13}}
+test textWind-3.7 {EmbWinConfigure procedure} -setup {
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f
+ frame .f.f -width 15 -height 20 -bg $color
+ pack .f.f
+ .t window create 1.3 -window .f.f
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {can't embed .f.f in .t}
+test textWind-3.8 {EmbWinConfigure procedure} -setup {
+ destroy .t2
+} -body {
+ .t insert 1.0 "Some sample text"
+ toplevel .t2 -width 20 -height 10 -bg $color
+ .t window create 1.3
+ .t window configure 1.3 -window .t2
+} -cleanup {
+ destroy .t2
+} -returnCodes error -result {can't embed .t2 in .t}
+test textWind-3.9 {EmbWinConfigure procedure} -setup {
+ destroy .t2
+} -body {
+ .t insert 1.0 "Some sample text"
+ toplevel .t2 -width 20 -height 10 -bg $color
+ .t window create 1.3
+ catch {.t window configure 1.3 -window .t2}
+ .t window configure 1.3 -window
+} -cleanup {
+ destroy .t2
+} -result {-window {} {} {} {}}
+test textWind-3.10 {EmbWinConfigure procedure} -setup {
+ .t delete 1.0 end
+} -body {
+ .t insert 1.0 "Some sample text"
+ .t window create 1.3
+ .t window configure 1.3 -window .t
+} -returnCodes error -result {can't embed .t in .t}
+test textWind-3.11 {EmbWinConfigure procedure} -setup {
+ .t delete 1.0 end
+} -body {
+ # This test checks for various errors when the text claims
+ # a window away from itself.
+ .t insert 1.0 "Some sample text"
+ button .t.b -text "Hello!"
+ .t window create 1.4 -window .t.b
+ .t window create 1.6 -window .t.b
+ update
+ .t index .t.b
+} -result {1.6}
+
+
+.t delete 1.0 end
+frame .f -width 10 -height 20 -bg $color
+.t window create 1.0 -window .f
+test textWind-4.1 {AlignParseProc and AlignPrintProc procedures} -body {
+ .t window configure 1.0 -align baseline
+ .t window configure 1.0 -align
+} -result {-align {} {} center baseline}
+test textWind-4.2 {AlignParseProc and AlignPrintProc procedures} -body {
+ .t window configure 1.0 -align bottom
+ .t window configure 1.0 -align
+} -result {-align {} {} center bottom}
+test textWind-4.3 {AlignParseProc and AlignPrintProc procedures} -body {
+ .t window configure 1.0 -align center
+ .t window configure 1.0 -align
+} -result {-align {} {} center center}
+test textWind-4.4 {AlignParseProc and AlignPrintProc procedures} -body {
+ .t window configure 1.0 -align top
+ .t window configure 1.0 -align
+} -result {-align {} {} center top}
+test textWind-4.5 {AlignParseProc and AlignPrintProc procedures} -body {
+ .t window configure 1.0 -align top
+ .t window configure 1.0 -align gorp
+} -returnCodes error -result {bad align "gorp": must be baseline, bottom, center, or top}
+test textWind-4.6 {AlignParseProc and AlignPrintProc procedures} -body {
+ .t window configure 1.0 -align top
+ catch {.t window configure 1.0 -align gorp}
+ .t window configure 1.0 -align
+} -result {-align {} {} center top}
+
+
+test textWind-5.1 {EmbWinStructureProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.2 -window .f
+ update
+ destroy .f
+ .t index .f
+} -returnCodes error -result {bad text index ".f"}
+test textWind-5.2 {EmbWinStructureProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.2 -window .f
+ update
+ destroy .f
+ catch {.t index .f}
+ list [.t bbox 1.2] [.t bbox 1.3]
+} -result {{19 11 0 0} {19 5 7 13}}
+test textWind-5.3 {EmbWinStructureProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.2 -align bottom
+ .t window configure 1.2 -window .f
+ update
+ destroy .f
+ .t index .f
+} -returnCodes error -result {bad text index ".f"}
+test textWind-5.4 {EmbWinStructureProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.2 -align bottom
+ .t window configure 1.2 -window .f
+ update
+ destroy .f
+ catch {.t index .f}
+ list [.t bbox 1.2] [.t bbox 1.3]
+} -result {{19 18 0 0} {19 5 7 13}}
+test textWind-5.5 {EmbWinStructureProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ .t window create 1.2 -create {frame .f -width 10 -height 20 -bg $color}
+ update
+ .t window configure 1.2 -create {frame .f -width 20 -height 10 -bg $color}
+ destroy .f
+ update
+ list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3]
+} -result {0 1.2 {19 6 20 10} {39 5 7 13}}
+
+
+test textWind-6.1 {EmbWinRequestProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+ set result {}
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.2 -window .f
+ lappend result [.t bbox 1.2] [.t bbox 1.3]
+ .f configure -width 25 -height 30
+ lappend result [.t bbox 1.2] [.t bbox 1.3]
+} -cleanup {
+ destroy .f
+} -result {{19 5 10 20} {29 8 7 13} {19 5 25 30} {44 13 7 13}}
+
+
+test textWind-7.1 {EmbWinLostSlaveProc procedure} -constraints {
+ textfonts
+} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.2 -window .f
+ update
+ place .f -in .t -x 100 -y 50
+ update
+ list [winfo geom .f] [.t bbox 1.2]
+} -cleanup {
+ destroy .f
+} -result [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]]
+test textWind-7.2 {EmbWinLostSlaveProc procedure} -constraints {
+ textfonts
+} -setup {
+ .t delete 1.0 end
+ destroy .t.f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .t.f -width 10 -height 20 -bg $color
+ .t window create 1.2 -window .t.f
+ update
+ place .t.f -x 100 -y 50
+ update
+ list [winfo geom .t.f] [.t bbox 1.2]
+} -cleanup {
+ destroy .t.f
+} -result [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]]
+
+
+test textWind-8.1 {EmbWinDeleteProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.2 -window .f
+ bind .f <Destroy> {set x destroyed}
+ set x XXX
+ .t delete 1.2
+ list $x [.t bbox 1.2] [.t bbox 1.3] [winfo exists .f]
+} -result {destroyed {19 5 7 13} {26 5 7 13} 0}
+test textWind-8.2 {EmbWinDeleteProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.2 -window .f
+ bind .f <Destroy> {set x destroyed}
+ set x XXX
+ .t delete 1.2
+ .t index .f
+} -returnCodes error -result {bad text index ".f"}
+
+
+test textWind-9.1 {EmbWinCleanupProc procedure} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text\nA second line."
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 2.3 -window .f
+ .t delete 1.5 2.1
+ .t index .f
+} -cleanup {
+ destroy .f
+} -result {1.7}
+
+
+test textWind-10.1 {EmbWinLayoutProc procedure} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ .t window create 1.5 -create {
+ frame .f -width 10 -height 20 -bg $color
+ }
+ update
+ list [winfo exists .f] [winfo width .f] [winfo height .f] [.t index .f]
+} -cleanup {
+ destroy .f
+} -result {1 10 20 1.5}
+test textWind-10.2 {EmbWinLayoutProc procedure, error in creating window} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ proc bgerror args {
+ global msg
+ set msg $args
+ }
+} -body {
+ .t insert 1.0 "Some sample text"
+ .t window create 1.5 -create {
+ error "couldn't create window"
+ }
+ set msg xyzzy
+ update
+ list $msg [.t bbox 1.5]
+} -cleanup {
+ rename bgerror {}
+} -result {{{couldn't create window}} {40 11 0 0}}
+test textWind-10.3 {EmbWinLayoutProc procedure, error in creating window} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ proc bgerror args {
+ global msg
+ set msg $args
+ }
+} -body {
+ .t insert 1.0 "Some sample text"
+ .t window create 1.5 -create {
+ concat gorp
+ }
+ set msg xyzzy
+ update
+ list $msg [.t bbox 1.5]
+} -cleanup {
+ rename bgerror {}
+} -result {{{bad window path name "gorp"}} {40 11 0 0}}
+ .t delete 1.0 end
+ destroy .t.f
+ proc bgerror args {
+ global msg
+ if {[lsearch -exact $msg $args] == -1} {
+ lappend msg $args
+ }
+ }
+
+test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} -constraints {
+ textfonts
+} -setup {
+ .t delete 1.0 end
+ destroy .t.f
+ proc bgerror args {
+ global msg
+ if {[lsearch -exact $msg $args] == -1} {
+ lappend msg $args
+ }
+ }
+} -body {
+ .t insert 1.0 "Some sample text"
+ set msg {}
+ after idle {
+ .t window create 1.5 -create {
+ frame .t.f
+ frame .t.f.f -width 10 -height 20 -bg $color
+ }
+ }
+ set count 0
+ while {([llength $msg] < 2) && ($count < 100)} {
+ update
+ incr count
+ .t bbox 1.5
+ after 10
+ }
+ lappend msg [.t bbox 1.5] [winfo exists .t.f.f]
+} -cleanup {
+ destroy .t.f
+ rename bgerror {}
+} -result [list {{can't embed .t.f.f relative to .t}} {{window name "f" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0] 1]
+test textWind-10.5 {EmbWinLayoutProc procedure, error in creating window} -constraints {
+ textfonts
+} -setup {
+ .t delete 1.0 end
+ destroy .t.f
+ proc bgerror args {
+ global msg
+ if {[lsearch -exact $msg $args] == -1} {
+ lappend msg $args
+ }
+ }
+} -body {
+ .t insert 1.0 "Some sample text"
+ .t window create 1.5 -create {
+ frame .t.f
+ frame .t.f.f -width 10 -height 20 -bg $color
+ }
+ set msg {}
+ update idletasks
+ lappend msg [winfo exists .t.f.f]
+} -cleanup {
+ destroy .t.f
+ rename bgerror {}
+} -result {{{can't embed .t.f.f relative to .t}} 1}
+catch {destroy .t.f}
+test textWind-10.6 {EmbWinLayoutProc procedure, error in creating window} -constraints {
+ textfonts
+} -setup {
+ .t delete 1.0 end
+ proc bgerror args {
+ global msg
+ if {[lsearch -exact $msg $args] == -1} {
+ lappend msg $args
+ }
+ }
+} -body {
+ .t insert 1.0 "Some sample text"
+ .t window create 1.5 -create {
+ concat .t
+ }
+ set msg {}
+ update
+ lappend msg [.t bbox 1.5]
+} -cleanup {
+ rename bgerror {}
+} -result [list {{can't embed .t relative to .t}} [list 40 [expr {11+$fixedDiff/2}] 0 0]]
+test textWind-10.7 {EmbWinLayoutProc procedure, error in creating window} -constraints {
+ textfonts
+} -setup {
+ .t delete 1.0 end
+ destroy .t2
+ proc bgerror args {
+ global msg
+ if {[lsearch -exact $msg $args] == -1} {
+ lappend msg $args
+ }
+ }
+} -body {
+ .t insert 1.0 "Some sample text"
+ .t window create 1.5 -create {
+ toplevel .t2 -width 100 -height 150
+ wm geom .t2 +0+0
+ concat .t2
+ }
+ set msg {}
+ update
+ lappend msg [.t bbox 1.5]
+} -cleanup {
+ rename bgerror {}
+} -result [list {{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0]]
+test textWind-10.8 {EmbWinLayoutProc procedure, error in creating window} -setup {
+ .t delete 1.0 end
+ destroy .t2
+ proc bgerror args {
+ global msg
+ if {[lsearch -exact $msg $args] == -1} {
+ lappend msg $args
+ }
+ }
+} -body {
+ .t insert 1.0 "Some sample text"
+ .t window create 1.5 -create {
+ toplevel .t2 -width 100 -height 150
+ wm geom .t2 +0+0
+ concat .t2
+ }
+ set msg {}
+ update
+ set i 0
+ while {[llength $msg] == 1 && [incr i] < 200} { update }
+ return $msg
+} -cleanup {
+ destroy .t2
+ rename bgerror {}
+} -result {{{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}}}
+
+test textWind-10.9 {EmbWinLayoutProc procedure, steal window from self} -setup {
+ .t delete 1.0 end
+ destroy .t.b
+} -body {
+ .t insert 1.0 ABCDEFGHIJKLMNOP
+ button .t.b -text "Hello!"
+ .t window create 1.5 -window .t.b
+ update
+ .t window create 1.3 -create {concat .t.b}
+ update
+ .t index .t.b
+} -cleanup {
+ destroy .t.b
+} -result {1.3}
+test textWind-10.10 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap char
+ .t insert 1.0 "Some sample text"
+ frame .f -width 125 -height 20 -bg $color -bd 2 -relief raised
+ .t window create 1.12 -window .f
+ list [.t bbox .f] [.t bbox 1.13]
+} -cleanup {
+ destroy .f
+} -result {{89 5 126 20} {5 25 7 13}}
+test textWind-10.11 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap char
+ .t insert 1.0 "Some sample text"
+ frame .f -width 126 -height 20 -bg $color -bd 2 -relief raised
+ .t window create 1.12 -window .f
+ update
+ list [.t bbox .f] [.t bbox 1.13]
+} -cleanup {
+ destroy .f
+} -result {{89 5 126 20} {5 25 7 13}}
+test textWind-10.12 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap char
+ .t insert 1.0 "Some sample text"
+ frame .f -width 127 -height 20 -bg $color -bd 2 -relief raised
+ .t window create 1.12 -window .f
+ update
+ list [.t bbox .f] [.t bbox 1.13]
+} -cleanup {
+ destroy .f
+} -result {{5 18 127 20} {132 21 7 13}}
+test textWind-10.13 {EmbWinLayoutProc procedure, doesn't fit on line} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap none
+ .t insert 1.0 "Some sample text"
+ frame .f -width 130 -height 20 -bg $color -bd 2 -relief raised
+ .t window create 1.12 -window .f
+ update
+ list [.t bbox .f] [.t bbox 1.13]
+} -cleanup {
+ destroy .f
+} -result {{89 5 126 20} {}}
+test textWind-10.14 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap none
+ .t insert 1.0 "Some sample text"
+ frame .f -width 130 -height 220 -bg $color -bd 2 -relief raised
+ .t window create 1.12 -window .f
+ update
+ list [.t bbox .f] [.t bbox 1.13]
+} -cleanup {
+ destroy .f
+} -result {{89 5 126 78} {}}
+test textWind-10.15 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap char
+ .t insert 1.0 "Some sample text"
+ frame .f -width 250 -height 220 -bg $color -bd 2 -relief raised
+ .t window create 1.12 -window .f
+ update
+ list [.t bbox .f] [.t bbox 1.13]
+} -cleanup {
+ destroy .f
+} -result {{5 18 210 65} {}}
+
+
+test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} -setup {
+ .t delete 1.0 end
+ destroy .f
+ place forget .t
+ pack .t
+} -body {
+ .t insert 1.0 "Some sample text"
+ pack forget .t
+ place .t -x 30 -y 50
+ frame .f -width 30 -height 20 -bg $color
+ .t window create 1.12 -window .f
+ update
+ winfo geom .f
+} -cleanup {
+ destroy .f
+ place forget .t
+} -result {30x20+119+55}
+test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} -setup {
+ .t delete 1.0 end
+ destroy .t.f
+ place forget .t
+ pack .t
+} -body {
+ .t insert 1.0 "Some sample text"
+ pack forget .t
+ place .t -x 30 -y 50
+ frame .t.f -width 30 -height 20 -bg $color
+ .t window create 1.12 -window .t.f
+ update
+ winfo geom .t.f
+} -cleanup {
+ destroy .t.f
+ place forget .t
+ pack .t
+} -result {30x20+89+5}
+test textWind-11.3 {EmbWinDisplayProc procedure, configuration optimization} -setup {
+ .t delete 1.0 end
+ destroy .f
+ place forget .t
+ pack .t
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 30 -height 20 -bg $color
+ .t window create 1.12 -window .f
+ update
+ bind .f <Configure> {set x ".f configured"}
+ set x {no configures}
+ .t delete 1.0
+ .t insert 1.0 "X"
+ update
+ return $x
+} -cleanup {
+ destroy .f
+ place forget .t
+ pack .t
+} -result {no configures}
+test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ destroy .f .f2
+} -body {
+ .t insert 1.0 "xyzzy\nFirst window here: "
+ .t configure -wrap none
+ frame .f -width 30 -height 20 -bg $color
+ .t window create end -window .f
+ .t insert end " and second here: "
+ frame .f2 -width 40 -height 10 -bg $color
+ .t window create end -window .f2
+ .t insert end " with junk after it."
+ .t xview moveto 0
+ .t xview scroll 5 units
+ update
+ list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] [winfo ismapped .f2]
+} -cleanup {
+ destroy .f .f2
+} -result {1 30x20+103+18 {103 18 30 20} 0}
+test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ destroy .f .f2
+} -body {
+ .t insert 1.0 "xyzzy\nFirst window here: "
+ .t configure -wrap none
+ frame .f -width 30 -height 20 -bg $color
+ .t window create end -window .f
+ .t insert end " and second here: "
+ frame .f2 -width 40 -height 10 -bg $color
+ .t window create end -window .f2
+ .t insert end " with junk after it."
+ update
+ .t xview moveto 0
+ .t xview scroll 25 units
+ update
+ list [winfo ismapped .f] [winfo ismapped .f2] [winfo geom .f2] [.t bbox .f2]
+} -cleanup {
+ destroy .f .f2
+} -result {0 1 40x10+119+23 {119 23 40 10}}
+.t configure -wrap char
+
+
+test textWind-12.1 {EmbWinUndisplayProc procedure, mapping/unmapping} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 30 -height 20 -bg $color
+ .t window create 1.2 -window .f
+ bind .f <Map> {lappend x mapped}
+ bind .f <Unmap> {lappend x unmapped}
+ set x created
+ update
+ lappend x modified
+ .t delete 1.0
+ update
+ lappend x replaced
+ .t window configure .f -window {}
+ .t delete 1.1
+ .t window create 1.4 -window .f
+ update
+ lappend x off-screen
+ .t configure -wrap none
+ .t insert 1.0 "Enough text to make the line run off-screen"
+ update
+ return $x
+} -cleanup {
+ destroy .f
+} -result {created mapped modified replaced unmapped mapped off-screen unmapped}
+
+
+test textWind-13.1 {EmbWinBboxProc procedure} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 5 -height 5 -bg $color
+ .t window create 1.2 -window .f -align top -padx 2 -pady 1
+ update
+ list [winfo geom .f] [.t bbox .f]
+} -cleanup {
+ destroy .f
+} -result {5x5+21+6 {21 6 5 5}}
+test textWind-13.2 {EmbWinBboxProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 5 -height 5 -bg $color
+ .t window create 1.2 -window .f -align center -padx 2 -pady 1
+ update
+ list [winfo geom .f] [.t bbox .f]
+} -cleanup {
+ destroy .f
+} -result {5x5+21+9 {21 9 5 5}}
+test textWind-13.3 {EmbWinBboxProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 5 -height 5 -bg $color
+ .t window create 1.2 -window .f -align baseline -padx 2 -pady 1
+ update
+ list [winfo geom .f] [.t bbox .f]
+} -cleanup {
+ destroy .f
+} -result {5x5+21+10 {21 10 5 5}}
+test textWind-13.4 {EmbWinBboxProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 5 -height 5 -bg $color
+ .t window create 1.2 -window .f -align bottom -padx 2 -pady 1
+ update
+ list [winfo geom .f] [.t bbox .f]
+} -cleanup {
+ destroy .f
+} -result {5x5+21+12 {21 12 5 5}}
+test textWind-13.5 {EmbWinBboxProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 5 -height 5 -bg $color
+ .t window create 1.2 -window .f -align top -padx 2 -pady 1 -stretch 1
+ update
+ list [winfo geom .f] [.t bbox .f]
+} -cleanup {
+ destroy .f
+} -result {5x11+21+6 {21 6 5 11}}
+test textWind-13.6 {EmbWinBboxProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 5 -height 5 -bg $color
+ .t window create 1.2 -window .f -align center -padx 2 -pady 1 -stretch 1
+ update
+ list [winfo geom .f] [.t bbox .f]
+} -cleanup {
+ destroy .f
+} -result {5x11+21+6 {21 6 5 11}}
+test textWind-13.7 {EmbWinBboxProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 5 -height 5 -bg $color
+ .t window create 1.2 -window .f -align baseline -padx 2 -pady 1 -stretch 1
+ update
+ list [winfo geom .f] [.t bbox .f]
+} -cleanup {
+ destroy .f
+} -result {5x9+21+6 {21 6 5 9}}
+test textWind-13.8 {EmbWinBboxProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 5 -height 5 -bg $color
+ .t window create 1.2 -window .f -align bottom -padx 2 -pady 1 -stretch 1
+ update
+ list [winfo geom .f] [.t bbox .f]
+} -cleanup {
+ destroy .f
+} -result {5x11+21+6 {21 6 5 11}}
+test textWind-13.9 {EmbWinBboxProc procedure, spacing options} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -spacing1 5 -spacing3 2
+ .t delete 1.0 end
+ .t insert 1.0 "Some sample text"
+ frame .f -width 5 -height 5 -bg $color
+ .t window create 1.2 -window .f -align center -padx 2 -pady 1
+ update
+ list [winfo geom .f] [.t bbox .f]
+} -cleanup {
+ destroy .f
+} -result {5x5+21+14 {21 14 5 5}}
+
+
+test textWind-14.1 {EmbWinDelayedUnmap procedure} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 30 -height 20 -bg $color
+ .t window create 1.2 -window .f
+ update
+ bind .f <Unmap> {lappend x unmapped}
+ set x modified
+ .t insert 1.0 x
+ lappend x removed
+ .t window configure .f -window {}
+ lappend x updated
+ update
+ return $x
+} -cleanup {
+ destroy .f
+} -result {modified removed unmapped updated}
+test textWind-14.2 {EmbWinDelayedUnmap procedure} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 30 -height 20 -bg $color
+ .t window create 1.2 -window .f
+ update
+ bind .f <Unmap> {lappend x unmapped}
+ set x modified
+ .t insert 1.0 x
+ lappend x deleted
+ .t delete .f
+ lappend x updated
+ update
+ return $x
+} -cleanup {
+ destroy .f
+} -result {modified deleted updated}
+test textWind-14.3 {EmbWinDelayedUnmap procedure} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text\nAnother line\n3\n4\n5\n6\n7\n8\n9"
+ frame .f -width 30 -height 20 -bg $color
+ .t window create 1.2 -window .f
+ update
+ .t yview 2.0
+ set result [winfo ismapped .f]
+ update ; after 10
+ list $result [winfo ismapped .f]
+} -cleanup {
+ destroy .f
+} -result {1 0}
+test textWind-14.4 {EmbWinDelayedUnmap procedure} -setup {
+ .t delete 1.0 end
+ destroy .t.f
+} -body {
+ .t insert 1.0 "Some sample text\nAnother line\n3\n4\n5\n6\n7\n8\n9"
+ frame .t.f -width 30 -height 20 -bg $color
+ .t window create 1.2 -window .t.f
+ update
+ .t yview 2.0
+ set result [winfo ismapped .t.f]
+ update
+ list $result [winfo ismapped .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {1 0}
+
+
+test textWind-15.1 {TkTextWindowIndex procedure} -setup {
+ .t delete 1.0 end
+} -body {
+ .t index .foo
+} -returnCodes error -result {bad text index ".foo"}
+test textWind-15.2 {TkTextWindowIndex procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -spacing1 0 -spacing2 0 -spacing3 0 \
+ -wrap none
+ .t insert 1.0 "Some sample text"
+ frame .f -width 30 -height 20 -bg $color
+ .t window create 1.6 -window .f
+ .t tag add a 1.1
+ .t tag add a 1.3
+ list [.t index .f] [.t bbox 1.7]
+} -cleanup {
+ destroy .f
+} -result {1.6 {77 8 7 13}}
+
+
+test textWind-16.1 {EmbWinTextStructureProc procedure} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap none
+ .t insert 1.0 "Some sample text"
+ frame .f -width 30 -height 20 -bg $color
+ .t window create 1.6 -window .f
+ update
+ pack forget .t
+ update
+ winfo ismapped .f
+} -cleanup {
+ pack .t
+} -result 0
+test textWind-16.2 {EmbWinTextStructureProc procedure} -setup {
+ .t delete 1.0 end
+ destroy .f .f2
+} -body {
+ .t configure -spacing1 0 -spacing2 0 -spacing3 0 \
+ -wrap none
+ .t insert 1.0 "Some sample text"
+ frame .f -width 30 -height 20 -bg $color
+ .t window create 1.6 -window .f
+ update
+ set result {}
+ lappend result [winfo geom .f] [.t bbox .f]
+ frame .f2 -width 150 -height 30 -bd 2 -relief raised
+ pack .f2 -before .t
+ update
+ lappend result [winfo geom .f] [.t bbox .f]
+} -cleanup {
+ destroy .f .f2
+} -result {30x20+47+5 {47 5 30 20} 30x20+47+35 {47 5 30 20}}
+test textWind-16.3 {EmbWinTextStructureProc procedure} -setup {
+ .t delete 1.0 end
+} -body {
+ .t configure -wrap none
+ .t insert 1.0 "Some sample text"
+ .t window create 1.6
+ update
+ pack forget .t
+ update
+} -cleanup {
+ pack .t
+} -result {}
+test textWind-16.4 {EmbWinTextStructureProc procedure} -setup {
+ .t delete 1.0 end
+} -body {
+ .t configure -spacing1 0 -spacing2 0 -spacing3 0 \
+ -wrap none
+ .t insert 1.0 "Some sample text"
+ frame .t.f -width 30 -height 20 -bg $color
+ .t window create 1.6 -window .t.f
+ update
+ pack forget .t
+ update
+ list [winfo ismapped .t.f] [.t bbox .t.f]
+} -cleanup {
+ pack .t
+} -result {1 {47 5 30 20}}
+
+
+test textWind-17.1 {peer widgets and embedded windows} -setup {
+ destroy .t .tt .f
+} -body {
+ pack [text .t]
+ .t insert end "Line 1"
+ frame .f -width 20 -height 10 -bg blue
+ .t window create 1.3 -window .f
+ toplevel .tt
+ pack [.t peer create .tt.t]
+ update ; update
+ destroy .t .tt
+ winfo exists .f
+} -result {0}
+
+test textWind-17.2 {peer widgets and embedded windows} -setup {
+ destroy .t .f .tt
+} -body {
+ pack [text .t]
+ .t insert end "Line 1\nLine 2"
+ frame .f -width 20 -height 10 -bg blue
+ .t window create 1.4 -window .f
+ toplevel .tt
+ pack [.t peer create .tt.t]
+ update ; update
+ destroy .t
+ .tt.t insert 1.0 "foo"
+ update
+ destroy .tt
+} -result {}
+
+test textWind-17.3 {peer widget and -create} -setup {
+ destroy .t .tt
+} -body {
+ pack [text .t]
+ .t delete 1.0 end
+ .t insert 1.0 "Some sample text"
+ toplevel .tt
+ pack [.t peer create .tt.t]
+ update ; update
+ .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue}
+ update
+ destroy .t .tt
+} -result {}
+
+test textWind-17.4 {peer widget deleted one window shouldn't delete others} -setup {
+ destroy .t .tt
+ set res {}
+} -body {
+ pack [text .t]
+ .t delete 1.0 end
+ .t insert 1.0 "Some sample text"
+ toplevel .tt
+ pack [.t peer create .tt.t]
+ .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue}
+ update ; update
+ destroy .tt
+ lappend res [.t get 1.2]
+ update
+ lappend res [.t get 1.2]
+} -cleanup {
+ destroy .t
+} -result {{} {}}
+
+test textWind-17.5 {peer widget window configuration} -setup {
+ destroy .t .tt
+} -body {
+ pack [text .t]
+ .t delete 1.0 end
+ .t insert 1.0 "Some sample text"
+ toplevel .tt
+ pack [.t peer create .tt.t]
+ .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue}
+ update ; update
+ list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window]
+} -cleanup {
+ destroy .tt .t
+} -result {.t.f .tt.t.f}
+
+test textWind-17.6 {peer widget window configuration} -setup {
+ destroy .t .tt
+} -body {
+ pack [text .t]
+ .t delete 1.0 end
+ .t insert 1.0 "Some sample text"
+ toplevel .tt
+ pack [.t peer create .tt.t]
+ .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue}
+ update ; update
+ list [.t window configure 1.2 -window] \
+ [.tt.t window configure 1.2 -window]
+} -cleanup {
+ destroy .tt .t
+} -result {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}}
+
+test textWind-17.7 {peer widget window configuration} -setup {
+ destroy .t .tt
+} -body {
+ pack [text .t]
+ .t delete 1.0 end
+ .t insert 1.0 "Some sample text"
+ toplevel .tt
+ pack [.t peer create .tt.t]
+ .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue]
+ update ; update
+ list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window]
+} -cleanup {
+ destroy .tt .t
+} -result {.t.f {}}
+
+test textWind-17.8 {peer widget window configuration} -setup {
+ destroy .t .tt
+} -body {
+ pack [text .t]
+ .t delete 1.0 end
+ .t insert 1.0 "Some sample text"
+ toplevel .tt
+ pack [.t peer create .tt.t]
+ .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue]
+ update ; update
+ list [.t window configure 1.2 -window] \
+ [.tt.t window configure 1.2 -window]
+} -cleanup {
+ destroy .tt .t
+} -result {{-window {} {} {} .t.f} {-window {} {} {} {}}}
+
+test textWind-17.9 {peer widget window configuration} -setup {
+ destroy .t .tt
+} -body {
+ pack [text .t]
+ .t delete 1.0 end
+ .t insert 1.0 "Some sample text"
+ toplevel .tt
+ pack [.t peer create .tt.t]
+ .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue]
+ update ; update
+ .tt.t window configure 1.2 -window [frame .tt.t.f -width 10 -height 20 -bg red]
+ list [.t window configure 1.2 -window] [.tt.t window configure 1.2 -window]
+} -cleanup {
+ destroy .tt .t
+} -result {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}}
+
+test textWind-17.10 {peer widget window configuration} -setup {
+ destroy .t .tt
+} -body {
+ pack [text .t]
+ .t delete 1.0 end
+ .t insert 1.0 "Some sample text"
+ toplevel .tt
+ pack [.t peer create .tt.t]
+ .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue]
+ .tt.t window create 1.2 -window [frame .tt.t.f -width 25 -height 20 -bg blue]
+ update ; update
+ .t window configure 1.2 -create \
+ {destroy %W.f ; frame %W.f -width 50 -height 7 -bg red}
+ .tt.t window configure 1.2 -window {}
+ .t window configure 1.2 -window {}
+ set res [list [.t window configure 1.2 -window] \
+ [.tt.t window configure 1.2 -window]]
+ update
+ lappend res [.t window configure 1.2 -window] \
+ [.tt.t window configure 1.2 -window]
+} -cleanup {
+ destroy .tt .t
+} -result {{-window {} {} {} {}} {-window {} {} {} {}} {-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}}
+
+test textWind-18.1 {embedded window deletion triggered by a script bound to <Map>} -setup {
+ catch {destroy .t .f .f2}
+} -body {
+ pack [text .t]
+ for {set i 1} {$i < 100} {incr i} {.t insert end "Line $i\n"}
+ .t window create end -window [frame .f -background red -width 80 -height 80]
+ .t window create end -window [frame .f2 -background blue -width 80 -height 80]
+ bind .f <Map> {.t delete .f}
+ update
+ # this shall not crash (bug 1501749)
+ after 100 {.t yview end}
+ tkwait visibility .f2
+ update
+} -cleanup {
+ destroy .t .f .f2
+} -result {}
+
+option clear
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/tk.test b/tk8.6/tests/tk.test
new file mode 100644
index 0000000..748a6cf
--- /dev/null
+++ b/tk8.6/tests/tk.test
@@ -0,0 +1,184 @@
+# This file is a Tcl script to test the tk command.
+# It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2002 ActiveState Corporation.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+test tk-1.1 {tk command: general} -body {
+ tk
+} -returnCodes error -result {wrong # args: should be "tk subcommand ?arg ...?"}
+test tk-1.2 {tk command: general} -body {
+ tk xyz
+} -returnCodes error -result {unknown or ambiguous subcommand "xyz": must be appname, busy, caret, fontchooser, inactive, scaling, useinputmethods, or windowingsystem}
+
+# Value stored to restore default settings after 2.* tests
+set appname [tk appname]
+test tk-2.1 {tk command: appname} -body {
+ tk appname xyz abc
+} -returnCodes error -result {wrong # args: should be "tk appname ?newName?"}
+test tk-2.2 {tk command: appname} -body {
+ tk appname foobazgarply
+} -result {foobazgarply}
+test tk-2.3 {tk command: appname} -constraints unix -body {
+ tk appname bazfoogarply
+ expr {[lsearch -exact [winfo interps] [tk appname]] >= 0}
+} -result {1}
+test tk-2.4 {tk command: appname} -body {
+ tk appname [tk appname]
+} -result [tk appname]
+tk appname $appname
+
+# Value stored to restore default settings after 3.* tests
+set scaling [tk scaling]
+test tk-3.1 {tk command: scaling} -body {
+ tk scaling -displayof
+} -returnCodes error -result {value for "-displayof" missing}
+test tk-3.2 {tk command: scaling: get current} -body {
+ tk scaling 1
+ format %.2g [tk scaling]
+} -result 1
+test tk-3.3 {tk command: scaling: get current} -body {
+ tk scaling -displayof . 1.25
+ format %.3g [tk scaling]
+} -result 1.25
+test tk-3.4 {tk command: scaling: set new} -body {
+ tk scaling xyz
+} -returnCodes error -result {expected floating-point number but got "xyz"}
+test tk-3.5 {tk command: scaling: set new} -body {
+ tk scaling -displayof . xyz
+} -returnCodes error -result {expected floating-point number but got "xyz"}
+test tk-3.6 {tk command: scaling: set new} -body {
+ tk scaling 1
+ format %.2g [tk scaling]
+} -result 1
+test tk-3.7 {tk command: scaling: set new} -body {
+ tk scaling -displayof . 1.25
+ format %.3g [tk scaling]
+} -result 1.25
+test tk-3.8 {tk command: scaling: negative} -body {
+ tk scaling -1
+ expr {[tk scaling] > 0}
+} -result {1}
+test tk-3.9 {tk command: scaling: too big} -body {
+ tk scaling 1000000
+ expr {[tk scaling] < 10000}
+} -result {1}
+test tk-3.10 {tk command: scaling: widthmm} -body {
+ tk scaling 1.25
+ expr {int((25.4*[winfo screenwidth .])/(72*1.25) + 0.5) \
+ - [winfo screenmmwidth .]}
+} -result {0}
+test tk-3.11 {tk command: scaling: heightmm} -body {
+ tk scaling 1.25
+ expr {int((25.4*[winfo screenheight .])/(72*1.25) + 0.5) \
+ - [winfo screenmmheight .]}
+} -result {0}
+tk scaling $scaling
+
+# Value stored to restore default settings after 4.* tests
+set useim [tk useinputmethods]
+test tk-4.1 {tk command: useinputmethods} -body {
+ tk useinputmethods -displayof
+} -returnCodes error -result {value for "-displayof" missing}
+test tk-4.2 {tk command: useinputmethods: get current} -body {
+ tk useinputmethods no
+} -cleanup {
+ tk useinputmethods $useim
+} -result 0
+test tk-4.3 {tk command: useinputmethods: get current} -body {
+ tk useinputmethods no
+ tk useinputmethods -displayof .
+} -cleanup {
+ tk useinputmethods $useim
+} -result 0
+test tk-4.4 {tk command: useinputmethods: set new} -body {
+ tk useinputmethods xyz
+} -returnCodes error -result {expected boolean value but got "xyz"}
+test tk-4.5 {tk command: useinputmethods: set new} -body {
+ tk useinputmethods -displayof . xyz
+} -returnCodes error -result {expected boolean value but got "xyz"}
+test tk-4.6 {tk command: useinputmethods: set new} -body {
+ # This isn't really a test, but more of a check... The answer is what was
+ # given, because we may be on a Unix system that doesn't have the XIM
+ # stuff
+ if {[tk useinputmethods 1] == 0} {
+ puts "this wish doesn't have XIM (X Input Methods) support"
+ }
+ return $useim
+} -result $useim
+test tk-4.7 {tk command: useinputmethods: set new} -constraints win -body {
+ # Mac and Windows don't have X Input Methods, so this should always return
+ # 0
+ tk useinputmethods 1
+} -cleanup {
+ tk useinputmethods $useim
+} -result 0
+
+test tk-5.1 {tk caret} -body {
+ tk caret
+} -returnCodes error -result {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}
+test tk-5.2 {tk caret} -body {
+ tk caret bogus
+} -returnCodes error -result {bad window path name "bogus"}
+test tk-5.3 {tk caret} -body {
+ tk caret . -foo
+} -returnCodes error -result {bad caret option "-foo": must be -x, -y, or -height}
+test tk-5.4 {tk caret} -body {
+ tk caret . -x 0 -y
+} -returnCodes error -result {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}
+test tk-5.5 {tk caret} -body {
+ tk caret . -x 10 -y 11 -h 12; tk caret .
+} -result {-height 12 -x 10 -y 11}
+test tk-5.6 {tk caret} -body {
+ tk caret . -x 20 -y 25 -h 30; tk caret . -hei
+} -result {30}
+
+# tk inactive
+test tk-6.1 {tk inactive} -body {
+ string is integer [tk inactive]
+} -result 1
+test tk-6.2 {tk inactive reset} -body {
+ tk inactive reset
+} -returnCodes ok -match glob -result *
+test tk-6.3 {tk inactive wrong argument} -body {
+ tk inactive foo
+} -returnCodes 1 -result {bad option "foo": must be reset}
+test tk-6.4 {tk inactive too many arguments} -body {
+ tk inactive reset foo
+} -returnCodes 1 -result {wrong # args: should be "tk inactive ?-displayof window? ?reset?"}
+test tk-6.5 {tk inactive} -body {
+ tk inactive reset
+ update
+ after 100
+ set i [tk inactive]
+ expr {$i == -1 || ( $i > 90 && $i < 200 )}
+} -result 1
+
+test tk-7.1 {tk inactive in a safe interpreter} -body {
+# tk inactive in safe interpreters
+ safe::interpCreate foo
+ safe::loadTk foo
+ foo eval {tk inactive}
+} -cleanup {
+ ::safe::interpDelete foo
+} -result -1
+test tk-7.2 {tk inactive reset in a safe interpreter} -body {
+# tk inactive in safe interpreters
+ safe::interpCreate foo
+ safe::loadTk foo
+ foo eval {tk inactive reset}
+} -cleanup {
+ ::safe::interpDelete foo
+} -returnCodes 1 -result {resetting the user inactivity timer is not allowed in a safe interpreter}
+
+# tests of [tk busy] in busy.test
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/ttk/all.tcl b/tk8.6/tests/ttk/all.tcl
new file mode 100644
index 0000000..f03cd56
--- /dev/null
+++ b/tk8.6/tests/ttk/all.tcl
@@ -0,0 +1,20 @@
+# all.tcl --
+#
+# This file contains a top-level script to run all of the ttk
+# tests. Execute it by invoking "source all.tcl" when running tktest
+# in this directory.
+#
+# Copyright (c) 2007 by the Tk developers.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tk ;# This is the Tk test suite; fail early if no Tk!
+package require tcltest 2.2
+tcltest::configure {*}$argv
+tcltest::configure -testdir [file normalize [file dirname [info script]]]
+tcltest::configure -loadfile \
+ [file join [file dirname [tcltest::testsDirectory]] constraints.tcl]
+tcltest::configure -singleproc 1
+tcltest::runAllTests
+
diff --git a/tk8.6/tests/ttk/checkbutton.test b/tk8.6/tests/ttk/checkbutton.test
new file mode 100644
index 0000000..6b79287
--- /dev/null
+++ b/tk8.6/tests/ttk/checkbutton.test
@@ -0,0 +1,64 @@
+#
+# ttk::checkbutton widget tests.
+#
+
+package require Tk
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test checkbutton-1.1 "Checkbutton check" -body {
+ pack [ttk::checkbutton .cb -text "TCheckbutton" -variable cb]
+}
+test checkbutton-1.2 "Checkbutton invoke" -body {
+ .cb invoke
+ list [set ::cb] [.cb instate selected]
+} -result [list 1 1]
+test checkbutton-1.3 "Checkbutton reinvoke" -body {
+ .cb invoke
+ list [set ::cb] [.cb instate selected]
+} -result [list 0 0]
+
+test checkbutton-1.4 "Checkbutton variable" -body {
+ set result []
+ set ::cb 1
+ lappend result [.cb instate selected]
+ set ::cb 0
+ lappend result [.cb instate selected]
+} -result {1 0}
+
+test checkbutton-1.5 "Unset checkbutton variable" -body {
+ set result []
+ unset ::cb
+ lappend result [.cb instate alternate] [info exists ::cb]
+ set ::cb 1
+ lappend result [.cb instate alternate] [info exists ::cb]
+} -result {1 0 0 1}
+
+# See #1257319
+test checkbutton-1.6 "Checkbutton default variable" -body {
+ destroy .cb ; unset -nocomplain {} ; set result [list]
+ ttk::checkbutton .cb -onvalue on -offvalue off
+ lappend result [.cb cget -variable] [info exists .cb] [.cb state]
+ .cb invoke
+ lappend result [info exists .cb] [set .cb] [.cb state]
+ .cb invoke
+ lappend result [info exists .cb] [set .cb] [.cb state]
+} -result [list .cb 0 alternate 1 on selected 1 off {}]
+
+# Bug [109865fa01]
+test checkbutton-1.7 "Button destroyed by click" -body {
+ proc destroy_button {} {
+ destroy .top
+ }
+ toplevel .top
+ ttk::menubutton .top.mb -text Button -style TLabel
+ bind .top.mb <ButtonRelease-1> destroy_button
+ pack .top.mb
+ focus -force .top.mb
+ update
+ event generate .top.mb <1>
+ event generate .top.mb <ButtonRelease-1>
+ update ; # shall not trigger error invalid command name ".top.b"
+} -result {}
+
+tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/combobox.test b/tk8.6/tests/ttk/combobox.test
new file mode 100644
index 0000000..43f3cf1
--- /dev/null
+++ b/tk8.6/tests/ttk/combobox.test
@@ -0,0 +1,68 @@
+#
+# ttk::combobox widget tests
+#
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test combobox-1.0 "Combobox tests -- setup" -body {
+ ttk::combobox .cb
+} -result .cb
+
+test combobox-1.1 "Bad -values list" -body {
+ .cb configure -values "bad \{list"
+} -result "unmatched open brace in list" -returnCodes 1
+
+test combobox-1.end "Combobox tests -- cleanup" -body {
+ destroy .cb
+}
+
+test combobox-2.0 "current command" -body {
+ ttk::combobox .cb -values [list a b c d e a]
+ .cb current
+} -result -1
+
+test combobox-2.1 "current -- set index" -body {
+ .cb current 5
+ .cb get
+} -result a
+
+test combobox-2.2 "current -- change -values" -body {
+ .cb configure -values [list c b a d e]
+ .cb current
+} -result 2
+
+test combobox-2.3 "current -- change value" -body {
+ .cb set "b"
+ .cb current
+} -result 1
+
+test combobox-2.4 "current -- value not in list" -body {
+ .cb set "z"
+ .cb current
+} -result -1
+
+test combobox-2.end "Cleanup" -body { destroy .cb }
+
+
+test combobox-1890211 "ComboboxSelected event after listbox unposted" -body {
+ # whitebox test...
+ pack [ttk::combobox .cb -values [list a b c]]
+ set result [list]
+ bind .cb <<ComboboxSelected>> {
+ lappend result Event [winfo ismapped .cb.popdown] [.cb get]
+ }
+ lappend result Start 0 [.cb get]
+ ttk::combobox::Post .cb
+ lappend result Post [winfo ismapped .cb.popdown] [.cb get]
+ .cb.popdown.f.l selection clear 0 end; .cb.popdown.f.l selection set 1
+ ttk::combobox::LBSelected .cb.popdown.f.l
+ lappend result Select [winfo ismapped .cb.popdown] [.cb get]
+ update
+ set result
+} -result [list Start 0 {} Post 1 {} Select 0 b Event 0 b] -cleanup {
+ destroy .cb
+}
+
+tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/entry.test b/tk8.6/tests/ttk/entry.test
new file mode 100644
index 0000000..0c2f0be
--- /dev/null
+++ b/tk8.6/tests/ttk/entry.test
@@ -0,0 +1,283 @@
+#
+# Tile package: entry widget tests
+#
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+variable scrollInfo
+proc scroll args {
+ global scrollInfo
+ set scrollInfo $args
+}
+
+# Some of the tests raise background errors;
+# override default bgerror to catch them.
+#
+variable bgerror ""
+proc bgerror {error} {
+ variable bgerror $error
+ variable bgerrorInfo $::errorInfo
+ variable bgerrorCode $::errorCode
+}
+
+#
+test entry-1.1 "Create entry widget" -body {
+ ttk::entry .e
+} -result .e
+
+test entry-1.2 "Insert" -body {
+ .e insert end abcde
+ .e get
+} -result abcde
+
+test entry-1.3 "Selection" -body {
+ .e selection range 1 3
+ selection get
+} -result bc
+
+test entry-1.4 "Delete" -body {
+ .e delete 1 3
+ .e get
+} -result ade
+
+test entry-1.5 "Deletion - insert cursor" -body {
+ .e insert end abcde
+ .e icursor 0
+ .e delete 0 end
+ .e index insert
+} -result 0
+
+test entry-1.6 "Deletion - insert cursor at end" -body {
+ .e insert end abcde
+ .e icursor end
+ .e delete 0 end
+ .e index insert
+} -result 0
+
+test entry-1.7 "Deletion - insert cursor in the middle " -body {
+ .e insert end abcde
+ .e icursor 3
+ .e delete 0 end
+ .e index insert
+} -result 0
+
+test entry-1.done "Cleanup" -body { destroy .e }
+
+# Scrollbar tests.
+
+test entry-2.1 "Create entry before scrollbar" -body {
+ pack [ttk::entry .te -xscrollcommand [list .tsb set]] \
+ -expand true -fill both
+ pack [ttk::scrollbar .tsb -orient horizontal -command [list .te xview]] \
+ -expand false -fill x
+} -cleanup {destroy .te .tsb}
+
+test entry-2.2 "Initial scroll position" -body {
+ ttk::entry .e -font fixed -width 5 -xscrollcommand scroll
+ .e insert end "0123456789"
+ pack .e; update
+ set scrollInfo
+} -result {0.0 0.5} -cleanup { destroy .e }
+# NOTE: result can vary depending on font.
+
+# Bounding box / scrolling tests.
+test entry-3.0 "Series 3 setup" -body {
+ ttk::style theme use default
+ variable fixed fixed
+ variable cw [font measure $fixed a]
+ variable ch [font metrics $fixed -linespace]
+ variable bd 2 ;# border + padding
+ variable ux [font measure $fixed \u4e4e]
+
+ pack [ttk::entry .e -font $fixed -width 20]
+ update
+}
+
+test entry-3.1 "bbox widget command" -body {
+ .e delete 0 end
+ .e bbox 0
+} -result [list $bd $bd 0 $ch]
+
+test entry-3.2 "xview" -body {
+ .e delete 0 end;
+ .e insert end [string repeat "0" 40]
+ update idletasks
+ set result [.e xview]
+} -result {0.0 0.5}
+
+test entry-3.last "Series 3 cleanup" -body {
+ destroy .e
+}
+
+# Selection tests:
+
+test entry-4.0 "Selection test - setup" -body {
+ ttk::entry .e
+ .e insert end asdfasdf
+ .e selection range 0 end
+}
+
+test entry-4.1 "Selection test" -body {
+ selection get
+} -result asdfasdf
+
+test entry-4.2 "Disable -exportselection" -body {
+ .e configure -exportselection false
+ selection get
+} -returnCodes error -result "PRIMARY selection doesn't exist*" -match glob
+
+test entry-4.3 "Reenable -exportselection" -body {
+ .e configure -exportselection true
+ selection get
+} -result asdfasdf
+
+test entry-4.4 "Force selection loss" -body {
+ selection own .
+ .e index sel.first
+} -returnCodes error -result "selection isn't in widget .e"
+
+test entry-4.5 "Allow selection changes if readonly" -body {
+ .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]
+} -result {2 4}
+
+test entry-4.6 "Disallow selection changes if disabled" -body {
+ .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]
+} -result {0 10}
+
+test entry-4.7 {sel.first and sel.last gravity} -body {
+ set result [list]
+ .e delete 0 end
+ .e insert 0 0123456789
+ .e select range 2 6
+ .e insert 2 XXX
+ lappend result [.e index sel.first] [.e index sel.last]
+ .e insert 6 YYY
+ lappend result [.e index sel.first] [.e index sel.last] [.e get]
+} -result {5 9 5 12 01XXX2YYY3456789}
+
+# Self-destruct tests.
+
+test entry-5.1 {widget deletion while active} -body {
+ destroy .e
+ pack [ttk::entry .e]
+ update
+ .e config -xscrollcommand { destroy .e }
+ update idletasks
+ winfo exists .e
+} -result 0
+
+# TODO: test killing .e in -validatecommand, -invalidcommand, variable trace;
+
+
+# -textvariable tests.
+
+test entry-6.1 {Update linked variable in write trace} -body {
+ proc override args {
+ global x
+ set x "Overridden!"
+ }
+ catch {destroy .e}
+ set x ""
+ trace variable x w override
+ ttk::entry .e -textvariable x
+ .e insert 0 "Some text"
+ set result [list $x [.e get]]
+ set result
+} -result {Overridden! Overridden!} -cleanup {
+ unset x
+ rename override {}
+ destroy .e
+}
+
+test entry-6.2 {-textvariable tests} -body {
+ set result [list]
+ ttk::entry .e -textvariable x
+ set x "text"
+ lappend result [.e get]
+ unset x
+ lappend result [.e get]
+ .e insert end "newtext"
+ lappend result [.e get] [set x]
+} -result [list "text" "" "newtext" "newtext"] -cleanup {
+ destroy .e
+ unset -nocomplain x
+}
+
+test entry-7.1 {Bad style options} -body {
+ ttk::style theme create entry-7.1 -settings {
+ ttk::style configure TEntry -foreground BadColor
+ ttk::style map TEntry -foreground {readonly AnotherBadColor}
+ ttk::style map TEntry -font {readonly ABadFont}
+ ttk::style map TEntry \
+ -selectbackground {{} BadColor} \
+ -selectforeground {{} BadColor} \
+ -insertcolor {{} BadColor}
+ }
+ pack [ttk::entry .e -text "Don't crash"]
+ ttk::style theme use entry-7.1
+ update
+ .e selection range 0 end
+ update
+ .e state readonly;
+ update
+} -cleanup { destroy .e ; ttk::style theme use default }
+
+test entry-8.1 "Unset linked variable" -body {
+ variable foo "bar"
+ pack [ttk::entry .e -textvariable foo]
+ unset foo
+ .e insert end "baz"
+ list [.e cget -textvariable] [.e get] [set foo]
+} -result [list foo "baz" "baz"] -cleanup { destroy .e }
+
+test entry-8.2 "Unset linked variable by deleting namespace" -body {
+ namespace eval ::test { variable foo "bar" }
+ pack [ttk::entry .e -textvariable ::test::foo]
+ namespace delete ::test
+ .e insert end "baz" ;# <== error here
+ list [.e cget -textvariable] [.e get] [set foo]
+} -returnCodes error -result "*parent namespace doesn't exist*" -match glob
+# '-result [list ::test::foo "baz" "baz"]' would also be sensible,
+# but Tcl namespaces don't work that way.
+
+test entry-8.2a "Followup to test 8.2" -body {
+ .e cget -textvariable
+} -result ::test::foo -cleanup { destroy .e }
+# For 8.2a, -result {} would also be sensible.
+
+test entry-9.1 "Index range invariants" -setup {
+ # See bug#1721532 for discussion
+ proc entry-9.1-trace {n1 n2 op} {
+ set ::V NO!
+ }
+ variable V
+ trace add variable V write entry-9.1-trace
+ ttk::entry .e -textvariable V
+} -body {
+ set result [list]
+ .e insert insert a ; lappend result [.e index insert] [.e index end]
+ .e insert insert b ; lappend result [.e index insert] [.e index end]
+ .e insert insert c ; lappend result [.e index insert] [.e index end]
+ .e insert insert d ; lappend result [.e index insert] [.e index end]
+ .e insert insert e ; lappend result [.e index insert] [.e index end]
+ set result
+} -result [list 1 3 2 3 3 3 3 3 3 3] -cleanup {
+ unset V
+ destroy .e
+}
+
+tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/image.test b/tk8.6/tests/ttk/image.test
new file mode 100644
index 0000000..a55f7f8
--- /dev/null
+++ b/tk8.6/tests/ttk/image.test
@@ -0,0 +1,50 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test image-1.1 "Bad image element" -body {
+ ttk::style element create BadImage image badimage
+} -returnCodes error -result {image "badimage" doesn't exist}
+
+test image-1.2 "Duplicate element" -setup {
+ image create photo test.element -width 10 -height 10
+ ttk::style element create testElement image test.element
+} -body {
+ ttk::style element create testElement image test.element
+} -returnCodes 1 -result "Duplicate element testElement"
+
+test image-2.0 "Deletion of displayed image (label)" -setup {
+ image create photo test.image -width 10 -height 10
+} -body {
+ pack [set w [ttk::label .ttk_image20 -image test.image]]
+ tkwait visibility $w
+ image delete test.image
+ update
+} -cleanup {
+ destroy .ttk_image20
+} -result {}
+
+test image-2.1 "Deletion of displayed image (checkbutton)" -setup {
+ image create photo test.image -width 10 -height 10
+} -body {
+ pack [set w [ttk::checkbutton .ttk_image21 -image test.image]]
+ tkwait visibility $w
+ image delete test.image
+ update
+} -cleanup {
+ destroy .ttk_image21
+} -result {}
+
+test image-2.2 "Deletion of displayed image (radiobutton)" -setup {
+ image create photo test.image -width 10 -height 10
+} -body {
+ pack [set w [ttk::radiobutton .ttk_image22 -image test.image]]
+ tkwait visibility $w
+ image delete test.image
+ update
+} -cleanup {
+ destroy .ttk_image22
+} -result {}
+
+#
+tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/labelframe.test b/tk8.6/tests/ttk/labelframe.test
new file mode 100644
index 0000000..28b4d2e
--- /dev/null
+++ b/tk8.6/tests/ttk/labelframe.test
@@ -0,0 +1,130 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test labelframe-1.0 "Setup" -body {
+ pack [ttk::labelframe .lf] -expand true -fill both
+}
+
+test labelframe-2.1 "Can't use indirect descendant as labelwidget" -body {
+ ttk::frame .lf.t
+ ttk::checkbutton .lf.t.cb
+ .lf configure -labelwidget .lf.t.cb
+} -returnCodes 1 -result "can't *" -match glob \
+ -cleanup { destroy .lf.t } ;
+
+test labelframe-2.2 "Can't use toplevel as labelwidget" -body {
+ toplevel .lf.t
+ .lf configure -labelwidget .lf.t
+} -returnCodes 1 -result "can't *" -match glob \
+ -cleanup { destroy .lf.t } ;
+
+test labelframe-2.3 "Can't use non-windows as -labelwidget" -body {
+ .lf configure -labelwidget BogusWindowName
+} -returnCodes 1 -result {bad window path name "BogusWindowName"}
+
+test labelframe-2.4 "Can't use nonexistent-windows as -labelwidget" -body {
+ .lf configure -labelwidget .nosuchwindow
+} -returnCodes 1 -result {bad window path name ".nosuchwindow"}
+
+
+###
+# See also series labelframe-4.x
+#
+test labelframe-3.1 "Add child slave" -body {
+ checkbutton .lf.cb -text "abcde"
+ .lf configure -labelwidget .lf.cb
+ list [update; winfo viewable .lf.cb] [winfo manager .lf.cb]
+} -result [list 1 labelframe]
+
+test labelframe-3.2 "Remove child slave" -body {
+ .lf configure -labelwidget {}
+ list [update; winfo viewable .lf.cb] [winfo manager .lf.cb]
+} -result [list 0 {}]
+
+test labelframe-3.3 "Re-add child slave" -body {
+ .lf configure -labelwidget .lf.cb
+ list [update; winfo viewable .lf.cb] [winfo manager .lf.cb]
+} -result [list 1 labelframe]
+
+test labelframe-3.4 "Re-manage child slave" -body {
+ pack .lf.cb -side right
+ list [update; winfo viewable .lf.cb] [winfo manager .lf.cb] [.lf cget -labelwidget]
+} -result [list 1 pack {}]
+
+test labelframe-3.5 "Re-add child slave" -body {
+ .lf configure -labelwidget .lf.cb
+ list [update; winfo viewable .lf.cb] [winfo manager .lf.cb]
+} -result [list 1 labelframe]
+
+test labelframe-3.6 "Destroy child slave" -body {
+ destroy .lf.cb
+ .lf cget -labelwidget
+} -result {}
+
+###
+# Re-run series labelframe-3.x with nonchild slaves.
+#
+# @@@ ODDITY, 14 Nov 2005:
+# @@@ labelframe-4.1 fails if .cb is a [checkbutton],
+# @@@ but seems to succeed if it's some other widget class.
+# @@@ I suspect a race condition; unable to track it down ATM.
+#
+# @@@ FOLLOWUP: This *may* have been caused by a bug in ManagerIdleProc
+# @@@ (see manager.c r1.11). There's still probably a race condition in here.
+#
+test labelframe-4.1 "Add nonchild slave" -body {
+ checkbutton .cb -text "abcde"
+ .lf configure -labelwidget .cb
+ update
+ list [winfo ismapped .cb] [winfo viewable .cb] [winfo manager .cb]
+
+} -result [list 1 1 labelframe]
+
+test labelframe-4.2 "Remove nonchild slave" -body {
+ .lf configure -labelwidget {}
+ update;
+ list [winfo ismapped .cb] [winfo viewable .cb] [winfo manager .cb]
+} -result [list 0 0 {}]
+
+test labelframe-4.3 "Re-add nonchild slave" -body {
+ .lf configure -labelwidget .cb
+ list [update; winfo viewable .cb] [winfo manager .cb]
+} -result [list 1 labelframe]
+
+test labelframe-4.4 "Re-manage nonchild slave" -body {
+ pack .cb -side right
+ list [update; winfo viewable .cb] \
+ [winfo manager .cb] \
+ [.lf cget -labelwidget]
+} -result [list 1 pack {}]
+
+test labelframe-4.5 "Re-add nonchild slave" -body {
+ .lf configure -labelwidget .cb
+ list [update; winfo viewable .cb] \
+ [winfo manager .cb] \
+ [.lf cget -labelwidget]
+} -result [list 1 labelframe .cb]
+
+test labelframe-4.6 "Destroy nonchild slave" -body {
+ destroy .cb
+ .lf cget -labelwidget
+} -result {}
+
+test labelframe-5.0 "Cleanup" -body {
+ destroy .lf
+}
+
+# 1342876 -- labelframe should raise sibling -labelwidget above self.
+#
+test labelframe-6.1 "Stacking order" -body {
+ toplevel .t
+ pack [ttk::checkbutton .t.x1]
+ pack [ttk::labelframe .t.lf -labelwidget [ttk::label .t.lb]]
+ pack [ttk::checkbutton .t.x2]
+ winfo children .t
+} -cleanup {
+ destroy .t
+} -result [list .t.x1 .t.lf .t.lb .t.x2]
+
+tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/layout.test b/tk8.6/tests/ttk/layout.test
new file mode 100644
index 0000000..814e1d9
--- /dev/null
+++ b/tk8.6/tests/ttk/layout.test
@@ -0,0 +1,25 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test layout-1.1 "Size computations for mixed-orientation layouts" -body {
+ ttk::style theme use default
+
+ set block [image create photo -width 10 -height 10]
+ ttk::style element create block image $block
+ ttk::style layout Blocks {
+ border -children { block } -side left
+ border -children { block } -side top
+ border -children { block } -side bottom
+ }
+ ttk::style configure Blocks -borderwidth 1 -relief raised
+ ttk::button .b -style Blocks
+
+ pack .b -expand true -fill both
+
+ list [winfo reqwidth .b] [winfo reqheight .b]
+
+} -cleanup { destroy .b } -result [list 24 24]
+
+
+tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/notebook.test b/tk8.6/tests/ttk/notebook.test
new file mode 100644
index 0000000..3a2a6ff
--- /dev/null
+++ b/tk8.6/tests/ttk/notebook.test
@@ -0,0 +1,514 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test notebook-1.0 "Setup" -body {
+ ttk::notebook .nb
+} -result .nb
+
+#
+# Error handling tests:
+#
+test notebook-1.1 "Cannot add ancestor" -body {
+ .nb add .
+} -returnCodes error -result "*" -match glob
+
+proc inoperative {args} {}
+
+inoperative test notebook-1.2 "Cannot add siblings" -body {
+ # This is legal now
+ .nb add [frame .sibling]
+} -returnCodes error -result "*" -match glob
+
+test notebook-1.3 "Cannot add toplevel" -body {
+ .nb add [toplevel .nb.t]
+} -cleanup {
+ destroy .t.nb
+} -returnCodes 1 -match glob -result "can't add .nb.t*"
+
+test notebook-1.4 "Try to select bad tab" -body {
+ .nb select @6000,6000
+} -returnCodes 1 -match glob -result "* not found"
+
+#
+# Now add stuff:
+#
+test notebook-2.0 "Add children" -body {
+ pack .nb -expand true -fill both
+ .nb add [frame .nb.foo] -text "Foo"
+ pack [label .nb.foo.l -text "Foo"]
+
+ .nb add [frame .nb.bar -relief raised -borderwidth 2] -text "Bar"
+ pack [label .nb.bar.l -text "Bar"]
+
+ .nb tabs
+} -result [list .nb.foo .nb.bar]
+
+test notebook-2.1 "select pane" -body {
+ .nb select .nb.foo
+ update
+ list [winfo viewable .nb.foo] [winfo viewable .nb.bar] [.nb index current]
+} -result [list 1 0 0]
+
+test notebook-2.2 "select another pane" -body {
+ .nb select 1
+ update
+ list [winfo viewable .nb.foo] [winfo viewable .nb.bar] [.nb index current]
+} -result [list 0 1 1]
+
+test notebook-2.3 "tab - get value" -body {
+ .nb tab .nb.foo -text
+} -result "Foo"
+
+test notebook-2.4 "tab - set value" -body {
+ .nb tab .nb.foo -text "Changed Foo"
+ .nb tab .nb.foo -text
+} -result "Changed Foo"
+
+test notebook-2.5 "tab - get all options" -body {
+ .nb tab .nb.foo
+} -result [list \
+ -padding 0 -sticky nsew \
+ -state normal -text "Changed Foo" -image "" -compound none -underline -1]
+
+test notebook-4.1 "Test .nb index end" -body {
+ .nb index end
+} -result 2
+
+test notebook-4.2 "'end' is not a selectable index" -body {
+ .nb select end
+} -returnCodes error -result "*" -match glob
+
+test notebook-4.3 "Select index out of range" -body {
+ .nb select 2
+} -returnCodes error -result "*" -match glob
+
+test notebook-4.4 "-padding option" -body {
+ .nb configure -padding "5 5 5 5"
+}
+
+test notebook-4.end "Cleanup test suite 1-4.*" -body { destroy .nb }
+
+test notebook-5.1 "Virtual events" -body {
+ toplevel .t
+ set ::events [list]
+ bind .t <<NotebookTabChanged>> { lappend events changed %W }
+
+ pack [set nb [ttk::notebook .t.nb]] -expand true -fill both; update
+ $nb add [frame $nb.f1]
+ $nb add [frame $nb.f2]
+ $nb add [frame $nb.f3]
+
+ $nb select $nb.f1
+ update; set events
+} -result [list changed .t.nb]
+
+test notebook-5.2 "Virtual events, continued" -body {
+ set events [list]
+ $nb select $nb.f3
+ update ; set events
+} -result [list changed .t.nb]
+# OR: [list deselected .t.nb.f1 selected .t.nb.f3 changed .t.nb]
+
+test notebook-5.3 "Disabled tabs" -body {
+ set events [list]
+ $nb tab $nb.f2 -state disabled
+ $nb select $nb.f2
+ update
+ list $events [$nb index current]
+} -result [list [list] 2]
+
+test notebook-5.4 "Reenable tab" -body {
+ set events [list]
+ $nb tab $nb.f2 -state normal
+ $nb select $nb.f2
+ update
+ list $events [$nb index current]
+} -result [list [list changed .t.nb] 1]
+
+test notebook-5.end "Virtual events, cleanup" -body { destroy .t }
+
+test notebook-6.0 "Select hidden tab" -setup {
+ set nb [ttk::notebook .nb]
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ $nb tab $nb.f1 -state hidden
+ lappend result [$nb tab $nb.f1 -state]
+ $nb select $nb.f1
+ lappend result [$nb tab $nb.f1 -state]
+} -result [list hidden normal]
+
+test notebook-6.1 "Hide selected tab" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb hide $nb.f2
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ update idletasks; lappend result [winfo ismapped $nb.f3]
+} -result [list 1 1 2 0 1]
+
+# See 1370833
+test notebook-6.2 "Forget selected tab" -setup {
+ ttk::notebook .n
+ pack .n
+ label .n.l -text abc
+ .n add .n.l
+} -body {
+ update
+ after 100
+ .n forget .n.l
+ update ;# Yowch!
+} -cleanup {
+ destroy .n
+} -result {}
+
+test notebook-6.3 "Hide first tab when it's the current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f1
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f1]
+ $nb hide $nb.f1
+ lappend result [$nb index current] [winfo ismapped $nb.f1]
+} -result [list 0 1 1 0]
+
+test notebook-6.4 "Forget first tab when it's the current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f1
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f1]
+ $nb forget $nb.f1
+ lappend result [$nb index current] [winfo ismapped $nb.f1]
+} -result [list 0 1 0 0]
+
+test notebook-6.5 "Hide last tab when it's the current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f3
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f3]
+ $nb hide $nb.f3
+ lappend result [$nb index current] [winfo ismapped $nb.f3]
+} -result [list 2 1 1 0]
+
+test notebook-6.6 "Forget a middle tab when it's the current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb forget $nb.f2
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 1 0]
+
+test notebook-6.7 "Hide a middle tab when it's the current" -setup {
+ pack [set nb [ttk::notebook .nb]]; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb hide $nb.f2
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 2 0]
+
+test notebook-6.8 "Forget a non-current tab < current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb forget $nb.f1
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 0 1]
+
+test notebook-6.9 "Hide a non-current tab < current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb hide $nb.f1
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 1 1]
+
+test notebook-6.10 "Forget a non-current tab > current" -setup {
+ pack [set nb [ttk::notebook .nb]] ; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb forget $nb.f3
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 1 1]
+
+test notebook-6.11 "Hide a non-current tab > current" -setup {
+ pack [set nb [ttk::notebook .nb]]; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+ $nb hide $nb.f3
+ lappend result [$nb index current] [winfo ismapped $nb.f2]
+} -result [list 1 1 1 1]
+
+test notebook-6.12 "Hide and re-add a tab" -setup {
+ pack [set nb [ttk::notebook .nb]]; update
+ $nb add [ttk::frame $nb.f1]
+ $nb add [ttk::frame $nb.f2]
+ $nb add [ttk::frame $nb.f3]
+ $nb select $nb.f2
+} -cleanup {
+ destroy $nb
+} -body {
+ set result [list]
+ lappend result [$nb index current] [$nb tab $nb.f2 -state]
+ $nb hide $nb.f2
+ lappend result [$nb index current] [$nb tab $nb.f2 -state]
+ $nb add $nb.f2
+ lappend result [$nb index current] [$nb tab $nb.f2 -state]
+} -result [list 1 normal 2 hidden 2 normal]
+
+#
+# Insert:
+#
+unset nb
+test notebook-7.0 "insert - setup" -body {
+ pack [ttk::notebook .nb]
+ for {set i 0} {$i < 5} {incr i} {
+ .nb add [ttk::frame .nb.f$i] -text "$i"
+ }
+ .nb select .nb.f1
+ list [.nb index current] [.nb tabs]
+} -result [list 1 [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]]
+
+test notebook-7.1 "insert - move backwards" -body {
+ .nb insert 1 3
+ list [.nb index current] [.nb tabs]
+} -result [list 2 [list .nb.f0 .nb.f3 .nb.f1 .nb.f2 .nb.f4]]
+
+test notebook-7.2 "insert - move backwards again" -body {
+ .nb insert 1 3
+ list [.nb index current] [.nb tabs]
+} -result [list 3 [list .nb.f0 .nb.f2 .nb.f3 .nb.f1 .nb.f4]]
+
+test notebook-7.3 "insert - move backwards again" -body {
+ .nb insert 1 3
+ list [.nb index current] [.nb tabs]
+} -result [list 1 [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]]
+
+test notebook-7.4 "insert - move forwards" -body {
+ .nb insert 3 1
+ list [.nb index current] [.nb tabs]
+} -result [list 3 [list .nb.f0 .nb.f2 .nb.f3 .nb.f1 .nb.f4]]
+
+test notebook-7.5 "insert - move forwards again" -body {
+ .nb insert 3 1
+ list [.nb index current] [.nb tabs]
+} -result [list 2 [list .nb.f0 .nb.f3 .nb.f1 .nb.f2 .nb.f4]]
+
+test notebook-7.6 "insert - move forwards again" -body {
+ .nb insert 3 1
+ list [.nb index current] [.nb tabs]
+} -result [list 1 [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]]
+
+test notebook-7.7a "insert - current tab undisturbed" -body {
+ .nb select 0
+ .nb insert 3 1
+ .nb index current
+} -result 0
+
+test notebook-7.7b "insert - current tab undisturbed" -body {
+ .nb select 0
+ .nb insert 1 3
+ .nb index current
+} -result 0
+
+test notebook-7.7c "insert - current tab undisturbed" -body {
+ .nb select 4
+ .nb insert 3 1
+ .nb index current
+} -result 4
+
+test notebook-7.7d "insert - current tab undisturbed" -body {
+ .nb select 4
+ .nb insert 1 3
+ .nb index current
+} -result 4
+
+test notebook-7.8a "move tabs - current tab undisturbed - exhaustive" -body {
+ .nb select .nb.f0
+ foreach i {0 1 2 3 4} {
+ .nb insert $i .nb.f$i
+ }
+
+ foreach i {0 1 2 3 4} {
+ .nb select .nb.f$i
+ foreach j {0 1 2 3 4} {
+ foreach k {0 1 2 3 4} {
+ .nb insert $j $k
+ set current [lindex [.nb tabs] [.nb index current]]
+ if {$current != ".nb.f$i"} {
+ error "($i,$j,$k) current = $current"
+ }
+ .nb insert $k $j
+ if {[.nb tabs] ne [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]} {
+ error "swap $j $k; swap $k $j => [.nb tabs]"
+ }
+ }
+ }
+ }
+ .nb tabs
+} -result [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]
+
+test notebook-7.8b "insert new - current tab undisturbed - exhaustive" -body {
+ foreach i {0 1 2 3 4} {
+ .nb select .nb.f$i
+ foreach j {0 1 2 3 4} {
+.nb select .nb.f$i
+ .nb insert $j [frame .nb.newf]
+ set current [lindex [.nb tabs] [.nb index current]]
+ if {$current != ".nb.f$i"} {
+ puts stderr "new tab at $j, current = $current, expect .nb.f$i"
+ }
+ destroy .nb.newf
+ if {[.nb tabs] ne [list .nb.f0 .nb.f1 .nb.f2 .nb.f3 .nb.f4]} {
+ error "tabs disturbed"
+ }
+ }
+ }
+}
+
+test notebook-7.end "insert - cleanup" -body {
+ destroy .nb
+}
+
+test notebook-1817596-1 "insert should autoselect first tab" -body {
+ pack [ttk::notebook .nb]
+ list \
+ [.nb insert end [ttk::label .nb.l1 -text One] -text One] \
+ [.nb select] \
+ ;
+} -result [list "" .nb.l1] -cleanup { destroy .nb }
+
+test notebook-1817596-2 "error in insert should have no effect" -body {
+ pack [ttk::notebook .nb]
+ .nb insert end [ttk::label .nb.l1]
+ .nb insert end [ttk::label .nb.l2]
+ list \
+ [catch { .nb insert .l2 0 -badoption badvalue } err] \
+ [.nb tabs] \
+} -result [list 1 [list .nb.l1 .nb.l2]] -cleanup { destroy .nb }
+
+test notebook-1817596-3 "insert/configure" -body {
+ pack [ttk::notebook .nb]
+ .nb insert end [ttk::label .nb.l0] -text "L0"
+ .nb insert end [ttk::label .nb.l1] -text "L1"
+ .nb insert end [ttk::label .nb.l2] -text "XX"
+ .nb insert 0 2 -text "L2"
+
+ list [.nb tabs] [.nb tab 0 -text] [.nb tab 1 -text] [.nb tab 2 -text]
+
+} -result [list [list .nb.l2 .nb.l0 .nb.l1] L2 L0 L1] -cleanup { destroy .nb }
+
+test notebook-readd-1 "add same widget twice" -body {
+ pack [ttk::notebook .nb]
+ .nb add [ttk::button .nb.b1] -text "Button"
+ .nb add .nb.b1
+ .nb tabs
+} -result [list .nb.b1] -cleanup { destroy .nb }
+
+test notebook-readd-2 "add same widget twice, with options" -body {
+ pack [ttk::notebook .nb]
+ .nb add [ttk::button .nb.b1] -text "Tab label"
+ .nb add .nb.b1 -text "Changed tab label"
+ .nb tabs
+} -result [list .nb.b1] -cleanup { destroy .nb }
+
+test notebook-readd-3 "insert same widget twice, with options" -body {
+ pack [ttk::notebook .nb]
+ .nb insert end [ttk::button .nb.b1] -text "Tab label"
+ .nb insert end .nb.b1 -text "Changed tab label"
+ .nb tabs
+} -result [list .nb.b1] -cleanup { destroy .nb }
+
+
+# See #1343984
+test notebook-1343984-1 "don't autoselect on destroy - setup" -body {
+ ttk::notebook .nb
+ set ::history [list]
+ bind TestFrame <Map> { lappend history MAP %W }
+ bind TestFrame <Destroy> { lappend history DESTROY %W }
+ .nb add [ttk::frame .nb.frame1 -class TestFrame] -text "Frame 1"
+ .nb add [ttk::frame .nb.frame2 -class TestFrame] -text "Frame 2"
+ .nb add [ttk::frame .nb.frame3 -class TestFrame] -text "Frame 3"
+ pack .nb -fill both -expand 1
+ update
+ set ::history
+} -result [list MAP .nb.frame1]
+
+test notebook-1343984-2 "don't autoselect on destroy" -body {
+ set ::history [list]
+ destroy .nb
+ update
+ set ::history
+} -result [list DESTROY .nb.frame1 DESTROY .nb.frame2 DESTROY .nb.frame3]
+
+tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/panedwindow.test b/tk8.6/tests/ttk/panedwindow.test
new file mode 100644
index 0000000..7fe5c87
--- /dev/null
+++ b/tk8.6/tests/ttk/panedwindow.test
@@ -0,0 +1,291 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+proc propagate-geometry {} { update idletasks }
+
+# Basic sanity checks:
+#
+test panedwindow-1.0 "Setup" -body {
+ ttk::panedwindow .pw
+} -result .pw
+
+test panedwindow-1.1 "Make sure empty panedwindow doesn't crash" -body {
+ pack .pw -expand true -fill both
+ update
+}
+
+test panedwindow-1.2 "Add a pane" -body {
+ .pw add [ttk::frame .pw.f1]
+ winfo manager .pw.f1
+} -result "panedwindow"
+
+test panedwindow-1.3 "Steal pane" -body {
+ pack .pw.f1 -side bottom
+ winfo manager .pw.f1
+} -result "pack"
+
+test panedwindow-1.4 "Make sure empty panedwindow still doesn't crash" -body {
+ update
+}
+
+test panedwindow-1.5 "Remanage pane" -body {
+ #XXX .pw insert 0 .pw.f1
+ .pw add .pw.f1
+ winfo manager .pw.f1
+} -result "panedwindow"
+
+test panedwindow-1.6 "Forget pane" -body {
+ .pw forget .pw.f1
+ winfo manager .pw.f1
+} -result ""
+
+test panedwindow-1.7 "Make sure empty panedwindow still still doesn't crash" -body {
+ update
+}
+
+test panedwindow-1.8 "Re-forget pane" -body {
+ .pw forget .pw.f1
+} -returnCodes 1 -result ".pw.f1 is not managed by .pw"
+
+test panedwindow-1.end "Cleanup" -body {
+ destroy .pw
+}
+
+# Resize behavior:
+#
+test panedwindow-2.1 "..." -body {
+ ttk::panedwindow .pw -orient horizontal
+
+ .pw add [listbox .pw.l1]
+ .pw add [listbox .pw.l2]
+ .pw add [listbox .pw.l3]
+ .pw add [listbox .pw.l4]
+
+ pack .pw -expand true -fill both
+ update
+ set w1 [winfo width .]
+
+ # This should make the window shrink:
+ destroy .pw.l2
+
+ update
+ set w2 [winfo width .]
+
+ expr {$w2 < $w1}
+} -result 1
+
+test panedwindow-2.2 "..., cont'd" -body {
+
+ # This should keep the window from shrinking:
+ wm geometry . [wm geometry .]
+
+ set rw2 [winfo reqwidth .pw]
+
+ destroy .pw.l1
+ update
+
+ set w3 [winfo width .]
+ set rw3 [winfo reqwidth .pw]
+
+ expr {$w3 == $w2 && $rw3 < $rw2}
+ # problem: [winfo reqwidth] shrinks, but sashes haven't moved
+ # since we haven't gotten a ConfigureNotify.
+ # How to (a) check for this, and (b) fix it?
+} -result 1
+
+test panedwindow-2.3 "..., cont'd" -body {
+
+ .pw add [listbox .pw.l5]
+ update
+ set rw4 [winfo reqwidth .pw]
+
+ expr {$rw4 > $rw3}
+} -result 1
+
+test panedwindow-2.end "Cleanup" -body { destroy .pw }
+
+#
+# ...
+#
+test panedwindow-3.0 "configure pane" -body {
+ ttk::panedwindow .pw
+ .pw add [listbox .pw.lb1]
+ .pw add [listbox .pw.lb2]
+ .pw pane 1 -weight 2
+ .pw pane 1 -weight
+} -result 2
+
+test panedwindow-3.1 "configure pane -- errors" -body {
+ .pw pane 1 -weight -4
+} -returnCodes 1 -match glob -result "-weight must be nonnegative"
+
+test panedwindow-3.2 "add pane -- errors" -body {
+ .pw add [ttk::label .pw.l] -weight -1
+} -returnCodes 1 -match glob -result "-weight must be nonnegative"
+
+
+test panedwindow-3.end "cleanup" -body { destroy .pw }
+
+
+test panedwindow-4.1 "forget" -body {
+ pack [ttk::panedwindow .pw -orient vertical] -expand true -fill both
+ .pw add [label .pw.l1 -text "L1"]
+ .pw add [label .pw.l2 -text "L2"]
+ .pw add [label .pw.l3 -text "L3"]
+ .pw add [label .pw.l4 -text "L4"]
+
+ update
+
+ .pw forget .pw.l1
+ .pw forget .pw.l2
+ .pw forget .pw.l3
+ .pw forget .pw.l4
+ update
+}
+
+test panedwindow-4.2 "forget forgotten" -body {
+ .pw forget .pw.l1
+} -returnCodes 1 -result ".pw.l1 is not managed by .pw"
+
+# checkorder $winlist --
+# Ensure that Y coordinates windows in $winlist are strictly increasing.
+#
+proc checkorder {winlist} {
+ set pos -1
+ set positions [list]
+ foreach win $winlist {
+ lappend positions [set nextpos [winfo y $win]]
+ if {$nextpos <= $pos} {
+ error "window $win out of order ($positions)"
+ }
+ set pos $nextpos
+ }
+}
+
+test panedwindow-4.3 "insert command" -body {
+ .pw insert end .pw.l1
+ .pw insert end .pw.l3
+ .pw insert 1 .pw.l2
+ .pw insert end .pw.l4
+
+ update;
+ checkorder {.pw.l1 .pw.l2 .pw.l3 .pw.l4}
+}
+
+test panedwindow-4.END "cleanup" -body {
+ destroy .pw
+}
+
+# See #1292219
+
+test panedwindow-5.1 "Propagate Map/Unmap state to children" -body {
+ set result [list]
+ pack [ttk::panedwindow .pw]
+ .pw add [ttk::button .pw.b]
+ update
+
+ lappend result [winfo ismapped .pw] [winfo ismapped .pw.b]
+
+ pack forget .pw
+ update
+ lappend result [winfo ismapped .pw] [winfo ismapped .pw.b]
+
+ set result
+} -result [list 1 1 0 0] -cleanup {
+ destroy .pw
+}
+
+### sashpos tests.
+#
+proc sashpositions {pw} {
+ set positions [list]
+ set npanes [llength [winfo children $pw]]
+ for {set i 0} {$i < $npanes - 1} {incr i} {
+ lappend positions [$pw sashpos $i]
+ }
+ return $positions
+}
+
+test paned-sashpos-setup "Setup for sash position test" -body {
+ ttk::style theme use default
+ ttk::style configure -sashthickness 5
+
+ ttk::panedwindow .pw
+ .pw add [frame .pw.f1 -width 20 -height 20]
+ .pw add [frame .pw.f2 -width 20 -height 20]
+ .pw add [frame .pw.f3 -width 20 -height 20]
+ .pw add [frame .pw.f4 -width 20 -height 20]
+
+ propagate-geometry
+ list [winfo reqwidth .pw] [winfo reqheight .pw]
+} -result [list 20 [expr {20*4 + 5*3}]]
+
+test paned-sashpos-attempt-restore "Attempt to set sash positions" -body {
+ # This is not expected to succeed, since .pw isn't large enough yet.
+ #
+ .pw sashpos 0 30
+ .pw sashpos 1 60
+ .pw sashpos 2 90
+
+ list [winfo reqwidth .pw] [winfo reqheight .pw] [sashpositions .pw]
+} -result [list 20 95 [list 0 5 10]]
+
+test paned-sashpos-restore "Set height then sash positions" -body {
+ # Setting sash positions after setting -height _should_ succeed.
+ #
+ .pw configure -height 120
+ .pw sashpos 0 30
+ .pw sashpos 1 60
+ .pw sashpos 2 90
+ list [winfo reqwidth .pw] [winfo reqheight .pw] [sashpositions .pw]
+} -result [list 20 120 [list 30 60 90]]
+
+test paned-sashpos-cleanup "Clean up" -body { destroy .pw }
+
+test paned-propagation-setup "Setup." -body {
+ ttk::style theme use default
+ ttk::style configure -sashthickness 5
+ wm geometry . {}
+ ttk::panedwindow .pw -orient vertical
+
+ frame .pw.f1 -width 100 -height 50
+ frame .pw.f2 -width 100 -height 50
+
+ list [winfo reqwidth .pw.f1] [winfo reqheight .pw.f1]
+} -result [list 100 50]
+
+test paned-propagation-1 "Initial request size" -body {
+ .pw add .pw.f1
+ .pw add .pw.f2
+ propagate-geometry
+ list [winfo reqwidth .pw] [winfo reqheight .pw]
+} -result [list 100 105]
+
+test paned-propagation-2 "Slave change before map" -body {
+ .pw.f1 configure -width 200 -height 100
+ propagate-geometry
+ list [winfo reqwidth .pw] [winfo reqheight .pw]
+} -result [list 200 155]
+
+test paned-propagation-3 "Map window" -body {
+ pack .pw -expand true -fill both
+ update
+ list [winfo width .pw] [winfo height .pw] [.pw sashpos 0]
+} -result [list 200 155 100]
+
+test paned-propagation-4 "Slave change after map, off-axis" -body {
+ .pw.f1 configure -width 100 ;# should be granted
+ propagate-geometry
+ list [winfo reqwidth .pw] [winfo reqheight .pw] [.pw sashpos 0]
+} -result [list 100 155 100]
+
+test paned-propagation-5 "Slave change after map, on-axis" -body {
+ .pw.f1 configure -height 50 ;# should be denied
+ propagate-geometry
+ list [winfo reqwidth .pw] [winfo reqheight .pw] [.pw sashpos 0]
+} -result [list 100 155 100]
+
+test paned-propagation-cleanup "Clean up." -body { destroy .pw }
+
+tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/progressbar.test b/tk8.6/tests/ttk/progressbar.test
new file mode 100644
index 0000000..b9add86
--- /dev/null
+++ b/tk8.6/tests/ttk/progressbar.test
@@ -0,0 +1,85 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+
+test progressbar-1.1 "Setup" -body {
+ ttk::progressbar .pb
+} -result .pb
+
+test progressbar-1.2 "Linked variable" -body {
+ set PB 50
+ .pb configure -variable PB
+ .pb cget -value
+} -result 50
+
+test progressbar-1.3 "Change linked variable" -body {
+ set PB 80
+ .pb cget -value
+} -result 80
+
+test progressbar-1.4 "Set linked variable to bad value" -body {
+ set PB "bogus"
+ .pb instate invalid
+} -result 1
+
+test progressbar-1.4.1 "Set linked variable back to a good value" -body {
+ set PB 80
+ .pb instate invalid
+} -result 0
+
+test progressbar-1.5 "Set -variable to illegal variable" -body {
+ set BAD "bogus"
+ .pb configure -variable BAD
+ .pb instate invalid
+} -result 1
+
+test progressbar-1.6 "Unset -variable" -body {
+ unset -nocomplain UNSET
+ .pb configure -variable UNSET
+ .pb instate disabled
+} -result 1
+
+test progressbar-2.0 "step command" -body {
+ .pb configure -variable {} ;# @@@
+ .pb configure -value 5 -maximum 10 -mode determinate
+ .pb step
+ .pb cget -value
+} -result 6.0
+
+test progressbar-2.1 "step command, with stepamount" -body {
+ .pb step 3
+ .pb cget -value
+} -result 9.0
+
+test progressbar-2.2 "step wraps at -maximum in determinate mode" -body {
+ .pb step
+ .pb cget -value
+} -result 0.0
+
+test progressbar-2.3 "step doesn't wrap in indeterminate mode" -body {
+ .pb configure -value 8 -maximum 10 -mode indeterminate
+ .pb step
+ .pb step
+ .pb step
+ .pb cget -value
+} -result 11.0
+
+test progressbar-2.4 "step with linked variable" -body {
+ .pb configure -variable PB ;# @@@
+ set PB 5
+ .pb step
+ set PB
+} -result 6.0
+
+test progressbar-2.5 "error in write trace" -body {
+ trace variable PB w { error "YIPES!" ;# }
+ .pb step
+ set PB ;# NOTREACHED
+} -cleanup { unset PB } -returnCodes 1 -match glob -result "*YIPES!"
+
+test progressbar-end "Cleanup" -body {
+ destroy .pb
+}
+
+tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/radiobutton.test b/tk8.6/tests/ttk/radiobutton.test
new file mode 100644
index 0000000..ba02954
--- /dev/null
+++ b/tk8.6/tests/ttk/radiobutton.test
@@ -0,0 +1,48 @@
+#
+# ttk::radiobutton widget tests.
+#
+
+package require Tk
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test radiobutton-1.1 "Radiobutton check" -body {
+ pack \
+ [ttk::radiobutton .rb1 -text "One" -variable choice -value 1] \
+ [ttk::radiobutton .rb2 -text "Two" -variable choice -value 2] \
+ [ttk::radiobutton .rb3 -text "Three" -variable choice -value 3] \
+ ;
+}
+test radiobutton-1.2 "Radiobutton invoke" -body {
+ .rb1 invoke
+ set ::choice
+} -result 1
+
+test radiobutton-1.3 "Radiobutton state" -body {
+ .rb1 instate selected
+} -result 1
+
+test radiobutton-1.4 "Other radiobutton invoke" -body {
+ .rb2 invoke
+ set ::choice
+} -result 2
+
+test radiobutton-1.5 "Other radiobutton state" -body {
+ .rb2 instate selected
+} -result 1
+
+test radiobutton-1.6 "First radiobutton state" -body {
+ .rb1 instate selected
+} -result 0
+
+test radiobutton-1.7 "Unset radiobutton variable" -body {
+ unset ::choice
+ list [info exists ::choice] [.rb1 instate alternate] [.rb2 instate alternate]
+} -result {0 1 1}
+
+test radiobutton-1.8 "Reset radiobutton variable" -body {
+ set ::choice 2
+ list [info exists ::choice] [.rb1 instate alternate] [.rb2 instate alternate]
+} -result {1 0 0}
+
+tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/scrollbar.test b/tk8.6/tests/ttk/scrollbar.test
new file mode 100644
index 0000000..0464273
--- /dev/null
+++ b/tk8.6/tests/ttk/scrollbar.test
@@ -0,0 +1,69 @@
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+testConstraint coreScrollbar [expr {[tk windowingsystem] eq "aqua"}]
+
+test scrollbar-swapout-1 "Use core scrollbars on OSX..." -constraints {
+ coreScrollbar
+} -body {
+ ttk::scrollbar .sb -command "yadda"
+ list [winfo class .sb] [.sb cget -command]
+} -result [list Scrollbar yadda] -cleanup {
+ destroy .sb
+}
+
+test scrollbar-swapout-2 "... unless -style is specified ..." -constraints {
+ coreScrollbar
+} -body {
+ ttk::style layout Vertical.Custom.TScrollbar \
+ [ttk::style layout Vertical.TScrollbar] ; # See #1833339
+ ttk::scrollbar .sb -command "yadda" -style Custom.TScrollbar
+ list [winfo class .sb] [.sb cget -command] [.sb cget -style]
+} -result [list TScrollbar yadda Custom.TScrollbar] -cleanup {
+ destroy .sb
+}
+
+test scrollbar-swapout-3 "... or -class." -constraints {
+ coreScrollbar
+} -body {
+ ttk::scrollbar .sb -command "yadda" -class Custom.TScrollbar
+ list [winfo class .sb] [.sb cget -command]
+} -result [list Custom.TScrollbar yadda] -cleanup {
+ destroy .sb
+}
+
+test scrollbar-1.0 "Setup" -body {
+ ttk::scrollbar .tsb
+} -result .tsb
+
+test scrollbar-1.1 "Set method" -body {
+ .tsb set 0.2 0.4
+ .tsb get
+} -result [list 0.2 0.4]
+
+test scrollbar-1.2 "Set orientation" -body {
+ .tsb configure -orient vertical
+ set w [winfo reqwidth .tsb] ; set h [winfo reqheight .tsb]
+ expr {$h > $w}
+} -result 1
+
+test scrollbar-1.3 "Change orientation" -body {
+ .tsb configure -orient horizontal
+ set w [winfo reqwidth .tsb] ; set h [winfo reqheight .tsb]
+ expr {$h < $w}
+} -result 1
+
+#
+# Scale tests:
+#
+
+test scale-1.0 "Self-destruction" -body {
+ trace variable v w { destroy .s ;# }
+ ttk::scale .s -variable v
+ pack .s ; update
+ .s set 1 ; update
+} -returnCodes 1 -match glob -result "*"
+
+tcltest::cleanupTests
+
diff --git a/tk8.6/tests/ttk/spinbox.test b/tk8.6/tests/ttk/spinbox.test
new file mode 100644
index 0000000..32b77af
--- /dev/null
+++ b/tk8.6/tests/ttk/spinbox.test
@@ -0,0 +1,280 @@
+#
+# ttk::spinbox widget tests
+#
+
+package require Tk
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+test spinbox-1.0 "Spinbox tests -- setup" -body {
+ ttk::spinbox .sb
+} -cleanup { destroy .sb } -result .sb
+
+test spinbox-1.1 "Bad -values list" -setup {
+ ttk::spinbox .sb
+} -body {
+ .sb configure -values "bad \{list"
+} -cleanup {
+ destroy .sb
+} -returnCodes error -result "unmatched open brace in list"
+
+test spinbox-1.3.1 "get retrieves value" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb set 50
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 50
+
+test spinbox-1.3.2 "get retrieves value" -setup {
+ ttk::spinbox .sb -from 0 -to 100 -values 55
+} -body {
+ .sb set 55
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 55
+
+test spinbox-1.4.1 "set changes value" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb set 33
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 33
+
+test spinbox-1.4.2 "set changes value" -setup {
+ ttk::spinbox .sb -from 0 -to 100 -values 55
+} -body {
+ .sb set 33
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 33
+
+
+test spinbox-1.6.1 "insert start" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb set 5
+ .sb insert 0 4
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 45
+
+test spinbox-1.6.2 "insert end" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb set 5
+ .sb insert end 4
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 54
+
+test spinbox-1.6.3 "insert invalid index" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb set 5
+ .sb insert 100 4
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result 54
+
+test spinbox-1.7.1 "-command option: set doesnt fire" -setup {
+ ttk::spinbox .sb -from 0 -to 100 -command {set ::spinbox_test 1}
+} -body {
+ set ::spinbox_test 0
+ .sb set 50
+ set ::spinbox_test
+} -cleanup {
+ destroy .sb
+} -result 0
+
+test spinbox-1.7.2 "-command option: button handler will fire" -setup {
+ ttk::spinbox .sb -from 0 -to 100 -command {set ::spinbox_test 1}
+} -body {
+ set ::spinbox_test 0
+ .sb set 50
+ event generate .sb <<Increment>>
+ set ::spinbox_test
+} -cleanup {
+ destroy .sb
+} -result 1
+
+test spinbox-1.8.1 "option -validate" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb configure -validate all
+ .sb cget -validate
+} -cleanup {
+ destroy .sb
+} -result {all}
+
+test spinbox-1.8.2 "option -validate" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb configure -validate key
+ .sb configure -validate focus
+ .sb configure -validate focusin
+ .sb configure -validate focusout
+ .sb configure -validate none
+ .sb cget -validate
+} -cleanup {
+ destroy .sb
+} -result {none}
+
+test spinbox-1.8.3 "option -validate" -setup {
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb configure -validate bogus
+} -cleanup {
+ destroy .sb
+} -returnCodes error -result {bad validate "bogus": must be all, key, focus, focusin, focusout, or none}
+
+test spinbox-1.8.4 "-validate option: " -setup {
+ set ::spinbox_test {}
+ ttk::spinbox .sb -from 0 -to 100
+} -body {
+ .sb configure -validate all -validatecommand {lappend ::spinbox_test %P}
+ pack .sb
+ .sb set 50
+ focus -force .sb
+ after 500 {set ::spinbox_wait 1} ; vwait ::spinbox_wait
+ set ::spinbox_test
+} -cleanup {
+ destroy .sb
+} -result {50}
+
+
+test spinbox-2.0 "current command -- unset should be 0" -constraints nyi -setup {
+ ttk::spinbox .sb -values [list a b c d e a]
+} -body {
+ .sb current
+} -cleanup {
+ destroy .sb
+} -result 0
+# @@@ for combobox, this is -1.
+
+test spinbox-2.1 "current command -- set index" -constraints nyi -setup {
+ ttk::spinbox .sb -values [list a b c d e a]
+} -body {
+ .sb current 5
+ .sb get
+} -cleanup {
+ destroy .sb
+} -result a
+
+test spinbox-2.2 "current command -- change -values" -constraints nyi -setup {
+ ttk::spinbox .sb -values [list a b c d e a]
+} -body {
+ .sb current 5
+ .sb configure -values [list c b a d e]
+ .sb current
+} -cleanup {
+ destroy .sb
+} -result 2
+
+test spinbox-2.3 "current command -- change value" -constraints nyi -setup {
+ ttk::spinbox .sb -values [list c b a d e]
+} -body {
+ .sb current 2
+ .sb set "b"
+ .sb current
+} -cleanup {
+ destroy .sb
+} -result 1
+
+test spinbox-2.4 "current command -- value not in list" -constraints nyi -setup {
+ ttk::spinbox .sb -values [list c b a d e]
+} -body {
+ .sb current 2
+ .sb set "z"
+ .sb current
+} -cleanup {
+ destroy .sb
+} -result -1
+
+# nostomp: NB intentional difference between ttk::spinbox and tk::spinbox;
+# see also #1439266
+#
+test spinbox-nostomp-1 "don't stomp on -variable (init; -from/to)" -body {
+ set SBV 55
+ ttk::spinbox .sb -textvariable SBV -from 0 -to 100 -increment 5
+ list $SBV [.sb get]
+} -cleanup {
+ unset SBV
+ destroy .sb
+} -result [list 55 55]
+
+test spinbox-nostomp-2 "don't stomp on -variable (init; -values)" -body {
+ set SBV Apr
+ ttk::spinbox .sb -textvariable SBV -values {Jan Feb Mar Apr May Jun Jul Aug}
+ list $SBV [.sb get]
+} -cleanup {
+ unset SBV
+ destroy .sb
+} -result [list Apr Apr]
+
+test spinbox-nostomp-3 "don't stomp on -variable (configure; -from/to)" -body {
+ set SBV 55
+ ttk::spinbox .sb
+ .sb configure -textvariable SBV -from 0 -to 100 -increment 5
+ list $SBV [.sb get]
+} -cleanup {
+ unset SBV
+ destroy .sb
+} -result [list 55 55]
+
+test spinbox-nostomp-4 "don't stomp on -variable (configure; -values)" -body {
+ set SBV Apr
+ ttk::spinbox .sb
+ .sb configure -textvariable SBV -values {Jan Feb Mar Apr May Jun Jul Aug}
+ list $SBV [.sb get]
+} -cleanup {
+ unset SBV
+ destroy .sb
+} -result [list Apr Apr]
+
+test spinbox-dieoctaldie-1 "Cope with leading zeros" -body {
+ # See SF#2358545 -- ttk::spinbox also affected
+ set secs 07
+ ttk::spinbox .sb -from 0 -to 59 -format %02.0f -textvariable secs
+
+ set result [list $secs]
+ event generate .sb <<Increment>>; lappend result $secs
+ event generate .sb <<Increment>>; lappend result $secs
+ event generate .sb <<Increment>>; lappend result $secs
+ event generate .sb <<Increment>>; lappend result $secs
+
+ event generate .sb <<Decrement>>; lappend result $secs
+ event generate .sb <<Decrement>>; lappend result $secs
+ event generate .sb <<Decrement>>; lappend result $secs
+ event generate .sb <<Decrement>>; lappend result $secs
+
+ set result
+} -result [list 07 08 09 10 11 10 09 08 07] -cleanup {
+ destroy .sb
+ unset secs
+}
+
+test spinbox-dieoctaldie-2 "Cope with general bad input" -body {
+ set result [list]
+ ttk::spinbox .sb -from 0 -to 100 -format %03.0f
+ .sb set asdfasdf ; lappend result [.sb get]
+ event generate .sb <<Increment>> ; lappend result [.sb get]
+ .sb set asdfasdf ; lappend result [.sb get]
+ event generate .sb <<Decrement>> ; lappend result [.sb get]
+} -result [list asdfasdf 000 asdfasdf 000] -cleanup {
+ destroy .sb
+}
+
+tcltest::cleanupTests
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/ttk/treetags.test b/tk8.6/tests/ttk/treetags.test
new file mode 100644
index 0000000..7f26e2f
--- /dev/null
+++ b/tk8.6/tests/ttk/treetags.test
@@ -0,0 +1,221 @@
+
+package require Tk
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+### treeview tag invariants:
+#
+
+proc assert {expr {message ""}} {
+ if {![uplevel 1 [list expr $expr]]} {
+ error "PANIC: $message ($expr failed)"
+ }
+}
+proc in {e l} { expr {[lsearch -exact $l $e] >= 0} }
+
+proc itemConstraints {tv item} {
+ # $tag in [$tv item $item -tags] <==> [$tv tag has $tag $item]
+ foreach tag [$tv item $item -tags] {
+ assert {[in $item [$tv tag has $tag]]}
+ }
+ foreach child [$tv children $item] {
+ itemConstraints $tv $child
+ }
+}
+
+proc treeConstraints {tv} {
+ # $item in [$tv tag has $tag] <==> [$tv tag has $tag $item]
+ #
+ foreach tag [$tv tag names] {
+ foreach item [$tv tag has $tag] {
+ assert {[in $tag [$tv item $item -tags]]}
+ }
+ }
+
+ itemConstraints $tv {}
+}
+#
+###
+
+test treetags-1.0 "Setup" -body {
+ set tv [ttk::treeview .tv]
+ .tv insert {} end -id item1 -text "Item 1"
+ pack .tv
+} -cleanup {
+ treeConstraints $tv
+}
+
+test treetags-1.1 "Bad tag list" -body {
+ $tv item item1 -tags {bad {list}here bad}
+ $tv item item1 -tags
+} -returnCodes error -result "list element in braces *" -match glob
+
+test treetags-1.2 "Good tag list" -body {
+ $tv item item1 -tags tag1
+ $tv item item1 -tags
+} -cleanup {
+ assert {[$tv tag has tag1 item1]}
+ treeConstraints $tv
+} -result [list tag1]
+
+test treetags-1.3 "tag has - test" -body {
+ $tv insert {} end -id item2 -text "Item 2" -tags tag2
+ set result [list]
+ foreach item {item1 item2} {
+ foreach tag {tag1 tag2 tag3} {
+ lappend result $item $tag [$tv tag has $tag $item]
+ }
+ }
+ set result
+} -cleanup {
+ treeConstraints $tv
+} -result [list \
+ item1 tag1 1 item1 tag2 0 item1 tag3 0 \
+ item2 tag1 0 item2 tag2 1 item2 tag3 0 ]
+
+test treetags-1.4 "tag has - query" -body {
+ list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
+} -cleanup {
+ treeConstraints $tv
+} -result [list [list item1] [list item2] [list]]
+
+test treetags-1.5 "tag add" -body {
+ $tv tag add tag3 {item1 item2}
+ list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
+} -cleanup {
+ treeConstraints $tv
+} -result [list [list item1] [list item2] [list item1 item2]]
+
+test treetags-1.6 "tag remove - list" -body {
+ $tv tag remove tag3 {item1 item2}
+ list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
+} -cleanup {
+ treeConstraints $tv
+} -result [list [list item1] [list item2] [list]]
+
+test treetags-1.7 "tag remove - all items" -body {
+ $tv tag remove tag1
+ list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
+} -cleanup {
+ treeConstraints $tv
+} -result [list [list] [list item2] [list]]
+
+test treetags-1.8 "tag names" -body {
+ lsort [$tv tag names]
+} -result [list tag1 tag2 tag3]
+
+test treetags-1.9 "tag names - tag added to item" -body {
+ $tv item item1 -tags tag4
+ lsort [$tv tag names]
+} -result [list tag1 tag2 tag3 tag4]
+
+test treetags-1.10 "tag names - tag configured" -body {
+ $tv tag configure tag5
+ lsort [$tv tag names]
+} -result [list tag1 tag2 tag3 tag4 tag5]
+
+test treetags-1.end "cleanup" -body {
+ $tv item item1 -tags tag1
+ $tv item item2 -tags tag2
+ list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
+} -cleanup {
+ treeConstraints $tv
+} -result [list [list item1] [list item2] [list]]
+
+test treetags-2.0 "tag bind" -body {
+ $tv tag bind tag1 <KeyPress> {set ::KEY %A}
+ $tv tag bind tag1 <KeyPress>
+} -cleanup {
+ treeConstraints $tv
+} -result {set ::KEY %A}
+
+test treetags-2.1 "Events delivered to tags" -body {
+ focus -force $tv ; update ;# needed so [event generate] delivers KeyPress
+ $tv focus item1
+ event generate $tv <KeyPress-a>
+ set ::KEY
+} -cleanup {
+ treeConstraints $tv
+} -result a
+
+test treetags-2.2 "Events delivered to correct tags" -body {
+ $tv tag bind tag2 <KeyPress> [list set ::KEY2 %A]
+
+ $tv focus item1
+ event generate $tv <KeyPress-b>
+ $tv focus item2
+ event generate $tv <KeyPress-c>
+
+ list $::KEY $::KEY2
+} -cleanup {
+ treeConstraints $tv
+} -result [list b c]
+
+test treetags-2.3 "Virtual events delivered to focus item" -body {
+ set ::bong 0
+ $tv tag bind tag2 <<Bing>> { incr bong }
+ $tv focus item2
+ event generate $tv <<Bing>>
+ $tv focus item1
+ event generate $tv <<Bing>>
+ set bong
+} -cleanup {
+ treeConstraints $tv
+} -result 1
+
+test treetags-2.4 "Bad events" -body {
+ $tv tag bind bad <Enter> { puts "Entered!" }
+} -returnCodes 1 -result "unsupported event <Enter>*" -match glob
+
+test treetags-3.0 "tag configure - set" -body {
+ $tv tag configure tag1 -foreground blue -background red
+} -cleanup {
+ treeConstraints $tv
+} -result {}
+
+test treetags-3.1 "tag configure - get" -body {
+ $tv tag configure tag1 -foreground
+} -cleanup {
+ treeConstraints $tv
+} -result blue
+
+# @@@ fragile test
+test treetags-3.2 "tag configure - enumerate" -body {
+ $tv tag configure tag1
+} -cleanup {
+ treeConstraints $tv
+} -result [list \
+ -text {} -image {} -anchor {} -background red -foreground blue -font {} \
+]
+
+# The next test exercises tag resource management.
+# If options are not properly freed, the message:
+# Test file error: "Font times 20 still in cache."
+# will show up on stderr at program exit.
+#
+test treetags-3.3 "tag configure - set font" -body {
+ $tv tag configure tag2 -font {times 20}
+}
+
+test treetags-3.4 "stomp tags in tag binding procedure" -body {
+ set result [list]
+ $tv tag bind rm1 <<Remove>> { lappend ::result rm1 [%W focus] <<Remove>> }
+ $tv tag bind rm2 <<Remove>> {
+ lappend ::result rm2 [%W focus] <<Remove>>
+ %W item [%W focus] -tags {tag1}
+ }
+ $tv tag bind rm3 <<Remove>> { lappend ::result rm3 [%W focus] <<Remove>> }
+
+ $tv item item1 -tags {rm1 rm2 rm3}
+ $tv focus item1
+ event generate $tv <<Remove>>
+ set result
+} -cleanup {
+ treeConstraints $tv
+} -result [list rm1 item1 <<Remove>> rm2 item1 <<Remove>> rm3 item1 <<Remove>>]
+
+#
+
+test treetags-end "Cleanup" -body { destroy $tv }
+
+tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/treeview.test b/tk8.6/tests/ttk/treeview.test
new file mode 100644
index 0000000..aa7e64a
--- /dev/null
+++ b/tk8.6/tests/ttk/treeview.test
@@ -0,0 +1,639 @@
+#
+# [7Jun2005] TO CHECK: [$tv see {}] -- shouldn't work (at least, shouldn't do
+# what it currently does)
+#
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+# consistencyCheck --
+# Traverse the tree to make sure the item data structures
+# are properly linked.
+#
+# Since [$tv children] follows ->next links and [$tv index]
+# follows ->prev links, this should cover all invariants.
+#
+proc consistencyCheck {tv {item {}}} {
+ set i 0;
+ foreach child [$tv children $item] {
+ assert {[$tv parent $child] == $item} "parent $child = $item"
+ assert {[$tv index $child] == $i} "index $child [$tv index $child]=$i"
+ incr i
+ consistencyCheck $tv $child
+ }
+}
+
+proc assert {expr {message ""}} {
+ if {![uplevel 1 [list expr $expr]]} {
+ set error "PANIC! PANIC! PANIC: $message ($expr failed)"
+ puts stderr $error
+ error $error
+ }
+}
+
+test treeview-0 "treeview test - setup" -body {
+ ttk::treeview .tv -columns {a b c}
+ pack .tv -expand true -fill both
+ update
+}
+
+test treeview-1.1 "columns" -body {
+ .tv configure -columns {a b c}
+}
+
+test treeview-1.2 "Bad columns" -body {
+ #.tv configure -columns {illegal "list"value}
+ ttk::treeview .badtv -columns {illegal "list"value}
+} -returnCodes 1 -result "list element in quotes followed by*" -match glob
+
+test treeview-1.3 "bad displaycolumns" -body {
+ .tv configure -displaycolumns {a b d}
+} -returnCodes 1 -result "Invalid column index d"
+
+test treeview-1.4 "more bad displaycolumns" -body {
+ .tv configure -displaycolumns {1 2 3}
+} -returnCodes 1 -result "Column index 3 out of bounds"
+
+test treeview-1.5 "Don't forget to check negative numbers" -body {
+ .tv configure -displaycolumns {1 -2 3}
+} -returnCodes 1 -result "Column index -2 out of bounds"
+
+# Item creation.
+#
+test treeview-2.1 "insert -- not enough args" -body {
+ .tv insert
+} -returnCodes 1 -result "wrong # args: *" -match glob
+
+test treeview-2.3 "insert -- bad integer index" -body {
+ .tv insert {} badindex
+} -returnCodes 1 -result "expected integer *" -match glob
+
+test treeview-2.4 "insert -- bad parent node" -body {
+ .tv insert badparent end
+} -returnCodes 1 -result "Item badparent not found" -match glob
+
+test treeview-2.5 "insert -- finaly insert a node" -body {
+ .tv insert {} end -id newnode -text "New node"
+} -result newnode
+
+test treeview-2.6 "insert -- make sure node was inserted" -body {
+ .tv children {}
+} -result [list newnode]
+
+test treeview-2.7 "insert -- prevent duplicate node names" -body {
+ .tv insert {} end -id newnode
+} -returnCodes 1 -result "Item newnode already exists"
+
+test treeview-2.8 "insert -- new node at end" -body {
+ .tv insert {} end -id lastnode
+ consistencyCheck .tv
+ .tv children {}
+} -result [list newnode lastnode]
+
+consistencyCheck .tv
+
+test treeview-2.9 "insert -- new node at beginning" -body {
+ .tv insert {} 0 -id firstnode
+ consistencyCheck .tv
+ .tv children {}
+} -result [list firstnode newnode lastnode]
+
+test treeview-2.10 "insert -- one more node" -body {
+ .tv insert {} 2 -id onemore
+ consistencyCheck .tv
+ .tv children {}
+} -result [list firstnode newnode onemore lastnode]
+
+test treeview-2.11 "insert -- and another one" -body {
+ .tv insert {} 2 -id anotherone
+ consistencyCheck .tv
+ .tv children {}
+} -result [list firstnode newnode anotherone onemore lastnode]
+
+test treeview-2.12 "insert -- one more at end" -body {
+ .tv insert {} end -id newlastone
+ consistencyCheck .tv
+ .tv children {}
+} -result [list firstnode newnode anotherone onemore lastnode newlastone]
+
+test treeview-2.13 "insert -- one more at beginning" -body {
+ .tv insert {} 0 -id newfirstone
+ consistencyCheck .tv
+ .tv children {}
+} -result [list newfirstone firstnode newnode anotherone onemore lastnode newlastone]
+
+test treeview-2.14 "insert -- bad options" -body {
+ .tv insert {} end -badoption foo
+} -returnCodes 1 -result {unknown option "-badoption"}
+
+test treeview-2.15 "insert -- at position 0 w/no children" -body {
+ .tv insert newnode 0 -id newnode.n2 -text "Foo"
+ .tv children newnode
+} -result newnode.n2 ;# don't crash
+
+test treeview-2.16 "insert -- insert way past end" -body {
+ .tv insert newnode 99 -id newnode.n3 -text "Foo"
+ consistencyCheck .tv
+ .tv children newnode
+} -result [list newnode.n2 newnode.n3]
+
+test treeview-2.17 "insert -- insert before beginning" -body {
+ .tv insert newnode -1 -id newnode.n1 -text "Foo"
+ consistencyCheck .tv
+ .tv children newnode
+} -result [list newnode.n1 newnode.n2 newnode.n3]
+
+###
+#
+test treeview-3.1 "parent" -body {
+ .tv parent newnode.n1
+} -result newnode
+test treeview-3.2 "parent - top-level node" -body {
+ .tv parent newnode
+} -result {}
+test treeview-3.3 "parent - root node" -body {
+ .tv parent {}
+} -result {}
+test treeview-3.4 "index" -body {
+ list [.tv index newnode.n3] [.tv index newnode.n2] [.tv index newnode.n1]
+} -result [list 2 1 0]
+test treeview-3.5 "index - exhaustive test" -body {
+ set result [list]
+ foreach item [.tv children {}] {
+ lappend result [.tv index $item]
+ }
+ set result
+} -result [list 0 1 2 3 4 5 6]
+
+test treeview-3.6 "detach" -body {
+ .tv detach newnode
+ consistencyCheck .tv
+ .tv children {}
+} -result [list newfirstone firstnode anotherone onemore lastnode newlastone]
+# XREF: treeview-2.13
+
+test treeview-3.7 "detach didn't screw up internal links" -body {
+ consistencyCheck .tv
+ set result [list]
+ foreach item [.tv children {}] {
+ lappend result [.tv index $item]
+ }
+ set result
+} -result [list 0 1 2 3 4 5]
+
+test treeview-3.8 "detached node has no parent, index 0" -body {
+ list [.tv parent newnode] [.tv index newnode]
+} -result [list {} 0]
+# @@@ Can't distinguish detached nodes from first root node
+
+test treeview-3.9 "detached node's children undisturbed" -body {
+ .tv children newnode
+} -result [list newnode.n1 newnode.n2 newnode.n3]
+
+test treeview-3.10 "detach is idempotent" -body {
+ .tv detach newnode
+ consistencyCheck .tv
+ .tv children {}
+} -result [list newfirstone firstnode anotherone onemore lastnode newlastone]
+
+test treeview-3.11 "Can't detach root item" -body {
+ .tv detach [list {}]
+ update
+ consistencyCheck .tv
+} -returnCodes 1 -result "Cannot detach root item"
+consistencyCheck .tv
+
+test treeview-3.12 "Reattach" -body {
+ .tv move newnode {} end
+ consistencyCheck .tv
+ .tv children {}
+} -result [list newfirstone firstnode anotherone onemore lastnode newlastone newnode]
+
+# Bug # ?????
+test treeview-3.13 "Re-reattach" -body {
+ .tv move newnode {} end
+ consistencyCheck .tv
+ .tv children {}
+} -result [list newfirstone firstnode anotherone onemore lastnode newlastone newnode]
+
+catch {
+ .tv insert newfirstone end -id x1
+ .tv insert newfirstone end -id x2
+ .tv insert newfirstone end -id x3
+}
+
+test treeview-3.14 "Duplicated entry in children list" -body {
+ .tv children newfirstone [list x3 x1 x2 x3]
+ # ??? Maybe this should raise an error?
+ consistencyCheck .tv
+ .tv children newfirstone
+} -result [list x3 x1 x2]
+
+test treeview-3.14.1 "Duplicated entry in children list" -body {
+ .tv children newfirstone [list x1 x2 x3 x3 x2 x1]
+ consistencyCheck .tv
+ .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-3.15 "Consecutive duplicate entries in children list" -body {
+ .tv children newfirstone [list x1 x2 x2 x3]
+ consistencyCheck .tv
+ .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-3.16 "Insert child after self" -body {
+ .tv move x2 newfirstone 1
+ consistencyCheck .tv
+ .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-3.17 "Insert last child after self" -body {
+ .tv move x3 newfirstone 2
+ consistencyCheck .tv
+ .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-3.18 "Insert last child after end" -body {
+ .tv move x3 newfirstone 3
+ consistencyCheck .tv
+ .tv children newfirstone
+} -result [list x1 x2 x3]
+
+test treeview-4.1 "opened - initial state" -body {
+ .tv item newnode -open
+} -result 0
+test treeview-4.2 "opened - open node" -body {
+ .tv item newnode -open 1
+ .tv item newnode -open
+} -result 1
+test treeview-4.3 "opened - closed node" -body {
+ .tv item newnode -open 0
+ .tv item newnode -open
+} -result 0
+
+test treeview-5.1 "item -- error checks" -body {
+ .tv item newnode -text "Bad values" -values "{bad}list"
+} -returnCodes 1 -result "list element in braces followed by*" -match glob
+
+test treeview-5.2 "item -- error leaves options unchanged " -body {
+ .tv item newnode -text
+} -result "New node"
+
+test treeview-5.3 "Heading" -body {
+ .tv heading #0 -text "Heading"
+}
+
+test treeview-5.4 "get cell" -body {
+ set l [list a b c]
+ .tv item newnode -values $l
+ .tv set newnode 1
+} -result b
+
+test treeview-5.5 "set cell" -body {
+ .tv set newnode 1 XXX
+ .tv item newnode -values
+} -result [list a XXX c]
+
+test treeview-5.6 "set illegal cell" -body {
+ .tv set newnode #0 YYY
+} -returnCodes 1 -result "Display column #0 cannot be set"
+
+test treeview-5.7 "set illegal cell" -body {
+ .tv set newnode 3 YY ;# 3 == current #columns
+} -returnCodes 1 -result "Column index 3 out of bounds"
+
+test treeview-5.8 "set display columns" -body {
+ .tv configure -displaycolumns [list 2 1 0]
+ .tv set newnode #1 X
+ .tv set newnode #2 Y
+ .tv set newnode #3 Z
+ .tv item newnode -values
+} -result [list Z Y X]
+
+test treeview-5.9 "display columns part 2" -body {
+ list [.tv column #1 -id] [.tv column #2 -id] [.tv column #3 -id]
+} -result [list c b a]
+
+test treeview-5.10 "cannot set column -id" -body {
+ .tv column #1 -id X
+} -returnCodes 1 -result "Attempt to change read-only option"
+
+test treeview-5.11 "get" -body {
+ .tv set newnode #1
+} -result X
+
+test treeview-5.12 "get dictionary" -body {
+ .tv set newnode
+} -result [list a Z b Y c X]
+
+test treeview-5.13 "get, no value" -body {
+ set newitem [.tv insert {} end]
+ set result [.tv set $newitem #1]
+ .tv delete $newitem
+ set result
+} -result {}
+
+
+test treeview-6.1 "deletion - setup" -body {
+ .tv insert {} end -id dtest
+ foreach id [list a b c d e] {
+ .tv insert dtest end -id $id
+ }
+ .tv children dtest
+} -result [list a b c d e]
+
+test treeview-6.1.1 "delete" -body {
+ .tv delete b
+ consistencyCheck .tv
+ list [.tv exists b] [.tv children dtest]
+} -result [list 0 [list a c d e]]
+
+consistencyCheck .tv
+
+test treeview-6.2 "delete - duplicate items in list" -body {
+ .tv delete [list a e a e]
+ consistencyCheck .tv
+ .tv children dtest
+} -result [list c d]
+
+test treeview-6.3 "delete - descendants removed" -body {
+ .tv insert c end -id c1
+ .tv insert c end -id c2
+ .tv insert c1 end -id c11
+ consistencyCheck .tv
+ .tv delete c
+ consistencyCheck .tv
+ list [.tv exists c] [.tv exists c1] [.tv exists c2] [.tv exists c11]
+} -result [list 0 0 0 0]
+
+test treeview-6.4 "delete - delete parent and descendants" -body {
+ .tv insert dtest end -id c
+ .tv insert c end -id c1
+ .tv insert c end -id c2
+ .tv insert c1 end -id c11
+ consistencyCheck .tv
+ .tv delete [list c c1 c2 c11]
+ consistencyCheck .tv
+ list [.tv exists c] [.tv exists c1] [.tv exists c2] [.tv exists c11]
+} -result [list 0 0 0 0]
+
+test treeview-6.5 "delete - delete descendants and parent" -body {
+ .tv insert dtest end -id c
+ .tv insert c end -id c1
+ .tv insert c end -id c2
+ .tv insert c1 end -id c11
+ consistencyCheck .tv
+ .tv delete [list c11 c1 c2 c]
+ consistencyCheck .tv
+ list [.tv exists c] [.tv exists c1] [.tv exists c2] [.tv exists c11]
+} -result [list 0 0 0 0]
+
+test treeview-6.6 "delete - end" -body {
+ consistencyCheck .tv
+ .tv children dtest
+} -result [list d]
+
+test treeview-7.1 "move" -body {
+ .tv insert d end -id d1
+ .tv insert d end -id d2
+ .tv insert d end -id d3
+ .tv move d3 d 0
+ consistencyCheck .tv
+ .tv children d
+} -result [list d3 d1 d2]
+
+test treeview-7.2 "illegal move" -body {
+ .tv move d d2 end
+} -returnCodes 1 -result "Cannot insert d as descendant of d2"
+
+test treeview-7.3 "illegal move has no effect" -body {
+ consistencyCheck .tv
+ .tv children d
+} -result [list d3 d1 d2]
+
+test treeview-7.4 "Replace children" -body {
+ .tv children d [list d3 d2 d1]
+ consistencyCheck .tv
+ .tv children d
+} -result [list d3 d2 d1]
+
+test treeview-7.5 "replace children - precondition" -body {
+ # Just check to make sure the test suite so far has left
+ # us in the state we expect to be in:
+ list [.tv parent newnode] [.tv children newnode]
+} -result [list {} [list newnode.n1 newnode.n2 newnode.n3]]
+
+test treeview-7.6 "Replace children - illegal move" -body {
+ .tv children newnode.n1 [list newnode.n1 newnode.n2 newnode.n3]
+} -returnCodes 1 -result "Cannot insert newnode.n1 as descendant of newnode.n1"
+
+consistencyCheck .tv
+
+test treeview-8.0 "Selection set" -body {
+ .tv selection set [list newnode.n1 newnode.n3 newnode.n2]
+ .tv selection
+} -result [list newnode.n1 newnode.n2 newnode.n3]
+
+test treeview-8.1 "Selection add" -body {
+ .tv selection add [list newnode]
+ .tv selection
+} -result [list newnode newnode.n1 newnode.n2 newnode.n3]
+
+test treeview-8.2 "Selection toggle" -body {
+ .tv selection toggle [list newnode.n2 d3]
+ .tv selection
+} -result [list newnode newnode.n1 newnode.n3 d3]
+
+test treeview-8.3 "Selection remove" -body {
+ .tv selection remove [list newnode.n2 d3]
+ .tv selection
+} -result [list newnode newnode.n1 newnode.n3]
+
+test treeview-8.4 "Selection - clear" -body {
+ .tv selection set {}
+ .tv selection
+} -result {}
+
+test treeview-8.5 "Selection - bad operation" -body {
+ .tv selection badop foo
+} -returnCodes 1 -match glob -result {bad selection operation "badop": must be *}
+
+### NEED: more tests for see/yview/scrolling
+
+proc scrollcallback {args} {
+ set ::scrolldata $args
+}
+test treeview-9.0 "scroll callback - empty tree" -body {
+ .tv configure -yscrollcommand scrollcallback
+ .tv delete [.tv children {}]
+ update
+ set ::scrolldata
+} -result [list 0.0 1.0]
+
+### identify tests:
+#
+proc identify* {tv comps args} {
+ foreach {x y} $args {
+ foreach comp $comps {
+ lappend result [$tv identify $comp $x $y]
+ }
+ }
+ return $result
+}
+
+# get list of column IDs from list of display column ids.
+#
+proc columnids {tv dcols} {
+ set result [list]
+ foreach dcol $dcols {
+ if {[catch {
+ lappend result [$tv column $dcol -id]
+ }]} {
+ lappend result ERROR
+ }
+ }
+ return $result
+}
+
+test treeview-identify-setup "identify series - setup" -body {
+ destroy .tv
+ ttk::setTheme default
+ ttk::treeview .tv -columns [list A B C]
+ .tv insert {} end -id branch -text branch -open true
+ .tv insert branch end -id item1 -text item1
+ .tv insert branch end -id item2 -text item2
+ .tv insert branch end -id item3 -text item3
+
+ .tv column #0 -width 50 ;# 0-50
+ .tv column A -width 50 ;# 50-100
+ .tv column B -width 50 ;# 100-150
+ .tv column C -width 50 ;# 150-200 (plus slop for margins)
+
+ wm geometry . {} ; pack .tv ; update
+}
+
+test treeview-identify-1 "identify heading" -body {
+ .tv configure -show {headings tree}
+ update idletasks
+ identify* .tv {region column} 10 10
+} -result [list heading #0]
+
+test treeview-identify-2 "identify columns" -body {
+ .tv configure -displaycolumns #all
+ update idletasks
+ columnids .tv [identify* .tv column 25 10 75 10 125 10 175 10]
+} -result [list {} A B C]
+
+test treeview-identify-3 "reordered columns" -body {
+ .tv configure -displaycolumns {B A C}
+ update idletasks
+ columnids .tv [identify* .tv column 25 10 75 10 125 10 175 10]
+} -result [list {} B A C]
+
+test treeview-identify-4 "no tree column" -body {
+ .tv configure -displaycolumns #all -show {headings}
+ update idletasks
+ identify* .tv {region column} 25 10 75 10 125 10 175 10
+} -result [list heading #1 heading #2 heading #3 nothing {}]
+
+# Item height in default theme is 20px
+test treeview-identify-5 "vertical scan - no headings" -body {
+ .tv configure -displaycolumns #all -show {tree}
+ update idletasks
+ identify* .tv {region item} 25 10 25 30 25 50 25 70 25 90
+} -result [list tree branch tree item1 tree item2 tree item3 nothing {}]
+
+test treeview-identify-6 "vertical scan - with headings" -body {
+ .tv configure -displaycolumns #all -show {tree headings}
+ update idletasks
+ identify* .tv {region item} 25 10 25 30 25 50 25 70 25 90
+} -result [list heading {} tree branch tree item1 tree item2 tree item3]
+
+test treeview-identify-7 "vertical scan - headings, no tree" -body {
+ .tv configure -displaycolumns #all -show {headings}
+ update idletasks
+ identify* .tv {region item} 25 10 25 30 25 50 25 70 25 90
+} -result [list heading {} cell branch cell item1 cell item2 cell item3]
+
+# In default theme, -indent and -itemheight both 20px
+# Disclosure element name is "Treeitem.indicator"
+set disclosure "*.indicator"
+test treeview-identify-8 "identify element" -body {
+ .tv configure -show {tree}
+ .tv insert branch 0 -id branch2 -open true
+ .tv insert branch2 0 -id branch3 -open true
+ .tv insert branch3 0 -id leaf3
+ update idletasks;
+ identify* .tv {item element} 10 10 30 30 50 50
+} -match glob -result [list \
+ branch $disclosure branch2 $disclosure branch3 $disclosure]
+
+# See #2381555
+test treeview-identify-9 "identify works when horizontally scrolled" -setup {
+ .tv configure -show {tree headings}
+ foreach column {#0 A B C} {
+ .tv column $column -stretch 0 -width 50
+ }
+ place .tv -x 0 -y 0 -width 100
+} -body {
+ set result [list]
+ foreach xoffs {0 50 100} {
+ .tv xview $xoffs ; update
+ lappend result [identify* .tv {region column} 10 10 60 10]
+ }
+ set result
+} -result [list \
+ [list heading #0 heading #1] \
+ [list heading #1 heading #2] \
+ [list heading #2 heading #3] ]
+
+test treeview-identify-cleanup "identify - cleanup" -body {
+ destroy .tv
+}
+
+### NEED: tests for focus item, selection
+
+### Misc. tests:
+
+destroy .tv
+test treeview-10.1 "Root node properly initialized (#1541739)" -setup {
+ ttk::treeview .tv
+ .tv insert {} end -id a
+ .tv see a
+} -cleanup {
+ destroy .tv
+}
+
+test treeview-3006842 "Null bindings" -setup {
+ ttk::treeview .tv -show tree
+} -body {
+ .tv tag bind empty <ButtonPress-1> {}
+ .tv insert {} end -text "Click me" -tags empty
+ event generate .tv <ButtonPress-1> -x 10 -y 10
+ .tv tag bind empty
+} -result {} -cleanup {
+ destroy .tv
+}
+
+test treeview-3085489-1 "tag add, no -tags" -setup {
+ ttk::treeview .tv
+} -body {
+ set item [.tv insert {} end]
+ .tv tag add foo $item
+ .tv item $item -tags
+} -cleanup {
+ destroy .tv
+} -result [list foo]
+
+test treeview-3085489-2 "tag remove, no -tags" -setup {
+ ttk::treeview .tv
+} -body {
+ set item [.tv insert {} end]
+ .tv tag remove foo $item
+ .tv item $item -tags
+} -cleanup {
+ destroy .tv
+} -result [list]
+
+tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/ttk.test b/tk8.6/tests/ttk/ttk.test
new file mode 100644
index 0000000..e58b021
--- /dev/null
+++ b/tk8.6/tests/ttk/ttk.test
@@ -0,0 +1,647 @@
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+proc skip args {}
+proc ok {} { return }
+
+variable widgetClasses {
+ button checkbutton radiobutton menubutton label entry
+ frame labelframe scrollbar
+ notebook progressbar combobox separator
+ panedwindow treeview sizegrip
+ scale
+}
+
+proc bgerror {error} {
+ variable bgerror $error
+ variable bgerrorInfo $::errorInfo
+ variable bgerrorCode $::errorCode
+}
+
+# Self-destruct tests.
+# Do these early, so any memory corruption has a longer time to cause a crash.
+#
+proc selfdestruct {w args} {
+ destroy $w
+}
+test ttk-6.1 "Self-destructing checkbutton" -body {
+ pack [ttk::checkbutton .sd -text "Self-destruction" -variable ::sd]
+ trace variable sd w [list selfdestruct .sd]
+ update
+ .sd invoke
+} -returnCodes 1
+test ttk-6.2 "Checkbutton self-destructed" -body {
+ winfo exists .sd
+} -result 0
+
+# test ttk-6.3 not applicable [see #2175411]
+
+test ttk-6.4 "Destroy widget in configure" -setup {
+ set OUCH ouch
+ trace variable OUCH r { kill.b }
+ proc kill.b {args} { destroy .b }
+} -cleanup {
+ unset OUCH
+} -body {
+ pack [ttk::checkbutton .b]
+ set rc [catch { .b configure -variable OUCH } msg]
+ list $rc $msg [winfo exists .b] [info commands .b]
+} -result [list 1 "widget has been destroyed" 0 {}]
+
+test ttk-6.5 "Clean up -textvariable traces" -body {
+ foreach class {ttk::button ttk::checkbutton ttk::radiobutton} {
+ $class .b1 -textvariable V
+ set V "asdf"
+ destroy .b1
+ set V ""
+ }
+}
+
+test ttk-6.6 "Bad color spec in styles" -body {
+ pack [ttk::button .b1 -text Hi!]
+ ttk::style configure TButton -foreground badColor
+ event generate .b1 <Expose>
+ update
+ ttk::style configure TButton -foreground black
+ destroy .b1
+ set ::bgerror
+} -result {unknown color name "badColor"}
+
+test ttk-6.7 "Basic destruction test" -body {
+ foreach widget $widgetClasses {
+ ttk::$widget .w
+ pack .w
+ destroy .w
+ }
+}
+
+test ttk-6.8 "Button command removes itself" -body {
+ ttk::button .b -command ".b configure -command {}; set ::A {it worked}"
+ .b invoke
+ destroy .b
+ set ::A
+} -result {it worked}
+
+test ttk-6.9 "Bad font spec in styles" -setup {
+ ttk::style theme create badfont -settings {
+ ttk::style configure . -font {Helvetica 12 Bogus}
+ }
+ ttk::style theme use badfont
+} -cleanup {
+ ttk::style theme use default
+} -body {
+ pack [ttk::label .l -text Hi! -font {}]
+ event generate .l <Expose>
+ update
+ destroy .l
+ set ::bgerror
+} -result {unknown font style "Bogus"}
+
+test ttk-construction-failure-1 "Excercise construction failure path" -setup {
+ option add *TLabel.cursor badCursor 1
+} -cleanup {
+ option add *TLabel.cursor {} 1
+} -body {
+ catch {ttk::label .l} errmsg
+ list $errmsg [info commands .l] [winfo exists .l]
+} -result [list {bad cursor spec "badCursor"} {} 0]
+
+test ttk-construction-failure-2 "Destroy widget in constructor" -setup {
+ set OUCH ouch
+ trace variable OUCH r { kill.b }
+ proc kill.b {args} { destroy .b }
+} -cleanup {
+ unset OUCH
+} -body {
+ list \
+ [catch { ttk::checkbutton .b -variable OUCH } msg] \
+ $msg \
+ [winfo exists .b] \
+ [info commands .b] \
+ ;
+} -result [list 1 "widget has been destroyed" 0 {}]
+
+test ttk-selfdestruct-ok-1 "Intentional self-destruction" -body {
+ # see #2298720
+ toplevel .t
+ ttk::button .t.b -command [list destroy .t]
+ .t.b invoke
+ list [winfo exists .t] [winfo exists .t.b]
+} -result [list 0 0]
+
+#
+# Basic tests.
+#
+test ttk-1.1 "Create button" -body {
+ pack [ttk::button .t] -expand true -fill both
+ update
+}
+
+test ttk-1.2 "Check style" -body {
+ .t cget -style
+} -result {}
+
+test ttk-1.3 "Set bad style" -body {
+ .t configure -style "nosuchstyle"
+} -returnCodes 1 -result {Layout nosuchstyle not found}
+
+test ttk-1.4 "Original style preserved" -body {
+ .t cget -style
+} -result ""
+
+proc checkstate {w} {
+ foreach statespec {
+ {!active !disabled}
+ {!active disabled}
+ {active !disabled}
+ {active disabled}
+ active
+ disabled
+ } {
+ lappend result [$w instate $statespec]
+ }
+ set result
+}
+
+# NB: this will fail if the top-level window pops up underneath the cursor
+test ttk-2.0 "Check state" -body {
+ checkstate .t
+} -result [list 1 0 0 0 0 0]
+
+test ttk-2.1 "Change state" -body {
+ .t state active
+} -result !active
+
+test ttk-2.2 "Check state again" -body {
+ checkstate .t
+} -result [list 0 0 1 0 1 0]
+
+test ttk-2.3 "Change state again" -body {
+ .t state {!active disabled}
+} -result {active !disabled}
+
+test ttk-2.4 "Check state again" -body {
+ checkstate .t
+} -result [list 0 1 0 0 0 1]
+
+test ttk-2.5 "Change state again" -body {
+ .t state !disabled
+} -result {disabled}
+
+test ttk-2.6 "instate scripts, false" -body {
+ set x 0
+ .t instate disabled { set x 1 }
+ set x
+} -result 0
+
+test ttk-2.7 "instate scripts, true" -body {
+ set x 0
+ .t instate !disabled { set x 1 }
+ set x
+} -result 1
+
+test ttk-2.8 "bug 3223850: button state disabled during click" -setup {
+ destroy .b
+ set ttk28 {}
+ pack [ttk::button .b -command {set ::ttk28 failed}]
+} -body {
+ bind .b <ButtonPress-1> {after 0 {.b configure -state disabled}}
+ after 1 {event generate .b <ButtonPress-1>}
+ after 20 {event generate .b <ButtonRelease-1>}
+ set aid [after 100 {set ::ttk28 [.b instate {disabled !pressed}]}]
+ vwait ::ttk28
+ after cancel $aid
+ set ttk28
+} -cleanup {
+ destroy .b
+ unset -nocomplain ttk28 aid
+} -result 1
+
+foreach wc $widgetClasses {
+ test ttk-coreoptions-$wc "$wc has all core options" -body {
+ ttk::$wc .w
+ foreach option {-class -style -cursor -takefocus} {
+ .w cget $option
+ }
+ } -cleanup {
+ catch {destroy .w}
+ }
+}
+
+# misc. error detection
+test ttk-3.0 "Bad option" -body {
+ ttk::button .bad -badoption foo
+} -returnCodes 1 -result {unknown option "-badoption"} -match glob
+
+test ttk-3.1 "Make sure widget command not created" -body {
+ .bad state disabled
+} -returnCodes 1 -result {invalid command name ".bad"} -match glob
+
+test ttk-3.2 "Propagate errors from variable traces" -body {
+ set A 0
+ trace add variable A write {error "failure" ;# }
+ ttk::checkbutton .cb -variable A
+ .cb invoke
+} -cleanup {
+ unset ::A ; destroy .cb
+} -returnCodes error -result {can't set "A": failure}
+
+test ttk-3.3 "Constructor failure with cursor" -body {
+ ttk::button .b -cursor bottom_right_corner -style BadStyle
+} -returnCodes 1 -result "Layout BadStyle not found"
+
+test ttk-3.4 "SF#2009213" -body {
+ ttk::style configure TScale -sliderrelief {}
+ pack [ttk::scale .s]
+ update
+} -cleanup {
+ ttk::style configure TScale -sliderrelief raised
+ destroy .s
+}
+
+# Test resource allocation
+# (@@@ "-font" is a compatibility option now, so tests 4.1-4.3
+# don't really test anything useful at the moment.)
+#
+
+test ttk-4.0 "Setup" -body {
+ catch { destroy .t }
+ pack [ttk::label .t -text "Button 1"]
+ testConstraint fontOption [expr ![catch { set prevFont [.t cget -font] }]]
+ ok
+}
+
+test ttk-4.1 "Change font" -constraints fontOption -body {
+ .t configure -font "Helvetica 18 bold"
+}
+test ttk-4.2 "Check font" -constraints fontOption -body {
+ .t cget -font
+} -result "Helvetica 18 bold"
+
+test ttk-4.3 "Restore font" -constraints fontOption -body {
+ .t configure -font $prevFont
+}
+
+test ttk-4.4 "Bad resource specifications" -body {
+ ttk::style theme settings alt {
+ ttk::style configure TButton -font {Bad font}
+ # @@@ it would be best to raise an error at this point,
+ # @@@ but that's not really feasible in the current framework.
+ }
+ pack [ttk::button .tb1 -text "Ouch"]
+ ttk::style theme use alt
+ update;
+ # As long as we haven't crashed, everything's OK
+ ttk::style theme settings alt {
+ ttk::style configure TButton -font TkDefaultFont
+ }
+ ttk::style theme use default
+ destroy .tb1
+}
+
+#
+# -compound tests:
+#
+variable iconData \
+{R0lGODlhIAAgAKIAANnZ2YQAAP8AAISEhP///////////////yH5BAEAAAAALAAAAAAgACAA
+AAP/CLoMGLqKoMvtGIqiqxEYCLrcioGiyxwIusyBgaLLLRiBoMsQKLrcjYGgu4Giy+2CAkFX
+A0WX2wXFIOgGii7trkCEohsDCACBoktEKLpKhISiGwAIECiqSKooukiqKKoxgACBooukKiIo
+SKooujGDECi6iqQqsopEV2MQAkV3kXQZRXdjEAJFl5F0FUWXY3ACRZcFSRdFlyVwJlB0WZB0
+UXRZAmcCRZeRdBVFl2NwAkV3kXQZRXdjcAJFV5FURVaR6GoMDgSKLpKqiKAgqaLoxgwOBIoq
+kiqKLpIqimrM4ECg6BIRiq4SIaHoxgyCBoou7a5AhKIbMzgAAIGiy+2CTWJmBhAAAkWX2wXF
+zCDoBooud2PMDIKuRqDocgtGzMwg6O4Eii5z4Kgi6DIMhqLoagQGjiqCLvPgYOgqji6CLrfi
+6DIj6HI7jq4i6DIkADs=}
+
+variable compoundStrings {text image center top bottom left right none}
+
+if {0} {
+ proc now {} { set ::now [clock clicks -milliseconds] }
+ proc tick {} { puts -nonewline stderr "+" ; flush stderr }
+ proc tock {} {
+ set then $::now; set ::now [clock clicks -milliseconds]
+ puts stderr " [expr {$::now - $then}] ms"
+ }
+} else {
+ proc now {} {} ; proc tick {} {} ; proc tock {} {}
+}
+
+now ; tick
+test ttk-8.0 "Setup for 8.X" -body {
+ ttk::button .ctb
+ image create photo icon -data $::iconData;
+ pack .ctb
+}
+tock
+
+now
+test ttk-8.1 "Test -compound options" -body {
+ # Exhaustively test each combination.
+ # Main goal is to make sure no code paths crash.
+ foreach image {icon ""} {
+ foreach text {"Hi!" ""} {
+ foreach compound $::compoundStrings {
+ .ctb configure -image $image -text $text -compound $compound
+ update; tick
+ }
+ }
+ }
+}
+tock
+
+test ttk-8.2 "Test -compound options with regular button" -body {
+ button .rtb
+ pack .rtb
+
+ foreach image {"" icon} {
+ foreach text {"Hi!" ""} {
+ foreach compound [lrange $::compoundStrings 2 end] {
+ .rtb configure -image $image -text $text -compound $compound
+ update; tick
+ }
+ }
+ }
+}
+tock
+
+test ttk-8.3 "Rerun test 8.1" -body {
+ foreach image {icon ""} {
+ foreach text {"Hi!" ""} {
+ foreach compound $::compoundStrings {
+ .ctb configure -image $image -text $text -compound $compound
+ update; tick
+ }
+ }
+ }
+}
+tock
+
+test ttk-8.4 "ImageChanged" -body {
+ ttk::button .b -image icon
+ icon blank
+} -cleanup { destroy .b }
+
+#------------------------------------------------------------------------
+
+test ttk-9.1 "Traces on nonexistant namespaces" -body {
+ ttk::checkbutton .tcb -variable foo::bar
+} -returnCodes 1 -result "*parent namespace doesn't exist*" -match glob
+
+test ttk-9.2 "Traces on nonexistant namespaces II" -body {
+ ttk::checkbutton .tcb -variable X
+ .tcb configure -variable foo::bar
+} -returnCodes 1 -result "*parent namespace doesn't exist*" -match glob
+
+test ttk-9.3 "Restore saved options on configure error" -body {
+ .tcb cget -variable
+} -result X
+
+test ttk-9.4 "Textvariable tests" -body {
+ set tcbLabel "Testing..."
+ .tcb configure -textvariable tcbLabel
+ .tcb cget -text
+} -result "Testing..."
+
+# Changing -text has no effect if there is a linked -textvariable.
+# Compatible with core widget.
+test ttk-9.5 "Change -text" -body {
+ .tcb configure -text "Changed -text"
+ .tcb cget -text
+} -result "Testing..."
+
+# Unset -textvariable clears the text.
+# NOTE: this is different from core widgets, which automagically reinitalize
+# the -textvariable to the last value of -text.
+#
+test ttk-9.6 "Unset -textvariable" -body {
+ unset tcbLabel
+ list [info exists tcbLabel] [.tcb cget -text]
+} -result [list 0 ""]
+
+test ttk-9.7 "Unset textvariable, comparison" -body {
+#
+# NB: ttk::label behaves differently from the standard label here;
+# NB: this is on purpose: I believe the standard behaviour is the Wrong Thing
+#
+ unset -nocomplain V1 V2
+ label .l -text Foo ; ttk::label .tl -text Foo
+
+ .l configure -textvariable V1 ; .tl configure -textvariable V2
+ list [set V1] [info exists V2]
+} -cleanup { destroy .l .tl } -result [list Foo 0]
+
+test ttk-9.8 "-textvariable overrides -text" -body {
+ ttk::label .tl -textvariable TV
+ set TV Foo
+ .tl configure -text Bar
+ .tl cget -text
+} -cleanup { destroy .tl } -result "Foo"
+
+#
+# Frame widget tests:
+#
+
+test ttk-10.1 "ttk::frame -class resource" -body {
+ ttk::frame .f -class Foo
+} -result .f
+
+test ttk-10.2 "Check widget class" -body {
+ winfo class .f
+} -result Foo
+
+test ttk-10.3 "Check class resource" -body {
+ .f cget -class
+} -result Foo
+
+test ttk-10.4 "Try to modify class resource" -body {
+ .f configure -class Bar
+} -returnCodes 1 -match glob -result "*read-only option*"
+
+test ttk-10.5 "Check class resource again" -body {
+ .f cget -class
+} -result Foo
+
+test ttk-11.1 "-state test, setup" -body {
+ ttk::button .b
+ .b instate disabled
+} -result 0
+
+test ttk-11.2 "-state test, disable" -body {
+ .b configure -state disabled
+ .b instate disabled
+} -result 1
+
+test ttk-11.3 "-state test, reenable" -body {
+ .b configure -state normal
+ .b instate disabled
+} -result 0
+
+test ttk-11.4 "-state test, unrecognized -state value" -body {
+ .b configure -state bogus
+ .b state
+} -result [list]
+
+test ttk-11.5 "-state test, 'active'" -body {
+ .b configure -state active
+ .b state
+} -result [list active] -cleanup { .b state !active }
+
+test ttk-11.6 "-state test, 'readonly'" -body {
+ .b configure -state readonly
+ .b state
+} -result [list readonly] -cleanup { .b state !readonly }
+
+test ttk-11.7 "-state test, cleanup" -body {
+ destroy .b
+}
+
+test ttk-12.1 "-cursor option" -body {
+ ttk::button .b
+ .b cget -cursor
+} -result {}
+
+test ttk-12.2 "-cursor option" -body {
+ .b configure -cursor arrow
+ .b cget -cursor
+} -result arrow
+
+test ttk-12.3 "-borderwidth frame option" -body {
+ destroy .t
+ toplevel .t
+ raise .t
+ pack [set t [ttk::frame .t.f]] -expand true -fill x ;
+ pack [ttk::label $t.l -text "ASDF QWERTY"] -expand true -fill both
+ foreach theme {default alt} {
+ ttk::style theme use $theme
+ foreach relief {flat raised sunken ridge groove solid} {
+ $t configure -relief $relief
+ for {set i 5} {$i >= 0} {incr i -1} {
+ $t configure -borderwidth $i
+ update
+ }
+ }
+ }
+}
+
+test ttk-12.4 "-borderwidth frame option" -body {
+ .t.f configure -relief raised
+ .t.f configure -borderwidth 1
+ ttk::style theme use alt
+ update
+}
+
+test ttk-13.1 "Custom styles -- bad -style option" -body {
+ ttk::button .tb1 -style badstyle
+} -returnCodes 1 -result "*badstyle not found*" -match glob
+
+test ttk-13.4 "Custom styles -- bad -style option" -body {
+ ttk::button .tb1
+ .tb1 configure -style badstyle
+} -cleanup {
+ destroy .tb1
+} -returnCodes 1 -result "*badstyle not found*" -match glob
+
+test ttk-13.5 "Custom layouts -- missing element definition" -body {
+ ttk::style layout badstyle {
+ NoSuchElement
+ }
+ ttk::button .tb1 -style badstyle
+} -cleanup {
+ destroy .tb1
+} -result .tb1
+# @@@ Should: signal an error, possibly a background error.
+
+#
+# See #793909
+#
+
+test ttk-14.1 "-variable in nonexistant namespace" -body {
+ ttk::checkbutton .tw -variable ::nsn::foo
+} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \
+ -match glob -cleanup { destroy .tw }
+
+test ttk-14.2 "-textvariable in nonexistant namespace" -body {
+ ttk::label .tw -textvariable ::nsn::foo
+} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \
+ -match glob -cleanup { destroy .tw }
+
+test ttk-14.3 "-textvariable in nonexistant namespace" -body {
+ ttk::entry .tw -textvariable ::nsn::foo
+} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \
+ -match glob -cleanup { destroy .tw }
+
+test ttk-15.1 {Bug 3062331} -setup {
+ destroy .b
+} -body {
+ set Y {}
+ ttk::button .b -textvariable Y
+ trace variable Y u "destroy .b; #"
+ unset Y
+} -cleanup {
+ destroy .b
+} -result {}
+
+test ttk-15.2 {Bug 3341056} -setup {
+ proc foo {} {
+ destroy .lf
+ ttk::labelframe .lf
+ ttk::checkbutton .lf.cb -text xxx
+ }
+} -body {
+ ttk::button .b -text xxx -command foo
+ .b invoke
+ .b invoke
+ .lf.cb invoke
+ destroy .b
+} -cleanup {
+ rename foo {}
+ destroy .lf
+} -result {}
+
+## Test ensemble processing:
+#
+# (See also: SF#2021443)
+#
+proc wrong#args {args} {
+ return "wrong # args: should be \"$args\""
+}
+proc wrong#varargs {varpart args} {
+ set usage $args
+ append usage " ?$varpart ...?"
+ return "wrong # args: should be \"$usage\""
+}
+
+test ttk-ensemble-0 "style element create: insufficient args" -body {
+ ttk::style
+} -returnCodes 1 -result \
+ [wrong#varargs arg ttk::style option]
+
+test ttk-ensemble-1 "style element create: insufficient args" -body {
+ ttk::style element
+} -returnCodes 1 -result \
+ [wrong#varargs arg ttk::style element option]
+
+test ttk-ensemble-2 "style element create: insufficient args" -body {
+ ttk::style element create
+} -returnCodes 1 -result \
+ [wrong#varargs {-option value} ttk::style element create name type]
+
+test ttk-ensemble-3 "style element create: insufficient args" -body {
+ ttk::style element create plain.background
+} -returnCodes 1 -result \
+ [wrong#varargs {-option value} ttk::style element create name type]
+
+test ttk-ensemble-4 "style element create: insufficient args" -body {
+ ttk::style element create plain.background from
+} -returnCodes 1 -result [wrong#args theme ?element?]
+
+test ttk-ensemble-5 "style element create: valid" -body {
+ ttk::style element create plain.background from default
+} -returnCodes 0 -result ""
+
+eval destroy [winfo children .]
+
+tcltest::cleanupTests
+
+#*EOF*
diff --git a/tk8.6/tests/ttk/validate.test b/tk8.6/tests/ttk/validate.test
new file mode 100644
index 0000000..417deac
--- /dev/null
+++ b/tk8.6/tests/ttk/validate.test
@@ -0,0 +1,277 @@
+##
+## Entry widget validation tests
+## Derived from core test suite entry-19.1 through entry-19.20
+##
+
+package require Tk 8.5
+package require tcltest 2.1
+namespace import -force tcltest::*
+
+loadTestedCommands
+
+testConstraint ttkEntry 1
+testConstraint coreEntry [expr {![testConstraint ttkEntry]}]
+
+eval tcltest::configure $argv
+
+test validate-0.0 "Setup" -constraints ttkEntry -body {
+ rename entry {}
+ interp alias {} entry {} ttk::entry
+ return;
+}
+
+test validate-0.1 "More setup" -body {
+ 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 \
+ ;
+ 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 validate-1.1 {entry widget validation - insert} -body {
+ .e insert 0 a
+ set ::vVals
+} -result {.e 1 0 a {} a all key}
+
+test validate-1.2 {entry widget validation - insert} -body {
+ .e insert 1 b
+ set ::vVals
+} -result {.e 1 1 ab a b all key}
+
+test validate-1.3 {entry widget validation - insert} -body {
+ .e insert end c
+ set ::vVals
+} -result {.e 1 2 abc ab c all key}
+
+test validate-1.4 {entry widget validation - insert} -body {
+ .e insert 1 123
+ list $::vVals $::e
+} -result {{.e 1 1 a123bc abc 123 all key} a123bc}
+
+test validate-1.5 {entry widget validation - delete} -body {
+ .e delete 2
+ set ::vVals
+} -result {.e 0 2 a13bc a123bc 2 all key}
+
+test validate-1.6 {entry widget validation - delete} -body {
+ .e configure -validate key
+ .e delete 1 3
+ set ::vVals
+} -result {.e 0 1 abc a13bc 13 key key}
+
+test validate-1.7 {entry widget validation - vmode focus} -body {
+ set ::vVals {}
+ .e configure -validate focus
+ .e insert end d
+ set ::vVals
+} -result {}
+
+test validate-1.8 {entry widget validation - vmode focus} -body {
+ focus -force .e
+ # update necessary to process FocusIn event
+ update
+ set ::vVals
+} -result {.e -1 -1 abcd abcd {} focus focusin}
+
+test validate-1.9 {entry widget validation - vmode focus} -body {
+ focus -force .
+ # update necessary to process FocusOut event
+ update
+ set ::vVals
+} -result {.e -1 -1 abcd abcd {} focus focusout}
+
+.e configure -validate all
+test validate-1.10 {entry widget validation - vmode all} -body {
+ focus -force .e
+ # update necessary to process FocusIn event
+ update
+ set ::vVals
+} -result {.e -1 -1 abcd abcd {} all focusin}
+
+test validate-1.11 {entry widget validation} -body {
+ focus -force .
+ # update necessary to process FocusOut event
+ update
+ set ::vVals
+} -result {.e -1 -1 abcd abcd {} all focusout}
+.e configure -validate focusin
+
+test validate-1.12 {entry widget validation} -body {
+ focus -force .e
+ # update necessary to process FocusIn event
+ update
+ set ::vVals
+} -result {.e -1 -1 abcd abcd {} focusin focusin}
+
+test validate-1.13 {entry widget validation} -body {
+ set ::vVals {}
+ focus -force .
+ # update necessary to process FocusOut event
+ update
+ set ::vVals
+} -result {}
+.e configure -validate focuso
+
+test validate-1.14 {entry widget validation} -body {
+ focus -force .e
+ # update necessary to process FocusIn event
+ update
+ set ::vVals
+} -result {}
+
+test validate-1.15 {entry widget validation} -body {
+ focus -force .
+ # update necessary to process FocusOut event
+ update
+ set ::vVals
+} -result {.e -1 -1 abcd abcd {} focusout focusout}
+
+# DIFFERENCE: core entry temporarily sets "-validate all", ttk::entry doesn't.
+test validate-1.16 {entry widget validation} -body {
+ .e configure -validate all
+ list [.e validate] $::vVals
+} -result {1 {.e -1 -1 abcd abcd {} all forced}}
+
+# DIFFERENCE: ttk::entry does not perform validation when setting the -variable
+test validate-1.17 {entry widget validation} -constraints coreEntry -body {
+ .e configure -validate all
+ set ::e newdata
+ list [.e cget -validate] $::vVals
+} -result {all {.e -1 -1 newdata abcd {} all forced}}
+
+proc doval {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ return 0
+}
+
+test validate-1.18 {entry widget validation} -constraints coreEntry -body {
+ .e configure -validate all
+ set ::e nextdata
+ list [.e cget -validate] $::vVals
+} -result {none {.e -1 -1 nextdata newdata {} all forced}}
+# DIFFERENCE: ttk::entry doesn't validate when setting linked -variable
+# DIFFERENCE: ttk::entry doesn't disable validation
+
+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
+}
+
+## 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 validate-1.19 {entry widget validation} -constraints coreEntry -body {
+ .e configure -validate all
+ .e validate
+ list [.e cget -validate] [.e get] $::vVals
+} -result {none mydata {.e -1 -1 nextdata nextdata {} all forced}}
+
+## 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.
+
+# DIFFERENCE: ttk entry doesn't get out of sync w/textvar
+test validate-1.20 {entry widget validation} -constraints coreEntry -body {
+ .e configure -validate all
+ set ::e testdata
+ list [.e cget -validate] [.e get] $::e $::vVals
+} -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}}
+
+#
+# New tests, -JE:
+#
+proc doval {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ .e delete 0 end;
+ .e insert end dovaldata
+ return 0
+}
+test validate-2.1 "Validation script changes value" -body {
+ .e configure -validate none
+ set ::e testdata
+ .e configure -validate all
+ .e validate
+ list [.e get] $::e $::vVals
+} -result {dovaldata dovaldata {.e -1 -1 testdata testdata {} all forced}}
+# DIFFERENCE: core entry disables validation, ttk entry does not.
+
+destroy .e
+catch {unset ::e ::vVals}
+
+# See bug #1236979
+
+test validate-2.2 "configure in -validatecommand" -body {
+ proc validate-2.2 {win str} {
+ $win configure -foreground black
+ return 1
+ }
+ ttk::entry .e -textvariable var -validatecommand {validate-2.2 %W %P}
+ .e validate
+} -result 1 -cleanup { destroy .e }
+
+
+### invalid state behavior
+#
+
+test validate-3.0 "Setup" -body {
+ set ::E "123"
+ ttk::entry .e \
+ -validatecommand {string is integer -strict %P} \
+ -validate all \
+ -textvariable ::E \
+ ;
+ return [list [.e get] [.e state]]
+} -result [list 123 {}]
+
+test validate-3.1 "insert - valid" -body {
+ .e insert end "4"
+ return [list [.e get] [.e state]]
+} -result [list 1234 {}]
+
+test validate-3.2 "insert - invalid" -body {
+ .e insert end "X"
+ return [list [.e get] [.e state]]
+} -result [list 1234 {}]
+
+test validate-3.3 "force invalid value" -body {
+ append ::E "XY"
+ return [list [.e get] [.e state]]
+} -result [list 1234XY {}]
+
+test validate-3.4 "revalidate" -body {
+ return [list [.e validate] [.e get] [.e state]]
+} -result [list 0 1234XY {invalid}]
+
+testConstraint NA 0
+# the next two tests (used to) exercise validation lockout protection --
+# if the widget is currently invalid, all edits are allowed.
+# This behavior is currently disabled.
+#
+test validate-3.5 "all edits allowed while invalid" -constraints NA -body {
+ .e delete 4
+ return [list [.e get] [.e state]]
+} -result [list 1234Y {invalid}]
+
+test validate-3.6 "...until the value becomes valid" -constraints NA -body {
+ .e delete 4
+ return [list [.e get] [.e state]]
+} -result [list 1234 {}]
+
+test validate-3.last "Cleanup" -body { destroy .e }
+
+
+###
+tcltest::cleanupTests
diff --git a/tk8.6/tests/ttk/vsapi.test b/tk8.6/tests/ttk/vsapi.test
new file mode 100644
index 0000000..bb88fef
--- /dev/null
+++ b/tk8.6/tests/ttk/vsapi.test
@@ -0,0 +1,47 @@
+# -*- tcl -*-
+#
+
+package require Tk 8.5
+package require tcltest ; namespace import -force tcltest::*
+loadTestedCommands
+
+testConstraint xpnative \
+ [expr {[lsearch -exact [ttk::style theme names] xpnative] != -1}]
+
+test vsapi-1.1 "WINDOW WP_SMALLCLOSEBUTTON" -constraints {xpnative} -body {
+ ttk::style element create smallclose vsapi \
+ WINDOW 19 {disabled 4 pressed 3 active 2 {} 1}
+ ttk::style layout CloseButton {CloseButton.smallclose -sticky news}
+ ttk::button .b -style CloseButton
+ pack .b -expand true -fill both
+ list [winfo reqwidth .b] [winfo reqheight .b]
+} -cleanup { destroy .b } -result [list 13 13]
+
+test vsapi-1.2 "EXPLORERBAR EBP_HEADERPIN" -constraints {xpnative} -body {
+ ttk::style element create pin vsapi \
+ EXPLORERBAR 3 {
+ {pressed !selected} 3
+ {active !selected} 2
+ {pressed selected} 6
+ {active selected} 5
+ {selected} 4
+ {} 1
+ }
+ ttk::style layout Explorer.Pin {Explorer.Pin.pin -sticky news}
+ ttk::checkbutton .pin -style Explorer.Pin
+ pack .pin -expand true -fill both
+ list [winfo reqwidth .pin] [winfo reqheight .pin]
+} -cleanup { destroy .pin } -result [list 16 16]
+
+test vsapi-1.3 "EXPLORERBAR EBP_HEADERCLOSE" -constraints {xpnative} -body {
+ ttk::style element create headerclose vsapi \
+ EXPLORERBAR 2 {pressed 3 active 2 {} 1}
+ ttk::style layout Explorer.CloseButton {
+ Explorer.CloseButton.headerclose -sticky news
+ }
+ ttk::button .b -style Explorer.CloseButton
+ pack .b -expand true -fill both
+ list [winfo reqwidth .b] [winfo reqheight .b]
+} -cleanup { destroy .b } -result [list 16 16]
+
+tcltest::cleanupTests
diff --git a/tk8.6/tests/unixButton.test b/tk8.6/tests/unixButton.test
new file mode 100644
index 0000000..137ef33
--- /dev/null
+++ b/tk8.6/tests/unixButton.test
@@ -0,0 +1,255 @@
+# This file is a Tcl script to test the Unix specific behavior of
+# labels, buttons, checkbuttons, and radiobuttons in Tk (i.e., all the
+# widgets defined in tkUnixButton.c). It is organized in the standard
+# fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+imageInit
+
+# Create entries in the option database to be sure that geometry options
+# like border width have predictable values.
+
+option add *Label.borderWidth 2
+option add *Label.highlightThickness 0
+option add *Label.font {Helvetica -12 bold}
+option add *Button.borderWidth 2
+option add *Button.highlightThickness 2
+option add *Button.font {Helvetica -12 bold}
+option add *Checkbutton.borderWidth 2
+option add *Checkbutton.highlightThickness 2
+option add *Checkbutton.font {Helvetica -12 bold}
+option add *Radiobutton.borderWidth 2
+option add *Radiobutton.highlightThickness 2
+option add *Radiobutton.font {Helvetica -12 bold}
+
+
+proc bogusTrace args {
+ error "trace aborted"
+}
+
+
+test unixbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints {
+ unix testImageType
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create test image1
+ image1 changed 0 0 0 0 60 40
+ label .b1 -image image1 -bd 4 -padx 0 -pady 2
+ button .b2 -image image1 -bd 4 -padx 0 -pady 2
+ checkbutton .b3 -image image1 -bd 4 -padx 1 -pady 1
+ radiobutton .b4 -image image1 -bd 4 -padx 2 -pady 0
+ pack .b1 .b2 .b3 .b4
+ update
+ list [winfo reqwidth .b1] [winfo reqheight .b1] \
+ [winfo reqwidth .b2] [winfo reqheight .b2] \
+ [winfo reqwidth .b3] [winfo reqheight .b3] \
+ [winfo reqwidth .b4] [winfo reqheight .b4]
+} -cleanup {
+ deleteWindows
+ image delete image1
+} -result {68 48 74 54 112 52 112 52}
+test unixbutton-1.2 {TkpComputeButtonGeometry procedure} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ label .b1 -bitmap question -bd 3 -padx 0 -pady 2
+ button .b2 -bitmap question -bd 3 -padx 0 -pady 2
+ checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1
+ radiobutton .b4 -bitmap question -bd 3 -padx 2 -pady 0
+ pack .b1 .b2 .b3 .b4
+ update
+ list [winfo reqwidth .b1] [winfo reqheight .b1] \
+ [winfo reqwidth .b2] [winfo reqheight .b2] \
+ [winfo reqwidth .b3] [winfo reqheight .b3] \
+ [winfo reqwidth .b4] [winfo reqheight .b4]
+} -cleanup {
+ deleteWindows
+} -result {23 33 29 39 54 37 54 37}
+test unixbutton-1.3 {TkpComputeButtonGeometry procedure} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ label .b1 -bitmap question -bd 3 -highlightthickness 4
+ button .b2 -bitmap question -bd 3 -highlightthickness 0
+ checkbutton .b3 -bitmap question -bd 3 -highlightthickness 1 \
+ -indicatoron 0
+ radiobutton .b4 -bitmap question -bd 3 -highlightthickness 1 \
+ -indicatoron false
+ pack .b1 .b2 .b3 .b4
+ update
+ list [winfo reqwidth .b1] [winfo reqheight .b1] \
+ [winfo reqwidth .b2] [winfo reqheight .b2] \
+ [winfo reqwidth .b3] [winfo reqheight .b3] \
+ [winfo reqwidth .b4] [winfo reqheight .b4]
+} -cleanup {
+ deleteWindows
+} -result {31 41 25 35 25 35 25 35}
+test unixbutton-1.4 {TkpComputeButtonGeometry procedure} -constraints {
+ unix nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
+ label .b1 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold}
+ button .b2 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold}
+ checkbutton .b3 -text Xagqpim -padx 1 -pady 1 -font {Helvetica -18 bold}
+ radiobutton .b4 -text Xagqpim -padx 2 -pady 0 -font {Helvetica -18 bold}
+ pack .b1 .b2 .b3 .b4
+ update
+ list [winfo reqwidth .b1] [winfo reqheight .b1] \
+ [winfo reqwidth .b2] [winfo reqheight .b2] \
+ [winfo reqwidth .b3] [winfo reqheight .b3] \
+ [winfo reqwidth .b4] [winfo reqheight .b4]
+} -cleanup {
+ deleteWindows
+} -result {82 29 88 35 114 31 121 29}
+test unixbutton-1.5 {TkpComputeButtonGeometry procedure} -constraints {
+ unix nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
+ label .l1 -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." -wraplength 1.5i -padx 0 -pady 0
+ pack .l1
+ update
+ list [winfo reqwidth .l1] [winfo reqheight .l1]
+} -cleanup {
+ deleteWindows
+} -result {136 88}
+test unixbutton-1.6 {TkpComputeButtonGeometry procedure} -constraints {
+ unix nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
+ label .l1 -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." -padx 0 -pady 0
+ pack .l1
+ update
+ list [winfo reqwidth .l1] [winfo reqheight .l1]
+} -cleanup {
+ deleteWindows
+} -result {231 46}
+test unixbutton-1.7 {TkpComputeButtonGeometry procedure} -constraints {
+ unix nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
+ label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10
+ button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5
+ checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -width 20 -height 2
+ radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -width 4
+ pack .b1 .b2 .b3 .b4
+ update
+ list [winfo reqwidth .b1] [winfo reqheight .b1] \
+ [winfo reqwidth .b2] [winfo reqheight .b2] \
+ [winfo reqwidth .b3] [winfo reqheight .b3] \
+ [winfo reqwidth .b4] [winfo reqheight .b4]
+} -cleanup {
+ deleteWindows
+} -result {74 22 60 84 168 38 61 22}
+test unixbutton-1.8 {TkpComputeButtonGeometry procedure} -constraints {
+ unix nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
+ label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \
+ -highlightthickness 4
+ button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 \
+ -highlightthickness 0
+ checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 \
+ -highlightthickness 1 -indicatoron no
+ radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -indicatoron 0
+ pack .b1 .b2 .b3 .b4
+ update
+ list [winfo reqwidth .b1] [winfo reqheight .b1] \
+ [winfo reqwidth .b2] [winfo reqheight .b2] \
+ [winfo reqwidth .b3] [winfo reqheight .b3] \
+ [winfo reqwidth .b4] [winfo reqheight .b4]
+} -cleanup {
+ deleteWindows
+} -result {62 30 56 24 58 22 62 22}
+test unixbutton-1.9 {TkpComputeButtonGeometry procedure} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ button .b2 -bitmap question -default active
+ list [winfo reqwidth .b2] [winfo reqheight .b2]
+} -cleanup {
+ deleteWindows
+} -result {37 47}
+test unixbutton-1.10 {TkpComputeButtonGeometry procedure} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ button .b2 -bitmap question -default normal
+ list [winfo reqwidth .b2] [winfo reqheight .b2]
+} -cleanup {
+ deleteWindows
+} -result {37 47}
+test unixbutton-1.11 {TkpComputeButtonGeometry procedure} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ button .b2 -bitmap question -default disabled
+ list [winfo reqwidth .b2] [winfo reqheight .b2]
+} -cleanup {
+ deleteWindows
+} -result {27 37}
+
+
+test unixbutton-2.1 {disabled coloring check, bug 669595} -constraints {
+ unix
+} -setup {
+ deleteWindows
+ catch {unset value}
+} -body {
+ # this was just a visual bug, but at least this shows the visual
+ set on 1
+ set off 0
+ label .l -text "The following widgets should\
+ \nshow significant visible diffs\
+ \nfor selected vs unselected."
+ checkbutton .cb0 -anchor w -state disabled \
+ -text Unselected -variable off
+ checkbutton .cb1 -anchor w -state disabled \
+ -text Selected -variable on
+ checkbutton .cb2 -anchor w -state disabled \
+ -text Unselected -variable off -disabledforeground ""
+ checkbutton .cb3 -anchor w -state disabled \
+ -text Selected -variable on -disabledforeground ""
+ radiobutton .rb0 -anchor w -state disabled \
+ -text Unselected -variable off
+ radiobutton .rb1 -anchor w -state disabled \
+ -text Selected -variable on -value 1
+ radiobutton .rb2 -anchor w -state disabled \
+ -text Unselected -variable off -disabledforeground ""
+ radiobutton .rb3 -anchor w -state disabled \
+ -text Selected -variable on -value 1 -disabledforeground ""
+ pack .l .cb0 .cb1 .cb2 .cb3 .rb0 .rb1 .rb2 .rb3 -side top -fill x
+ after 400
+ set on
+} -cleanup {
+ deleteWindows
+} -result 1
+
+
+# cleanup
+imageFinish
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/unixEmbed.test b/tk8.6/tests/unixEmbed.test
new file mode 100644
index 0000000..8aaa3c4
--- /dev/null
+++ b/tk8.6/tests/unixEmbed.test
@@ -0,0 +1,717 @@
+# This file is a Tcl script to test out the procedures in the file
+# tkUnixEmbed.c. It is organized in the standard fashion for Tcl
+# tests.
+#
+# Copyright (c) 1996-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+setupbg
+dobg {wm withdraw .}
+
+# eatColors --
+# Creates a toplevel window and allocates enough colors in it to
+# use up all the slots in the colormap.
+#
+# Arguments:
+# w - Name of toplevel window to create.
+
+proc eatColors {w} {
+ catch {destroy $w}
+ toplevel $w
+ wm geom $w +0+0
+ canvas $w.c -width 400 -height 200 -bd 0
+ pack $w.c
+ for {set y 0} {$y < 8} {incr y} {
+ for {set x 0} {$x < 40} {incr x} {
+ set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
+ $w.c create rectangle [expr 10*$x] [expr 20*$y] \
+ [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
+ -fill $color
+ }
+ }
+ update
+}
+
+# colorsFree --
+#
+# Returns 1 if there appear to be free colormap entries in a window,
+# 0 otherwise.
+#
+# Arguments:
+# w - Name of window in which to check.
+# red, green, blue - Intensities to use in a trial color allocation
+# to see if there are colormap entries free.
+
+proc colorsFree {w {red 31} {green 245} {blue 192}} {
+ set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
+ expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
+ && ([lindex $vals 2]/256 == $blue)
+}
+
+test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -use xyz
+} -returnCodes error -result {expected integer but got "xyz"}
+test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -use 47
+} -returnCodes error -result {couldn't create child of window "47"}
+test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} -constraints {
+ unix nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -colormap new
+ wm geometry .t +0+0
+ eatColors .t.t
+ frame .t.f -container 1
+ toplevel .x -use [winfo id .t.f]
+ colorsFree .x
+} -cleanup {
+ deleteWindows
+} -result {0}
+test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} -constraints {
+ unix nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t -container 1 -colormap new
+ wm geometry .t +0+0
+ eatColors .t2
+ toplevel .x -use [winfo id .t]
+ colorsFree .x
+} -cleanup {
+ deleteWindows
+} -result {1}
+
+test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} -constraints {
+ unix testembed
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ frame .f2 -container 1 -width 200 -height 50
+ pack .f1 .f2
+ dobg "set w [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t -use $w
+ list [testembed] [expr [lindex [lindex [testembed all] 0] 0] - $w]
+ }
+} -cleanup {
+ deleteWindows
+} -result {{{XXX {} {} .t}} 0}
+test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} -constraints {
+ unix testembed
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ frame .f2 -container 1 -width 200 -height 50
+ pack .f1 .f2
+ dobg "set w1 [winfo id .f1]"
+ dobg "set w2 [winfo id .f2]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ toplevel .t2 -use $w2
+ testembed
+ }
+} -cleanup {
+ deleteWindows
+} -result {{XXX {} {} .t2} {XXX {} {} .t1}}
+test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} -constraints {
+ unix testembed
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ frame .f2 -container 1 -width 200 -height 50
+ pack .f1 .f2
+ toplevel .t1 -use [winfo id .f1]
+ toplevel .t2 -use [winfo id .f2]
+ testembed
+} -cleanup {
+ deleteWindows
+} -result {{XXX .f2 {} .t2} {XXX .f1 {} .t1}}
+
+# Can't think of any way to test the procedures TkpMakeWindow,
+# TkpMakeContainer, or EmbedErrorProc.
+
+
+test unixEmbed-2.1 {EmbeddedEventProc procedure} -constraints {
+ unix testembed
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ testembed
+ }
+ destroy .f1
+ update
+ dobg {
+ testembed
+ }
+} -cleanup {
+ deleteWindows
+} -result {}
+test unixEmbed-2.2 {EmbeddedEventProc procedure} -constraints {
+ unix testembed
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ testembed
+ destroy .t1
+ testembed
+ }
+} -cleanup {
+ deleteWindows
+} -result {}
+test unixEmbed-2.3 {EmbeddedEventProc procedure} -constraints {
+ unix testembed
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ toplevel .t1 -use [winfo id .f1]
+ update
+ destroy .f1
+ testembed
+} -result {}
+test unixEmbed-2.4 {EmbeddedEventProc procedure} -constraints {
+ unix testembed
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ toplevel .t1 -use [winfo id .f1]
+ update
+ destroy .t1
+ set x [testembed]
+ update
+ list $x [testembed]
+} -cleanup {
+ deleteWindows
+} -result {{{XXX .f1 {} {}}} {}}
+
+
+test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} -constraints {
+ unix testembed nonPortable
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ set x [testembed]
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ wm withdraw .t1
+ }
+ list $x [testembed]
+} -cleanup {
+ deleteWindows
+} -result {{{XXX .f1 {} {}}} {{XXX .f1 XXX {}}}}
+test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -container 1
+ wm geometry .t1 +0+0
+ toplevel .t2 -use [winfo id .t1] -bg red
+ update
+ wm geometry .t2
+} -cleanup {
+ deleteWindows
+} -result {200x200+0+0}
+test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1 -bd 2 -relief raised
+ update
+ wm geometry .t1 +30+40
+ }
+ update
+ dobg {
+ wm geometry .t1
+ }
+} -cleanup {
+ deleteWindows
+} -result {200x200+0+0}
+test unixEmbed-3.4 {ContainerEventProc procedure, disallow position changes} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ update
+ wm geometry .t1 300x100+30+40
+ }
+ update
+ dobg {
+ wm geometry .t1
+ }
+} -cleanup {
+ deleteWindows
+} -result {300x100+0+0}
+test unixEmbed-3.5 {ContainerEventProc procedure, geometry requests} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ }
+ update
+ dobg {
+ .t1 configure -width 300 -height 80
+ }
+ update
+ list [winfo width .f1] [winfo height .f1] [dobg {wm geometry .t1}]
+} -cleanup {
+ deleteWindows
+} -result {300 80 300x80+0+0}
+test unixEmbed-3.6 {ContainerEventProc procedure, map requests} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ set x unmapped
+ bind .t1 <Map> {set x mapped}
+ }
+ update
+ dobg {
+ after 100
+ update
+ set x
+ }
+} -cleanup {
+ deleteWindows
+} -result {mapped}
+test unixEmbed-3.7 {ContainerEventProc procedure, destroy events} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ bind .f1 <Destroy> {set x dead}
+ set x alive
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ }
+ update
+ dobg {
+ destroy .t1
+ }
+ update
+ list $x [winfo exists .f1]
+} -cleanup {
+ deleteWindows
+} -result {dead 0}
+
+
+test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ }
+ update
+ dobg {
+ .t1 configure -width 180 -height 100
+ }
+ update
+ dobg {
+ winfo geometry .t1
+ }
+} -cleanup {
+ deleteWindows
+} -result {180x100+0+0}
+test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} -constraints {
+ unix testembed
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ }
+ update
+ set x [testembed]
+ destroy .f1
+ list $x [testembed]
+} -cleanup {
+ deleteWindows
+} -result {{{XXX .f1 XXX {}}} {}}
+
+
+test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ bind .t1 <FocusIn> {lappend x "focus in %W"}
+ bind .t1 <FocusOut> {lappend x "focus out %W"}
+ set x {}
+ }
+ focus -force .f1
+ update
+ dobg {set x}
+} -cleanup {
+ deleteWindows
+} -result {{focus in .t1}}
+test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ }
+ update
+ dobg {
+ after 200 {destroy .t1}
+ }
+ after 400
+ focus -force .f1
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ bind .t1 <FocusIn> {lappend x "focus in %W"}
+ bind .t1 <FocusOut> {lappend x "focus out %W"}
+ set x {}
+ }
+ focus -force .f1
+ update
+ set x [dobg {update; set x}]
+ focus .
+ update
+ list $x [dobg {update; set x}]
+} -cleanup {
+ deleteWindows
+} -result {{{focus in .t1}} {{focus in .t1} {focus out .t1}}}
+
+
+test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ }
+ update
+ dobg {
+ bind .t1 <Configure> {lappend x {configure .t1 %w %h}}
+ set x {}
+ .t1 configure -width 300 -height 120
+ update
+ list $x [winfo geom .t1]
+ }
+} -cleanup {
+ deleteWindows
+} -result {{{configure .t1 300 120}} 300x120+0+0}
+test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ place .f1 -width 200 -height 200
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ }
+ after 300 {set x done}
+ vwait x
+ dobg {
+ bind .t1 <Configure> {lappend x {configure .t1 %w %h}}
+ set x {}
+ .t1 configure -width 300 -height 120
+ update
+ list $x [winfo geom .t1]
+ }
+} -cleanup {
+ deleteWindows
+} -result {{{configure .t1 200 200}} 200x200+0+0}
+
+# Can't think up any tests for TkpGetOtherWindow procedure.
+
+
+test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ deleteWindows
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ }
+ focus -force .
+ bind . <KeyPress> {lappend x {key %A %E}}
+ set x {}
+ set y [dobg {
+ update
+ bind .t1 <KeyPress> {lappend y {key %A}}
+ set y {}
+ event generate .t1 <KeyPress> -keysym a
+ set y
+ }]
+ update
+ list $x $y
+} -cleanup {
+ deleteWindows
+ bind . <KeyPress> {}
+} -result {{{key a 1}} {}}
+test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1
+ }
+ update
+ focus -force .f1
+ update
+ bind . <KeyPress> {lappend x {key %A}}
+ set x {}
+ set y [dobg {
+ update
+ bind .t1 <KeyPress> {lappend y {key %A}}
+ set y {}
+ event generate .t1 <KeyPress> -keysym b
+ set y
+ }]
+ update
+ list $x $y
+} -cleanup {
+ deleteWindows
+ bind . <KeyPress> {}
+} -result {{} {{key b}}}
+
+
+test unixEmbed-8.1 {TkpClaimFocus procedure} -constraints unix -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ frame .f2 -width 200 -height 50
+ pack .f1 .f2
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken
+ }
+ focus -force .f2
+ update
+ list [dobg {
+ focus .t1
+ set x [list [focus]]
+ update
+ after 500
+ update
+ lappend x [focus]
+ }] [focus]
+} -cleanup {
+ deleteWindows
+} -result {{{} .t1} .f1}
+test unixEmbed-8.2 {TkpClaimFocus procedure} -constraints unix -setup {
+ deleteWindows
+ catch {interp delete child}
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ frame .f2 -width 200 -height 50
+ pack .f1 .f2
+ interp create child
+ child eval "set argv {-use [winfo id .f1]}"
+ load {} Tk child
+ child eval {
+ . configure -bd 2 -highlightthickness 2 -relief sunken
+ }
+ focus -force .f2
+ update
+ list [child eval {
+ focus .
+ set x [list [focus]]
+ update
+ lappend x [focus]
+ }] [focus]
+} -cleanup {
+ deleteWindows
+} -result {{{} .} .f1}
+catch {interp delete child}
+
+
+test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} -constraints {
+ unix testembed
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ frame .f2 -container 1 -width 200 -height 50
+ frame .f3 -container 1 -width 200 -height 50
+ frame .f4 -container 1 -width 200 -height 50
+ pack .f1 .f2 .f3 .f4
+ set x {}
+ lappend x [testembed]
+ foreach w {.f3 .f4 .f1 .f2} {
+ destroy $w
+ lappend x [testembed]
+ }
+ set x
+} -cleanup {
+ deleteWindows
+} -result {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}}
+test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} -constraints {
+ unix testembed
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ dobg "set w1 [winfo id .f1]"
+ dobg {
+ eval destroy [winfo child .]
+ toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken
+ set x {}
+ lappend x [testembed]
+ destroy .t1
+ lappend x [testembed]
+ }
+} -cleanup {
+ deleteWindows
+} -result {{{XXX {} {} .t1}} {}}
+
+
+test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ toplevel .t1 -use [winfo id .f1] -width 150 -height 80
+ update
+ wm geometry .t1 +40+50
+ update
+ wm geometry .t1
+} -cleanup {
+ deleteWindows
+} -result {150x80+0+0}
+test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -container 1 -width 200 -height 50
+ pack .f1
+ toplevel .t1 -use [winfo id .f1] -width 150 -height 80
+ update
+ wm geometry .t1 70x300+10+20
+ update
+ wm geometry .t1
+} -cleanup {
+ deleteWindows
+} -result {70x300+0+0}
+
+# cleanup
+deleteWindows
+cleanupbg
+cleanupTests
+return
+
diff --git a/tk8.6/tests/unixFont.test b/tk8.6/tests/unixFont.test
new file mode 100644
index 0000000..27826d4
--- /dev/null
+++ b/tk8.6/tests/unixFont.test
@@ -0,0 +1,318 @@
+# This file is a Tcl script to test out the procedures in tkUnixFont.c.
+# It is organized in the standard fashion for Tcl tests.
+#
+# Many of these tests are visually oriented and cannot be checked
+# programmatically (such as "does an underlined font appear to be
+# underlined?"); these tests attempt to exercise the code in question,
+# but there are no results that can be checked. Some tests depend on the
+# fonts having or not having certain properties, which may not be valid
+# at all sites.
+#
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+if {[tk windowingsystem] eq "x11"} {
+ set xlsf [auto_execok xlsfonts]
+}
+foreach {constraint font} {
+ hasArial arial
+ hasCourierNew "courier new"
+ hasTimesNew "times new roman"
+} {
+ if {[tk windowingsystem] eq "x11"} {
+ testConstraint $constraint 1
+ if {[llength $xlsf]} {
+ if {![catch {eval exec $xlsf [list *-$font-*]} res]
+ && ![string match *unmatched* $res]} {
+ # Newer Unix systems have more default fonts installed,
+ # so we can't rely on fallbacks for fonts to need to
+ # fall back on anything.
+ testConstraint $constraint 0
+ }
+ }
+ } else {
+ testConstraint $constraint 0
+ }
+}
+
+catch {destroy .b}
+toplevel .b
+wm geom .b +0+0
+update idletasks
+
+# Font should be fixed width and have chars missing below char 32, so can
+# test control char expansion and missing character code.
+
+set courier {Courier -10}
+set cx [font measure $courier 0]
+
+label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font fixed
+pack .b.l
+canvas .b.c -closeenough 0
+
+set t [.b.c create text 0 0 -anchor nw -just left -font $courier]
+pack .b.c
+update
+
+set ax [winfo reqwidth .b.l]
+set ay [winfo reqheight .b.l]
+proc getsize {} {
+ update
+ return "[winfo reqwidth .b.l] [winfo reqheight .b.l]"
+}
+
+test unixfont-1.1 {TkpGetNativeFont procedure: not native} {unix noExceed} {
+ list [catch {font measure {} xyz} msg] $msg
+} {1 {font "" doesn't exist}}
+test unixfont-1.2 {TkpGetNativeFont procedure: native} unix {
+ font measure fixed 0
+} {6}
+
+test unixfont-2.1 {TkpGetFontFromAttributes procedure: no family} unix {
+ font actual {-size 10}
+ set x {}
+} {}
+test unixfont-2.2 {TkpGetFontFromAttributes procedure: Times relatives} \
+ {unix noExceed hasTimesNew} {
+ set x {}
+ lappend x [lindex [font actual {-family "Times New Roman"}] 1]
+ lappend x [lindex [font actual {-family "New York"}] 1]
+ lappend x [lindex [font actual {-family "Times"}] 1]
+} {times times times}
+test unixfont-2.3 {TkpGetFontFromAttributes procedure: Courier relatives} \
+ {unix noExceed hasCourierNew} {
+ set x {}
+ lappend x [lindex [font actual {-family "Courier New"}] 1]
+ lappend x [lindex [font actual {-family "Monaco"}] 1]
+ lappend x [lindex [font actual {-family "Courier"}] 1]
+} {courier courier courier}
+test unixfont-2.4 {TkpGetFontFromAttributes procedure: Helvetica relatives} \
+ {unix noExceed hasArial} {
+ set x {}
+ lappend x [lindex [font actual {-family "Arial"}] 1]
+ lappend x [lindex [font actual {-family "Geneva"}] 1]
+ lappend x [lindex [font actual {-family "Helvetica"}] 1]
+} {helvetica helvetica helvetica}
+test unixfont-2.5 {TkpGetFontFromAttributes procedure: fallback} unix {
+ font actual {-xyz-xyz-*-*-*-*-*-*-*-*-*-*-*-*}
+ set x {}
+} {}
+test unixfont-2.6 {TkpGetFontFromAttributes: fallback to fixed family} unix {
+ lindex [font actual {-family fixed -size 10}] 1
+} {fixed}
+test unixfont-2.7 {TkpGetFontFromAttributes: fixed family not available!} unix {
+ # no test available
+} {}
+test unixfont-2.8 {TkpGetFontFromAttributes: loop over returned font names} unix {
+ lindex [font actual {-family fixed -size 31}] 1
+} {fixed}
+test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} {unix noExceed} {
+ lindex [font actual {-family courier}] 1
+} {courier}
+test unixfont-2.10 {TkpGetFontFromAttributes: scalable font found} unix {
+ lindex [font actual {-family courier -size 37}] 3
+} {37}
+test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} unix {
+ # On Linux, XListFonts() was returning names for fonts that do not
+ # actually exist, causing the subsequent XLoadQueryFont() to fail
+ # unexpectedly. Now falls back to another font if that happens.
+
+ font actual {-size 14}
+ set x {}
+} {}
+
+test unixfont-3.1 {TkpDeleteFont procedure} unix {
+ font actual {-family xyz}
+ set x {}
+} {}
+
+test unixfont-4.1 {TkpGetFontFamilies procedure} unix {
+ font families
+ set x {}
+} {}
+
+test unixfont-5.1 {Tk_MeasureChars procedure: no chars to be measured} unix {
+ .b.l config -text "000000" -wrap [expr $ax*3]
+ .b.l config -wrap 0
+} {}
+test unixfont-5.2 {Tk_MeasureChars procedure: no right margin} unix {
+ .b.l config -text "000000"
+} {}
+test unixfont-5.3 {Tk_MeasureChars procedure: loop over chars} unix {
+ .b.l config -text "0"
+ .b.l config -text "\377"
+ .b.l config -text "0\3770\377"
+ .b.l config -text "000000000000000"
+} {}
+.b.l config -wrap [expr $ax*10]
+test unixfont-5.4 {Tk_MeasureChars procedure: reached right edge} unix {
+ .b.l config -text "0000000000000"
+ getsize
+} "[expr $ax*10] [expr $ay*2]"
+test unixfont-5.5 {Tk_MeasureChars procedure: ran out of chars} unix {
+ .b.l config -text "000000"
+ getsize
+} "[expr $ax*6] $ay"
+test unixfont-5.6 {Tk_MeasureChars procedure: find last word} unix {
+ .b.l config -text "000000 00000"
+ getsize
+} "[expr $ax*6] [expr $ay*2]"
+test unixfont-5.7 {Tk_MeasureChars procedure: already saw space in line} unix {
+ .b.l config -text "000000 00000"
+ getsize
+} "[expr $ax*6] [expr $ay*2]"
+test unixfont-5.8 {Tk_MeasureChars procedure: internal spaces significant} unix {
+ .b.l config -text "00 000 00000"
+ getsize
+} "[expr $ax*7] [expr $ay*2]"
+test unixfont-5.9 {Tk_MeasureChars procedure: TK_PARTIAL_OK} unix {
+ .b.c dchars $t 0 end
+ .b.c insert $t 0 "0000"
+ .b.c index $t @[expr int($ax*2.5)],1
+} {2}
+test unixfont-5.10 {Tk_MeasureChars procedure: TK_AT_LEAST_ONE} unix {
+ .b.l config -text "000000000000"
+ getsize
+} "[expr $ax*10] [expr $ay*2]"
+test unixfont-5.11 {Tk_MeasureChars: TK_AT_LEAST_ONE + not even one char fit!} unix {
+ set a [.b.l cget -wrap]
+ .b.l config -text "000000" -wrap 1
+ set x [getsize]
+ .b.l config -wrap $a
+ set x
+} "$ax [expr $ay*6]"
+test unixfont-5.12 {Tk_MeasureChars procedure: include eol spaces} unix {
+ .b.l config -text "000 \n000"
+ getsize
+} "[expr $ax*6] [expr $ay*2]"
+
+test unixfont-6.1 {Tk_DrawChars procedure: loop test} unix {
+ .b.l config -text "a"
+ update
+} {}
+test unixfont-6.2 {Tk_DrawChars procedure: loop test} unix {
+ .b.l config -text "abcd"
+ update
+} {}
+test unixfont-6.3 {Tk_DrawChars procedure: special char} unix {
+ .b.l config -text "\001"
+ update
+} {}
+test unixfont-6.4 {Tk_DrawChars procedure: normal then special} unix {
+ .b.l config -text "ab\001"
+ update
+} {}
+test unixfont-6.5 {Tk_DrawChars procedure: ends with special} unix {
+ .b.l config -text "ab\001"
+ update
+} {}
+test unixfont-6.6 {Tk_DrawChars procedure: more normal chars at end} unix {
+ .b.l config -text "ab\001def"
+ update
+} {}
+
+test unixfont-7.1 {DrawChars procedure: no effects} unix {
+ .b.l config -text "abc"
+ update
+} {}
+test unixfont-7.2 {DrawChars procedure: underlining} unix {
+ set f [.b.l cget -font]
+ .b.l config -text "abc" -font "courier 10 underline"
+ update
+ .b.l config -font $f
+} {}
+test unixfont-7.3 {DrawChars procedure: overstrike} unix {
+ set f [.b.l cget -font]
+ .b.l config -text "abc" -font "courier 10 overstrike"
+ update
+ .b.l config -font $f
+} {}
+
+test unixfont-8.1 {AllocFont procedure: use old font} unix {
+ font create xyz
+ button .c -font xyz
+ font configure xyz -family times
+ update
+ destroy .c
+ font delete xyz
+} {}
+test unixfont-8.2 {AllocFont procedure: parse information from XLFD} unix {
+ expr {[lindex [font actual {-family times -size 0}] 3] == 0}
+} {0}
+test unixfont-8.3 {AllocFont procedure: can't parse info from name} unix {
+ catch {unset fontArray}
+ # check that font actual returns the correct attributes.
+ # the values of those attributes are system dependent.
+ array set fontArray [font actual a12biluc]
+ set result [lsort [array names fontArray]]
+ catch {unset fontArray}
+ set result
+} {-family -overstrike -size -slant -underline -weight}
+test unixfont-8.4 {AllocFont procedure: classify characters} unix {
+ set x 0
+ incr x [font measure $courier "\u4000"] ;# 6
+ incr x [font measure $courier "\002"] ;# 4
+ incr x [font measure $courier "\012"] ;# 2
+ incr x [font measure $courier "\101"] ;# 1
+ set x
+} [expr $cx*13]
+test unixfont-8.5 {AllocFont procedure: setup widths of normal chars} unix {
+ font metrics $courier -fixed
+} {1}
+test unixfont-8.6 {AllocFont procedure: setup widths of special chars} unix {
+ set x 0
+ incr x [font measure $courier "\001"] ;# 4
+ incr x [font measure $courier "\002"] ;# 4
+ incr x [font measure $courier "\012"] ;# 2
+ set x
+} [expr $cx*10]
+test unixfont-8.7 {AllocFont procedure: XA_UNDERLINE_POSITION} unix {
+ catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
+ set x {}
+} {}
+test unixfont-8.8 {AllocFont procedure: no XA_UNDERLINE_POSITION} unix {
+ catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific}
+ set x {}
+} {}
+test unixfont-8.9 {AllocFont procedure: XA_UNDERLINE_THICKNESS} unix {
+ catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
+ set x {}
+} {}
+test unixfont-8.10 {AllocFont procedure: no XA_UNDERLINE_THICKNESS} unix {
+ catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific}
+ set x {}
+} {}
+test unixfont-8.11 {AllocFont procedure: XA_UNDERLINE_POSITION was 0} unix {
+ catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
+ set x {}
+} {}
+
+test unixfont-9.1 {GetControlCharSubst procedure: 2 chars subst} unix {
+ .b.c dchars $t 0 end
+ .b.c insert $t 0 "0\a0"
+ set x {}
+ lappend x [.b.c index $t @[expr $ax*0],0]
+ lappend x [.b.c index $t @[expr $ax*1],0]
+ lappend x [.b.c index $t @[expr $ax*2],0]
+ lappend x [.b.c index $t @[expr $ax*3],0]
+} {0 1 1 2}
+test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} unix {
+ .b.c dchars $t 0 end
+ .b.c insert $t 0 "0\0010"
+ set x {}
+ lappend x [.b.c index $t @[expr $ax*0],0]
+ lappend x [.b.c index $t @[expr $ax*1],0]
+ lappend x [.b.c index $t @[expr $ax*2],0]
+ lappend x [.b.c index $t @[expr $ax*3],0]
+ lappend x [.b.c index $t @[expr $ax*4],0]
+ lappend x [.b.c index $t @[expr $ax*5],0]
+} {0 1 1 1 1 2}
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/unixMenu.test b/tk8.6/tests/unixMenu.test
new file mode 100644
index 0000000..3d655e4
--- /dev/null
+++ b/tk8.6/tests/unixMenu.test
@@ -0,0 +1,1275 @@
+# This file is a Tcl script to test menus in Tk. It is
+# organized in the standard fashion for Tcl tests. This
+# file tests the Macintosh-specific features of the menu
+# system.
+#
+# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+
+test unixMenu-1.1 {TkpNewMenu - normal menu} -constraints unix -setup {
+ destroy .m1
+} -body {
+ list [menu .m1] [destroy .m1]
+} -returnCodes ok -result {.m1 {}}
+test unixMenu-1.2 {TkpNewMenu - help menu} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ . configure -menu .m1
+ .m1 add cascade -label Help -menu .m1.help
+ list [menu .m1.help] [. configure -menu ""] [destroy .m1]
+} -returnCodes ok -result {.m1.help {} {}}
+
+
+test unixMenu-2.1 {TkpDestroyMenu - nothing to do} -constraints unix -body {}
+
+
+test unixMenu-3.1 {TkpDestroymenuEntry - nothing to do} -constraints unix -body {}
+
+
+test unixMenu-4.1 {TkpConfigureMenuEntry - non-cascade entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label test
+ list [.m1 entryconfigure test -label foo] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -menu .m2 -label test
+ menu .m1.foo -tearoff 0
+ list [.m1 entryconfigure test -menu .m1.foo] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+
+
+test unixMenu-5.1 {TkpMenuNewEntry - nothing to do} -constraints unix -body {}
+
+
+test unixMenu-6.1 {TkpSetWindowMenuBar - null menu} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label foo
+ . configure -menu .m1
+ list [. configure -menu ""] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test unixMenu-6.2 {TkpSetWindowMenuBar - menu} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label foo
+ list [. configure -menu .m1] [. configure -menu ""] [destroy .m1]
+} -returnCodes ok -result {{} {} {}}
+
+
+test unixMenu-7.1 {TkpSetMainMenubar - nothing to do} -constraints unix -body {}
+
+
+test unixMenu-8.1 {GetMenuIndicatorGeometry - indicator off} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo -indicatoron 0
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-8.2 {GetMenuIndicatorGeometry - not checkbutton or radio} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} -constraints {
+ unix testImageType
+} -setup {
+ destroy .m1
+ catch {image delete image1}
+} -body {
+ menu .m1
+ image create test image1
+ .m1 add checkbutton -image image1 -label foo
+ .m1 invoke foo
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -cleanup {
+ image delete image1
+} -returnCodes ok
+test unixMenu-8.4 {GetMenuIndicatorGeometry - checkbutton bitmap} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -bitmap questhead -label foo
+ .m1 invoke foo
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-8.5 {GetMenuIndicatorGeometry - checkbutton} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo
+ .m1 invoke foo
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} -constraints {
+ unix testImageType
+} -setup {
+ destroy .m1
+ catch {image delete image1}
+} -body {
+ menu .m1
+ image create test image1
+ .m1 add radiobutton -image image1 -label foo
+ .m1 invoke foo
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+ image delete image1
+} -returnCodes ok
+test unixMenu-8.7 {GetMenuIndicatorGeometry - radiobutton bitmap} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add radiobutton -bitmap questhead -label foo
+ .m1 invoke foo
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-8.8 {GetMenuIndicatorGeometry - radiobutton} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add radiobutton -label foo
+ .m1 invoke foo
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add radiobutton -label foo -hidemargin 1
+ .m1 invoke foo
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+
+
+test unixMenu-9.1 {GetMenuAccelGeometry - cascade entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label foo
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-9.2 {GetMenuAccelGeometry - non-null label} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -accel "Ctrl+S"
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-9.3 {GetMenuAccelGeometry - null label} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+
+
+test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label foo
+ . configure -menu .m1
+ .m1 activate 1
+ list [update] [. configure -menu ""] [destroy .m1]
+} -returnCodes ok -result {{} {} {}}
+test unixMenu-10.2 {DrawMenuEntryBackground - active} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ $tearoff activate 0
+ list [update] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test unixMenu-10.3 {DrawMenuEntryBackground - non-active} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+
+
+test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -accel "Ctrl+U"
+ . configure -menu .m1
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+# drawArrow parameter is never false under Unix
+test unixMenu-11.2 {DrawMenuEntryAccelerator - cascade entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-11.3 {DrawMenuEntryAccelerator - normal entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -accel "Ctrl+U"
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test unixMenu-12.1 {DrawMenuEntryIndicator - non-check or radio} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-12.2 {DrawMenuEntryIndicator - checkbutton - indicator off} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo -indicatoron 0
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-12.3 {DrawMenuEntryIndicator - checkbutton - not selected} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo
+ .m1 invoke 1
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-12.5 {DrawMenuEntryIndicator - radiobutton - indicator off} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add radiobutton -label foo -indicatoron 0
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-12.6 {DrawMenuEntryIndicator - radiobutton - not selected} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add radiobutton -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add radiobutton -label foo
+ .m1 invoke 1
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test unixMenu-13.1 {DrawMenuSeparator - menubar case} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add separator
+ . configure -menu .m1
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-13.2 {DrawMenuSepartor - normal menu} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add separator
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test unixMenu-14.1 {DrawMenuEntryLabel} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test unixMenu-15.1 {DrawMenuUnderline - menubar} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -underline 0
+ . configure -menu .m1
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-15.2 {DrawMenuUnderline - no menubar} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -underline 0
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test unixMenu-16.1 {TkpPostMenu} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+
+
+test unixMenu-17.1 {GetMenuSeparatorGeometry} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add separator
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+
+
+test unixMenu-18.1 {GetTearoffEntryGeometry} -constraints {
+ unix nonUnixUserInteraction
+} -setup {
+ destroy .mb
+} -body {
+ menubutton .mb -text "test" -menu .mb.m
+ menu .mb.m
+ .mb.m add command -label test
+ pack .mb
+ raise .
+ list [tk::MbPost .mb] [tk::MenuUnpost .mb.m] [destroy .mb]
+} -result {{} {} {}}
+
+
+# Don't know how to reproduce the case where the tkwin has been deleted.
+
+test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ . configure -menu .m1
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+# Don't know how to generate one width windows
+test unixMenu-19.2 {TkpComputeMenubarGeometry - one entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label File
+ . configure -menu .m1
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.3 {TkpComputeMenubarGeometry - entry with different font} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -font "Courier 24"
+ .m1 add cascade -label File -font "Helvetica 18"
+ . configure -menu .m1
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.4 {TkpComputeMenubarGeometry - separator} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add separator
+ . configure -menu .m1
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.5 {TkpComputeMenubarGeometry - First entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label File
+ . configure -menu .m1
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label File -font "Times 72"
+ . configure -menu .m1
+ wm geometry . 10x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label File
+ .m1 add cascade -label Edit
+ . configure -menu .m1
+ wm geometry . 200x200
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label File
+ .m1 add cascade -label Edit -font "Times 72"
+ . configure -menu .m1
+ wm geometry . 100x100
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label File -font "Times 72"
+ .m1 add cascade -label Edit
+ . configure -menu .m1
+ wm geometry . 100x100
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0 -font "Times 72"
+ .m1 add cascade -label File
+ .m1 add cascade -label Edit
+ . configure -menu .m1
+ wm geometry . 10x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+# ABC notation; capital A means first window fits, small a means it
+# does not. capital B menu means second window fist, etc.
+test unixMenu-19.11 {TkpComputeMenubarGeometry - abc} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0 -font "Times 72"
+ .m1 add cascade -label "aaaaa"
+ .m1 add cascade -label "bbbbb"
+ .m1 add cascade -label "ccccc"
+ . configure -menu .m1
+ wm geometry . 10x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.12 {TkpComputeMenubarGeometry - abC} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label "aaaaa" -font "Times 72"
+ .m1 add cascade -label "bbbbb" -font "Times 72"
+ .m1 add cascade -label "C"
+ . configure -menu .m1
+ wm geometry . 10x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.13 {TkpComputeMenubarGeometry - aBc} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label "aaaaa" -font "Times 72"
+ .m1 add cascade -label "B"
+ .m1 add cascade -label "ccccc" -font "Times 72"
+ . configure -menu .m1
+ wm geometry . 10x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.14 {TkpComputeMenubarGeometry - aBC} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label "aaaaa" -font "Times 72"
+ .m1 add cascade -label "B"
+ .m1 add cascade -label "C"
+ . configure -menu .m1
+ wm geometry . 60x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.15 {TkpComputeMenubarGeometry - Abc} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label "A"
+ .m1 add cascade -label "bbbbb" -font "Times 72"
+ .m1 add cascade -label "ccccc" -font "Times 72"
+ . configure -menu .m1
+ wm geometry . 60x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.16 {TkpComputeMenubarGeometry - AbC} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label "A"
+ .m1 add cascade -label "bbbbb" -font "Times 72"
+ .m1 add cascade -label "C"
+ . configure -menu .m1
+ wm geometry . 60x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.17 {TkpComputeMenubarGeometry - ABc} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label "A"
+ .m1 add cascade -label "B"
+ .m1 add cascade -label "ccccc" -font "Times 72"
+ . configure -menu .m1
+ wm geometry . 60x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label "A"
+ .m1 add cascade -label "B"
+ .m1 add cascade -label "C"
+ . configure -menu .m1
+ wm geometry . 100x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label Help -menu .m1.help
+ menu .m1.help -tearoff 0
+ .m1 add cascade -label File -menu .m1.file
+ menu .m1.file -tearoff 0
+ .m1 add cascade -label Edit -menu .m1.edit
+ menu .m1.edit -tearoff 0
+ . configure -menu .m1
+ wm geometry . 100x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label Edit -menu .m1.edit
+ menu .m1.edit -tearoff 0
+ .m1 add cascade -label Help -menu .m1.help
+ menu .m1.help -tearoff 0
+ .m1 add cascade -label File -menu .m1.file
+ menu .m1.file -tearoff 0
+ . configure -menu .m1
+ wm geometry . 100x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label File -menu .m1.file
+ menu .m1.file -tearoff 0
+ .m1 add cascade -label Edit -menu .m1.edit
+ menu .m1.edit -tearoff 0
+ .m1 add cascade -label Help -menu .m1.help
+ menu .m1.help -tearoff 0
+ . configure -menu .m1
+ wm geometry . 100x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label File -menu .m1.file
+ menu .m1.file -tearoff 0
+ .m1 add cascade -label Help -menu .m1.help
+ menu .m1.help -tearoff 0
+ . configure -menu .m1
+ wm geometry . 100x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label File -menu .m1.file
+ menu .m1.file -tearoff 0
+ .m1 add cascade -label Help -menu .m1.help -font "Helvetica 72"
+ menu .m1.help -tearoff 0
+ . configure -menu .m1
+ wm geometry . 100x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label Help -menu .m1.help
+ menu .m1.help -tearoff 0
+ . configure -menu .m1
+ wm geometry . 100x10
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+
+
+test unixMenu-20.1 {DrawTearoffEntry - menubar} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label File
+ . configure -menu .m1
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-20.2 {DrawTearoffEntry - non-menubar} -constraints {
+ unix nonUnixUserInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ .m1 post 40 40
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test unixMenu-21.1 {TkpInitializeMenuBindings - nothing to do} -constraints unix -body {}
+
+
+test unixMenu-22.1 {SetHelpMenu - no menubars} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label test -menu .m1.test
+ list [menu .m1.test] [destroy .m1]
+} -result {.m1.test {}}
+# Don't know how to automate missing tkwins
+test unixMenu-22.2 {SetHelpMenu - menubar but no help menu} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ . configure -menu .m1
+ .m1 add cascade -label .m1.file
+ list [menu .m1.file] [. configure -menu ""] [destroy .m1]
+} -result {.m1.file {} {}}
+test unixMenu-22.3 {SetHelpMenu - menubar with help menu} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ . configure -menu .m1
+ .m1 add cascade -label .m1.help
+ list [menu .m1.help] [. configure -menu ""] [destroy .m1]
+} -result {.m1.help {} {}}
+test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} -constraints {
+ unix
+} -setup {
+ destroy .m1 .t2
+} -body {
+ toplevel .t2
+ wm geometry .t2 +40+40
+ menu .m1 -tearoff 0
+ . configure -menu .m1
+ .t2 configure -menu .m1
+ .m1 add cascade -label .m1.help
+ list [menu .m1.help] [. configure -menu ""] [destroy .m1] [destroy .t2]
+} -result {.m1.help {} {} {}}
+
+
+test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -activeforeground red
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ set tk_strictMotif 1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1] [set tk_strictMotif 0]
+} -result {{} {} 0}
+test unixMenu-23.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -disabledforeground blue
+ .m1 add command -label foo -state disabled -background red
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -disabledforeground blue
+ .m1 add command -label foo -state disabled
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -disabledforeground ""
+ .m1 add command -label foo -state disabled
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.7 {TkpDrawMenuEntry - gc for normal - custom entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -foreground red
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.8 {TkpDrawMenuEntry - gc for normal} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo -selectcolor orange
+ .m1 invoke 1
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo
+ .m1 invoke 1
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -activebackground green
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.12 {TkpDrawMenuEntry - border} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ set tk_strictMotif 1
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1] [set tk_strictMotif 0]
+} -result {{} {} 0}
+test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -activeforeground yellow
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.15 {TkpDrawMenuEntry - active border} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.16 {TkpDrawMenuEntry - font - custom entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -font "Helvectica 72"
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.17 {TkpDrawMenuEntry - font} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1 -font "Courier 72"
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.18 {TkpDrawMenuEntry - separator} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add separator
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.19 {TkpDrawMenuEntry - standard} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label File -menu .m1.file
+ menu .m1.file
+ .m1.file add command -label foo
+ .m1 entryconfigure File -state disabled
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.21 {TkpDrawMenuEntry - indicator} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label Foo
+ .m1 invoke Foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-23.22 {TkpDrawMenuEntry - hide margin} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label Foo -hidemargin 1
+ .m1 invoke Foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test unixMenu-24.1 {GetMenuLabelGeometry - image} -constraints {
+ testImageType unix
+} -setup {
+ destroy .m1
+ catch {image delete image1}
+} -body {
+ menu .m1
+ image create test image1
+ .m1 add command -image image1
+ list [update idletasks] [destroy .m1] [image delete image1]
+} -result {{} {} {}}
+test unixMenu-24.2 {GetMenuLabelGeometry - bitmap} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -bitmap questhead
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-24.3 {GetMenuLabelGeometry - no text} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-24.4 {GetMenuLabelGeometry - text} -constraints unix -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "This is a test."
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+
+
+test unixMenu-25.1 {TkpComputeStandardMenuGeometry - no entries} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.2 {TkpComputeStandardMenuGeometry - one entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "one"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.3 {TkpComputeStandardMenuGeometry - more than one entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "one"
+ .m1 add command -label "two"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.4 {TkpComputeStandardMenuGeometry - separator} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add separator
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} -constraints {
+ unix nonUnixUserInteraction
+} -setup {
+ destroy .mb
+} -body {
+ menubutton .mb -text "test" -menu .mb.m
+ menu .mb.m
+ .mb.m add command -label test
+ pack .mb
+ catch {tk::MbPost .mb}
+ list [update] [tk::MenuUnpost .mb.m] [destroy .mb]
+} -result {{} {} {}}
+test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.7 {TkpComputeStandardMenuGeometry - different font for entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -font "Helvetica 12"
+ .m1 add command -label "test" -font "Courier 12"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.8 {TkpComputeStandardMenuGeometry - second entry larger} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 add command -label "test test"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.9 {TkpComputeStandardMenuGeometry - first entry larger} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test test"
+ .m1 add command -label "test"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.10 {TkpComputeStandardMenuGeometry - accelerator} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test" -accel "Ctrl+S"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.11 {TkpComputeStandardMenuGeometry - second accel larger} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test" -accel "1"
+ .m1 add command -label "test" -accel "1 1"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.12 {TkpComputeStandardMenuGeometry - second accel smaller} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test" -accel "1 1"
+ .m1 add command -label "test" -accel "1"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.13 {TkpComputeStandardMenuGeometry - indicator} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label test
+ .m1 invoke 1
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or equal } -constraints {
+ unix testImageType
+} -setup {
+ destroy .m1
+ catch {image delete image1}
+} -body {
+ image create test image1
+ menu .m1
+ .m1 add checkbutton -image image1
+ .m1 invoke 1
+ .m1 add checkbutton -label test
+ .m1 invoke 2
+ list [update idletasks] [destroy .m1] [image delete image1]
+} -result {{} {} {}}
+test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } -constraints {
+ unix testImageType
+} -setup {
+ destroy .m1
+ catch {image delete image1}
+} -body {
+ image create test image1
+ menu .m1
+ .m1 add checkbutton -image image1
+ .m1 invoke 1
+ .m1 add checkbutton -label test
+ .m1 invoke 2
+ list [update idletasks] [destroy .m1] [image delete image1]
+} -result {{} {} {}}
+test unixMenu-25.16 {TkpComputeStandardMenuGeometry - zero sized menus} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label one
+ .m1 add command -label two
+ .m1 add command -label three -columnbreak 1
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label one
+ .m1 add command -label two -columnbreak 1
+ .m1 add command -label three
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label one
+ .m1 add command -label two -columnbreak 1
+ .m1 add command -label three
+ .m1 add command -label four
+ .m1 add command -label five -columnbreak 1
+ .m1 add command -label six
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add checkbutton -label one -hidemargin 1
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+
+
+test unixMenu-26.1 {TkpMenuInit - nothing to do} -constraints unix -body {}
+
+
+
+# cleanup
+deleteWindows
+cleanupTests
+return
diff --git a/tk8.6/tests/unixSelect.test b/tk8.6/tests/unixSelect.test
new file mode 100644
index 0000000..53ae006
--- /dev/null
+++ b/tk8.6/tests/unixSelect.test
@@ -0,0 +1,437 @@
+# This file contains tests for the tkUnixSelect.c file.
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+
+global longValue selValue selInfo
+
+set selValue {}
+set selInfo {}
+
+proc handler {type offset count} {
+ global selValue selInfo
+ lappend selInfo $type $offset $count
+ set numBytes [expr {[string length $selValue] - $offset}]
+ if {$numBytes <= 0} {
+ return ""
+ }
+ string range $selValue $offset [expr $numBytes+$offset]
+}
+
+proc errIncrHandler {type offset count} {
+ global selValue selInfo pass
+ if {$offset == 4000} {
+ if {$pass == 0} {
+ # Just sizing the selection; don't do anything here.
+ set pass 1
+ } else {
+ # Fetching the selection; wait long enough to cause a timeout.
+ after 6000
+ }
+ }
+ lappend selInfo $type $offset $count
+ set numBytes [expr {[string length $selValue] - $offset}]
+ if {$numBytes <= 0} {
+ return ""
+ }
+ string range $selValue $offset [expr $numBytes+$offset]
+}
+
+proc errHandler args {
+ error "selection handler aborted"
+}
+
+proc badHandler {path type offset count} {
+ global selValue selInfo
+ selection handle -type $type $path {}
+ lappend selInfo $path $type $offset $count
+ set numBytes [expr {[string length $selValue] - $offset}]
+ if {$numBytes <= 0} {
+ return ""
+ }
+ string range $selValue $offset [expr $numBytes+$offset]
+}
+proc reallyBadHandler {path type offset count} {
+ global selValue selInfo pass
+ if {$offset == 4000} {
+ if {$pass == 0} {
+ set pass 1
+ } else {
+ selection handle -type $type $path {}
+ }
+ }
+ lappend selInfo $path $type $offset $count
+ set numBytes [expr {[string length $selValue] - $offset}]
+ if {$numBytes <= 0} {
+ return ""
+ }
+ string range $selValue $offset [expr $numBytes+$offset]
+}
+
+# Eliminate any existing selection on the screen. This is needed in case
+# there is a selection in some other application, in order to prevent races
+# from causing false errors in the tests below.
+
+selection clear .
+after 1500
+
+# common setup code
+proc setup {{path .f1} {display {}}} {
+ catch {destroy $path}
+ if {$display == {}} {
+ frame $path
+ } else {
+ toplevel $path -screen $display
+ wm geom $path +0+0
+ }
+ selection own $path
+}
+
+# set up a very large buffer to test INCR retrievals
+set longValue ""
+foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} {
+ set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14
+ append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j
+}
+
+# ----------------------------------------------------------------------
+
+test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} -constraints {
+ unix
+} -setup {
+ destroy .e
+ setupbg
+} -body {
+ pack [entry .e]
+ update
+ .e insert 0 \u00fcber
+ .e selection range 0 end
+ dobg {string length [selection get]}
+} -cleanup {
+ cleanupbg
+ destroy .e
+} -result {4}
+
+test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} -constraints {
+ unix
+} -setup {
+ setupbg
+} -body {
+ dobg {
+ pack [entry .e]
+ update
+ .e insert 0 \u00fc\u0444
+ .e selection range 0 end
+ }
+ selection get
+} -cleanup {
+ cleanupbg
+} -result \u00fc?
+
+test unixSelect-1.3 {TkSelGetSelection procedure: simple i18n text, iso2022} -constraints {
+ unix
+} -setup {
+ setupbg
+ setup
+} -body {
+ selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \
+ {handler COMPOUND_TEXT}
+ selection own .
+ set selValue \u00fc\u0444
+ set selInfo {}
+ set result [dobg {
+ set x [selection get -type COMPOUND_TEXT]
+ list [string equal \u00fc\u0444 $x] [string length $x]
+ }]
+ lappend result $selInfo
+} -cleanup {
+ cleanupbg
+} -result {1 2 {COMPOUND_TEXT 0 4000}}
+
+test unixSelect-1.4 {TkSelGetSelection procedure: INCR i18n text, iso2022} -constraints {
+ unix
+} -setup {
+ setupbg
+ setup
+} -body {
+ # This test is subtle. The selection ends up getting fetched twice by
+ # Tk: once to compute the length, and again to actually send the data.
+ # The first time through, we don't convert the data to ISO2022, so the
+ # buffer boundaries end up being different in the two passes.
+ selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \
+ {handler COMPOUND_TEXT}
+ selection own .
+ set selValue [string repeat x 3999]\u00fc\u0444[string repeat x 3999]
+ set selInfo {}
+ set result [dobg {
+ set x [selection get -type COMPOUND_TEXT]
+ list [string equal \
+ [string repeat x 3999]\u00fc\u0444[string repeat x 3999] $x] \
+ [string length $x]
+ }]
+ lappend result $selInfo
+} -cleanup {
+ cleanupbg
+} -result {1 8000 {COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3999 COMPOUND_TEXT 7998 4000 COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3998 COMPOUND_TEXT 7997 4000}}
+
+test unixSelect-1.5 {TkSelGetSelection procedure: simple i18n text, iso2022} -constraints {
+ unix
+} -setup {
+ setupbg
+ setup
+} -body {
+ selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \
+ {handler COMPOUND_TEXT}
+ selection own .
+ set selValue \u00fc\u0444
+ set selInfo {}
+ set result [dobg {
+ set x [selection get -type COMPOUND_TEXT]
+ list [string equal \u00fc\u0444 $x] [string length $x]
+ }]
+ lappend result $selInfo
+} -cleanup {
+ cleanupbg
+} -result {1 2 {COMPOUND_TEXT 0 4000}}
+
+test unixSelect-1.6 {TkSelGetSelection procedure: INCR i18n text} -constraints {
+ unix
+} -setup {
+ setupbg
+} -body {
+ dobg [subst -nobackslashes {entry .e; pack .e; update
+ .e insert 0 \u00fcber$longValue
+ .e selection range 0 end}]
+ string length [selection get]
+} -cleanup {
+ cleanupbg
+} -result [expr {4 + [string length $longValue]}]
+
+test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} -constraints {
+ unix
+} -setup {
+ setupbg
+} -body {
+ dobg {
+ pack [entry .e]
+ update
+ .e insert 0 [string repeat x 3999]\u00fc
+ .e selection range 0 end
+ }
+ selection get
+} -cleanup {
+ cleanupbg
+} -result [string repeat x 3999]\u00fc
+
+test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} -constraints {
+ unix
+} -setup {
+ setupbg
+} -body {
+ dobg {
+ pack [entry .e]
+ update
+ .e insert 0 \u00fc[string repeat x 3999]
+ .e selection range 0 end
+ }
+ selection get
+} -cleanup {
+ cleanupbg
+} -result \u00fc[string repeat x 3999]
+
+test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} -constraints {
+ unix
+} -setup {
+ setupbg
+} -body {
+ dobg {
+ pack [entry .e]
+ update
+ .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000]
+ .e selection range 0 end
+ }
+ selection get
+} -cleanup {
+ cleanupbg
+} -result [string repeat x 3999]\u00fc[string repeat x 4000]
+# Now some tests to make sure that the right thing is done when
+# transferring UTF8 selections, to prevent [Bug 614650] and its ilk
+# from rearing its ugly head again.
+
+test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
+ unix
+} -setup {
+ setupbg
+} -body {
+ dobg {
+ pack [entry .e]
+ update
+ .e insert 0 [string repeat x 3999]\u00fc
+ .e selection range 0 end
+ }
+ selection get -type UTF8_STRING
+} -cleanup {
+ cleanupbg
+} -result [string repeat x 3999]\u00fc
+
+test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
+ unix
+} -setup {
+ setupbg
+} -body {
+ dobg {
+ pack [entry .e]
+ update
+ .e insert 0 \u00fc[string repeat x 3999]
+ .e selection range 0 end
+ }
+ selection get -type UTF8_STRING
+} -cleanup {
+ cleanupbg
+} -result \u00fc[string repeat x 3999]
+
+test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
+ unix
+} -setup {
+ setupbg
+} -body {
+ dobg {
+ pack [entry .e]
+ update
+ .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000]
+ .e selection range 0 end
+ }
+ selection get -type UTF8_STRING
+} -cleanup {
+ cleanupbg
+} -result [string repeat x 3999]\u00fc[string repeat x 4000]
+
+test unixSelect-1.13 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints {
+ unix
+} -setup {
+ destroy .e
+ setupbg
+} -body {
+ pack [entry .e]
+ update
+ .e insert 0 \u00fcber\u0444
+ .e selection range 0 end
+ dobg {string length [selection get -type UTF8_STRING]}
+} -cleanup {
+ destroy .e
+ cleanupbg
+} -result {5}
+
+test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints {
+ unix
+} -setup {
+ setupbg
+} -body {
+ dobg {
+ pack [entry .e]
+ update
+ .e insert 0 \u00fc\u0444
+ .e selection range 0 end
+ }
+ selection get -type UTF8_STRING
+} -cleanup {
+ cleanupbg
+} -result \u00fc\u0444
+
+test unixSelect-1.15 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
+ unix
+} -setup {
+ setupbg
+} -body {
+ dobg {
+ pack [entry .e]
+ update
+ .e insert 0 [string repeat [string repeat \u00c4\u00e4 50]\n 21]
+ .e selection range 0 end
+ }
+ selection get -type UTF8_STRING
+} -cleanup {
+ cleanupbg
+} -result [string repeat [string repeat \u00c4\u00e4 50]\n 21]
+
+test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
+ unix
+} -setup {
+ setupbg
+} -body {
+ dobg {
+ pack [entry .e]
+ update
+ .e insert 0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21]
+ .e selection range 0 end
+ }
+ selection get -type UTF8_STRING
+} -cleanup {
+ cleanupbg
+} -result i[string repeat [string repeat \u00c4\u00e4 50]\n 21]
+
+test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
+ unix
+} -setup {
+ setupbg
+} -body {
+ dobg {
+ pack [text .t]
+ update
+ .t insert 1.0 [string repeat [string repeat \u00c4\u00e4 50]\n 21]
+ # Has to be selected in a separate stage
+ .t tag add sel 1.0 21.end+1c
+ }
+ after 10
+ selection get -type UTF8_STRING
+} -cleanup {
+ cleanupbg
+} -result [string repeat [string repeat \u00c4\u00e4 50]\n 21]
+
+test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
+ unix
+} -setup {
+ setupbg
+} -body {
+ dobg {
+ pack [text .t]
+ update
+ .t insert 1.0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21]
+ # Has to be selected in a separate stage
+ .t tag add sel 1.0 21.end+1c
+ }
+ after 10
+ selection get -type UTF8_STRING
+} -cleanup {
+ cleanupbg
+} -result i[string repeat [string repeat \u00c4\u00e4 50]\n 21]
+
+test unixSelect-1.19 {Automatic UTF8_STRING support for selection handle} -constraints {
+ unix
+} -setup {
+ destroy .l
+} -body {
+ # See Bug #666346 "Selection handling crashes under KDE 3.0"
+ label .l
+ selection handle .l [list handler STRING]
+ set selValue "This is the selection value"
+ selection own .l
+ selection get -type UTF8_STRING
+} -cleanup {
+ destroy .l
+} -result {This is the selection value}
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/unixWm.test b/tk8.6/tests/unixWm.test
new file mode 100644
index 0000000..d579fc7
--- /dev/null
+++ b/tk8.6/tests/unixWm.test
@@ -0,0 +1,2537 @@
+# This file is a Tcl script to test out Tk's interactions with
+# the window manager, including the "wm" command. It is organized
+# in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+namespace import -force ::tk::test:loadTkCommand
+
+proc sleep ms {
+ global x
+ after $ms {set x 1}
+ vwait x
+}
+
+# Procedure to set up a collection of top-level windows
+
+proc makeToplevels {} {
+ deleteWindows
+ foreach i {.raise1 .raise2 .raise3} {
+ toplevel $i
+ wm geom $i 150x100+0+0
+ update
+ }
+}
+
+set i 1
+foreach geom {+20+80 +80+20 +0+0} {
+ destroy .t
+ test unixWm-1.$i {initial window position} unix {
+ toplevel .t -width 200 -height 150
+ wm geom .t $geom
+ update
+ wm geom .t
+ } 200x150$geom
+ incr i
+}
+
+# The tests below are tricky because window managers don't all move
+# windows correctly. Try one motion and compute the window manager's
+# error, then factor this error into the actual tests. In other words,
+# this just makes sure that things are consistent between moves.
+
+set i 1
+destroy .t
+toplevel .t -width 100 -height 150
+wm geom .t +200+200
+update
+wm geom .t +150+150
+update
+scan [wm geom .t] %dx%d+%d+%d width height x y
+set xerr [expr 150-$x]
+set yerr [expr 150-$y]
+foreach geom {+20+80 +80+20 +0+0 -0-0 +0-0 -0+0 -10-5 -10+5 +10-5} {
+ test unixWm-2.$i {moving window while mapped} unix {
+ wm geom .t $geom
+ update
+ scan [wm geom .t] %dx%d%1s%d%1s%d width height xsign x ysign y
+ format "%s%d%s%d" $xsign [eval expr $x$xsign$xerr] $ysign \
+ [eval expr $y$ysign$yerr]
+ } $geom
+ incr i
+}
+
+set i 1
+foreach geom {+20+80 +80+20 +0+0 -0-0 +0-0 -0+0 -10-5 -10+5 +10-5} {
+ test unixWm-3.$i {moving window while iconified} unix {
+ wm iconify .t
+ sleep 200
+ wm geom .t $geom
+ update
+ wm deiconify .t
+ scan [wm geom .t] %dx%d%1s%d%1s%d width height xsign x ysign y
+ format "%s%d%s%d" $xsign [eval expr $x$xsign$xerr] $ysign \
+ [eval expr $y$ysign$yerr]
+ } $geom
+ incr i
+}
+
+set i 1
+foreach geom {+20+80 +100+40 +0+0} {
+ test unixWm-4.$i {moving window while withdrawn} unix {
+ wm withdraw .t
+ sleep 200
+ wm geom .t $geom
+ update
+ wm deiconify .t
+ wm geom .t
+ } 100x150$geom
+ incr i
+}
+
+test unixWm-5.1 {compounded state changes} {unix nonPortable} {
+ destroy .t
+ toplevel .t -width 200 -height 100
+ wm geometry .t +100+100
+ update
+ wm withdraw .t
+ wm deiconify .t
+ list [winfo ismapped .t] [wm state .t]
+} {1 normal}
+test unixWm-5.2 {compounded state changes} {unix nonPortable} {
+ destroy .t
+ toplevel .t -width 200 -height 100
+ wm geometry .t +100+100
+ update
+ wm withdraw .t
+ wm deiconify .t
+ wm withdraw .t
+ list [winfo ismapped .t] [wm state .t]
+} {0 withdrawn}
+test unixWm-5.3 {compounded state changes} {unix nonPortable} {
+ destroy .t
+ toplevel .t -width 200 -height 100
+ wm geometry .t +100+100
+ update
+ wm iconify .t
+ wm deiconify .t
+ wm iconify .t
+ wm deiconify .t
+ list [winfo ismapped .t] [wm state .t]
+} {1 normal}
+test unixWm-5.4 {compounded state changes} {unix nonPortable} {
+ destroy .t
+ toplevel .t -width 200 -height 100
+ wm geometry .t +100+100
+ update
+ wm iconify .t
+ wm deiconify .t
+ wm iconify .t
+ list [winfo ismapped .t] [wm state .t]
+} {0 iconic}
+test unixWm-5.5 {compounded state changes} {unix nonPortable} {
+ destroy .t
+ toplevel .t -width 200 -height 100
+ wm geometry .t +100+100
+ update
+ wm iconify .t
+ wm withdraw .t
+ list [winfo ismapped .t] [wm state .t]
+} {0 withdrawn}
+test unixWm-5.6 {compounded state changes} {unix nonPortable} {
+ destroy .t
+ toplevel .t -width 200 -height 100
+ wm geometry .t +100+100
+ update
+ wm iconify .t
+ wm withdraw .t
+ wm deiconify .t
+ list [winfo ismapped .t] [wm state .t]
+} {1 normal}
+test unixWm-5.7 {compounded state changes} {unix nonPortable} {
+ destroy .t
+ toplevel .t -width 200 -height 100
+ wm geometry .t +100+100
+ update
+ wm withdraw .t
+ wm iconify .t
+ list [winfo ismapped .t] [wm state .t]
+} {0 iconic}
+
+destroy .t
+toplevel .t -width 200 -height 100
+wm geom .t +10+10
+wm minsize .t 1 1
+update
+test unixWm-6.1 {size changes} unix {
+ .t config -width 180 -height 150
+ update
+ wm geom .t
+} 180x150+10+10
+test unixWm-6.2 {size changes} unix {
+ wm geom .t 250x60
+ .t config -width 170 -height 140
+ update
+ wm geom .t
+} 250x60+10+10
+test unixWm-6.3 {size changes} unix {
+ wm geom .t 250x60
+ .t config -width 170 -height 140
+ wm geom .t {}
+ update
+ wm geom .t
+} 170x140+10+10
+test unixWm-6.4 {size changes} {unix nonPortable userInteraction} {
+ wm minsize .t 1 1
+ update
+ puts stdout "Please resize window \"t\" with the mouse (but don't move it!),"
+ puts -nonewline stdout "then hit return: "
+ flush stdout
+ gets stdin
+ update
+ set width [winfo width .t]
+ set height [winfo height .t]
+ .t config -width 230 -height 110
+ update
+ incr width -[winfo width .t]
+ incr height -[winfo height .t]
+ wm geom .t {}
+ update
+ set w2 [winfo width .t]
+ set h2 [winfo height .t]
+ .t config -width 114 -height 261
+ update
+ list $width $height $w2 $h2 [wm geom .t]
+} {0 0 230 110 114x261+10+10}
+
+# I don't know why the wait below is needed, but without it the test
+# fails under twm.
+sleep 200
+
+test unixWm-6.5 {window initially iconic} {unix nonPortable} {
+ destroy .t
+ toplevel .t -width 100 -height 30
+ wm geometry .t +0+0
+ wm title .t 2
+ wm iconify .t
+ update idletasks
+ wm withdraw .t
+ wm deiconify .t
+ list [winfo ismapped .t] [wm state .t]
+} {1 normal}
+
+destroy .m
+toplevel .m
+wm overrideredirect .m 1
+foreach i {{Test label} Another {Yet another} {Last label}} j {1 2 3} {
+ label .m.$j -text $i
+}
+wm geometry .m +[expr 100 - [winfo vrootx .]]+[expr 200 - [winfo vrooty .]]
+update
+test unixWm-7.1 {override_redirect and Tk_MoveTopLevelWindow} unix {
+ list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m]
+} {1 normal 100 200}
+wm geometry .m +[expr 150 - [winfo vrootx .]]+[expr 210 - [winfo vrooty .]]
+update
+test unixWm-7.2 {override_redirect and Tk_MoveTopLevelWindow} unix {
+ list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m]
+} {1 normal 150 210}
+wm withdraw .m
+test unixWm-7.3 {override_redirect and Tk_MoveTopLevelWindow} unix {
+ list [winfo ismapped .m]
+} 0
+destroy .m
+destroy .t
+
+test unixWm-8.1 {icon windows} unix {
+ destroy .t
+ destroy .icon
+ toplevel .t -width 100 -height 30
+ wm geometry .t +0+0
+ toplevel .icon -width 50 -height 50 -bg red
+ wm iconwindow .t .icon
+ list [catch {wm withdraw .icon} msg] $msg
+} {1 {can't withdraw .icon: it is an icon for .t}}
+test unixWm-8.2 {icon windows} unix {
+ destroy .t
+ toplevel .t -width 100 -height 30
+ list [catch {wm iconwindow} msg] $msg
+} {1 {wrong # args: should be "wm option window ?arg ...?"}}
+test unixWm-8.3 {icon windows} unix {
+ destroy .t
+ toplevel .t -width 100 -height 30
+ list [catch {wm iconwindow .t b c} msg] $msg
+} {1 {wrong # args: should be "wm iconwindow window ?pathName?"}}
+test unixWm-8.4 {icon windows} unix {
+ destroy .t
+ destroy .icon
+ toplevel .t -width 100 -height 30
+ wm geom .t +0+0
+ set result [wm iconwindow .t]
+ toplevel .icon -width 50 -height 50 -bg red
+ wm iconwindow .t .icon
+ lappend result [wm iconwindow .t] [wm state .icon]
+ wm iconwindow .t {}
+ lappend result [wm iconwindow .t] [wm state .icon]
+ update
+ lappend result [winfo ismapped .t] [winfo ismapped .icon]
+ wm iconify .t
+ update
+ lappend result [winfo ismapped .t] [winfo ismapped .icon]
+} {.icon icon {} withdrawn 1 0 0 0}
+test unixWm-8.5 {icon windows} unix {
+ destroy .t
+ toplevel .t -width 100 -height 30
+ list [catch {wm iconwindow .t .gorp} msg] $msg
+} {1 {bad window path name ".gorp"}}
+test unixWm-8.6 {icon windows} unix {
+ destroy .t
+ toplevel .t -width 100 -height 30
+ frame .t.icon -width 50 -height 50 -bg red
+ list [catch {wm iconwindow .t .t.icon} msg] $msg
+} {1 {can't use .t.icon as icon window: not at top level}}
+test unixWm-8.7 {icon windows} unix {
+ destroy .t
+ destroy .icon
+ toplevel .t -width 100 -height 30
+ wm geom .t +0+0
+ toplevel .icon -width 50 -height 50 -bg red
+ toplevel .icon2 -width 50 -height 50 -bg green
+ wm iconwindow .t .icon
+ set result "[wm iconwindow .t] [wm state .icon] [wm state .icon2]"
+ wm iconwindow .t .icon2
+ lappend result [wm iconwindow .t] [wm state .icon] [wm state .icon2]
+} {.icon icon normal .icon2 withdrawn icon}
+destroy .icon2
+test unixWm-8.8 {icon windows} unix {
+ destroy .t
+ destroy .icon
+ toplevel .icon -width 50 -height 50 -bg red
+ wm geom .icon +0+0
+ update
+ set result [winfo ismapped .icon]
+ toplevel .t -width 100 -height 30
+ wm geom .t +0+0
+ tkwait visibility .t ;# Needed to keep tvtwm happy.
+ wm iconwindow .t .icon
+ sleep 500
+ lappend result [winfo ismapped .t] [winfo ismapped .icon]
+} {1 1 0}
+test unixWm-8.9 {icon windows} {unix nonPortable} {
+ # This test is non-portable because some window managers will
+ # destroy an icon window when it's associated window is destroyed.
+
+ destroy .t
+ destroy .icon
+ toplevel .t -width 100 -height 30
+ toplevel .icon -width 50 -height 50 -bg red
+ wm geom .t +0+0
+ wm iconwindow .t .icon
+ update
+ set result "[wm state .icon] [winfo ismapped .t] [winfo ismapped .icon]"
+ destroy .t
+ wm geom .icon +0+0
+ update
+ lappend result [winfo ismapped .icon] [wm state .icon]
+ wm deiconify .icon
+ update
+ lappend result [winfo ismapped .icon] [wm state .icon]
+} {icon 1 0 0 withdrawn 1 normal}
+
+test unixWm-8.10.1 {test for memory leaks} unix {
+ wm title .t "This is a long long long long long long title"
+ wm title .t "This is a long long long long long long title"
+ wm title .t "This is a long long long long long long title"
+ wm title .t "This is a long long long long long long title"
+ wm title .t "This is a long long long long long long title"
+ wm title .t "This is a long long long long long long title"
+ wm title .t "This is a long long long long long long title"
+ wm title .t "This is a long long long long long long title"
+ set x 1
+} 1
+test unixWm-8.10.2 {test for memory leaks} unix {
+ wm group .t .
+ wm group .t .
+ wm group .t .
+ wm group .t .
+ wm group .t .
+ wm group .t .
+ wm group .t .
+ wm group .t .
+ wm group .t .
+ wm group .t .
+ set x 1
+} 1
+
+test unixWm-9.1 {TkWmMapWindow procedure, client property} {unix testwrapper} {
+ destroy .t
+ toplevel .t -width 100 -height 50
+ wm geom .t +0+0
+ wm client .t Test_String
+ update
+ testprop [testwrapper .t] WM_CLIENT_MACHINE
+} {Test_String}
+test unixWm-9.2 {TkWmMapWindow procedure, command property} {unix testwrapper} {
+ destroy .t
+ toplevel .t -width 100 -height 50
+ wm geom .t +0+0
+ wm command .t "test command"
+ update
+ testprop [testwrapper .t] WM_COMMAND
+} {test
+command
+}
+test unixWm-9.3 {TkWmMapWindow procedure, iconic windows} unix {
+ destroy .t
+ toplevel .t -width 100 -height 300 -bg blue
+ wm geom .t +0+0
+ wm iconify .t
+ sleep 500
+ winfo ismapped .t
+} {0}
+test unixWm-9.4 {TkWmMapWindow procedure, icon windows} unix {
+ destroy .t
+ sleep 500
+ toplevel .t -width 100 -height 50 -bg blue
+ wm iconwindow . .t
+ update
+ set result [winfo ismapped .t]
+} {0}
+test unixWm-9.5 {TkWmMapWindow procedure, normal windows} unix {
+ destroy .t
+ toplevel .t -width 200 -height 20
+ wm geom .t +0+0
+ update
+ winfo ismapped .t
+} {1}
+
+test unixWm-10.1 {TkWmDeadWindow procedure, canceling UpdateGeometry idle handler} unix {
+ destroy .t
+ toplevel .t -width 100 -height 50
+ wm geom .t +0+0
+ update
+ .t configure -width 200 -height 100
+ destroy .t
+} {}
+test unixWm-10.2 {TkWmDeadWindow procedure, destroying menubar} {unix testmenubar} {
+ destroy .t
+ destroy .f
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ wm geom .t +0+0
+ update
+ frame .f -width 400 -height 30 -bd 2 -relief raised -bg green
+ bind .f <Destroy> {lappend result destroyed}
+ testmenubar window .t .f
+ update
+ set result {}
+ destroy .t
+ lappend result [winfo exists .f]
+} {destroyed 0}
+
+test unixWm-11.1 {Tk_WmCmd procedure, miscellaneous errors} unix {
+ list [catch {wm} msg] $msg
+} {1 {wrong # args: should be "wm option window ?arg ...?"}}
+test unixWm-11.2 {Tk_WmCmd procedure, miscellaneous errors} unix {
+ list [catch {wm aspect} msg] $msg
+} {1 {wrong # args: should be "wm option window ?arg ...?"}}
+test unixWm-11.3 {Tk_WmCmd procedure, miscellaneous errors} unix {
+ list [catch {wm iconify bogus} msg] $msg
+} {1 {bad window path name "bogus"}}
+test unixWm-11.4 {Tk_WmCmd procedure, miscellaneous errors} unix {
+ destroy .b
+ button .b -text hello
+ list [catch {wm geometry .b} msg] $msg
+} {1 {window ".b" isn't a top-level window}}
+
+destroy .t
+destroy .icon
+
+toplevel .t -width 100 -height 50
+wm geom .t +0+0
+update
+
+test unixWm-12.1 {Tk_WmCmd procedure, "aspect" option} unix {
+ list [catch {wm aspect .t 12} msg] $msg
+} {1 {wrong # args: should be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"}}
+test unixWm-12.2 {Tk_WmCmd procedure, "aspect" option} unix {
+ list [catch {wm aspect .t 12 13 14 15 16} msg] $msg
+} {1 {wrong # args: should be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"}}
+test unixWm-12.3 {Tk_WmCmd procedure, "aspect" option} unix {
+ set result {}
+ lappend result [wm aspect .t]
+ wm aspect .t 3 4 10 2
+ lappend result [wm aspect .t]
+ wm aspect .t {} {} {} {}
+ lappend result [wm aspect .t]
+} {{} {3 4 10 2} {}}
+test unixWm-12.4 {Tk_WmCmd procedure, "aspect" option} unix {
+ list [catch {wm aspect .t bad 14 15 16} msg] $msg
+} {1 {expected integer but got "bad"}}
+test unixWm-12.5 {Tk_WmCmd procedure, "aspect" option} unix {
+ list [catch {wm aspect .t 13 foo 15 16} msg] $msg
+} {1 {expected integer but got "foo"}}
+test unixWm-12.6 {Tk_WmCmd procedure, "aspect" option} unix {
+ list [catch {wm aspect .t 13 14 bar 16} msg] $msg
+} {1 {expected integer but got "bar"}}
+test unixWm-12.7 {Tk_WmCmd procedure, "aspect" option} unix {
+ list [catch {wm aspect .t 13 14 15 baz} msg] $msg
+} {1 {expected integer but got "baz"}}
+test unixWm-12.8 {Tk_WmCmd procedure, "aspect" option} unix {
+ list [catch {wm aspect .t 0 14 15 16} msg] $msg
+} {1 {aspect number can't be <= 0}}
+test unixWm-12.9 {Tk_WmCmd procedure, "aspect" option} unix {
+ list [catch {wm aspect .t 13 0 15 16} msg] $msg
+} {1 {aspect number can't be <= 0}}
+test unixWm-12.10 {Tk_WmCmd procedure, "aspect" option} unix {
+ list [catch {wm aspect .t 13 14 0 16} msg] $msg
+} {1 {aspect number can't be <= 0}}
+test unixWm-12.11 {Tk_WmCmd procedure, "aspect" option} unix {
+ list [catch {wm aspect .t 13 14 15 0} msg] $msg
+} {1 {aspect number can't be <= 0}}
+
+test unixWm-13.1 {Tk_WmCmd procedure, "client" option} unix {
+ list [catch {wm client .t x y} msg] $msg
+} {1 {wrong # args: should be "wm client window ?name?"}}
+test unixWm-13.2 {Tk_WmCmd procedure, "client" option} {unix testwrapper} {
+ set result {}
+ lappend result [wm client .t]
+ wm client .t Test_String
+ lappend result [testprop [testwrapper .t] WM_CLIENT_MACHINE]
+ wm client .t New
+ lappend result [wm client .t]
+ wm client .t {}
+ lappend result [wm client .t] [testprop [testwrapper .t] WM_CLIENT_MACHINE]
+} {{} Test_String New {} {}}
+test unixWm-13.3 {Tk_WmCmd procedure, "client" option, unmapped window} unix {
+ destroy .t2
+ toplevel .t2
+ wm client .t2 Test_String
+ wm client .t2 {}
+ wm client .t2 Test_String
+ destroy .t2
+} {}
+
+test unixWm-14.1 {Tk_WmCmd procedure, "colormapwindows" option} unix {
+ list [catch {wm colormapwindows .t 12 13} msg] $msg
+} {1 {wrong # args: should be "wm colormapwindows window ?windowList?"}}
+test unixWm-14.2 {Tk_WmCmd procedure, "colormapwindows" option} unix {
+ destroy .t2
+ toplevel .t2 -width 200 -height 200 -colormap new
+ wm geom .t2 +0+0
+ frame .t2.a -width 100 -height 30
+ frame .t2.b -width 100 -height 30 -colormap new
+ pack .t2.a .t2.b -side top
+ update
+ set x [wm colormapwindows .t2]
+ frame .t2.c -width 100 -height 30 -colormap new
+ pack .t2.c -side top
+ update
+ list $x [wm colormapwindows .t2]
+} {{.t2.b .t2} {.t2.b .t2.c .t2}}
+test unixWm-14.3 {Tk_WmCmd procedure, "colormapwindows" option} unix {
+ list [catch {wm col . "a \{"} msg] $msg
+} {1 {unmatched open brace in list}}
+test unixWm-14.4 {Tk_WmCmd procedure, "colormapwindows" option} unix {
+ list [catch {wm colormapwindows . foo} msg] $msg
+} {1 {bad window path name "foo"}}
+test unixWm-14.5 {Tk_WmCmd procedure, "colormapwindows" option} unix {
+ destroy .t2
+ toplevel .t2 -width 200 -height 200 -colormap new
+ wm geom .t2 +0+0
+ frame .t2.a -width 100 -height 30
+ frame .t2.b -width 100 -height 30
+ frame .t2.c -width 100 -height 30
+ pack .t2.a .t2.b .t2.c -side top
+ wm colormapwindows .t2 {.t2.c .t2 .t2.a}
+ wm colormapwindows .t2
+} {.t2.c .t2 .t2.a}
+test unixWm-14.6 {Tk_WmCmd procedure, "colormapwindows" option} unix {
+ destroy .t2
+ toplevel .t2 -width 200 -height 200
+ wm geom .t2 +0+0
+ frame .t2.a -width 100 -height 30
+ frame .t2.b -width 100 -height 30
+ frame .t2.c -width 100 -height 30
+ pack .t2.a .t2.b .t2.c -side top
+ wm colormapwindows .t2 {.t2.b .t2.a}
+ wm colormapwindows .t2
+} {.t2.b .t2.a}
+test unixWm-14.7 {Tk_WmCmd procedure, "colormapwindows" option} unix {
+ destroy .t2
+ toplevel .t2 -width 200 -height 200 -colormap new
+ wm geom .t2 +0+0
+ set x [wm colormapwindows .t2]
+ wm colormapwindows .t2 {}
+ list $x [wm colormapwindows .t2]
+} {{} {}}
+destroy .t2
+
+test unixWm-15.1 {Tk_WmCmd procedure, "command" option} unix {
+ list [catch {wm command .t 12 13} msg] $msg
+} {1 {wrong # args: should be "wm command window ?value?"}}
+test unixWm-15.2 {Tk_WmCmd procedure, "command" option} unix {
+ list [catch {wm command .t 12 13} msg] $msg
+} {1 {wrong # args: should be "wm command window ?value?"}}
+test unixWm-15.3 {Tk_WmCmd procedure, "command" option} {unix testwrapper} {
+ set result {}
+ lappend result [wm command .t]
+ wm command .t "test command"
+ lappend result [testprop [testwrapper .t] WM_COMMAND]
+ wm command .t "new command"
+ lappend result [wm command .t]
+ wm command .t {}
+ lappend result [wm command .t] [testprop [testwrapper .t] WM_COMMAND]
+} {{} {test
+command
+} {new command} {} {}}
+test unixWm-15.4 {Tk_WmCmd procedure, "command" option, window not mapped} unix {
+ destroy .t2
+ toplevel .t2
+ wm geom .t2 +0+0
+ wm command .t2 "test command"
+ wm command .t2 "new command"
+ wm command .t2 {}
+ destroy .t2
+} {}
+test unixWm-15.5 {Tk_WmCmd procedure, "command" option} unix {
+ list [catch {wm command .t "a \{b"} msg] $msg
+} {1 {unmatched open brace in list}}
+
+test unixWm-16.1 {Tk_WmCmd procedure, "deiconify" option} unix {
+ list [catch {wm deiconify .t 12} msg] $msg
+} {1 {wrong # args: should be "wm deiconify window"}}
+test unixWm-16.2 {Tk_WmCmd procedure, "deiconify" option} unix {
+ destroy .icon
+ toplevel .icon -width 50 -height 50 -bg red
+ wm iconwindow .t .icon
+ set result [list [catch {wm deiconify .icon} msg] $msg]
+ destroy .icon
+ set result
+} {1 {can't deiconify .icon: it is an icon for .t}}
+test unixWm-16.3 {Tk_WmCmd procedure, "deiconify" option} unix {
+ wm iconify .t
+ set result {}
+ lappend result [winfo ismapped .t] [wm state .t]
+ wm deiconify .t
+ lappend result [winfo ismapped .t] [wm state .t]
+} {0 iconic 1 normal}
+
+test unixWm-17.1 {Tk_WmCmd procedure, "focusmodel" option} unix {
+ list [catch {wm focusmodel .t 12 13} msg] $msg
+} {1 {wrong # args: should be "wm focusmodel window ?active|passive?"}}
+test unixWm-17.2 {Tk_WmCmd procedure, "focusmodel" option} unix {
+ list [catch {wm focusmodel .t bogus} msg] $msg
+} {1 {bad argument "bogus": must be active or passive}}
+test unixWm-17.3 {Tk_WmCmd procedure, "focusmodel" option} unix {
+ set result {}
+ lappend result [wm focusmodel .t]
+ wm focusmodel .t active
+ lappend result [wm focusmodel .t]
+ wm focusmodel .t passive
+ lappend result [wm focusmodel .t]
+ set result
+} {passive active passive}
+
+test unixWm-18.1 {Tk_WmCmd procedure, "frame" option} unix {
+ list [catch {wm frame .t 12} msg] $msg
+} {1 {wrong # args: should be "wm frame window"}}
+test unixWm-18.2 {Tk_WmCmd procedure, "frame" option} {unix nonPortable} {
+ expr [wm frame .t] == [winfo id .t]
+} {0}
+test unixWm-18.3 {Tk_WmCmd procedure, "frame" option} {unix nonPortable} {
+ destroy .t2
+ toplevel .t2
+ wm geom .t2 +0+0
+ wm overrideredirect .t2 1
+ update
+ set result [expr [wm frame .t2] == [winfo id .t2]]
+ destroy .t2
+ set result
+} {1}
+
+test unixWm-19.1 {Tk_WmCmd procedure, "geometry" option} unix {
+ list [catch {wm geometry .t 12 13} msg] $msg
+} {1 {wrong # args: should be "wm geometry window ?newGeometry?"}}
+test unixWm-19.2 {Tk_WmCmd procedure, "geometry" option} {unix nonPortable} {
+ wm geometry .t -1+5
+ update
+ wm geometry .t
+} {100x50-1+5}
+test unixWm-19.3 {Tk_WmCmd procedure, "geometry" option} {unix nonPortable} {
+ wm geometry .t +10-4
+ update
+ wm geometry .t
+} {100x50+10-4}
+test unixWm-19.4 {Tk_WmCmd procedure, "geometry" option} {unix nonPortable} {
+ destroy .t2
+ toplevel .t2
+ wm geom .t2 -5+10
+ listbox .t2.l -width 30 -height 12 -setgrid 1
+ pack .t2.l
+ update
+ set result [wm geometry .t2]
+ destroy .t2
+ set result
+} {30x12-5+10}
+test unixWm-19.5 {Tk_WmCmd procedure, "geometry" option} {unix nonPortable} {
+ wm geometry .t 150x300+5+6
+ update
+ set result {}
+ lappend result [wm geometry .t]
+ wm geometry .t {}
+ update
+ lappend result [wm geometry .t]
+} {150x300+5+6 100x50+5+6}
+test unixWm-19.6 {Tk_WmCmd procedure, "geometry" option} unix {
+ list [catch {wm geometry .t qrs} msg] $msg
+} {1 {bad geometry specifier "qrs"}}
+
+test unixWm-20.1 {Tk_WmCmd procedure, "grid" option} unix {
+ list [catch {wm grid .t 12 13} msg] $msg
+} {1 {wrong # args: should be "wm grid window ?baseWidth baseHeight widthInc heightInc?"}}
+test unixWm-20.2 {Tk_WmCmd procedure, "grid" option} unix {
+ list [catch {wm grid .t 12 13 14 15 16} msg] $msg
+} {1 {wrong # args: should be "wm grid window ?baseWidth baseHeight widthInc heightInc?"}}
+test unixWm-20.3 {Tk_WmCmd procedure, "grid" option} unix {
+ set result {}
+ lappend result [wm grid .t]
+ wm grid .t 5 6 20 10
+ lappend result [wm grid .t]
+ wm grid .t {} {} {} {}
+ lappend result [wm grid .t]
+} {{} {5 6 20 10} {}}
+test unixWm-20.4 {Tk_WmCmd procedure, "grid" option} unix {
+ list [catch {wm grid .t bad 10 11 12} msg] $msg
+} {1 {expected integer but got "bad"}}
+test unixWm-20.5 {Tk_WmCmd procedure, "grid" option} unix {
+ list [catch {wm grid .t -1 11 12 13} msg] $msg
+} {1 {baseWidth can't be < 0}}
+test unixWm-20.6 {Tk_WmCmd procedure, "grid" option} unix {
+ list [catch {wm grid .t 10 foo 12 13} msg] $msg
+} {1 {expected integer but got "foo"}}
+test unixWm-20.7 {Tk_WmCmd procedure, "grid" option} unix {
+ list [catch {wm grid .t 10 -11 12 13} msg] $msg
+} {1 {baseHeight can't be < 0}}
+test unixWm-20.8 {Tk_WmCmd procedure, "grid" option} unix {
+ list [catch {wm grid .t 10 11 bar 13} msg] $msg
+} {1 {expected integer but got "bar"}}
+test unixWm-20.9 {Tk_WmCmd procedure, "grid" option} unix {
+ list [catch {wm grid .t 10 11 -2 13} msg] $msg
+} {1 {widthInc can't be <= 0}}
+test unixWm-20.10 {Tk_WmCmd procedure, "grid" option} unix {
+ list [catch {wm grid .t 10 11 12 bogus} msg] $msg
+} {1 {expected integer but got "bogus"}}
+test unixWm-20.11 {Tk_WmCmd procedure, "grid" option} unix {
+ list [catch {wm grid .t 10 11 12 -1} msg] $msg
+} {1 {heightInc can't be <= 0}}
+
+destroy .t
+destroy .icon
+toplevel .t -width 100 -height 50
+wm geom .t +0+0
+update
+
+test unixWm-21.1 {Tk_WmCmd procedure, "group" option} unix {
+ list [catch {wm group .t 12 13} msg] $msg
+} {1 {wrong # args: should be "wm group window ?pathName?"}}
+test unixWm-21.2 {Tk_WmCmd procedure, "group" option} unix {
+ list [catch {wm group .t bogus} msg] $msg
+} {1 {bad window path name "bogus"}}
+test unixWm-21.3 {Tk_WmCmd procedure, "group" option} {unix testwrapper} {
+ set result {}
+ lappend result [wm group .t]
+ wm group .t .
+ set bit [format 0x%x [expr 0x40 & [lindex [testprop [testwrapper .t] \
+ WM_HINTS] 0]]]
+ lappend result [wm group .t] $bit
+ wm group .t {}
+ set bit [format 0x%x [expr 0x40 & [lindex [testprop [testwrapper .t] \
+ WM_HINTS] 0]]]
+ lappend result [wm group .t] $bit
+} {{} . 0x40 {} 0x0}
+test unixWm-21.4 {Tk_WmCmd procedure, "group" option, make window exist} {unix testwrapper} {
+ destroy .t2
+ toplevel .t2
+ wm geom .t2 +0+0
+ wm group .t .t2
+ set hints [testprop [testwrapper .t] WM_HINTS]
+ set result [expr [testwrapper .t2] - [lindex $hints 8]]
+ destroy .t2
+ set result
+} {0}
+test unixWm-21.5 {Tk_WmCmd procedure, "group" option, create leader wrapper} {unix testwrapper} {
+ destroy .t2
+ destroy .t3
+ toplevel .t2 -width 120 -height 300
+ wm geometry .t2 +0+0
+ toplevel .t3 -width 120 -height 300
+ wm geometry .t2 +0+0
+ set result [list [testwrapper .t2]]
+ wm group .t3 .t2
+ lappend result [expr {[testwrapper .t2] == ""}]
+ destroy .t2 .t3
+ set result
+} {{} 0}
+
+test unixWm-22.1 {Tk_WmCmd procedure, "iconbitmap" option} unix {
+ list [catch {wm iconbitmap .t 12 13} msg] $msg
+} {1 {wrong # args: should be "wm iconbitmap window ?bitmap?"}}
+test unixWm-22.2 {Tk_WmCmd procedure, "iconbitmap" option} {unix testwrapper} {
+ set result {}
+ lappend result [wm iconbitmap .t]
+ wm iconbitmap .t questhead
+ set bit [format 0x%x [expr 0x4 & [lindex [testprop [testwrapper .t] \
+ WM_HINTS] 0]]]
+ lappend result [wm iconbitmap .t] $bit
+ wm iconbitmap .t {}
+ set bit [format 0x%x [expr 0x4 & [lindex [testprop [testwrapper .t] \
+ WM_HINTS] 0]]]
+ lappend result [wm iconbitmap .t] $bit
+} {{} questhead 0x4 {} 0x0}
+test unixWm-22.3 {Tk_WmCmd procedure, "iconbitmap" option} unix {
+ list [catch {wm iconbitmap .t bad-bitmap} msg] $msg
+} {1 {bitmap "bad-bitmap" not defined}}
+
+test unixWm-23.1 {Tk_WmCmd procedure, "iconify" option} unix {
+ list [catch {wm iconify .t 12} msg] $msg
+} {1 {wrong # args: should be "wm iconify window"}}
+test unixWm-23.2 {Tk_WmCmd procedure, "iconify" option} unix {
+ destroy .t2
+ toplevel .t2
+ wm overrideredirect .t2 1
+ set result [list [catch {wm iconify .t2} msg] $msg]
+ destroy .t2
+ set result
+} {1 {can't iconify ".t2": override-redirect flag is set}}
+test unixWm-23.3 {Tk_WmCmd procedure, "iconify" option} unix {
+ destroy .t2
+ toplevel .t2
+ wm geom .t2 +0+0
+ wm transient .t2 .t
+ set result [list [catch {wm iconify .t2} msg] $msg]
+ destroy .t2
+ set result
+} {1 {can't iconify ".t2": it is a transient}}
+test unixWm-23.4 {Tk_WmCmd procedure, "iconify" option} unix {
+ destroy .t2
+ toplevel .t2
+ wm geom .t2 +0+0
+ wm iconwindow .t .t2
+ set result [list [catch {wm iconify .t2} msg] $msg]
+ destroy .t2
+ set result
+} {1 {can't iconify .t2: it is an icon for .t}}
+test unixWm-23.5 {Tk_WmCmd procedure, "iconify" option} unix {
+ destroy .t2
+ toplevel .t2
+ wm geom .t2 +0+0
+ update
+ wm iconify .t2
+ update
+ set result [winfo ismapped .t2]
+ destroy .t2
+ set result
+} {0}
+test unixWm-23.6 {Tk_WmCmd procedure, "iconify" option} unix {
+ destroy .t2
+ toplevel .t2
+ wm geom .t2 -0+0
+ update
+ set result [winfo ismapped .t2]
+ wm iconify .t2
+ update
+ lappend result [winfo ismapped .t2]
+ destroy .t2
+ set result
+} {1 0}
+
+test unixWm-24.1 {Tk_WmCmd procedure, "iconmask" option} unix {
+ list [catch {wm iconmask .t 12 13} msg] $msg
+} {1 {wrong # args: should be "wm iconmask window ?bitmap?"}}
+test unixWm-24.2 {Tk_WmCmd procedure, "iconmask" option} {unix testwrapper} {
+ set result {}
+ lappend result [wm iconmask .t]
+ wm iconmask .t questhead
+ set bit [format 0x%x [expr 0x20 & [lindex [testprop [testwrapper .t] \
+ WM_HINTS] 0]]]
+ lappend result [wm iconmask .t] $bit
+ wm iconmask .t {}
+ set bit [format 0x%x [expr 0x20 & [lindex [testprop [testwrapper .t] \
+ WM_HINTS] 0]]]
+ lappend result [wm iconmask .t] $bit
+} {{} questhead 0x20 {} 0x0}
+test unixWm-24.3 {Tk_WmCmd procedure, "iconmask" option} unix {
+ list [catch {wm iconmask .t bogus} msg] $msg
+} {1 {bitmap "bogus" not defined}}
+
+test unixWm-25.1 {Tk_WmCmd procedure, "iconname" option} unix {
+ list [catch {wm icon .t} msg] $msg
+} {1 {ambiguous option "icon": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, forget, frame, geometry, grid, group, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, manage, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw}}
+test unixWm-25.2 {Tk_WmCmd procedure, "iconname" option} unix {
+ list [catch {wm iconname .t 12 13} msg] $msg
+} {1 {wrong # args: should be "wm iconname window ?newName?"}}
+test unixWm-25.3 {Tk_WmCmd procedure, "iconname" option} {unix testwrapper} {
+ set result {}
+ lappend result [wm iconname .t]
+ wm iconname .t test_name
+ lappend result [wm iconname .t] [testprop [testwrapper .t] WM_ICON_NAME]
+ wm iconname .t {}
+ lappend result [wm iconname .t] [testprop [testwrapper .t] WM_ICON_NAME]
+} {{} test_name test_name {} {}}
+
+test unixWm-26.1 {Tk_WmCmd procedure, "iconposition" option} unix {
+ list [catch {wm iconposition .t 12} msg] $msg
+} {1 {wrong # args: should be "wm iconposition window ?x y?"}}
+test unixWm-26.2 {Tk_WmCmd procedure, "iconposition" option} unix {
+ list [catch {wm iconposition .t 12 13 14} msg] $msg
+} {1 {wrong # args: should be "wm iconposition window ?x y?"}}
+test unixWm-26.3 {Tk_WmCmd procedure, "iconposition" option} {unix testwrapper} {
+ set result {}
+ lappend result [wm iconposition .t]
+ wm iconposition .t 10 15
+ set prop [testprop [testwrapper .t] WM_HINTS]
+ lappend result [wm iconposition .t] [lindex $prop 5] [lindex $prop 6]
+ lappend result [format 0x%x [expr 0x10 & [lindex $prop 0]]]
+ wm iconposition .t {} {}
+ set bit [format 0x%x [expr 0x10 & [lindex [testprop [testwrapper .t] \
+ WM_HINTS] 0]]]
+ lappend result [wm iconposition .t] $bit
+} {{} {10 15} 0xa 0xf 0x10 {} 0x0}
+test unixWm-26.4 {Tk_WmCmd procedure, "iconposition" option} unix {
+ list [catch {wm iconposition .t bad 13} msg] $msg
+} {1 {expected integer but got "bad"}}
+test unixWm-26.5 {Tk_WmCmd procedure, "iconposition" option} unix {
+ list [catch {wm iconposition .t 13 lousy} msg] $msg
+} {1 {expected integer but got "lousy"}}
+
+test unixWm-27.1 {Tk_WmCmd procedure, "iconwindow" option} unix {
+ list [catch {wm iconwindow .t 12 13} msg] $msg
+} {1 {wrong # args: should be "wm iconwindow window ?pathName?"}}
+test unixWm-27.2 {Tk_WmCmd procedure, "iconwindow" option} {unix testwrapper} {
+ destroy .icon
+ toplevel .icon -width 50 -height 50 -bg green
+ set result {}
+ lappend result [wm iconwindow .t]
+ wm iconwindow .t .icon
+ set prop [testprop [testwrapper .t] WM_HINTS]
+ lappend result [wm iconwindow .t] [wm state .icon]
+ lappend result [format 0x%x [expr 0x8 & [lindex $prop 0]]]
+ lappend result [expr [testwrapper .icon] == [lindex $prop 4]]
+ wm iconwindow .t {}
+ set bit [format 0x%x [expr 0x8 & [lindex [testprop [testwrapper .t] \
+ WM_HINTS] 0]]]
+ lappend result [wm iconwindow .t] [wm state .icon] $bit
+ destroy .icon
+ set result
+} {{} .icon icon 0x8 1 {} withdrawn 0x0}
+test unixWm-27.3 {Tk_WmCmd procedure, "iconwindow" option} unix {
+ list [catch {wm iconwindow .t bogus} msg] $msg
+} {1 {bad window path name "bogus"}}
+test unixWm-27.4 {Tk_WmCmd procedure, "iconwindow" option} unix {
+ destroy .b
+ button .b -text Help
+ set result [list [catch {wm iconwindow .t .b} msg] $msg]
+ destroy .b
+ set result
+} {1 {can't use .b as icon window: not at top level}}
+test unixWm-27.5 {Tk_WmCmd procedure, "iconwindow" option} unix {
+ destroy .icon
+ toplevel .icon -width 50 -height 50 -bg green
+ destroy .t2
+ toplevel .t2
+ wm geom .t2 -0+0
+ wm iconwindow .t2 .icon
+ set result [list [catch {wm iconwindow .t .icon} msg] $msg]
+ destroy .t2
+ destroy .icon
+ set result
+} {1 {.icon is already an icon for .t2}}
+test unixWm-27.6 {Tk_WmCmd procedure, "iconwindow" option, changing icons} unix {
+ destroy .icon
+ destroy .icon2
+ toplevel .icon -width 50 -height 50 -bg green
+ toplevel .icon2 -width 50 -height 50 -bg red
+ set result {}
+ wm iconwindow .t .icon
+ lappend result [wm state .icon] [wm state .icon2]
+ wm iconwindow .t .icon2
+ lappend result [wm state .icon] [wm state .icon2]
+ destroy .icon .icon2
+ set result
+} {icon normal withdrawn icon}
+test unixWm-27.7 {Tk_WmCmd procedure, "iconwindow" option, withdrawing icon} unix {
+ destroy .icon
+ toplevel .icon -width 50 -height 50 -bg green
+ wm geometry .icon +0+0
+ update
+ set result {}
+ lappend result [wm state .icon] [winfo viewable .icon]
+ wm iconwindow .t .icon
+ lappend result [wm state .icon] [winfo viewable .icon]
+ destroy .icon
+ set result
+} {normal 1 icon 0}
+
+destroy .t
+destroy .icon
+toplevel .t -width 100 -height 50
+wm geom .t +0+0
+update
+
+test unixWm-28.1 {Tk_WmCmd procedure, "maxsize" option, setting the
+ maxsize should update WM_NORMAL_HINTS} {testwrapper} {
+ destroy .t
+ toplevel .t
+ wm maxsize .t 300 300
+ update
+ set hints [testprop [testwrapper .t] WM_NORMAL_HINTS]
+ format {%d %d} [lindex $hints 7] [lindex $hints 8]
+} {300 300}
+
+test unixWm-28.2 {Tk_WmCmd procedure, "maxsize" option, setting the
+ maxsize to a value smaller than the current size should
+ set the maxsize in WM_NORMAL_HINTS} {testwrapper} {
+ destroy .t
+ toplevel .t
+ wm geom .t 400x400
+ wm maxsize .t 300 300
+ update
+ set hints [testprop [testwrapper .t] WM_NORMAL_HINTS]
+ format {%d %d} [lindex $hints 7] [lindex $hints 8]
+} {300 300}
+
+test unixWm-28.3 {Tk_WmCmd procedure, "maxsize" option, setting the
+ maxsize to a value smaller than the current size should
+ set the maxsize in WM_NORMAL_HINTS even if the
+ interactive resizable flag is set to 0} {testwrapper} {
+ destroy .t
+ toplevel .t
+ wm geom .t 400x400
+ wm resizable .t 0 0
+ wm maxsize .t 300 300
+ update
+ set hints [testprop [testwrapper .t] WM_NORMAL_HINTS]
+ format {%d %d} [lindex $hints 7] [lindex $hints 8]
+} {300 300}
+
+test unixWm-29.1 {Tk_WmCmd procedure, "minsize" option, setting the
+ minsize should update WM_NORMAL_HINTS} {testwrapper} {
+ destroy .t
+ toplevel .t
+ wm minsize .t 300 300
+ update
+ set hints [testprop [testwrapper .t] WM_NORMAL_HINTS]
+ format {%d %d} [lindex $hints 5] [lindex $hints 6]
+} {300 300}
+
+test unixWm-29.2 {Tk_WmCmd procedure, "minsize" option, setting the
+ minsize to a value larger than the current size should
+ set the maxsize in WM_NORMAL_HINTS} {testwrapper} {
+ destroy .t
+ toplevel .t
+ wm geom .t 200x200
+ wm minsize .t 300 300
+ update
+ set hints [testprop [testwrapper .t] WM_NORMAL_HINTS]
+ format {%d %d} [lindex $hints 5] [lindex $hints 6]
+} {300 300}
+
+test unixWm-29.3 {Tk_WmCmd procedure, "minsize" option, setting the
+ minsize to a value larger than the current size should
+ set the minsize in WM_NORMAL_HINTS even if the
+ interactive resizable flag is set to 0} {testwrapper} {
+ destroy .t
+ toplevel .t
+ wm geom .t 200x200
+ wm resizable .t 0 0
+ wm minsize .t 300 300
+ update
+ set hints [testprop [testwrapper .t] WM_NORMAL_HINTS]
+ format {%d %d} [lindex $hints 5] [lindex $hints 6]
+} {300 300}
+
+destroy .t .icon
+toplevel .t -width 100 -height 50
+wm geom .t +0+0
+update
+
+test unixWm-30.1 {Tk_WmCmd procedure, "overrideredirect" option} unix {
+ list [catch {wm overrideredirect .t 1 2} msg] $msg
+} {1 {wrong # args: should be "wm overrideredirect window ?boolean?"}}
+test unixWm-30.2 {Tk_WmCmd procedure, "overrideredirect" option} unix {
+ list [catch {wm overrideredirect .t boo} msg] $msg
+} {1 {expected boolean value but got "boo"}}
+test unixWm-30.3 {Tk_WmCmd procedure, "overrideredirect" option} unix {
+ set result {}
+ lappend result [wm overrideredirect .t]
+ wm overrideredirect .t true
+ lappend result [wm overrideredirect .t]
+ wm overrideredirect .t off
+ lappend result [wm overrideredirect .t]
+} {0 1 0}
+
+test unixWm-31.1 {Tk_WmCmd procedure, "positionfrom" option} unix {
+ list [catch {wm positionfrom .t 1 2} msg] $msg
+} {1 {wrong # args: should be "wm positionfrom window ?user/program?"}}
+test unixWm-31.2 {Tk_WmCmd procedure, "positionfrom" option} {unix testwrapper} {
+ set result {}
+ lappend result [wm positionfrom .t]
+ wm positionfrom .t program
+ update
+ set bit [format 0x%x [expr 0x5 & [lindex [testprop [testwrapper .t] \
+ WM_NORMAL_HINTS] 0]]]
+ lappend result [wm positionfrom .t] $bit
+ wm positionfrom .t user
+ update
+ set bit [format 0x%x [expr 0x5 & [lindex [testprop [testwrapper .t] \
+ WM_NORMAL_HINTS] 0]]]
+ lappend result [wm positionfrom .t] $bit
+} {user program 0x4 user 0x1}
+test unixWm-31.3 {Tk_WmCmd procedure, "positionfrom" option} unix {
+ list [catch {wm positionfrom .t none} msg] $msg
+} {1 {bad argument "none": must be program or user}}
+
+test unixWm-32.1 {Tk_WmCmd procedure, "protocol" option} unix {
+ list [catch {wm protocol .t 1 2 3} msg] $msg
+} {1 {wrong # args: should be "wm protocol window ?name? ?command?"}}
+test unixWm-32.2 {Tk_WmCmd procedure, "protocol" option} unix {
+ wm protocol .t {foo a} {a b c}
+ wm protocol .t bar {test script for bar}
+ set result [wm protocol .t]
+ wm protocol .t {foo a} {}
+ wm protocol .t bar {}
+ set result
+} {bar {foo a}}
+test unixWm-32.3 {Tk_WmCmd procedure, "protocol" option} {unix testwrapper} {
+ set result {}
+ lappend result [wm protocol .t]
+ set x {}
+ foreach i [testprop [testwrapper .t] WM_PROTOCOLS] {
+ lappend x [winfo atomname $i]
+ }
+ lappend result $x
+ wm protocol .t foo {test script}
+ wm protocol .t bar {test script}
+ set x {}
+ foreach i [testprop [testwrapper .t] WM_PROTOCOLS] {
+ lappend x [winfo atomname $i]
+ }
+ lappend result [wm protocol .t] $x
+ wm protocol .t foo {}
+ wm protocol .t bar {}
+ set x {}
+ foreach i [testprop [testwrapper .t] WM_PROTOCOLS] {
+ lappend x [winfo atomname $i]
+ }
+ lappend result [wm protocol .t] $x
+} {{} WM_DELETE_WINDOW {bar foo} {WM_DELETE_WINDOW bar foo} {} WM_DELETE_WINDOW}
+test unixWm-32.4 {Tk_WmCmd procedure, "protocol" option} unix {
+ set result {}
+ wm protocol .t foo {a b c}
+ wm protocol .t bar {test script for bar}
+ lappend result [wm protocol .t foo] [wm protocol .t bar]
+ wm protocol .t foo {}
+ wm protocol .t bar {}
+ lappend result [wm protocol .t foo] [wm protocol .t bar]
+} {{a b c} {test script for bar} {} {}}
+test unixWm-32.5 {Tk_WmCmd procedure, "protocol" option} unix {
+ wm protocol .t foo {a b c}
+ wm protocol .t foo {test script}
+ set result [wm protocol .t foo]
+ wm protocol .t foo {}
+ set result
+} {test script}
+
+test unixWm-33.1 {Tk_WmCmd procedure, "resizable" option} unix {
+ list [catch {wm resizable . a} msg] $msg
+} {1 {wrong # args: should be "wm resizable window ?width height?"}}
+test unixWm-33.2 {Tk_WmCmd procedure, "resizable" option} unix {
+ list [catch {wm resizable . a b c} msg] $msg
+} {1 {wrong # args: should be "wm resizable window ?width height?"}}
+test unixWm-33.3 {Tk_WmCmd procedure, "resizable" option} unix {
+ list [catch {wm resizable .foo a b c} msg] $msg
+} {1 {bad window path name ".foo"}}
+test unixWm-33.4 {Tk_WmCmd procedure, "resizable" option} unix {
+ list [catch {wm resizable . x 1} msg] $msg
+} {1 {expected boolean value but got "x"}}
+test unixWm-33.5 {Tk_WmCmd procedure, "resizable" option} unix {
+ list [catch {wm resizable . 0 gorp} msg] $msg
+} {1 {expected boolean value but got "gorp"}}
+test unixWm-33.6 {Tk_WmCmd procedure, "resizable" option} unix {
+ destroy .t2
+ toplevel .t2 -width 200 -height 100
+ wm geom .t2 +0+0
+ set result ""
+ lappend result [wm resizable .t2]
+ wm resizable .t2 1 0
+ lappend result [wm resizable .t2]
+ wm resizable .t2 no off
+ lappend result [wm resizable .t2]
+ wm resizable .t2 false true
+ lappend result [wm resizable .t2]
+ destroy .t2
+ set result
+} {{1 1} {1 0} {0 0} {0 1}}
+
+test unixWm-34.1 {Tk_WmCmd procedure, "sizefrom" option} unix {
+ list [catch {wm sizefrom .t 1 2} msg] $msg
+} {1 {wrong # args: should be "wm sizefrom window ?user|program?"}}
+test unixWm-34.2 {Tk_WmCmd procedure, "sizefrom" option} {unix testwrapper} {
+ set result {}
+ lappend result [wm sizefrom .t]
+ wm sizefrom .t program
+ update
+ set bit [format 0x%x [expr 0xa & [lindex [testprop [testwrapper .t] \
+ WM_NORMAL_HINTS] 0]]]
+ lappend result [wm sizefrom .t] $bit
+ wm sizefrom .t user
+ update
+ set bit [format 0x%x [expr 0xa & [lindex [testprop [testwrapper .t] \
+ WM_NORMAL_HINTS] 0]]]
+ lappend result [wm sizefrom .t] $bit
+} {{} program 0x8 user 0x2}
+test unixWm-34.3 {Tk_WmCmd procedure, "sizefrom" option} unix {
+ list [catch {wm sizefrom .t none} msg] $msg
+} {1 {bad argument "none": must be program or user}}
+
+test unixWm-35.1 {Tk_WmCmd procedure, "state" option} unix {
+ list [catch {wm state .t 1} msg] $msg
+} {1 {bad argument "1": must be normal, iconic, or withdrawn}}
+test unixWm-35.2 {Tk_WmCmd procedure, "state" option} unix {
+ list [catch {wm state .t iconic 1} msg] $msg
+} {1 {wrong # args: should be "wm state window ?state?"}}
+test unixWm-35.3 {Tk_WmCmd procedure, "state" option} unix {
+ set result {}
+ destroy .t2
+ toplevel .t2 -width 120 -height 300
+ wm geometry .t2 +0+0
+ lappend result [wm state .t2]
+ update
+ lappend result [wm state .t2]
+ wm withdraw .t2
+ lappend result [wm state .t2]
+ wm iconify .t2
+ lappend result [wm state .t2]
+ wm deiconify .t2
+ lappend result [wm state .t2]
+ destroy .t2
+ set result
+} {normal normal withdrawn iconic normal}
+test unixWm-35.4 {Tk_WmCmd procedure, "state" option} unix {
+ set result {}
+ destroy .t2
+ toplevel .t2 -width 120 -height 300
+ wm geometry .t2 +0+0
+ lappend result [wm state .t2]
+ update
+ lappend result [wm state .t2]
+ wm state .t2 withdrawn
+ lappend result [wm state .t2]
+ wm state .t2 iconic
+ lappend result [wm state .t2]
+ wm state .t2 normal
+ lappend result [wm state .t2]
+ destroy .t2
+ set result
+} {normal normal withdrawn iconic normal}
+
+test unixWm-36.1 {Tk_WmCmd procedure, "title" option} unix {
+ list [catch {wm title .t 1 2} msg] $msg
+} {1 {wrong # args: should be "wm title window ?newTitle?"}}
+test unixWm-36.2 {Tk_WmCmd procedure, "title" option} {unix testwrapper} {
+ set result {}
+ lappend result [wm title .t] [testprop [testwrapper .t] WM_NAME]
+ wm title .t "Test window"
+ set bit [format 0x%x [expr 0xa & [lindex [testprop [testwrapper .t] \
+ WM_NORMAL_HINTS] 0]]]
+ lappend result [wm title .t] [testprop [testwrapper .t] WM_NAME]
+} {t t {Test window} {Test window}}
+
+test unixWm-37.3 {Tk_WmCmd procedure, "transient" option} {unix testwrapper} {
+ set result {}
+ destroy .t2
+ toplevel .t2 -width 120 -height 300
+ wm geometry .t2 +0+0
+ update
+ lappend result [wm transient .t2] \
+ [testprop [testwrapper .t2] WM_TRANSIENT_FOR]
+ wm transient .t2 .t
+ set transient [testprop [testwrapper .t2] WM_TRANSIENT_FOR]
+ lappend result [wm transient .t2] [expr [testwrapper .t] - $transient]
+ wm transient .t2 {}
+ lappend result [wm transient .t2] \
+ [testprop [testwrapper .t2] WM_TRANSIENT_FOR]
+ destroy .t2
+ set result
+} {{} {} .t 0 {} {}}
+test unixWm-37.4 {TkWmDeadWindow, destroy on master should clear transient} {unix testwrapper} {
+ destroy .t2
+ toplevel .t2
+ destroy .t3
+ toplevel .t3
+ wm transient .t2 .t3
+ update
+ destroy .t3
+ update
+ list [wm transient .t2] [testprop [testwrapper .t2] WM_TRANSIENT_FOR]
+} {{} {}}
+test unixWm-37.5 {Tk_WmCmd procedure, "transient" option, create master wrapper} {unix testwrapper} {
+ destroy .t2
+ destroy .t3
+ toplevel .t2 -width 120 -height 300
+ wm geometry .t2 +0+0
+ toplevel .t3 -width 120 -height 300
+ wm geometry .t2 +0+0
+ set result [list [testwrapper .t2]]
+ wm transient .t3 .t2
+ lappend result [expr {[testwrapper .t2] == ""}]
+ destroy .t2 .t3
+ set result
+} {{} 0}
+
+test unixWm-38.1 {Tk_WmCmd procedure, "withdraw" option} unix {
+ list [catch {wm withdraw .t 1} msg] $msg
+} {1 {wrong # args: should be "wm withdraw window"}}
+test unixWm-38.2 {Tk_WmCmd procedure, "withdraw" option} unix {
+ destroy .t2
+ toplevel .t2 -width 120 -height 300
+ wm geometry .t2 +0+0
+ wm iconwindow .t .t2
+ set result [list [catch {wm withdraw .t2} msg] $msg]
+ destroy .t2
+ set result
+} {1 {can't withdraw .t2: it is an icon for .t}}
+test unixWm-38.3 {Tk_WmCmd procedure, "withdraw" option} unix {
+ set result {}
+ wm withdraw .t
+ lappend result [wm state .t] [winfo ismapped .t]
+ wm deiconify .t
+ lappend result [wm state .t] [winfo ismapped .t]
+} {withdrawn 0 normal 1}
+
+test unixWm-39.1 {Tk_WmCmd procedure, miscellaneous} unix {
+ list [catch {wm unknown .t} msg] $msg
+} {1 {bad option "unknown": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, forget, frame, geometry, grid, group, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, manage, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw}}
+
+destroy .t .icon
+
+test unixWm-40.1 {Tk_SetGrid procedure, set grid dimensions before turning on grid} {unix nonPortable} {
+ destroy .t
+ toplevel .t
+ wm geometry .t 30x10+0+0
+ listbox .t.l -height 20 -width 20 -setgrid 1
+ pack .t.l -fill both -expand 1
+ update
+ wm geometry .t
+} {30x10+0+0}
+test unixWm-40.2 {Tk_SetGrid procedure, turning on grid when dimensions already set} unix {
+ destroy .t
+ toplevel .t
+ wm geometry .t 200x100+0+0
+ listbox .t.l -height 20 -width 20
+ pack .t.l -fill both -expand 1
+ update
+ .t.l configure -setgrid 1
+ update
+ wm geometry .t
+} {20x20+0+0}
+
+test unixWm-41.1 {ConfigureEvent procedure, internally generated size changes} unix {
+ destroy .t
+ toplevel .t -width 400 -height 150
+ wm geometry .t +0+0
+ tkwait visibility .t
+ set result {}
+ lappend result [winfo width .t] [winfo height .t]
+ .t configure -width 200 -height 300
+ sleep 500
+ lappend result [winfo width .t] [winfo height .t]
+} {400 150 200 300}
+test unixWm-41.2 {ConfigureEvent procedure, menubars} {nonPortable testmenubar} {
+ destroy .t
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ wm geom .t +0+0
+ update
+ set x [winfo rootx .t]
+ set y [winfo rooty .t]
+ frame .t.m -bd 2 -relief raised -height 20
+ testmenubar window .t .t.m
+ update
+ set result {}
+ bind .t <Configure> {
+ if {"%W" == ".t"} {
+ lappend result "%W: %wx%h"
+ }
+ }
+ bind .t.m <Configure> {lappend result "%W: %wx%h"}
+ wm geometry .t 200x300
+ update
+ lappend result [expr [winfo rootx .t.m] - $x] \
+ [expr [winfo rooty .t.m] - $y] \
+ [winfo width .t.m] [winfo height .t.m] \
+ [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y] \
+ [winfo width .t] [winfo height .t]
+} {{.t.m: 200x20} {.t: 200x300} 0 0 200 20 0 20 200 300}
+test unixWm-41.3 {ConfigureEvent procedure, synthesized Configure events} unix {
+ destroy .t
+ toplevel .t -width 400 -height 150
+ wm geometry .t +0+0
+ tkwait visibility .t
+ set result {no event}
+ bind .t <Configure> {set result "configured: %w %h"}
+ wm geometry .t +10+20
+ update
+ set result
+} {configured: 400 150}
+test unixWm-41.4 {ConfigureEvent procedure, synthesized Configure events} unix {
+ destroy .t
+ toplevel .t -width 400 -height 150
+ wm geometry .t +0+0
+ tkwait visibility .t
+ set result {no event}
+ bind .t <Configure> {set result "configured: %w %h"}
+ wm geometry .t 130x200
+ update
+ set result
+} {configured: 130 200}
+
+# No tests for ReparentEvent or ComputeReparentGeometry; I can't figure
+# out how to exercise these procedures reliably.
+
+test unixWm-42.1 {WrapperEventProc procedure, map and unmap events} unix {
+ destroy .t
+ toplevel .t -width 400 -height 150
+ wm geometry .t +0+0
+ tkwait visibility .t
+ set result {}
+ bind .t <Map> {set x "mapped"}
+ bind .t <Unmap> {set x "unmapped"}
+ set x {no event}
+ wm iconify .t
+ lappend result $x [winfo ismapped .t]
+ set x {no event}
+ wm deiconify .t
+ lappend result $x [winfo ismapped .t]
+} {unmapped 0 mapped 1}
+
+test unixWm-43.1 {TopLevelReqProc procedure, embedded in same process} unix {
+ destroy .t
+ toplevel .t -width 200 -height 200
+ wm geom .t +0+0
+ frame .t.f -container 1 -bd 2 -relief raised
+ place .t.f -x 20 -y 10
+ tkwait visibility .t.f
+ toplevel .t2 -use [winfo id .t.f] -width 30 -height 20 -bg blue
+ tkwait visibility .t2
+ set result {}
+ .t2 configure -width 70 -height 120
+ update
+ lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f]
+ lappend result [winfo width .t2] [winfo height .t2]
+ # destroy .t2
+ set result
+} {70 120 70 120}
+test unixWm-43.2 {TopLevelReqProc procedure, resize causes window to move} \
+ {unix nonPortable} {
+ destroy .t
+ toplevel .t -width 200 -height 200
+ wm geom .t +0+0
+ update
+ wm geom .t -0-0
+ update
+ set x [winfo x .t]
+ set y [winfo y .t]
+ .t configure -width 300 -height 150
+ update
+ list [expr [winfo x .t] - $x] [expr [winfo y .t] - $y] \
+ [winfo width .t] [winfo height .t]
+} {-100 50 300 150}
+
+test unixWm-44.1 {UpdateGeometryInfo procedure, width/height computation} unix {
+ destroy .t
+ toplevel .t -width 100 -height 200
+ wm geometry .t +30+40
+ wm overrideredirect .t 1
+ tkwait visibility .t
+ .t configure -width 180 -height 20
+ update
+ list [winfo width .t] [winfo height .t]
+} {180 20}
+test unixWm-44.2 {UpdateGeometryInfo procedure, width/height computation} unix {
+ destroy .t
+ toplevel .t -width 80 -height 60
+ wm grid .t 5 4 10 12
+ wm geometry .t +30+40
+ wm overrideredirect .t 1
+ tkwait visibility .t
+ wm geometry .t 10x2
+ update
+ list [winfo width .t] [winfo height .t]
+} {130 36}
+test unixWm-44.3 {UpdateGeometryInfo procedure, width/height computation} unix {
+ destroy .t
+ toplevel .t -width 80 -height 60
+ wm grid .t 5 4 10 12
+ wm geometry .t +30+40
+ wm overrideredirect .t 1
+ tkwait visibility .t
+ wm geometry .t 1x10
+ update
+ list [winfo width .t] [winfo height .t]
+} {40 132}
+test unixWm-44.4 {UpdateGeometryInfo procedure, width/height computation} unix {
+ destroy .t
+ toplevel .t -width 100 -height 200
+ wm geometry .t +30+40
+ wm overrideredirect .t 1
+ tkwait visibility .t
+ wm geometry .t 300x150
+ update
+ list [winfo width .t] [winfo height .t]
+} {300 150}
+test unixWm-44.5 {UpdateGeometryInfo procedure, negative width} unix {
+ destroy .t
+ toplevel .t -width 80 -height 60
+ wm grid .t 18 7 10 12
+ wm geometry .t +30+40
+ wm overrideredirect .t 1
+ tkwait visibility .t
+ wm geometry .t 5x8
+ update
+ list [winfo width .t] [winfo height .t]
+} {1 72}
+test unixWm-44.6 {UpdateGeometryInfo procedure, negative height} unix {
+ destroy .t
+ toplevel .t -width 80 -height 60
+ wm grid .t 18 7 10 12
+ wm geometry .t +30+40
+ wm overrideredirect .t 1
+ tkwait visibility .t
+ wm geometry .t 20x1
+ update
+ list [winfo width .t] [winfo height .t]
+} {100 1}
+
+destroy .t
+toplevel .t -width 80 -height 60
+test unixWm-44.7 {UpdateGeometryInfo procedure, computing position} unix {
+ wm geometry .t +5-10
+ wm overrideredirect .t 1
+ tkwait visibility .t
+ list [winfo x .t] [winfo y .t]
+} [list 5 [expr [winfo screenheight .t] - 70]]
+
+destroy .t
+toplevel .t -width 80 -height 60
+test unixWm-44.8 {UpdateGeometryInfo procedure, computing position} unix {
+ wm geometry .t -30+2
+ wm overrideredirect .t 1
+ tkwait visibility .t
+ list [winfo x .t] [winfo y .t]
+} [list [expr [winfo screenwidth .t] - 110] 2]
+destroy .t
+
+test unixWm-44.9 {UpdateGeometryInfo procedure, updating fixed dimensions} {unix testwrapper} {
+ destroy .t
+ toplevel .t -width 80 -height 60
+ wm resizable .t 0 0
+ wm geometry .t +0+0
+ tkwait visibility .t
+ .t configure -width 180 -height 20
+ update
+ set property [testprop [testwrapper .t] WM_NORMAL_HINTS]
+ list [expr [lindex $property 5]] [expr [lindex $property 6]] \
+ [expr [lindex $property 7]] [expr [lindex $property 8]]
+} {180 20 180 20}
+test unixWm-44.10 {UpdateGeometryInfo procedure, menubar changing} testmenubar {
+ destroy .t
+ toplevel .t -width 80 -height 60
+ wm resizable .t 0 0
+ wm geometry .t +0+0
+ tkwait visibility .t
+ .t configure -width 180 -height 50
+ frame .t.m -bd 2 -relief raised -width 100 -height 50
+ testmenubar window .t .t.m
+ update
+ .t configure -height 70
+ .t.m configure -height 30
+ list [update] [destroy .t]
+} {{} {}}
+
+test unixWm-45.1 {UpdateSizeHints procedure, grid information} {unix testwrapper} {
+ destroy .t
+ toplevel .t -width 80 -height 60
+ wm grid .t 6 10 10 5
+ wm minsize .t 2 4
+ wm maxsize .t 30 40
+ wm geometry .t +0+0
+ tkwait visibility .t
+ set property [testprop [testwrapper .t] WM_NORMAL_HINTS]
+ list [expr [lindex $property 5]] [expr [lindex $property 6]] \
+ [expr [lindex $property 7]] [expr [lindex $property 8]] \
+ [expr [lindex $property 9]] [expr [lindex $property 10]]
+} {40 30 320 210 10 5}
+test unixWm-45.2 {UpdateSizeHints procedure} {unix testwrapper} {
+ destroy .t
+ toplevel .t -width 80 -height 60
+ wm minsize .t 30 40
+ wm maxsize .t 200 500
+ wm geometry .t +0+0
+ tkwait visibility .t
+ set property [testprop [testwrapper .t] WM_NORMAL_HINTS]
+ list [expr [lindex $property 5]] [expr [lindex $property 6]] \
+ [expr [lindex $property 7]] [expr [lindex $property 8]] \
+ [expr [lindex $property 9]] [expr [lindex $property 10]]
+} {30 40 200 500 1 1}
+test unixWm-45.3 {UpdateSizeHints procedure, grid with menu} {testmenubar testwrapper} {
+ destroy .t
+ toplevel .t -width 80 -height 60
+ frame .t.menu -height 23 -width 50
+ testmenubar window .t .t.menu
+ wm grid .t 6 10 10 5
+ wm minsize .t 2 4
+ wm maxsize .t 30 40
+ wm geometry .t +0+0
+ tkwait visibility .t
+ set property [testprop [testwrapper .t] WM_NORMAL_HINTS]
+ list [winfo height .t] \
+ [expr [lindex $property 5]] [expr [lindex $property 6]] \
+ [expr [lindex $property 7]] [expr [lindex $property 8]] \
+ [expr [lindex $property 9]] [expr [lindex $property 10]]
+} {60 40 53 320 233 10 5}
+test unixWm-45.4 {UpdateSizeHints procedure, not resizable with menu} {testmenubar testwrapper} {
+ destroy .t
+ toplevel .t -width 80 -height 60
+ frame .t.menu -height 23 -width 50
+ testmenubar window .t .t.menu
+ wm resizable .t 0 0
+ wm geometry .t +0+0
+ tkwait visibility .t
+ set property [testprop [testwrapper .t] WM_NORMAL_HINTS]
+ list [winfo height .t] \
+ [expr [lindex $property 5]] [expr [lindex $property 6]] \
+ [expr [lindex $property 7]] [expr [lindex $property 8]] \
+ [expr [lindex $property 9]] [expr [lindex $property 10]]
+} {60 80 83 80 83 1 1}
+
+# I don't know how to test WaitForConfigureNotify.
+
+test unixWm-46.1 {WaitForEvent procedure, use of modal timeout} unix {
+ destroy .t
+ toplevel .t -width 200 -height 200
+ wm geom .t +0+0
+ update
+ wm iconify .t
+ set x no
+ after 0 {set x yes}
+ wm deiconify .t
+ set result $x
+ update
+ list $result $x
+} {no yes}
+
+test unixWm-47.1 {WaitRestrictProc procedure} {unix nonPortable} {
+ destroy .t
+ toplevel .t -width 300 -height 200
+ frame .t.f -bd 2 -relief raised
+ place .t.f -x 20 -y 30 -width 100 -height 20
+ wm geometry .t +0+0
+ tkwait visibility .t
+ set result {}
+ bind .t.f <Configure> {lappend result {configure on .t.f}}
+ bind .t <Map> {lappend result {map on .t}}
+ bind .t <Unmap> {lappend result {unmap on .t}; bind .t <Unmap> {}}
+ bind .t <Button> {lappend result {button %b on .t}}
+ event generate .t.f <Configure> -when tail
+ event generate .t <Configure> -when tail
+ event generate .t <Button> -button 3 -when tail
+ event generate .t <ButtonRelease> -button 3 -when tail
+ event generate .t <Map> -when tail
+ lappend result iconify
+ wm iconify .t
+ lappend result done
+ update
+ set result
+} {iconify {unmap on .t} done {configure on .t.f} {button 3 on .t} {map on .t}}
+
+# I don't know how to test WaitTimeoutProc, WaitForMapNotify, or UpdateHints.
+
+destroy .t
+toplevel .t -width 300 -height 200
+wm geometry .t +0+0
+tkwait visibility .t
+
+test unixWm-48.1 {ParseGeometry procedure} unix {
+ wm geometry .t =100x120
+ update
+ list [winfo width .t] [winfo height .t]
+} {100 120}
+test unixWm-48.2 {ParseGeometry procedure} unix {
+ list [catch {wm geometry .t =10zx120} msg] $msg
+} {1 {bad geometry specifier "=10zx120"}}
+test unixWm-48.3 {ParseGeometry procedure} unix {
+ list [catch {wm geometry .t x120} msg] $msg
+} {1 {bad geometry specifier "x120"}}
+test unixWm-48.4 {ParseGeometry procedure} unix {
+ list [catch {wm geometry .t =100x120a} msg] $msg
+} {1 {bad geometry specifier "=100x120a"}}
+test unixWm-48.5 {ParseGeometry procedure} unix {
+ list [catch {wm geometry .t z} msg] $msg
+} {1 {bad geometry specifier "z"}}
+test unixWm-48.6 {ParseGeometry procedure} unix {
+ list [catch {wm geometry .t +20&} msg] $msg
+} {1 {bad geometry specifier "+20&"}}
+test unixWm-48.7 {ParseGeometry procedure} unix {
+ list [catch {wm geometry .t +-} msg] $msg
+} {1 {bad geometry specifier "+-"}}
+test unixWm-48.8 {ParseGeometry procedure} unix {
+ list [catch {wm geometry .t +20a} msg] $msg
+} {1 {bad geometry specifier "+20a"}}
+test unixWm-48.9 {ParseGeometry procedure} unix {
+ list [catch {wm geometry .t +20-} msg] $msg
+} {1 {bad geometry specifier "+20-"}}
+test unixWm-48.10 {ParseGeometry procedure} unix {
+ list [catch {wm geometry .t +20+10z} msg] $msg
+} {1 {bad geometry specifier "+20+10z"}}
+test unixWm-48.11 {ParseGeometry procedure} unix {
+ catch {wm geometry .t +-10+20}
+} {0}
+test unixWm-48.12 {ParseGeometry procedure} unix {
+ catch {wm geometry .t +30+-10}
+} {0}
+test unixWm-48.13 {ParseGeometry procedure, resize causes window to move} unix {
+ destroy .t
+ toplevel .t -width 200 -height 200
+ wm geom .t +0+0
+ update
+ wm geom .t -0-0
+ update
+ set x [winfo x .t]
+ set y [winfo y .t]
+ wm geometry .t 150x300
+ update
+ list [expr [winfo x .t] - $x] [expr [winfo y .t] - $y] \
+ [winfo width .t] [winfo height .t]
+} {50 -100 150 300}
+
+test unixWm-49.1 {Tk_GetRootCoords procedure} unix {
+ destroy .t
+ toplevel .t -width 300 -height 200
+ frame .t.f -width 150 -height 100 -bd 2 -relief raised
+ place .t.f -x 150 -y 120
+ frame .t.f.f -width 20 -height 20 -bd 2 -relief raised
+ place .t.f.f -x 10 -y 20
+ wm overrideredirect .t 1
+ wm geometry .t +40+50
+ tkwait visibility .t
+ list [winfo rootx .t.f.f] [winfo rooty .t.f.f]
+} {202 192}
+test unixWm-49.2 {Tk_GetRootCoords procedure, menubars} {unix testmenubar} {
+ destroy .t
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ wm geom .t +0+0
+ update
+ set x [winfo rootx .t]
+ set y [winfo rooty .t]
+ frame .t.m -bd 2 -relief raised -width 100 -height 30
+ frame .t.m.f -width 20 -height 10 -bd 2 -relief raised
+ place .t.m.f -x 50 -y 5
+ frame .t.f -width 20 -height 30 -bd 2 -relief raised
+ place .t.f -x 10 -y 30
+ testmenubar window .t .t.m
+ update
+ list [expr [winfo rootx .t.m.f] - $x] [expr [winfo rooty .t.m.f] - $y] \
+ [expr [winfo rootx .t.f] - $x] [expr [winfo rooty .t.f] - $y]
+} {52 7 12 62}
+
+deleteWindows
+wm iconify .
+test unixWm-50.1 {Tk_CoordsToWindow procedure, finding a toplevel, x-coords} unix {
+ deleteWindows
+ toplevel .t -width 300 -height 400 -bg green
+ wm geom .t +40+0
+ tkwait visibility .t
+ toplevel .t2 -width 100 -height 80 -bg red
+ wm geom .t2 +140+200
+ tkwait visibility .t2
+ raise .t2
+ set x [winfo rootx .t]
+ set y [winfo rooty .t]
+ list [winfo containing [expr $x - 30] [expr $y + 250]] \
+ [winfo containing [expr $x - 1] [expr $y + 250]] \
+ [winfo containing $x [expr $y + 250]] \
+ [winfo containing [expr $x + 99] [expr $y + 250]] \
+ [winfo containing [expr $x + 100] [expr $y + 250]] \
+ [winfo containing [expr $x + 199] [expr $y + 250]] \
+ [winfo containing [expr $x + 200] [expr $y + 250]] \
+ [winfo containing [expr $x + 220] [expr $y + 250]]
+} {{} {} .t {} .t2 .t2 {} .t}
+test unixWm-50.2 {Tk_CoordsToWindow procedure, finding a toplevel, y-coords and overrideredirect} unix {
+ deleteWindows
+ toplevel .t -width 300 -height 400 -bg yellow
+ wm geom .t +0+50
+ tkwait visibility .t
+ toplevel .t2 -width 100 -height 80 -bg blue
+ wm overrideredirect .t2 1
+ wm geom .t2 +100+200
+ tkwait visibility .t2
+ raise .t2
+ set x [winfo rootx .t]
+ set y [winfo rooty .t]
+ set y2 [winfo rooty .t2]
+ list [winfo containing [expr $x +150] 10] \
+ [winfo containing [expr $x +150] [expr $y - 1]] \
+ [winfo containing [expr $x +150] $y] \
+ [winfo containing [expr $x +150] [expr $y2 - 1]] \
+ [winfo containing [expr $x +150] $y2] \
+ [winfo containing [expr $x +150] [expr $y2 + 79]] \
+ [winfo containing [expr $x +150] [expr $y2 + 80]] \
+ [winfo containing [expr $x +150] [expr $y + 450]]
+} {{} {} .t .t .t2 .t2 .t {}}
+test unixWm-50.3 {
+ Tk_CoordsToWindow procedure, finding a toplevel with embedding
+} -constraints tempNotWin -setup {
+ deleteWindows
+ toplevel .t -width 300 -height 400 -bg blue
+ wm geom .t +0+50
+ frame .t.f -container 1
+ place .t.f -x 150 -y 50
+ tkwait visibility .t.f
+ setupbg
+} -body {
+ dobg "
+ wm withdraw .
+ toplevel .x -width 100 -height 80 -use [winfo id .t.f] -bg yellow
+ tkwait visibility .x"
+ set result [dobg {
+ set x [winfo rootx .x]
+ set y [winfo rooty .x]
+ list [winfo containing [expr $x - 1] [expr $y + 50]] \
+ [winfo containing $x [expr $y +50]]
+ }]
+ set x [winfo rootx .t]
+ set y [winfo rooty .t]
+ lappend result [winfo containing [expr $x + 200] [expr $y + 49]] \
+ [winfo containing [expr $x + 200] [expr $y +50]]
+} -cleanup {
+ cleanupbg
+} -result {{} .x .t .t.f}
+test unixWm-50.4 {Tk_CoordsToWindow procedure, window in other application} unix {
+ destroy .t
+ catch {interp delete slave}
+ toplevel .t -width 200 -height 200 -bg green
+ wm geometry .t +0+0
+ tkwait visibility .t
+ interp create slave
+ load {} Tk slave
+ slave eval {wm geometry . 200x200+0+0; tkwait visibility .}
+ set result [list [winfo containing 100 100] \
+ [slave eval {winfo containing 100 100}]]
+ interp delete slave
+ set result
+} {{} .}
+test unixWm-50.5 {Tk_CoordsToWindow procedure, handling menubars} {unix testmenubar} {
+ deleteWindows
+ toplevel .t -width 300 -height 400 -bd 2 -relief raised
+ frame .t.f -width 150 -height 120 -bg green
+ place .t.f -x 10 -y 150
+ wm geom .t +0+50
+ frame .t.menu -width 100 -height 30 -bd 2 -relief raised
+ frame .t.menu.f -width 40 -height 20 -bg purple
+ place .t.menu.f -x 30 -y 10
+ testmenubar window .t .t.menu
+ tkwait visibility .t.menu
+ update
+ set x [winfo rootx .t]
+ set y [winfo rooty .t]
+ list [winfo containing $x [expr $y - 31]] \
+ [winfo containing $x [expr $y - 30]] \
+ [winfo containing [expr $x + 50] [expr $y - 19]] \
+ [winfo containing [expr $x + 50] [expr $y - 18]] \
+ [winfo containing [expr $x + 50] $y] \
+ [winfo containing [expr $x + 11] [expr $y + 152]] \
+ [winfo containing [expr $x + 12] [expr $y + 152]]
+} {{} .t.menu .t.menu .t.menu.f .t .t .t.f}
+test unixWm-50.6 {Tk_CoordsToWindow procedure, embedding within one app.} unix {
+ deleteWindows
+ toplevel .t -width 300 -height 400 -bg orange
+ wm geom .t +0+50
+ frame .t.f -container 1
+ place .t.f -x 150 -y 50
+ tkwait visibility .t.f
+ toplevel .t2 -width 100 -height 80 -bg green -use [winfo id .t.f]
+ tkwait visibility .t2
+ update
+ set x [winfo rootx .t]
+ set y [winfo rooty .t]
+ list [winfo containing [expr $x +149] [expr $y + 80]] \
+ [winfo containing [expr $x +150] [expr $y +80]] \
+ [winfo containing [expr $x +249] [expr $y +80]] \
+ [winfo containing [expr $x +250] [expr $y +80]]
+} {.t .t2 .t2 .t}
+test unixWm-50.7 {Tk_CoordsToWindow procedure, more basics} unix {
+ destroy .t
+ toplevel .t -width 300 -height 400 -bg green
+ wm geom .t +0+0
+ frame .t.f -width 100 -height 200 -bd 2 -relief raised
+ place .t.f -x 100 -y 100
+ frame .t.f.f -width 100 -height 200 -bd 2 -relief raised
+ place .t.f.f -x 0 -y 100
+ tkwait visibility .t.f.f
+ set x [expr [winfo rootx .t] + 150]
+ set y [winfo rooty .t]
+ list [winfo containing $x [expr $y + 50]] \
+ [winfo containing $x [expr $y + 150]] \
+ [winfo containing $x [expr $y + 250]] \
+ [winfo containing $x [expr $y + 350]] \
+ [winfo containing $x [expr $y + 450]]
+} {.t .t.f .t.f.f .t {}}
+test unixWm-50.8 {Tk_CoordsToWindow procedure, more basics} unix {
+ destroy .t
+ toplevel .t -width 400 -height 300 -bg green
+ wm geom .t +0+0
+ frame .t.f -width 200 -height 100 -bd 2 -relief raised
+ place .t.f -x 100 -y 100
+ frame .t.f.f -width 200 -height 100 -bd 2 -relief raised
+ place .t.f.f -x 100 -y 0
+ update
+ set x [winfo rooty .t]
+ set y [expr [winfo rooty .t] + 150]
+ list [winfo containing [expr $x + 50] $y] \
+ [winfo containing [expr $x + 150] $y] \
+ [winfo containing [expr $x + 250] $y] \
+ [winfo containing [expr $x + 350] $y] \
+ [winfo containing [expr $x + 450] $y]
+} {.t .t.f .t.f.f .t {}}
+test unixWm-50.9 {Tk_CoordsToWindow procedure, unmapped windows} unix {
+ destroy .t
+ destroy .t2
+ sleep 500 ;# Give window manager time to catch up.
+ toplevel .t -width 200 -height 200 -bg green
+ wm geometry .t +0+0
+ tkwait visibility .t
+ toplevel .t2 -width 200 -height 200 -bg red
+ wm geometry .t2 +0+0
+ tkwait visibility .t2
+ set result [list [winfo containing 100 100]]
+ wm iconify .t2
+ lappend result [winfo containing 100 100]
+} {.t2 .t}
+test unixWm-50.10 {Tk_CoordsToWindow procedure, unmapped windows} unix {
+ destroy .t
+ toplevel .t -width 200 -height 200 -bg green
+ wm geometry .t +0+0
+ frame .t.f -width 150 -height 150 -bd 2 -relief raised
+ place .t.f -x 25 -y 25
+ tkwait visibility .t.f
+ set result [list [winfo containing 100 100]]
+ place forget .t.f
+ update
+ lappend result [winfo containing 100 100]
+} {.t.f .t}
+deleteWindows
+wm deiconify .
+
+# No tests for UpdateVRootGeometry, Tk_GetVRootGeometry,
+# Tk_MoveToplevelWindow, UpdateWmProtocols, or TkWmProtocolEventProc.
+
+test unixWm-51.1 {TkWmRestackToplevel procedure, basic tests} {unix nonPortable} {
+ makeToplevels
+ update
+ raise .raise1
+ winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
+} .raise1
+test unixWm-51.2 {TkWmRestackToplevel procedure, basic tests} {unix nonPortable} {
+ makeToplevels
+ update
+ raise .raise2
+ winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
+} .raise2
+test unixWm-51.3 {TkWmRestackToplevel procedure, basic tests} {unix nonPortable} {
+ makeToplevels
+ update
+ raise .raise3
+ raise .raise2
+ raise .raise1 .raise3
+ set result [winfo containing [winfo rootx .raise1] \
+ [winfo rooty .raise1]]
+ destroy .raise2
+ sleep 500
+ list $result [winfo containing [winfo rootx .raise1] \
+ [winfo rooty .raise1]]
+} {.raise2 .raise1}
+test unixWm-51.4 {TkWmRestackToplevel procedure, basic tests} {unix nonPortable} {
+ makeToplevels
+ raise .raise2
+ raise .raise1
+ lower .raise3 .raise1
+ set result [winfo containing 100 100]
+ destroy .raise1
+ sleep 500
+ lappend result [winfo containing 100 100]
+} {.raise1 .raise3}
+test unixWm-51.5 {TkWmRestackToplevel procedure, basic tests} {unix nonPortable} {
+ makeToplevels
+ update
+ raise .raise2
+ raise .raise1
+ raise .raise3
+ frame .raise1.f1
+ frame .raise1.f1.f2
+ lower .raise3 .raise1.f1.f2
+ set result [winfo containing [winfo rootx .raise1] \
+ [winfo rooty .raise1]]
+ destroy .raise1
+ sleep 500
+ list $result [winfo containing [winfo rootx .raise2] \
+ [winfo rooty .raise2]]
+} {.raise1 .raise3}
+deleteWindows
+test unixWm-51.6 {TkWmRestackToplevel procedure, window to be stacked isn't mapped} unix {
+ destroy .t
+ toplevel .t -width 200 -height 200 -bg green
+ wm geometry .t +0+0
+ tkwait visibility .t
+ destroy .t2
+ toplevel .t2 -width 200 -height 200 -bg red
+ wm geometry .t2 +0+0
+ winfo containing 100 100
+} {.t}
+test unixWm-51.7 {TkWmRestackToplevel procedure, other window isn't mapped} unix {
+ foreach w {.t .t2 .t3} {
+ destroy $w
+ toplevel $w -width 200 -height 200 -bg green
+ wm geometry $w +0+0
+ }
+ raise .t .t2
+ sleep 2000
+ update
+ set result [list [winfo containing 100 100]]
+ lower .t3
+ sleep 2000
+ lappend result [winfo containing 100 100]
+} {.t3 .t}
+test unixWm-51.8 {TkWmRestackToplevel procedure, overrideredirect windows} unix {
+ destroy .t
+ toplevel .t -width 200 -height 200 -bg green
+ wm overrideredirect .t 1
+ wm geometry .t +0+0
+ tkwait visibility .t
+ destroy .t2
+ toplevel .t2 -width 200 -height 200 -bg red
+ wm overrideredirect .t2 1
+ wm geometry .t2 +0+0
+ tkwait visibility .t2
+
+ # Need to use vrootx and vrooty to make tests work correctly with
+ # virtual root window measures managers: overrideredirect windows
+ # come up at (0,0) in display coordinates, not virtual root
+ # coordinates.
+
+ set x [expr 100-[winfo vrootx .]]
+ set y [expr 100-[winfo vrooty .]]
+ set result [list [winfo containing $x $y]]
+ raise .t
+ lappend result [winfo containing $x $y]
+ raise .t2
+ lappend result [winfo containing $x $y]
+} {.t2 .t .t2}
+test unixWm-51.9 {TkWmRestackToplevel procedure, other window overrideredirect} unix {
+ foreach w {.t .t2 .t3} {
+ destroy $w
+ toplevel $w -width 200 -height 200 -bg green
+ wm overrideredirect $w 1
+ wm geometry $w +0+0
+ tkwait visibility $w
+ }
+ lower .t3 .t2
+ update
+
+ # Need to use vrootx and vrooty to make tests work correctly with
+ # virtual root window measures managers: overrideredirect windows
+ # come up at (0,0) in display coordinates, not virtual root
+ # coordinates.
+
+ set x [expr 100-[winfo vrootx .]]
+ set y [expr 100-[winfo vrooty .]]
+ set result [list [winfo containing $x $y]]
+ lower .t2
+ lappend result [winfo containing $x $y]
+} {.t2 .t3}
+test unixWm-51.10 {TkWmRestackToplevel procedure, don't move window that's already in the right place} unix {
+ makeToplevels
+ raise .raise1
+ set time [lindex [time {raise .raise1}] 0]
+ expr {$time < 2000000}
+} 1
+test unixWm-51.11 {TkWmRestackToplevel procedure, don't move window that's already in the right place} unix {
+ makeToplevels
+ set time [lindex [time {lower .raise1}] 0]
+ expr {$time < 2000000}
+} 1
+test unixWm-51.12 {TkWmRestackToplevel procedure, don't move window that's already in the right place} unix {
+ makeToplevels
+ set time [lindex [time {raise .raise3 .raise2}] 0]
+ expr {$time < 2000000}
+} 1
+test unixWm-51.13 {TkWmRestackToplevel procedure, don't move window that's already in the right place} unix {
+ makeToplevels
+ set time [lindex [time {lower .raise1 .raise2}] 0]
+ expr {$time < 2000000}
+} 1
+
+test unixWm-52.1 {TkWmAddToColormapWindows procedure} unix {
+ destroy .t
+ toplevel .t -width 200 -height 200 -colormap new -relief raised -bd 2
+ wm geom .t +0+0
+ update
+ wm colormap .t
+} {}
+test unixWm-52.2 {TkWmAddToColormapWindows procedure} unix {
+ destroy .t
+ toplevel .t -colormap new -relief raised -bd 2
+ wm geom .t +0+0
+ frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2
+ pack .t.f
+ update
+ wm colormap .t
+} {.t.f .t}
+test unixWm-52.3 {TkWmAddToColormapWindows procedure} unix {
+ destroy .t
+ toplevel .t -colormap new
+ wm geom .t +0+0
+ frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2
+ pack .t.f
+ frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2
+ pack .t.f2
+ update
+ wm colormap .t
+} {.t.f .t.f2 .t}
+test unixWm-52.4 {TkWmAddToColormapWindows procedure} unix {
+ destroy .t
+ toplevel .t -colormap new
+ wm geom .t +0+0
+ frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2
+ pack .t.f
+ update
+ wm colormapwindows .t .t.f
+ frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2
+ pack .t.f2
+ update
+ wm colormapwindows .t
+} {.t.f}
+
+test unixWm-53.1 {TkWmRemoveFromColormapWindows procedure} unix {
+ destroy .t
+ toplevel .t -colormap new
+ wm geom .t +0+0
+ frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2
+ pack .t.f
+ frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2
+ pack .t.f2
+ update
+ destroy .t.f2
+ wm colormap .t
+} {.t.f .t}
+test unixWm-53.2 {TkWmRemoveFromColormapWindows procedure} unix {
+ destroy .t
+ toplevel .t -colormap new
+ wm geom .t +0+0
+ frame .t.f -width 100 -height 100 -colormap new -relief sunken -bd 2
+ pack .t.f
+ frame .t.f2 -width 100 -height 100 -colormap new -relief sunken -bd 2
+ pack .t.f2
+ update
+ wm colormapwindows .t .t.f2
+ destroy .t.f2
+ wm colormap .t
+} {}
+
+test unixWm-54.1 {TkpMakeMenuWindow procedure, setting save_under} {unix nonUnixUserInteraction} {
+ destroy .t
+ destroy .m
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ bind .t <Expose> {set x exposed}
+ wm geom .t +0+0
+ update
+ menu .m
+ .m add command -label First
+ .m add command -label Second
+ .m add command -label Third
+ .m post 30 30
+ update
+ set x {no event}
+ destroy .m
+ set x
+} {no event}
+test unixWm-54.2 {TkpMakeMenuWindow procedure, setting override_redirect} {unix nonUnixUserInteraction} {
+ destroy .m
+ menu .m
+ .m add command -label First
+ .m add command -label Second
+ .m add command -label Third
+ .m post 30 30
+ update
+ set result [wm overrideredirect .m]
+ destroy .m
+ set result
+} {1}
+
+# No tests for TkGetPointerCoords, CreateWrapper, or GetMaxSize.
+
+test unixWm-55.1 {TkUnixSetMenubar procedure} {unix testmenubar} {
+ destroy .t
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ wm geom .t +0+0
+ update
+ frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
+ testmenubar window .t .t.f
+ update
+ list [winfo ismapped .t.f] [winfo geometry .t.f] \
+ [expr [winfo rootx .t] - [winfo rootx .t.f]] \
+ [expr [winfo rooty .t] - [winfo rooty .t.f]]
+} {1 300x30+0+0 0 30}
+test unixWm-55.2 {TkUnixSetMenubar procedure, removing menubar} {unix testmenubar} {
+ destroy .t
+ destroy .f
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ wm geom .t +0+0
+ update
+ set x [winfo rootx .t]
+ set y [winfo rooty .t]
+ frame .f -width 400 -height 30 -bd 2 -relief raised -bg green
+ testmenubar window .t .f
+ update
+ testmenubar window .t {}
+ update
+ list [winfo ismapped .f] [winfo geometry .f] \
+ [expr [winfo rootx .t] - $x] \
+ [expr [winfo rooty .t] - $y] \
+ [expr [winfo rootx .] - [winfo rootx .f]] \
+ [expr [winfo rooty .] - [winfo rooty .f]]
+} {0 300x30+0+0 0 0 0 0}
+test unixWm-55.3 {TkUnixSetMenubar procedure, removing geometry manager} {unix testmenubar} {
+ destroy .t
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ wm geom .t +0+0
+ update
+ set x [winfo rootx .t]
+ set y [winfo rooty .t]
+ frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
+ testmenubar window .t .t.f
+ update
+ testmenubar window .t {}
+ update
+ set result "[expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]"
+ .t.f configure -height 100
+ update
+ lappend result [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]
+} {0 0 0 0}
+test unixWm-55.4 {TkUnixSetMenubar procedure, toplevel not yet created} {unix testmenubar} {
+ destroy .t
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
+ testmenubar window .t .t.f
+ wm geom .t +0+0
+ update
+ list [winfo ismapped .t.f] [winfo geometry .t.f] \
+ [expr [winfo rootx .t] - [winfo rootx .t.f]] \
+ [expr [winfo rooty .t] - [winfo rooty .t.f]]
+} {1 300x30+0+0 0 30}
+test unixWm-55.5 {TkUnixSetMenubar procedure, changing menubar} {unix testmenubar} {
+ destroy .t
+ destroy .f
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
+ wm geom .t +0+0
+ update
+ set y [winfo rooty .t]
+ frame .f -width 400 -height 50 -bd 2 -relief raised -bg green
+ testmenubar window .t .t.f
+ update
+ set result {}
+ lappend result [winfo ismapped .f] [winfo ismapped .t.f]
+ lappend result [expr [winfo rooty .t.f] - $y]
+ testmenubar window .t .f
+ update
+ lappend result [winfo ismapped .f] [winfo ismapped .t.f]
+ lappend result [expr [winfo rooty .f] - $y]
+} {0 1 0 1 0 0}
+test unixWm-55.6 {TkUnixSetMenubar procedure, changing menubar to self} {unix testmenubar} {
+ destroy .t
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
+ testmenubar window .t .t.f
+ wm geom .t +0+0
+ update
+ testmenubar window .t .t.f
+ update
+ list [winfo ismapped .t.f] [winfo geometry .t.f] \
+ [expr [winfo rootx .t] - [winfo rootx .t.f]] \
+ [expr [winfo rooty .t] - [winfo rooty .t.f]]
+} {1 300x30+0+0 0 30}
+test unixWm-55.7 {TkUnixSetMenubar procedure, unsetting event handler} {unix testmenubar} {
+ destroy .t
+ destroy .f
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
+ frame .f -width 400 -height 40 -bd 2 -relief raised -bg blue
+ wm geom .t +0+0
+ update
+ set y [winfo rooty .t]
+ testmenubar window .t .t.f
+ update
+ set result [expr [winfo rooty .t] - $y]
+ testmenubar window .t .f
+ update
+ lappend result [expr [winfo rooty .t] - $y]
+ destroy .t.f
+ update
+ lappend result [expr [winfo rooty .t] - $y]
+} {30 40 40}
+
+test unixWm-56.1 {MenubarDestroyProc procedure} {unix testmenubar} {
+ destroy .t
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ wm geom .t +0+0
+ update
+ set y [winfo rooty .t]
+ frame .t.f -width 400 -height 30 -bd 2 -relief raised -bg green
+ testmenubar window .t .t.f
+ update
+ set result [expr [winfo rooty .t] - $y]
+ destroy .t.f
+ update
+ lappend result [expr [winfo rooty .t] - $y]
+} {30 0}
+
+test unixWm-57.1 {MenubarReqProc procedure} {unix testmenubar} {
+ destroy .t
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ wm geom .t +0+0
+ update
+ set x [winfo rootx .t]
+ set y [winfo rooty .t]
+ frame .t.f -width 400 -height 10 -bd 2 -relief raised -bg green
+ testmenubar window .t .t.f
+ update
+ set result "[expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]"
+ .t.f configure -height 100
+ update
+ lappend result [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]
+} {0 10 0 100}
+test unixWm-57.2 {MenubarReqProc procedure} {unix testmenubar} {
+ destroy .t
+ toplevel .t -width 300 -height 200 -bd 2 -relief raised
+ wm geom .t +0+0
+ update
+ set x [winfo rootx .t]
+ set y [winfo rooty .t]
+ frame .t.f -width 400 -height 20 -bd 2 -relief raised -bg green
+ testmenubar window .t .t.f
+ update
+ set result "[expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]"
+ .t.f configure -height 0
+ update
+ lappend result [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y]
+} {0 20 0 1}
+
+test unixWm-58.1 {UpdateCommand procedure, DString gets reallocated} {unix testwrapper} {
+ destroy .t
+ toplevel .t -width 100 -height 50
+ wm geom .t +0+0
+ wm command .t "argumentNumber0 argumentNumber1 argumentNumber2 argumentNumber0 argumentNumber3 argumentNumber4 argumentNumber5 argumentNumber6 argumentNumber0 argumentNumber7 argumentNumber8 argumentNumber9 argumentNumber10 argumentNumber0 argumentNumber11 argumentNumber12 argumentNumber13 argumentNumber14 argumentNumber15 argumentNumber16 argumentNumber17 argumentNumber18"
+ update
+ testprop [testwrapper .t] WM_COMMAND
+} {argumentNumber0
+argumentNumber1
+argumentNumber2
+argumentNumber0
+argumentNumber3
+argumentNumber4
+argumentNumber5
+argumentNumber6
+argumentNumber0
+argumentNumber7
+argumentNumber8
+argumentNumber9
+argumentNumber10
+argumentNumber0
+argumentNumber11
+argumentNumber12
+argumentNumber13
+argumentNumber14
+argumentNumber15
+argumentNumber16
+argumentNumber17
+argumentNumber18
+}
+
+# Test exit processing and cleanup:
+
+test unixWm-59.1 {exit processing} unix {
+ set script [makeFile {
+ update
+ exit
+ } script]
+ if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
+ set error 1
+ } else {
+ set error 0
+ }
+ removeFile script
+ list $error $msg
+} {0 {}}
+test unixWm-59.2 {exit processing} unix {
+ set code [loadTkCommand]
+ append code {
+ interp create x
+ x eval {set argc 2}
+ x eval {set argv "-geometry 10x10+0+0"}
+ x eval {load {} Tk}
+ update
+ exit
+ }
+ set script [makeFile $code script]
+ if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
+ set error 1
+ } else {
+ set error 0
+ }
+ removeFile script
+ list $error $msg
+} {0 {}}
+test unixWm-59.3 {exit processing} unix {
+ set code [loadTkCommand]
+ append code {
+ interp create x
+ x eval {set argc 2}
+ x eval {set argv "-geometry 10x10+0+0"}
+ x eval {load {} Tk}
+ x eval {
+ button .b -text hello
+ bind .b <Destroy> foo
+ }
+ x alias foo destroy_x
+ proc destroy_x {} {interp delete x}
+ update
+ exit
+ }
+ set script [makeFile $code script]
+ if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
+ set error 1
+ } else {
+ set error 0
+ }
+ removeFile script
+ list $error $msg
+} {0 {}}
+
+#
+# wm attributes tests:
+#
+# NOTE: since [wm attributes] is not guaranteed to have any effect,
+# the only thing we can really test here is the syntax.
+#
+test unixWm-60.1 {wm attributes - test} -constraints unix -body {
+ destroy .t
+ toplevel .t
+ wm attributes .t
+} -result [list -alpha 1.0 -topmost 0 -zoomed 0 -fullscreen 0 -type {}]
+
+test unixWm-60.2 {wm attributes - test} -constraints unix -body {
+ destroy .t
+ toplevel .t
+ wm attributes .t -topmost
+} -result 0
+
+test unixWm-60.3 {wm attributes - set (unrealized)} -constraints unix -body {
+ destroy .t
+ toplevel .t
+ wm attributes .t -topmost 1
+}
+
+test unixWm-60.4 {wm attributes - set (realized)} -constraints unix -body {
+ destroy .t
+ toplevel .t
+ tkwait visibility .t
+ wm attributes .t -topmost 1
+}
+
+test unixWm-60.5 {wm attributes - bad attribute} -constraints unix -body {
+ destroy .t
+ toplevel .t
+ wm attributes .t -foo
+} -returnCodes 1 -match glob -result {bad attribute "-foo":*}
+
+test unixWm-61.1 {Tk_WmCmd procedure, "iconphoto" option} unix {
+ list [catch {wm iconph .} msg] $msg
+} {1 {wrong # args: should be "wm iconphoto window ?-default? image1 ?image2 ...?"}}
+test unixWm-61.2 {Tk_WmCmd procedure, "iconphoto" option} unix {
+ destroy .t
+ toplevel .t
+ image create photo blank16 -width 16 -height 16
+ image create photo blank32 -width 32 -height 32
+ # This should just make blank icons for the window
+ wm iconphoto .t blank16 blank32
+ image delete blank16 blank32
+} {}
+
+test unixWm-62.0 {wm attributes -type void} -constraints unix -setup {
+ destroy .t
+ toplevel .t
+} -body {
+ wm attributes .t -type {}
+} -cleanup {
+ destroy .t
+} -result {}
+
+test unixWm-62.1 {wm attributes -type name} -constraints unix -setup {
+ destroy .t
+ toplevel .t
+} -body {
+ wm attributes .t -type dialog
+} -cleanup {
+ destroy .t
+} -result {}
+
+test unixWm-62.2 {wm attributes -type name} -constraints unix -setup {
+ destroy .t
+ toplevel .t
+} -body {
+ tkwait visibility .t
+ wm attributes .t -type dialog
+} -cleanup {
+ destroy .t
+} -result {}
+
+test unixWm-62.3 {wm attributes -type list} -constraints unix -setup {
+ destroy .t
+ toplevel .t
+} -body {
+ wm attributes .t -type {xyzzy dialog}
+} -cleanup {
+ destroy .t
+} -result {}
+
+test unixWm-62.4 {wm attributes -type list} -constraints unix -setup {
+ destroy .t
+ toplevel .t
+} -body {
+ tkwait visibility .t
+ wm attributes .t -type {xyzzy dialog}
+} -cleanup {
+ destroy .t
+} -result {}
+
+# cleanup
+destroy .t
+cleanupTests
+return
diff --git a/tk8.6/tests/util.test b/tk8.6/tests/util.test
new file mode 100644
index 0000000..c1ec6a5
--- /dev/null
+++ b/tk8.6/tests/util.test
@@ -0,0 +1,68 @@
+# This file is a Tcl script to test out the procedures in the file
+# tkUtil.c. It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+listbox .l -width 20 -height 5 -relief sunken -bd 2
+pack .l
+.l insert 0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
+update
+test util-1.1 {Tk_GetScrollInfo procedure} -body {
+ .l yview moveto a b
+} -returnCodes error -result {wrong # args: should be ".l yview moveto fraction"}
+test util-1.2 {Tk_GetScrollInfo procedure} -body {
+ .l yview moveto xyz
+} -returnCodes error -result {expected floating-point number but got "xyz"}
+test util-1.3 {Tk_GetScrollInfo procedure} -body {
+ .l yview 0
+ .l yview moveto .5
+ .l yview
+} -result {0.5 0.75}
+test util-1.4 {Tk_GetScrollInfo procedure} -body {
+ .l yview scroll a
+} -returnCodes error -result {wrong # args: should be ".l yview scroll number units|pages"}
+test util-1.5 {Tk_GetScrollInfo procedure} -body {
+ .l yview scroll a b c
+} -returnCodes error -result {wrong # args: should be ".l yview scroll number units|pages"}
+test util-1.6 {Tk_GetScrollInfo procedure} -body {
+ .l yview scroll xyz units
+} -returnCodes error -result {expected integer but got "xyz"}
+test util-1.7 {Tk_GetScrollInfo procedure} -body {
+ .l yview 0
+ .l yview scroll 2 pages
+ .l nearest 0
+} -result {6}
+test util-1.8 {Tk_GetScrollInfo procedure} -body {
+ .l yview 15
+ .l yview scroll -2 pages
+ .l nearest 0
+} -result {9}
+test util-1.9 {Tk_GetScrollInfo procedure} -body {
+ .l yview 0
+ .l yview scroll 2 units
+ .l nearest 0
+} -result {2}
+test util-1.10 {Tk_GetScrollInfo procedure} -body {
+ .l yview 15
+ .l yview scroll -2 units
+ .l nearest 0
+} -result {13}
+test util-1.11 {Tk_GetScrollInfo procedure} -body {
+ .l yview scroll 3 zips
+} -returnCodes error -result {bad argument "zips": must be units or pages}
+test util-1.12 {Tk_GetScrollInfo procedure} -body {
+ .l yview dropdead 3 times
+} -returnCodes error -result {unknown option "dropdead": must be moveto or scroll}
+
+# cleanup
+cleanupTests
+return
+
diff --git a/tk8.6/tests/visual.test b/tk8.6/tests/visual.test
new file mode 100644
index 0000000..2f5c34a
--- /dev/null
+++ b/tk8.6/tests/visual.test
@@ -0,0 +1,570 @@
+# This file is a Tcl script to test the visual- and colormap-handling
+# procedures in the file tkVisual.c. It is organized in the standard
+# fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+
+update
+
+# eatColors --
+# Creates a toplevel window and allocates enough colors in it to
+# use up all the slots in the colormap.
+#
+# Arguments:
+# w - Name of toplevel window to create.
+
+proc eatColors {w} {
+ catch {destroy $w}
+ toplevel $w
+ wm geom $w +0+0
+ canvas $w.c -width 400 -height 200 -bd 0
+ pack $w.c
+ for {set y 0} {$y < 8} {incr y} {
+ for {set x 0} {$x < 40} {incr x} {
+ set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
+ $w.c create rectangle [expr 10*$x] [expr 20*$y] \
+ [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
+ -fill $color
+ }
+ }
+ update
+}
+
+# colorsFree --
+#
+# Returns 1 if there appear to be free colormap entries in a window,
+# 0 otherwise.
+#
+# Arguments:
+# w - Name of window in which to check.
+# red, green, blue - Intensities to use in a trial color allocation
+# to see if there are colormap entries free.
+
+proc colorsFree {w {red 31} {green 245} {blue 192}} {
+ set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
+ expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
+ && ([lindex $vals 2]/256 == $blue)
+}
+
+# If more than one visual type is available for the screen, pick one
+# that is *not* the default.
+
+set default "[winfo visual .] [winfo depth .]"
+set avail [winfo visualsavailable .]
+set other {}
+if {[llength $avail] > 1} {
+ foreach visual $avail {
+ if {$visual != $default} {
+ set other $visual
+ break
+ }
+ }
+}
+testConstraint haveOtherVisual [expr {$other ne ""}]
+testConstraint havePseudocolorVisual [string match *pseudocolor* $avail]
+testConstraint haveMultipleVisuals [expr {[llength $avail] > 1}]
+
+# ----------------------------------------------------------------------
+
+test visual-1.1 {Tk_GetVisual, copying from other window} -body {
+ toplevel .t -visual .foo.bar
+} -returnCodes error -result {bad window path name ".foo.bar"}
+test visual-1.2 {Tk_GetVisual, copying from other window} -constraints {
+ haveOtherVisual nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual $other
+ wm geom .t1 +0+0
+ toplevel .t2 -width 200 -height 80 -visual .t1
+ wm geom .t2 +5+5
+ concat "[winfo visual .t2] [winfo depth .t2]"
+} -cleanup {
+ deleteWindows
+} -result $other
+test visual-1.3 {Tk_GetVisual, copying from other window} -constraints {
+ haveOtherVisual
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual $other
+ wm geom .t1 +0+0
+ toplevel .t2 -width 200 -height 80 -visual .
+ wm geom .t2 +5+5
+ concat "[winfo visual .t2] [winfo depth .t2]"
+} -cleanup {
+ deleteWindows
+} -result $default
+# Make sure reference count is incremented when copying visual (the
+# following test will cause the colormap to be freed prematurely if
+# the reference count isn't incremented).
+test visual-1.4 {Tk_GetVisual, colormap reference count} -constraints {
+ haveOtherVisual
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual $other
+ wm geom .t1 +0+0
+ set result [toplevel .t2 -gorp 80 -visual .t1]
+ update
+ return $result
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown option "-gorp"}
+test visual-1.5 {Tk_GetVisual, default colormap} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual default
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result $default
+
+
+test visual-2.1 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {truecolor 24}
+test visual-2.2 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {truecolor 24}
+test visual-2.3 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {truecolor 24}
+test visual-2.4 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {truecolor 24}
+test visual-2.5 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {truecolor 24}
+test visual-2.6 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {truecolor 24}
+test visual-2.7 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {truecolor 24}
+test visual-2.8 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {truecolor 24}
+test visual-2.9 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {directcolor 24}
+test visual-2.10 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {directcolor 24}
+test visual-2.11 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {directcolor 24}
+test visual-2.12 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {directcolor 24}
+test visual-2.13 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {directcolor 24}
+test visual-2.14 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {directcolor 24}
+test visual-2.15 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {directcolor 24}
+test visual-2.16 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {directcolor 24}
+test visual-2.17 {Tk_GetVisual, different visual types} -constraints {
+ nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual {truecolor 32}
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result {truecolor 32}
+
+
+test visual-3.1 {Tk_GetVisual, parsing visual string} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 \
+ -visual "[winfo visual .][winfo depth .]"
+ wm geometry .t1 +0+0
+ update
+ concat "[winfo visual .t1] [winfo depth .t1]"
+} -cleanup {
+ deleteWindows
+} -result $default
+test visual-3.2 {Tk_GetVisual, parsing visual string} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual goop20
+ wm geometry .t1 +0+0
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown or ambiguous visual name "goop20": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}
+test visual-3.3 {Tk_GetVisual, parsing visual string} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual d
+ wm geometry .t1 +0+0
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown or ambiguous visual name "d": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}
+test visual-3.4 {Tk_GetVisual, parsing visual string} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual static
+ wm geometry .t1 +0+0
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown or ambiguous visual name "static": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}
+test visual-3.5 {Tk_GetVisual, parsing visual string} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual "pseudocolor 48x"
+ wm geometry .t1 +0+0
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "48x"}
+
+
+test visual-4.1 {Tk_GetVisual, numerical visual id} -constraints {
+ haveOtherVisual nonPortable
+} -setup {
+ deleteWindows
+ toplevel .t1 -width 250 -height 100 -visual $other
+ wm geom .t1 +0+0
+ toplevel .t2 -width 200 -height 80 -visual [winfo visual .]
+ wm geom .t2 +5+5
+ toplevel .t3 -width 150 -height 250 -visual [winfo visual .t1]
+ wm geom .t3 +10+10
+} -body {
+ set v1 [list [winfo visualid .t2] [winfo visualid .t3]]
+ set v2 [list [winfo visualid .] [winfo visualid .t1]]
+ expr {$v1 eq $v2 ? "OK" : "[list $v1] ne [list $v2]"}
+} -cleanup {
+ deleteWindows
+} -result OK
+test visual-4.2 {Tk_GetVisual, numerical visual id} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -visual 12xyz
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad X identifier for visual: "12xyz"}
+test visual-4.3 {Tk_GetVisual, numerical visual id} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -visual 1291673
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {couldn't find an appropriate visual}
+
+
+test visual-5.1 {Tk_GetVisual, no matching visual} -constraints {
+ !havePseudocolorVisual
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual "pseudocolor 8"
+ wm geometry .t1 +0+0
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {couldn't find an appropriate visual}
+
+
+test visual-6.1 {Tk_GetVisual, no matching visual} -constraints {
+ havePseudocolorVisual haveMultipleVisuals nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 250 -height 100 -visual "best"
+ wm geometry .t1 +0+0
+ update
+ winfo visual .t1
+} -cleanup {
+ deleteWindows
+} -result {pseudocolor}
+
+
+# These tests are non-portable due to variations in how many colors
+# are already in use on the screen.
+test visual-7.1 {Tk_GetColormap, "new"} -constraints {
+ defaultPseudocolor8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ eatColors .t1
+ toplevel .t2 -width 30 -height 20
+ wm geom .t2 +0+0
+ update
+ colorsFree .t2
+} -cleanup {
+ deleteWindows
+} -result {0}
+test visual-7.2 {Tk_GetColormap, "new"} -constraints {
+ defaultPseudocolor8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ eatColors .t1
+ toplevel .t2 -width 30 -height 20 -colormap new
+ wm geom .t2 +0+0
+ update
+ colorsFree .t2
+} -cleanup {
+ deleteWindows
+} -result {1}
+test visual-7.3 {Tk_GetColormap, copy from other window} -constraints {
+ defaultPseudocolor8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ eatColors .t1
+ toplevel .t3 -width 400 -height 50 -colormap new
+ wm geom .t3 +0+0
+ toplevel .t2 -width 30 -height 20 -colormap .t3
+ wm geom .t2 +0+0
+ update
+ destroy .t3
+ colorsFree .t2
+} -cleanup {
+ deleteWindows
+} -result {1}
+test visual-7.4 {Tk_GetColormap, copy from other window} -constraints {
+ defaultPseudocolor8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ eatColors .t1
+ toplevel .t3 -width 400 -height 50 -colormap new
+ wm geom .t3 +0+0
+ toplevel .t2 -width 30 -height 20 -colormap .
+ wm geom .t2 +0+0
+ update
+ destroy .t3
+ colorsFree .t2
+} -cleanup {
+ deleteWindows
+} -result {0}
+test visual-7.5 {Tk_GetColormap, copy from other window} -constraints {
+ defaultPseudocolor8 nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 400 -height 50 -colormap .choke.lots
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad window path name ".choke.lots"}
+test visual-7.6 {Tk_GetColormap, copy from other window} -constraints {
+ defaultPseudocolor8 haveOtherVisual nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 300 -height 150 -visual $other
+ wm geometry .t1 +0+0
+ toplevel .t2 -width 400 -height 50 -colormap .t1
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't use colormap for .t1: incompatible visuals}
+
+
+test visual-8.1 {Tk_FreeColormap procedure} -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 300 -height 180 -colormap new
+ wm geometry .t1 +0+0
+ foreach i {.t2 .t3 .t4} {
+ toplevel $i -width 250 -height 150 -colormap .t1
+ wm geometry $i +0+0
+ }
+ destroy .t1
+ destroy .t3
+ destroy .t4
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test visual-8.2 {Tk_FreeColormap procedure} -constraints haveOtherVisual -setup {
+ deleteWindows
+} -body {
+ toplevel .t1 -width 300 -height 180 -visual $other
+ wm geometry .t1 +0+0
+ foreach i {.t2 .t3 .t4} {
+ toplevel $i -width 250 -height 150 -visual $other
+ wm geometry $i +0+0
+ }
+ destroy .t2
+ destroy .t3
+ destroy .t4
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+deleteWindows
+rename eatColors {}
+rename colorsFree {}
+
+# cleanup
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/visual_bb.test b/tk8.6/tests/visual_bb.test
new file mode 100644
index 0000000..2b06d05
--- /dev/null
+++ b/tk8.6/tests/visual_bb.test
@@ -0,0 +1,116 @@
+#!/usr/local/bin/wish -f
+#
+# This script displays provides visual tests for many of Tk's features.
+# Each test displays a window with various information in it, along
+# with instructions about how the window should appear. You can look
+# at the window to make sure it appears as expected. Individual tests
+# are kept in separate ".tcl" files in this directory.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+
+
+set auto_path ". $auto_path"
+wm title . "Visual Tests for Tk"
+
+set testNum 1
+
+# Each menu entry invokes a visual test file
+
+proc runTest {file} {
+ global testNum
+
+ test "2.$testNum" "testing $file" {userInteraction} {
+ uplevel \#0 source [file join [testsDirectory] $file]
+ concat ""
+ } {}
+ incr testNum
+}
+
+# The following procedure is invoked to print the contents of a canvas:
+
+proc lpr {c args} {
+ exec lpr <<[eval [list $c postscript] $args]
+}
+
+proc end {} {
+ cleanupTests
+ set ::EndOfVisualTests 1
+}
+
+# ----------------------------------------------------------------------
+
+test 1.1 {running visual tests} -constraints userInteraction -body {
+ #-------------------------------------------------------
+ # The code below create the main window, consisting of a
+ # menu bar and a message explaining the basic operation
+ # of the program.
+ #-------------------------------------------------------
+
+ frame .menu -relief raised -borderwidth 1
+ message .msg -font {Times 18} -relief raised -width 4i \
+ -borderwidth 1 -text "This application provides a collection of visual tests for the Tk toolkit. Each menu entry invokes a test, which displays information on the screen. You can then verify visually that the information is being displayed in the correct way. The tests under the \"Postscript\" menu exercise the Postscript-generation capabilities of canvas widgets."
+
+ pack .menu -side top -fill x
+ pack .msg -side bottom -expand yes -fill both
+
+ #-------------------------------------------------------
+ # The code below creates all the menus, which invoke procedures
+ # to create particular demonstrations of various widgets.
+ #-------------------------------------------------------
+
+ menubutton .menu.file -text "File" -menu .menu.file.m
+ menu .menu.file.m
+ .menu.file.m add command -label "Quit" -command end
+
+ menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m
+ menu .menu.group1.m
+ .menu.group1.m add command -label "Canvas arcs" -command {runTest arc.tcl}
+ .menu.group1.m add command -label "Beveled borders in text widgets" \
+ -command {runTest bevel.tcl}
+ .menu.group1.m add command -label "Colormap management" \
+ -command {runTest cmap.tcl}
+ .menu.group1.m add command -label "Label/button geometry" \
+ -command {runTest butGeom.tcl}
+ .menu.group1.m add command -label "Label/button colors" \
+ -command {runTest butGeom2.tcl}
+
+ menubutton .menu.ps -text "Canvas Postscript" -menu .menu.ps.m
+ menu .menu.ps.m
+ .menu.ps.m add command -label "Rectangles and other graphics" \
+ -command {runTest canvPsGrph.tcl}
+ .menu.ps.m add command -label "Text" \
+ -command {runTest canvPsText.tcl}
+ .menu.ps.m add command -label "Bitmaps" \
+ -command {runTest canvPsBmap.tcl}
+ .menu.ps.m add command -label "Images" \
+ -command {runTest canvPsImg.tcl}
+ .menu.ps.m add command -label "Arcs" \
+ -command {runTest canvPsArc.tcl}
+
+ pack .menu.file .menu.group1 .menu.ps -side left -padx 1m
+
+ # Set up for keyboard-based menu traversal
+
+ bind . <Any-FocusIn> {
+ if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} {
+ focus .menu
+ }
+ }
+ tk_menuBar .menu .menu.file .menu.group1 .menu.ps
+
+ # Set up a class binding to allow objects to be deleted from a canvas
+ # by clicking with mouse button 1:
+
+ bind Canvas <1> {%W delete [%W find closest %x %y]}
+
+ concat ""
+} -result {}
+
+if {![testConstraint userInteraction]} {
+ cleanupTests
+} else {
+ vwait EndOfVisualTests
+}
diff --git a/tk8.6/tests/winButton.test b/tk8.6/tests/winButton.test
new file mode 100644
index 0000000..88b4345
--- /dev/null
+++ b/tk8.6/tests/winButton.test
@@ -0,0 +1,203 @@
+# This file is a Tcl script to test the Windows specific behavior of
+# labels, buttons, checkbuttons, and radiobuttons in Tk (i.e., all the
+# widgets defined in tkWinButton.c). It is organized in the standard
+# fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+imageInit
+
+proc bogusTrace args {
+ error "trace aborted"
+}
+option clear
+
+# ----------------------------------------------------------------------
+
+test winbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints {
+ testImageType win nonPortable
+} -setup {
+ # nonPortable because of [3e3e25f483]: on Win7 first started with a high DPI screen
+ # the smallest size (i.e. 8) is not available for "MS Sans Serif" font
+ deleteWindows
+} -body {
+ image create test image1
+ image1 changed 0 0 0 0 60 40
+ label .b1 -image image1 -bd 4 -padx 0 -pady 2
+ button .b2 -image image1 -bd 4 -padx 0 -pady 2
+ checkbutton .b3 -image image1 -bd 4 -padx 1 -pady 1 \
+ -font {{MS Sans Serif} 8}
+ radiobutton .b4 -image image1 -bd 4 -padx 2 -pady 0 \
+ -font {{MS Sans Serif} 8}
+ pack .b1 .b2 .b3 .b4
+ update
+ # with patch 463234 with native L&F enabled, this returns:
+ # {68 48 70 50 88 50 88 50}
+ list [winfo reqwidth .b1] [winfo reqheight .b1] \
+ [winfo reqwidth .b2] [winfo reqheight .b2] \
+ [winfo reqwidth .b3] [winfo reqheight .b3] \
+ [winfo reqwidth .b4] [winfo reqheight .b4]
+} -cleanup {
+ deleteWindows
+ image delete image1
+} -result {68 48 70 50 90 52 90 52}
+
+test winbutton-1.2 {TkpComputeButtonGeometry procedure} -constraints {
+ win nonPortable
+} -setup {
+ # nonPortable because of [3e3e25f483]: on Win7 first started with a high DPI screen
+ # the smallest size (i.e. 8) is not available for "MS Sans Serif" font
+ deleteWindows
+} -body {
+ label .b1 -bitmap question -bd 3 -padx 0 -pady 2
+ button .b2 -bitmap question -bd 3 -padx 0 -pady 2
+ checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1 \
+ -font {{MS Sans Serif} 8}
+ radiobutton .b4 -bitmap question -bd 3 -padx 2 -pady 0 \
+ -font {{MS Sans Serif} 8}
+ pack .b1 .b2 .b3 .b4
+ update
+ # with patch 463234 with native L&F enabled, this returns:
+ # {23 33 25 35 43 35 43 35}
+ list [winfo reqwidth .b1] [winfo reqheight .b1] \
+ [winfo reqwidth .b2] [winfo reqheight .b2] \
+ [winfo reqwidth .b3] [winfo reqheight .b3] \
+ [winfo reqwidth .b4] [winfo reqheight .b4]
+} -cleanup {
+ deleteWindows
+} -result {23 33 25 35 45 37 45 37}
+
+test winbutton-1.3 {TkpComputeButtonGeometry procedure} -constraints win -setup {
+ deleteWindows
+} -body {
+ label .b1 -bitmap question -bd 3 -highlightthickness 4
+ button .b2 -bitmap question -bd 3 -highlightthickness 0
+ checkbutton .b3 -bitmap question -bd 3 -highlightthickness 1 \
+ -indicatoron 0
+ radiobutton .b4 -bitmap question -bd 3 -indicatoron false
+ pack .b1 .b2 .b3 .b4
+ update
+ # with patch 463234 with native L&F enabled, this returns:
+ # {31 41 23 33 25 35 25 35}
+ list [winfo reqwidth .b1] [winfo reqheight .b1] \
+ [winfo reqwidth .b2] [winfo reqheight .b2] \
+ [winfo reqwidth .b3] [winfo reqheight .b3] \
+ [winfo reqwidth .b4] [winfo reqheight .b4]
+} -cleanup {
+ deleteWindows
+} -result {31 41 23 33 27 37 27 37}
+
+test winbutton-1.4 {TkpComputeButtonGeometry procedure} -constraints {
+ win nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8}
+ button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8}
+ checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -font {{MS Sans Serif} 8}
+ radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -font {{MS Sans Serif} 8}
+ pack .b1 .b2 .b3 .b4
+ update
+ list [winfo reqwidth .b1] [winfo reqheight .b1] \
+ [winfo reqwidth .b2] [winfo reqheight .b2] \
+ [winfo reqwidth .b3] [winfo reqheight .b3] \
+ [winfo reqwidth .b4] [winfo reqheight .b4]
+} -cleanup {
+ deleteWindows
+} -result {58 24 67 33 88 30 90 28}
+
+test winbutton-1.5 {TkpComputeButtonGeometry procedure} -constraints {
+ win nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ label .l1 -wraplength 1.5i -padx 0 -pady 0 \
+ -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)."
+ pack .l1
+ update
+ list [winfo reqwidth .l1] [winfo reqheight .l1]
+} -cleanup {
+ deleteWindows
+} -result {178 84}
+
+test winbutton-1.6 {TkpComputeButtonGeometry procedure} -constraints {
+ win nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ label .l1 -padx 0 -pady 0 \
+ -text "This is a long string without wrapping.\n\nIt also has a blank line (above)."
+ pack .l1
+ update
+ list [winfo reqwidth .l1] [winfo reqheight .l1]
+} -cleanup {
+ deleteWindows
+} -result {222 52}
+
+test winbutton-1.7 {TkpComputeButtonGeometry procedure} -constraints {
+ win nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10
+ button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5
+ checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -width 20 -height 2
+ radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -width 4
+ pack .b1 .b2 .b3 .b4
+ update
+ list [winfo reqwidth .b1] [winfo reqheight .b1] \
+ [winfo reqwidth .b2] [winfo reqheight .b2] \
+ [winfo reqwidth .b3] [winfo reqheight .b3] \
+ [winfo reqwidth .b4] [winfo reqheight .b4]
+} -cleanup {
+ deleteWindows
+} -result {74 24 67 97 174 46 64 28}
+
+test winbutton-1.8 {TkpComputeButtonGeometry procedure} -constraints {
+ win nonPortable
+} -setup {
+ deleteWindows
+} -body {
+ label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \
+ -highlightthickness 4
+ button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 \
+ -highlightthickness 0
+ checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 \
+ -highlightthickness 1 -indicatoron no
+ radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -indicatoron 0
+ pack .b1 .b2 .b3 .b4
+ update
+ list [winfo reqwidth .b1] [winfo reqheight .b1] \
+ [winfo reqwidth .b2] [winfo reqheight .b2] \
+ [winfo reqwidth .b3] [winfo reqheight .b3] \
+ [winfo reqwidth .b4] [winfo reqheight .b4]
+} -cleanup {
+ deleteWindows
+} -result {66 32 65 31 69 31 71 29}
+
+test winbutton-1.9 {TkpComputeButtonGeometry procedure} -constraints win -setup {
+ deleteWindows
+} -body {
+ button .b2 -bitmap question -default normal
+ list [winfo reqwidth .b2] [winfo reqheight .b2]
+} -cleanup {
+ deleteWindows
+} -result {23 33}
+
+# cleanup
+imageFinish
+deleteWindows
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
+
diff --git a/tk8.6/tests/winClipboard.test b/tk8.6/tests/winClipboard.test
new file mode 100644
index 0000000..2a7ad73
--- /dev/null
+++ b/tk8.6/tests/winClipboard.test
@@ -0,0 +1,122 @@
+# This file is a Tcl script to test out Tk's Windows specific
+# clipboard code. It is organized in the standard fashion for Tcl
+# tests.
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1997 by Sun Microsystems, Inc.
+# Copyright (c) 1998-2000 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+# Note that these tests may fail if another application is grabbing the
+# clipboard (e.g. an X server)
+
+test winClipboard-1.1 {TkSelGetSelection} -constraints win -setup {
+ clipboard clear
+} -body {
+ selection get -selection CLIPBOARD
+} -cleanup {
+ clipboard clear
+} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined}
+
+test winClipboard-1.2 {TkSelGetSelection} -constraints {
+ win testclipboard
+} -setup {
+ clipboard clear
+} -body {
+ clipboard append {}
+ list [selection get -selection CLIPBOARD] [testclipboard]
+} -cleanup {
+ clipboard clear
+} -result {{} {}}
+
+test winClipboard-1.3 {TkSelGetSelection & TkWinClipboardRender} -constraints {
+ win testclipboard
+} -setup {
+ clipboard clear
+} -body {
+ clipboard append abcd
+ update
+ list [selection get -selection CLIPBOARD] [testclipboard]
+} -cleanup {
+ clipboard clear
+} -result {abcd abcd}
+
+test winClipboard-1.4 {TkSelGetSelection & TkWinClipboardRender} -constraints {
+ win testclipboard
+} -setup {
+ clipboard clear
+} -body {
+ set map [list "\r" "\\r" "\n" "\\n"]
+ clipboard append "line 1\nline 2"
+ list [string map $map [selection get -selection CLIPBOARD]]\
+ [string map $map [testclipboard]]
+} -cleanup {
+ clipboard clear
+} -result [list "line 1\\nline 2" "line 1\\nline 2"]
+
+test winClipboard-1.5 {TkSelGetSelection & TkWinClipboardRender} -constraints {
+ win testclipboard
+} -setup {
+ clipboard clear
+} -body {
+ set map [list "\r" "\\r" "\n" "\\n"]
+ clipboard append "line 1\u00c7\nline 2"
+ list [string map $map [selection get -selection CLIPBOARD]]\
+ [string map $map [testclipboard]]
+} -cleanup {
+ clipboard clear
+} -result [list "line 1\u00c7\\nline 2" "line 1\u00c7\\nline 2"]
+
+test winClipboard-1.6 {TkSelGetSelection & TkWinClipboardRender} -constraints {
+ win testclipboard
+} -setup {
+ clipboard clear
+} -body {
+ clipboard append "\u043f\u0440\u0438\u0432\u0435\u0442 \u043c\u0438\u0444"
+ list [selection get -selection CLIPBOARD] [testclipboard]
+} -cleanup {
+ clipboard clear
+} -result [list "\u043f\u0440\u0438\u0432\u0435\u0442 \u043c\u0438\u0444"\
+ "\u043f\u0440\u0438\u0432\u0435\u0442 \u043c\u0438\u0444"]
+
+test winClipboard-2.1 {TkSelUpdateClipboard reentrancy problem} -constraints {
+ win testclipboard
+} -setup {
+ clipboard clear
+} -body {
+ clipboard append -type OUR_ACTION "action data"
+ clipboard append "string data"
+ update
+ list [selection get -selection CLIPBOARD -type OUR_ACTION] [testclipboard]
+} -cleanup {
+ clipboard clear
+} -result {{action data} {string data}}
+
+test winClipboard-2.2 {TkSelUpdateClipboard reentrancy problem} -constraints {
+ win testclipboard
+} -setup {
+ clipboard clear
+} -body {
+ clipboard append -type OUR_ACTION "new data"
+ clipboard append "more data in string"
+ update
+ list [testclipboard] [selection get -selection CLIPBOARD -type OUR_ACTION]
+} -cleanup {
+ clipboard clear
+} -result {{more data in string} {new data}}
+
+# cleanup
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/winDialog.test b/tk8.6/tests/winDialog.test
new file mode 100755
index 0000000..c8c36bf
--- /dev/null
+++ b/tk8.6/tests/winDialog.test
@@ -0,0 +1,1057 @@
+# -*- tcl -*-
+# This file is a Tcl script to test the Windows specific behavior of
+# the common dialog boxes. It is organized in the standard
+# fashion for Tcl tests.
+#
+# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998-1999 ActiveState Corporation.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+
+if {[testConstraint testwinevent]} {
+ catch {testwinevent debug 1}
+}
+
+# Locale identifier LANG_ENGLISH is 0x09
+testConstraint english [expr {
+ [llength [info commands testwinlocale]]
+ && (([testwinlocale] & 0xff) == 9)
+}]
+
+proc vista? {{prevista 0} {postvista 1}} {
+ lassign [split $::tcl_platform(osVersion) .] major
+ return [expr {$major >= 6 ? $postvista : $prevista}]
+}
+
+# What directory to use in initialdir tests. Old code used to use
+# c:/. However, on Vista/later that is a protected directory if you
+# are not running privileged. Moreover, not everyone has a drive c:
+# but not having a TEMP would break a lot Windows programs
+proc initialdir {} {
+ # file join to return in Tcl canonical format (/ separator, not \)
+ #return [file join $::env(TEMP)]
+ return [tcltest::temporaryDirectory]
+}
+
+
+proc start {arg} {
+ set ::tk_dialog 0
+ set ::iter_after 0
+ set ::dialogclass "#32770"
+
+ after 1 $arg
+}
+
+proc then {cmd} {
+ set ::command $cmd
+ set ::dialogresult {}
+ set ::testfont {}
+
+ # Do not make the delay too short. The newer Vista dialogs take
+ # time to come up. Even if the testforwindow returns true, the
+ # controls are not ready to accept messages
+ after 500 afterbody
+ vwait ::dialogresult
+ return $::dialogresult
+}
+
+proc afterbody {} {
+ # On Vista and later, using the new file dialogs we have to find
+ # the window using its title as tk_dialog will not be set at the C level
+ if {[vista?]} {
+ if {[catch {testfindwindow "" $::dialogclass} ::tk_dialog]} {
+ if {[incr ::iter_after] > 30} {
+ set ::dialogresult ">30 iterations waiting on tk_dialog"
+ return
+ }
+ after 150 {afterbody}
+ return
+ }
+ } else {
+ if {$::tk_dialog == 0} {
+ if {[incr ::iter_after] > 30} {
+ set ::dialogresult ">30 iterations waiting on tk_dialog"
+ return
+ }
+ after 150 {afterbody}
+ return
+ }
+ }
+ uplevel #0 {set dialogresult [eval $command]}
+}
+
+proc Click {button} {
+ switch -exact -- $button {
+ ok { set button 1 }
+ cancel { set button 2 }
+ }
+ testwinevent $::tk_dialog $button WM_LBUTTONDOWN 1 0x000a000b
+ testwinevent $::tk_dialog $button WM_LBUTTONUP 0 0x000a000b
+}
+
+proc GetText {id} {
+ switch -exact -- $id {
+ ok { set id 1 }
+ cancel { set id 2 }
+ }
+ return [testwinevent $::tk_dialog $id WM_GETTEXT]
+}
+
+proc SetText {id text} {
+ return [testwinevent $::tk_dialog $id WM_SETTEXT $text]
+}
+
+proc ApplyFont {font} {
+ set ::testfont $font
+}
+
+# ----------------------------------------------------------------------
+
+test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints {
+ testwinevent
+} -body {
+ start {tk_chooseColor}
+ then {
+ Click cancel
+ }
+} -result {0}
+test winDialog-1.2 {Tk_ChooseColorObjCmd} -constraints {
+ testwinevent
+} -body {
+ start {set clr [tk_chooseColor -initialcolor "#ff9933"]}
+ then {
+ set x [Click cancel]
+ }
+ list $x $clr
+} -result {0 {}}
+test winDialog-1.3 {Tk_ChooseColorObjCmd} -constraints {
+ testwinevent
+} -body {
+ start {set clr [tk_chooseColor -initialcolor "#ff9933"]}
+ then {
+ set x [Click ok]
+ }
+ list $x $clr
+} -result [list 0 "#ff9933"]
+test winDialog-1.4 {Tk_ChooseColorObjCmd: -title} -constraints {
+ testwinevent
+} -setup {
+ catch {unset a x}
+} -body {
+ set x {}
+ start {set clr [tk_chooseColor -initialcolor "#ff9933" -title "Hello"]}
+ then {
+ if {[catch {
+ array set a [testgetwindowinfo $::tk_dialog]
+ if {[info exists a(text)]} {lappend x $a(text)}
+ } err]} { lappend x $err }
+ lappend x [Click ok]
+ }
+ lappend x $clr
+} -result [list Hello 0 "#ff9933"]
+test winDialog-1.5 {Tk_ChooseColorObjCmd: -title} -constraints {
+ testwinevent
+} -setup {
+ catch {unset a x}
+} -body {
+ set x {}
+ start {
+ set clr [tk_chooseColor -initialcolor "#ff9933" \
+ -title "\u041f\u0440\u0438\u0432\u0435\u0442"]
+ }
+ then {
+ if {[catch {
+ array set a [testgetwindowinfo $::tk_dialog]
+ if {[info exists a(text)]} {lappend x $a(text)}
+ } err]} { lappend x $err }
+ lappend x [Click ok]
+ }
+ lappend x $clr
+} -result [list "\u041f\u0440\u0438\u0432\u0435\u0442" 0 "#ff9933"]
+test winDialog-1.6 {Tk_ChooseColorObjCmd: -parent} -constraints {
+ testwinevent
+} -setup {
+ catch {unset a x}
+} -body {
+ start {set clr [tk_chooseColor -initialcolor "#ff9933" -parent .]}
+ set x {}
+ then {
+ if {[catch {
+ array set a [testgetwindowinfo $::tk_dialog]
+ if {[info exists a(parent)]} {
+ append x [expr {$a(parent) == [wm frame .]}]
+ }
+ } err]} {lappend x $err}
+ Click ok
+ }
+ list $x $clr
+} -result [list 1 "#ff9933"]
+test winDialog-1.7 {Tk_ChooseColorObjCmd: -parent} -constraints {
+ testwinevent
+} -body {
+ tk_chooseColor -initialcolor "#ff9933" -parent .xyzzy12
+} -returnCodes error -match glob -result {bad window path name*}
+
+
+test winDialog-2.1 {ColorDlgHookProc} -constraints {emptyTest nt} -body {}
+
+test winDialog-3.1 {Tk_GetOpenFileObjCmd} -constraints {
+ nt testwinevent english
+} -body {
+ start {tk_getOpenFile}
+ then {
+ set x [GetText cancel]
+ Click cancel
+ }
+ return $x
+} -result {Cancel}
+
+
+test winDialog-4.1 {Tk_GetSaveFileObjCmd} -constraints {
+ nt testwinevent english
+} -body {
+ start {tk_getSaveFile}
+ then {
+ set x [GetText cancel]
+ Click cancel
+ }
+ return $x
+} -result {Cancel}
+
+test winDialog-5.1 {GetFileName: no arguments} -constraints {
+ nt testwinevent
+} -body {
+ start {tk_getOpenFile -title Open}
+ then {
+ Click cancel
+ }
+} -result {0}
+test winDialog-5.2 {GetFileName: one argument} -constraints {
+ nt
+} -body {
+ tk_getOpenFile -foo
+} -returnCodes error -result {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
+test winDialog-5.3 {GetFileName: many arguments} -constraints {
+ nt testwinevent
+} -body {
+ start {tk_getOpenFile -initialdir [initialdir] -parent . -title test -initialfile foo}
+ then {
+ Click cancel
+ }
+} -result {0}
+test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints {
+ nt
+} -body {
+ tk_getOpenFile -foo bar -abc
+} -returnCodes error -result {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
+test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints {
+ nt testwinevent
+} -body {
+ start {set x [tk_getOpenFile -title bar]}
+ set y [then {
+ Click cancel
+ }]
+ # Note this also tests fix for
+ # http://core.tcl.tk/tk/tktview/4a0451f5291b3c9168cc560747dae9264e1d2ef6
+ # $x is expected to be empty
+ append x $y
+} -result {0}
+test winDialog-5.6 {GetFileName: valid option, but missing value} -constraints {
+ nt
+} -body {
+ tk_getOpenFile -initialdir bar -title
+} -returnCodes error -result {value for "-title" missing}
+
+test winDialog-5.7 {GetFileName: extension begins with .} -constraints {
+ nt testwinevent
+} -body {
+ start {set x [tk_getSaveFile -defaultextension .foo -title Save]}
+ set msg {}
+ then {
+ if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} {
+ Click cancel
+ } else {
+ Click ok
+ }
+ }
+ set x "[file tail $x]$msg"
+} -cleanup {
+ unset msg
+} -result bar.foo
+
+test winDialog-5.7.1 {GetFileName: extension {} } -constraints {
+ nt testwinevent
+} -body {
+ start {set x [tk_getSaveFile -defaultextension {} -title Save]}
+ set msg {}
+ then {
+ if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} {
+ Click cancel
+ } else {
+ Click ok
+ }
+ }
+ set x "[file tail $x]$msg"
+} -cleanup {
+ unset msg
+} -result bar
+
+test winDialog-5.7.2 {GetFileName: extension {} Bug 47af31bd3ac6fbbb33cde1a5bab1e756ff2a6e00 } -constraints {
+ nt testwinevent
+} -body {
+ start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]}
+ set msg {}
+ then {
+ if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} {
+ Click cancel
+ } else {
+ Click ok
+ }
+ }
+ set x "[file tail $x]$msg"
+} -cleanup {
+ unset msg
+} -result bar
+
+test winDialog-5.7.3 {GetFileName: extension {} Bug 47af31bd3ac6fbbb33cde1a5bab1e756ff2a6e00 } -constraints {
+ nt testwinevent
+} -body {
+ start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]}
+ set msg {}
+ then {
+ if {[catch {SetText [vista? 0x47C 0x3e9] bar.c} msg]} {
+ Click cancel
+ } else {
+ Click ok
+ }
+ }
+ set x "[file tail $x]$msg"
+} -cleanup {
+ unset msg
+} -result bar.c
+
+test winDialog-5.7.4 {GetFileName: extension {} } -constraints {
+ nt testwinevent
+} -body {
+ # Although the docs do not explicitly mention, -filetypes seems to
+ # override -defaultextension
+ start {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {foo} -title Save]}
+ set msg {}
+ then {
+ if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} {
+ Click cancel
+ } else {
+ Click ok
+ }
+ }
+ set x "[file tail $x]$msg"
+} -cleanup {
+ unset msg
+} -result bar.c
+
+test winDialog-5.7.5 {GetFileName: extension {} } -constraints {
+ nt testwinevent
+} -body {
+ # Although the docs do not explicitly mention, -filetypes seems to
+ # override -defaultextension
+ start {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {} -title Save]}
+ set msg {}
+ then {
+ if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} {
+ Click cancel
+ } else {
+ Click ok
+ }
+ }
+ set x "[file tail $x]$msg"
+} -cleanup {
+ unset msg
+} -result bar.c
+
+
+test winDialog-5.7.6 {GetFileName: All/extension } -constraints {
+ nt testwinevent
+} -body {
+ # In 8.6.4 this combination resulted in bar.ext.ext which is bad
+ start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {ext} -title Save]}
+ set msg {}
+ then {
+ if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} {
+ Click cancel
+ } else {
+ Click ok
+ }
+ }
+ set x "[file tail $x]$msg"
+} -cleanup {
+ unset msg
+} -result bar.ext
+
+test winDialog-5.7.7 {tk_getOpenFile: -defaultextension} -constraints {
+ nt testwinevent
+} -body {
+ unset -nocomplain x
+ tcltest::makeFile "" "5 7 7.ext" [initialdir]
+ start {set x [tk_getOpenFile \
+ -defaultextension ext \
+ -initialdir [file nativename [initialdir]] \
+ -initialfile "5 7 7" -title Foo]}
+ then {
+ Click ok
+ }
+ return $x
+} -result [file join [initialdir] "5 7 7.ext"]
+
+test winDialog-5.7.8 {tk_getOpenFile: -defaultextension} -constraints {
+ nt testwinevent
+} -body {
+ unset -nocomplain x
+ tcltest::makeFile "" "5 7 8.ext" [initialdir]
+ start {set x [tk_getOpenFile \
+ -defaultextension ext \
+ -initialdir [file nativename [initialdir]] \
+ -initialfile "5 7 8.ext" -title Foo]}
+ then {
+ Click ok
+ }
+ return $x
+} -result [file join [initialdir] "5 7 8.ext"]
+
+test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints {
+ nt testwinevent
+} -body {
+ start {set x [tk_getSaveFile -defaultextension foo -title Save]}
+ set msg {}
+ then {
+ if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} {
+ Click cancel
+ } else {
+ Click ok
+ }
+ }
+ set x "[file tail $x]$msg"
+} -cleanup {
+ unset msg
+} -result bar.foo
+test winDialog-5.9 {GetFileName: file types} -constraints {
+ nt testwinevent
+} -body {
+ # case FILE_TYPES:
+
+ start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo}
+ # XXX - currently disabled for vista style dialogs because the file
+ # types control has no control ID and we don't have a mechanism to
+ # locate it.
+ if {[vista?]} {
+ then {
+ Click cancel
+ }
+ return 1
+ } else {
+ then {
+ set x [GetText 0x470]
+ Click cancel
+ }
+ return [string equal $x {foo files (*.foo)}]
+ }
+} -result 1
+test winDialog-5.10 {GetFileName: file types: MakeFilter() fails} -constraints {
+ nt
+} -body {
+# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK)
+
+ tk_getSaveFile -filetypes {{"foo" .foo FOO}}
+} -returnCodes error -result {bad Macintosh file type "FOO"}
+test winDialog-5.11 {GetFileName: initial directory} -constraints {
+ nt testwinevent
+} -body {
+# case FILE_INITDIR:
+ unset -nocomplain x
+ start {set x [tk_getSaveFile \
+ -initialdir [initialdir] \
+ -initialfile "12x 455" -title Foo]}
+ then {
+ Click ok
+ }
+ return $x
+} -result [file join [initialdir] "12x 455"]
+
+test winDialog-5.12 {GetFileName: initial directory: Tcl_TranslateFilename()} -constraints {
+ nt
+} -body {
+# if (Tcl_TranslateFileName(interp, string, &ds) == NULL)
+
+ tk_getOpenFile -initialdir ~12x/455
+} -returnCodes error -result {user "12x" doesn't exist}
+
+test winDialog-5.12.1 {tk_getSaveFile: initial directory: ~} -constraints {
+ nt testwinevent
+} -body {
+ unset -nocomplain x
+ start {set x [tk_getSaveFile \
+ -initialdir ~ \
+ -initialfile "5 12 1" -title Foo]}
+ then {
+ Click ok
+ }
+ return $x
+} -result [file normalize [file join ~ "5 12 1"]]
+
+test winDialog-5.12.2 {tk_getSaveFile: initial directory: ~user} -constraints {
+ nt testwinevent
+} -body {
+
+ # Note: this test will fail on Tcl versions 8.6.4 and earlier due
+ # to a bug in file normalize for names of the form ~xxx that
+ # returns the wrong dir on Windows. In particular (in Win8 at
+ # least) it returned /users/Default instead of /users/USERNAME...
+
+ unset -nocomplain x
+ start {set x [tk_getSaveFile \
+ -initialdir ~$::tcl_platform(user) \
+ -initialfile "5 12 2" -title Foo]}
+ then {
+ Click ok
+ }
+ return $x
+} -result [file normalize [file join ~$::tcl_platform(user) "5 12 2"]]
+
+test winDialog-5.12.3 {tk_getSaveFile: initial directory: .} -constraints {
+ nt testwinevent
+} -body {
+ # Windows remembers dirs from previous selections so use
+ # a subdir for this test, not [initialdir] itself
+ set newdir [tcltest::makeDirectory "5 12 3"]
+ set cur [pwd]
+ try {
+ cd $newdir
+ unset -nocomplain x
+ start {set x [tk_getSaveFile \
+ -initialdir . \
+ -initialfile "testfile" -title Foo]}
+ then {
+ Click ok
+ }
+ } finally {
+ cd $cur
+ }
+ string equal $x [file join $newdir testfile]
+} -result 1
+
+test winDialog-5.12.4 {tk_getSaveFile: initial directory: unicode} -constraints {
+ nt testwinevent
+} -body {
+ set dir [tcltest::makeDirectory "\u0167\u00e9\u015d\u0167"]
+ unset -nocomplain x
+ start {set x [tk_getSaveFile \
+ -initialdir $dir \
+ -initialfile "testfile" -title Foo]}
+ then {
+ Click ok
+ }
+ string equal $x [file join $dir testfile]
+} -result 1
+
+test winDialog-5.12.5 {tk_getSaveFile: initial directory: nativename} -constraints {
+ nt testwinevent
+} -body {
+ unset -nocomplain x
+ start {set x [tk_getSaveFile \
+ -initialdir [file nativename [initialdir]] \
+ -initialfile "5 12 5" -title Foo]}
+ then {
+ Click ok
+ }
+ return $x
+} -result [file join [initialdir] "5 12 5"]
+
+test winDialog-5.12.6 {tk_getSaveFile: initial directory: relative} -constraints {
+ nt testwinevent
+} -body {
+ # Windows remembers dirs from previous selections so use
+ # a subdir for this test, not [initialdir] itself
+ set dir [tcltest::makeDirectory "5 12 6"]
+ set cur [pwd]
+ try {
+ cd [file dirname $dir]
+ unset -nocomplain x
+ start {set x [tk_getSaveFile \
+ -initialdir "5 12 6" \
+ -initialfile "testfile" -title Foo]}
+ then {
+ Click ok
+ }
+ } finally {
+ cd $cur
+ }
+ string equal $x [file join $dir testfile]
+} -result 1
+
+test winDialog-5.12.7 {tk_getOpenFile: initial directory: ~} -constraints {
+ nt testwinevent
+} -body {
+ set fn [file tail [lindex [glob -types f ~/*] 0]]
+ unset -nocomplain x
+ start {set x [tk_getOpenFile \
+ -initialdir ~ \
+ -initialfile $fn -title Foo]}
+ then {
+ Click ok
+ }
+ string equal $x [file normalize [file join ~ $fn]]
+} -result 1
+
+test winDialog-5.12.8 {tk_getOpenFile: initial directory: .} -constraints {
+ nt testwinevent
+} -body {
+ # Windows remembers dirs from previous selections so use
+ # a subdir for this test, not [initialdir] itself
+ set newdir [tcltest::makeDirectory "5 12 8"]
+ set path [tcltest::makeFile "" "testfile" $newdir]
+ set cur [pwd]
+ try {
+ cd $newdir
+ unset -nocomplain x
+ start {set x [tk_getOpenFile \
+ -initialdir . \
+ -initialfile "testfile" -title Foo]}
+ then {
+ Click ok
+ }
+ } finally {
+ cd $cur
+ }
+ string equal $x $path
+} -result 1
+
+test winDialog-5.12.9 {tk_getOpenFile: initial directory: unicode} -constraints {
+ nt testwinevent
+} -body {
+ set dir [tcltest::makeDirectory "\u0167\u00e9\u015d\u0167"]
+ set path [tcltest::makeFile "" testfile $dir]
+ unset -nocomplain x
+ start {set x [tk_getOpenFile \
+ -initialdir $dir \
+ -initialfile "testfile" -title Foo]}
+ then {
+ Click ok
+ }
+ string equal $x $path
+} -result 1
+
+test winDialog-5.12.10 {tk_getOpenFile: initial directory: nativename} -constraints {
+ nt testwinevent
+} -body {
+ unset -nocomplain x
+ tcltest::makeFile "" "5 12 10" [initialdir]
+ start {set x [tk_getOpenFile \
+ -initialdir [file nativename [initialdir]] \
+ -initialfile "5 12 10" -title Foo]}
+ then {
+ Click ok
+ }
+ return $x
+} -result [file join [initialdir] "5 12 10"]
+
+test winDialog-5.12.11 {tk_getOpenFile: initial directory: relative} -constraints {
+ nt testwinevent
+} -body {
+ # Windows remembers dirs from previous selections so use
+ # a subdir for this test, not [initialdir] itself
+ set dir [tcltest::makeDirectory "5 12 11"]
+ set path [tcltest::makeFile "" testfile $dir]
+ set cur [pwd]
+ try {
+ cd [file dirname $dir]
+ unset -nocomplain x
+ start {set x [tk_getOpenFile \
+ -initialdir [file tail $dir] \
+ -initialfile "testfile" -title Foo]}
+ then {
+ Click ok
+ }
+ } finally {
+ cd $cur
+ }
+ string equal $x $path
+} -result 1
+
+test winDialog-5.13 {GetFileName: initial file} -constraints {
+ nt testwinevent
+} -body {
+# case FILE_INITFILE:
+
+ start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]}
+ then {
+ Click ok
+ }
+ file tail $x
+} -result "12x 456"
+test winDialog-5.14 {GetFileName: initial file: Tcl_TranslateFileName()} -constraints {
+ nt
+} -body {
+# if (Tcl_TranslateFileName(interp, string, &ds) == NULL)
+ tk_getOpenFile -initialfile ~12x/455
+} -returnCodes error -result {user "12x" doesn't exist}
+if {![vista?]} {
+ # XXX - disabled for Vista because the new dialogs allow long file
+ # names to be specified but force the user to change it.
+ test winDialog-5.15 {GetFileName: initial file: long name} -constraints {
+ nt testwinevent
+ } -body {
+ start {
+ set dialogresult [catch {
+ tk_getSaveFile -initialfile [string repeat a 1024] -title Long
+ } x]
+ }
+ then {
+ Click ok
+ }
+ list $dialogresult [string match "invalid filename *" $x]
+ } -result {1 1}
+}
+test winDialog-5.16 {GetFileName: parent} -constraints {
+ nt
+} -body {
+# case FILE_PARENT:
+
+ toplevel .t
+ set x 0
+ start {tk_getOpenFile -parent .t -title Parent; set x 1}
+ then {
+ destroy .t
+ }
+ return $x
+} -result {1}
+test winDialog-5.17 {GetFileName: title} -constraints {
+ nt testwinevent
+} -body {
+# case FILE_TITLE:
+
+ start {tk_getOpenFile -title Narf}
+ then {
+ Click cancel
+ }
+} -result {0}
+if {[vista?]} {
+ # In the newer file dialogs, the file type widget does not even exist
+ # if no file types specified
+ test winDialog-5.18 {GetFileName: no filter specified} -constraints {
+ nt testwinevent
+ } -body {
+ # if (ofn.lpstrFilter == NULL)
+ start {tk_getOpenFile -title Filter}
+ then {
+ catch {set x [GetText 0x470]} y
+ Click cancel
+ }
+ return $y
+ } -result {Could not find control with id 1136}
+} else {
+ test winDialog-5.18 {GetFileName: no filter specified} -constraints {
+ nt testwinevent
+ } -body {
+ # if (ofn.lpstrFilter == NULL)
+
+ start {tk_getOpenFile -title Filter}
+ then {
+ set x [GetText 0x470]
+ Click cancel
+ }
+ return $x
+ } -result {All Files (*.*)}
+}
+test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints {
+ nt
+} -setup {
+ destroy .t
+} -body {
+# if (Tk_WindowId(parent) == None)
+
+ toplevel .t
+ start {tk_getOpenFile -parent .t -title Open}
+ then {
+ destroy .t
+ }
+} -result {}
+test winDialog-5.20 {GetFileName: parent HWND already exists} -constraints {
+ nt
+} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ update
+ start {tk_getOpenFile -parent .t -title Open}
+ then {
+ destroy .t
+ }
+} -result {}
+test winDialog-5.21 {GetFileName: call GetOpenFileName} -constraints {
+ nt testwinevent english
+} -body {
+# winCode = GetOpenFileName(&ofn);
+
+ start {tk_getOpenFile -title Open}
+ then {
+ set x [GetText ok]
+ Click cancel
+ }
+ return $x
+} -result {&Open}
+test winDialog-5.22 {GetFileName: call GetSaveFileName} -constraints {
+ nt testwinevent english
+} -body {
+# winCode = GetSaveFileName(&ofn);
+
+ start {tk_getSaveFile -title Save}
+ then {
+ set x [GetText ok]
+ Click cancel
+ }
+ return $x
+} -result {&Save}
+test winDialog-5.23 {GetFileName: convert \ to /} -constraints {
+ nt testwinevent
+} -body {
+ set msg {}
+ start {set x [tk_getSaveFile -title Back]}
+ then {
+ if {[catch {SetText [vista? 0x47C 0x3e9] [file nativename \
+ [file join [initialdir] "12x 457"]]} msg]} {
+ Click cancel
+ } else {
+ Click ok
+ }
+ }
+ return $x$msg
+} -cleanup {
+ unset msg
+} -result [file join [initialdir] "12x 457"]
+test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraints {
+ nt
+} -body {
+ # MacOS type that is correct, but has embedded nulls.
+
+ start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0}}}}]}
+ then {
+ Click cancel
+ }
+ return $x
+} -result {0}
+test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} -constraints {
+ nt
+} -body {
+ # MacOS type that is correct, but has embedded high-bit chars.
+
+ start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\u2022\u2022\u2022\u2022}}}}]}
+ then {
+ Click cancel
+ }
+ return $x
+} -result {0}
+
+
+test winDialog-6.1 {MakeFilter} -constraints {emptyTest nt} -body {}
+
+
+test winDialog-7.1 {Tk_MessageBoxObjCmd} -constraints {emptyTest nt} -body {}
+
+
+test winDialog-8.1 {OFNHookProc} -constraints {emptyTest nt} -body {}
+
+
+## The Tk_ChooseDirectoryObjCmd hang on the static build of Windows
+## because somehow the GetOpenFileName ends up a noop in the static
+## build.
+##
+test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} -constraints {
+ nt testwinevent
+} -body {
+ start {set x [tk_chooseDirectory]}
+ set y [then {
+ Click cancel
+ }]
+ # $x should be "" on a Cancel
+ append x $y
+} -result {0}
+test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} -constraints {
+ nt
+} -body {
+ tk_chooseDirectory -foo
+} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}
+test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk_chooseDirectory -initialdir [initialdir] -mustexist 1 -parent . -title test
+ }
+ then {
+ Click cancel
+ }
+} -result {0}
+test winDialog-9.4 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() != TCL_OK} -constraints {
+ nt
+} -body {
+ tk_chooseDirectory -foo bar -abc
+} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}
+test winDialog-9.5 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() == TCL_OK} -constraints {
+ nt testwinevent
+} -body {
+ start {tk_chooseDirectory -title bar}
+ then {
+ Click cancel
+ }
+} -result {0}
+test winDialog-9.6 {Tk_ChooseDirectoryObjCmd: valid option, but missing value} -constraints {
+ nt
+} -body {
+ tk_chooseDirectory -initialdir bar -title
+} -returnCodes error -result {value for "-title" missing}
+test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} -constraints {
+ nt testwinevent
+} -body {
+# case DIR_INITIAL:
+
+ start {set x [tk_chooseDirectory -initialdir [initialdir] -title Foo]}
+ then {
+ Click ok
+ }
+ string tolower [set x]
+} -result [string tolower [initialdir]]
+test winDialog-9.8 {Tk_ChooseDirectoryObjCmd: initial directory: Tcl_TranslateFilename()} -constraints {
+ nt
+} -body {
+# if (Tcl_TranslateFileName(interp, string,
+# &utfDirString) == NULL)
+
+ tk_chooseDirectory -initialdir ~12x/455
+} -returnCodes error -result {user "12x" doesn't exist}
+
+
+test winDialog-10.1 {Tk_FontchooserObjCmd: no arguments} -constraints {
+ nt testwinevent
+} -body {
+ start {tk fontchooser show}
+ list [then {
+ Click cancel
+ }] $::testfont
+} -result {0 {}}
+test winDialog-10.2 {Tk_FontchooserObjCmd: -initialfont} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -font system
+ tk fontchooser show
+ }
+ list [then {
+ Click cancel
+ }] $::testfont
+} -result {0 {}}
+test winDialog-10.3 {Tk_FontchooserObjCmd: -initialfont} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -font system
+ tk fontchooser show
+ }
+ list [then {
+ Click 1
+ }] [expr {[llength $::testfont] ne {}}]
+} -result {0 1}
+test winDialog-10.4 {Tk_FontchooserObjCmd: -title} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -title "tk test"
+ tk fontchooser show
+ }
+ list [then {
+ Click cancel
+ }] $::testfont
+} -result {0 {}}
+test winDialog-10.5 {Tk_FontchooserObjCmd: -parent} -constraints {
+ nt testwinevent
+} -setup {
+ array set a {parent {}}
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -parent .
+ tk fontchooser show
+ }
+ then {
+ array set a [testgetwindowinfo $::tk_dialog]
+ Click cancel
+ }
+ list [expr {$a(parent) == [wm frame .]}] $::testfont
+} -result {1 {}}
+test winDialog-10.6 {Tk_FontchooserObjCmd: -apply} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command FooBarBaz
+ tk fontchooser show
+ }
+ then {
+ Click cancel
+ }
+} -result 0
+test winDialog-10.7 {Tk_FontchooserObjCmd: -apply} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -parent .
+ tk fontchooser show
+ }
+ list [then {
+ Click [expr {0x0402}] ;# value from XP
+ Click cancel
+ }] [expr {[llength $::testfont] > 0}]
+} -result {0 1}
+test winDialog-10.8 {Tk_FontchooserObjCmd: -title} -constraints {
+ nt testwinevent
+} -setup {
+ array set a {text failed}
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -title "Hello"
+ tk fontchooser show
+ }
+ then {
+ array set a [testgetwindowinfo $::tk_dialog]
+ Click cancel
+ }
+ set a(text)
+} -result "Hello"
+test winDialog-10.9 {Tk_FontchooserObjCmd: -title} -constraints {
+ nt testwinevent
+} -setup {
+ array set a {text failed}
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont \
+ -title "\u041f\u0440\u0438\u0432\u0435\u0442"
+ tk fontchooser show
+ }
+ then {
+ array set a [testgetwindowinfo $::tk_dialog]
+ Click cancel
+ }
+ set a(text)
+} -result "\u041f\u0440\u0438\u0432\u0435\u0442"
+
+if {[testConstraint testwinevent]} {
+ catch {testwinevent debug 0}
+}
+
+# cleanup
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
+
diff --git a/tk8.6/tests/winFont.test b/tk8.6/tests/winFont.test
new file mode 100644
index 0000000..8039426
--- /dev/null
+++ b/tk8.6/tests/winFont.test
@@ -0,0 +1,392 @@
+# This file is a Tcl script to test out the procedures in tkWinFont.c.
+# It is organized in the standard fashion for Tcl tests.
+#
+# Many of these tests are visually oriented and cannot be checked
+# programmatically (such as "does an underlined font appear to be
+# underlined?"); these tests attempt to exercise the code in question,
+# but there are no results that can be checked.
+#
+# Copyright (c) 1996-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+
+
+test winfont-1.1 {TkpGetNativeFont procedure: not native} -constraints {
+ win
+} -body {
+ catch {font delete xyz}
+ font measure {} xyz
+} -returnCodes error -result {font "" doesn't exist}
+test winfont-1.2 {TkpGetNativeFont procedure: native} -constraints win -body {
+ font measure ansifixed 0
+ font measure ansi 0
+ font measure device 0
+ font measure oemfixed 0
+ font measure systemfixed 0
+ font measure system 0
+ set x {}
+} -result {}
+
+
+test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} -constraints {
+ win
+} -body {
+ expr {[font actual {-size -10} -size] > 0}
+} -result {1}
+test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} -constraints {
+ win
+} -body {
+ expr {[font actual {-family Arial} -size] > 0}
+} -result {1}
+test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} -constraints {
+ win
+} -body {
+ font actual {-weight normal} -weight
+} -result {normal}
+test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} -constraints {
+ win
+} -body {
+ font actual {-weight bold} -weight
+} -result {bold}
+test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} -constraints {
+ win
+} -body {
+ catch {expr {[font actual {-size 10} -size]}}
+} -result 0
+test winfont-2.6 {TkpGetFontFromAttributes procedure: family} -constraints {
+ win
+} -body {
+ font actual {-family Arial} -family
+} -result {Arial}
+test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} -constraints {
+ win
+} -setup {
+ set x {}
+} -body {
+ lappend x [font actual {-family "Times"} -family]
+ lappend x [font actual {-family "New York"} -family]
+ lappend x [font actual {-family "Times New Roman"} -family]
+} -result {{Times New Roman} {Times New Roman} {Times New Roman}}
+test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} -constraints {
+ win
+} -setup {
+ set x {}
+} -body {
+ lappend x [font actual {-family "Courier"} -family]
+ lappend x [font actual {-family "Monaco"} -family]
+ lappend x [font actual {-family "Courier New"} -family]
+} -result {{Courier New} {Courier New} {Courier New}}
+test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} -constraints {
+ win
+} -setup {
+ set x {}
+} -body {
+ lappend x [font actual {-family "Helvetica"} -family]
+ lappend x [font actual {-family "Geneva"} -family]
+ lappend x [font actual {-family "Arial"} -family]
+} -result {Arial Arial Arial}
+test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} -constraints {
+ win
+} -body {
+ # No way to get it to fail! Any font name is acceptable.
+} -result {}
+
+
+test winfont-3.1 {TkpDeleteFont procedure} -constraints win -body {
+ catch {font delete xyz}
+ font actual {-family xyz}
+ set x {}
+} -result {}
+
+
+test winfont-4.1 {TkpGetFontFamilies procedure} -constraints win -body {
+ font families
+ set x {}
+} -result {}
+
+destroy .t
+toplevel .t
+wm geometry .t +0+0
+update idletasks
+label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font systemfixed
+pack .t.l
+canvas .t.c -closeenough 0
+
+set courier {Courier 14}
+set cx [font measure $courier 0]
+set t [.t.c create text 0 0 -anchor nw -just left -font $courier]
+pack .t.c
+update
+
+set ax [winfo reqwidth .t.l]
+set ay [winfo reqheight .t.l]
+proc getsize {} {
+ update
+ return "[winfo reqwidth .t.l] [winfo reqheight .t.l]"
+}
+
+test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} -constraints {
+ win
+} -setup {
+ destroy .t.l
+} -body {
+ label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font systemfixed
+ pack .t.l
+ update
+ set ax [winfo reqwidth .t.l]
+ set ay [winfo reqheight .t.l]
+
+ .t.l config -wrap 0 -text "000000"
+ list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \
+ [expr {[winfo reqheight .t.l] eq $ay}]
+} -cleanup {
+ destroy .t.l
+} -result {1 1}
+
+test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} -constraints {
+ win
+} -setup {
+ destroy .t.l
+} -body {
+ label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font systemfixed
+ pack .t.l
+ update
+ set ax [winfo reqwidth .t.l]
+ set ay [winfo reqheight .t.l]
+
+ .t.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
+ list [expr {[winfo reqwidth .t.l] eq 256*$ax}] \
+ [expr {[winfo reqheight .t.l] eq $ay}]
+} -cleanup {
+ destroy .t.l
+} -result {1 1}
+
+test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} -constraints {
+ win
+} -setup {
+ destroy .t.l
+} -body {
+ label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font systemfixed
+ pack .t.l
+ update
+ set ax [winfo reqwidth .t.l]
+ set ay [winfo reqheight .t.l]
+
+ .t.l config -wrap [expr $ax*10] -text "00000000"
+ list [expr {[winfo reqwidth .t.l] eq 8*$ax}] \
+ [expr {[winfo reqheight .t.l] eq $ay}]
+} -cleanup {
+ destroy .t.l
+} -result {1 1}
+
+test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} -constraints {
+ win
+} -setup {
+ destroy .t.l
+} -body {
+ label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font systemfixed
+ pack .t.l
+ update
+ set ax [winfo reqwidth .t.l]
+ set ay [winfo reqheight .t.l]
+
+ .t.l config -wrap [expr $ax*6] -text "00000000"
+ list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \
+ [expr {[winfo reqheight .t.l] eq 2*$ay}]
+} -cleanup {
+ destroy .t.l
+} -result {1 1}
+
+test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} -constraints {
+ win
+} -setup {
+ destroy .t.c
+} -body {
+ canvas .t.c -closeenough 0
+ set t [.t.c create text 0 0 -anchor nw -just left -font $courier]
+ pack .t.c
+ update
+
+ .t.c dchars $t 0 end
+ .t.c insert $t 0 "0000"
+ .t.c index $t @[expr int($cx*2.5)],1
+} -cleanup {
+ destroy .t.c
+} -result {2}
+
+test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} -constraints {
+ win
+} -setup {
+ destroy .t.l
+} -body {
+ label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font systemfixed
+ pack .t.l
+ update
+ set ax [winfo reqwidth .t.l]
+ set ay [winfo reqheight .t.l]
+
+ .t.l config -text "000000" -wrap 1
+ list [expr {[winfo reqwidth .t.l] eq $ax}] \
+ [expr {[winfo reqheight .t.l] eq 6*$ay}]
+} -cleanup {
+ destroy .t.l
+} -result {1 1}
+
+test winfont-5.7 {Tk_MeasureChars procedure: whole words} -constraints {
+ win
+} -setup {
+ destroy .t.l
+} -body {
+ label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font systemfixed
+ pack .t.l
+ update
+ set ax [winfo reqwidth .t.l]
+ set ay [winfo reqheight .t.l]
+
+ .t.l config -wrap [expr $ax*8] -text "000000 0000"
+ list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \
+ [expr {[winfo reqheight .t.l] eq 2*$ay}]
+} -cleanup {
+ destroy .t.l
+} -result {1 1}
+
+test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} -constraints {
+ win
+} -setup {
+ destroy .t.l
+} -body {
+ label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font systemfixed
+ pack .t.l
+ update
+ set ax [winfo reqwidth .t.l]
+ set ay [winfo reqheight .t.l]
+
+ .t.l config -wrap [expr $ax*12] -text "000000 0000000"
+ list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \
+ [expr {[winfo reqheight .t.l] eq 2*$ay}]
+} -cleanup {
+ destroy .t.l
+} -result {1 1}
+
+test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} -constraints {
+ win
+} -setup {
+ destroy .t.l
+} -body {
+ label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font systemfixed
+ pack .t.l
+ update
+ set ax [winfo reqwidth .t.l]
+ set ay [winfo reqheight .t.l]
+
+ .t.l config -wrap [expr $ax*12] -text "000 00 00000"
+ list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \
+ [expr {[winfo reqheight .t.l] eq 2*$ay}]
+} -cleanup {
+ destroy .t.l
+} -result {1 1}
+
+test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} -constraints {
+ win
+} -setup {
+ destroy .t.l
+} -body {
+ label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font systemfixed
+ pack .t.l
+ update
+ set ax [winfo reqwidth .t.l]
+ set ay [winfo reqheight .t.l]
+
+ .t.l config -wrap [expr $ax*12] -text "0000000000000000"
+ list [expr {[winfo reqwidth .t.l] eq 12*$ax}] \
+ [expr {[winfo reqheight .t.l] eq 2*$ay}]
+} -cleanup {
+ destroy .t.l
+} -result {1 1}
+
+test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} -constraints {
+ win nonPortable
+} -setup {
+ destroy .t.l
+} -body {
+ label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font systemfixed
+ pack .t.l
+ update
+
+ set font [.t.l cget -font]
+ .t.l config -font {{MS Sans Serif} 8} -text "W"
+ set width [winfo reqwidth .t.l]
+ .t.l config -text "XaYoYaKaWx"
+ set x [lindex [getsize] 0]
+ .t.l config -font $font
+ expr $x < ($width*10)
+} -cleanup {
+ destroy .t.l
+} -result {1}
+
+
+test winfont-6.1 {Tk_DrawChars procedure: loop test} -constraints win -setup {
+ destroy .t.l
+} -body {
+ label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font systemfixed
+ pack .t.l
+ update
+ .t.l config -text "a"
+ update
+} -cleanup {
+ destroy .t.l
+} -result {}
+
+
+test winfont-7.1 {AllocFont procedure: use old font} -constraints win -setup {
+ destroy .c
+} -setup {
+ catch {font delete xyz}
+} -body {
+ font create xyz
+ button .c -font xyz
+ font configure xyz -family times
+ update
+ destroy .c
+ font delete xyz
+} -result {}
+test winfont-7.2 {AllocFont procedure: extract info from logfont} -constraints {
+ win
+} -body {
+ font actual {arial 10 bold italic underline overstrike}
+} -result {-family Arial -size 10 -weight bold -slant italic -underline 1 -overstrike 1}
+test winfont-7.3 {AllocFont procedure: extract info from textmetric} -constraints {
+ win
+} -body {
+ font metric {arial 10 bold italic underline overstrike} -fixed
+} -result {0}
+test winfont-7.4 {AllocFont procedure: extract info from textmetric} -constraints {
+ win
+} -body {
+ font metric systemfixed -fixed
+} -result {1}
+
+# cleanup
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
+
diff --git a/tk8.6/tests/winMenu.test b/tk8.6/tests/winMenu.test
new file mode 100644
index 0000000..ce2069f
--- /dev/null
+++ b/tk8.6/tests/winMenu.test
@@ -0,0 +1,1385 @@
+# This file is a Tcl script to test menus in Tk. It is
+# organized in the standard fashion for Tcl tests. This
+# file tests the Macintosh-specific features of the menu
+# system.
+#
+# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+
+test winMenu-1.1 {GetNewID} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+} -cleanup {
+ destroy .m1
+} -returnCodes ok -result {.m1}
+test winMenu-1.2 {GetNewID} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ destroy .m1
+} -result {}
+
+
+# Basically impossible to test menu IDs wrapping.
+
+test winMenu-2.1 {FreeID} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ destroy .m1
+} -returnCodes ok
+
+
+test winMenu-3.1 {TkpNewMenu} -constraints win -setup {
+ destroy .m1
+} -body {
+ list [catch {menu .m1} msg] $msg [catch {destroy .m1} msg2] $msg2
+} -result {0 .m1 0 {}}
+test winMenu-3.2 {TkpNewMenu} -constraints win -setup {
+ destroy .m1
+} -body {
+ . configure -menu ""
+ menu .m1
+ .m1 add command -label "foo"
+ list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [catch {destroy .m1} msg2] $msg2
+} -result {0 {} {} 0 {}}
+
+
+test winMenu-4.1 {TkpDestroyMenu} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ destroy .m1
+} -returnCodes ok
+test winMenu-4.2 {TkpDestroyMenu - help menu} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m1.system
+ . configure -menu .m1
+ list [catch {destroy .m1.system} msg] $msg [. configure -menu ""] [destroy .m1]
+} -result {0 {} {} {}}
+
+
+test winMenu-5.1 {TkpDestroyMenuEntry} -constraints win -setup {
+ destroy .m1
+} -body {
+ . configure -menu ""
+ menu .m1
+ .m1 add command -label "test"
+ update idletasks
+ list [catch {.m1 delete 1} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+
+
+test winMenu-6.1 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ list [catch {menu .m1} msg] $msg [destroy .m1]
+} -result {0 .m1 {}}
+test winMenu-6.2 {GetEntryText} -constraints {
+ testImageType win
+} -setup {
+ destroy .m1
+} -body {
+ catch {image delete image1}
+ menu .m1
+ image create test image1
+ list [catch {.m1 add command -image image1} msg] $msg [destroy .m1] [image delete image1]
+} -result {0 {} {} {}}
+test winMenu-6.3 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command -bitmap questhead} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-6.4 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-6.5 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command -label "foo"} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-6.6 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command -label "This string has one & in it"} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-6.7 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command -label "The & should be underlined." -underline 4} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-6.8 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command -label "The * should be underlined." -underline 4} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-6.9 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command -label "foo" -accel "bar"} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-6.10 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command -label "This string has one & in it" -accel "bar"} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-6.11 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command -label "The & should be underlined." -underline 4 -accel "bar"} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-6.12 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command -label "The * should be underlined." -underline 4 -accel "bar"} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-6.13 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command -label "foo" -accel "&bar"} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-6.14 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command -label "This string has one & in it" -accel "&bar"} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-6.15 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command -label "The & should be underlined." -underline 4 -accel "&bar"} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-6.16 {GetEntryText} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command -label "The * should be underlined." -underline 4 -accel "&bar"} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+
+test winMenu-7.1 {ReconfigureWindowsMenu - system menu item removal} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -menu .m1.system
+ menu .m1.system
+ .m1.system add command -label foo
+ update idletasks
+ .m1.system add command -label bar
+ list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1]
+} -result {0 {} {} {}}
+test winMenu-7.2 {ReconfigureWindowsMenu - menu item removal} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label Hello
+ update idletasks
+ .m1 add command -label foo
+ list [catch {update idletasks} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-7.3 {ReconfigureWindowsMenu - zero items} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label Hello
+ .m1 delete Hello
+ list [catch {update idletasks} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-7.4 {ReconfigureWindowsMenu - one item} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label Hello
+ list [catch {update idletasks} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-7.5 {ReconfigureWindowsMenu - two items} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label One
+ .m1 add command -label Two
+ list [catch {update idletasks} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-7.6 {ReconfigureWindowsMenu - separator item} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add separator
+ list [catch {update idletasks} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-7.7 {ReconfigureWindowsMenu - non-text item} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label Hello
+ list [catch {update idletasks} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-7.8 {ReconfigureWindowsMenu - disabled item} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label Hello -state disabled
+ list [catch {update idletasks} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-7.9 {ReconfigureWindowsMenu - non-selected checkbutton} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add checkbutton -label Hello
+ list [catch {update idletasks} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-7.10 {ReconfigureWindowsMenu - non-selected radiobutton} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add radiobutton -label Hello
+ list [catch {update idletasks} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-7.11 {ReconfigureWindowsMenu - selected checkbutton} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add checkbutton -label Hello
+ .m1 invoke Hello
+ list [catch {update idletasks} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-7.12 {ReconfigureWindowsMenu - selected radiobutton} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add radiobutton -label Hello
+ .m1 invoke Hello
+ list [catch {update idletasks} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-7.13 {ReconfigureWindowsMenu - cascade missing} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -label Hello
+ list [catch {update idletasks} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-7.14 {ReconfigureWindowsMenu - cascade} -constraints win -setup {
+ destroy .m1
+} -body {
+ catch {destroy .m2}
+ menu .m1 -tearoff 0
+ menu .m2
+ .m1 add cascade -menu .m2 -label Hello
+ list [catch {update idletasks} msg] $msg [destroy .m1] [destroy .m2]
+} -result {0 {} {} {}}
+test winMenu-7.15 {ReconfigureWindowsMenu - menubar without system menu} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -menu .m1.file
+ menu .m1.file -tearoff 0
+ . configure -menu .m1
+ list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1]
+} -result {0 {} {} {}}
+test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -menu .m1.system
+ menu .m1.system -tearoff 0
+ . configure -menu .m1
+ update idletasks
+ .m1.system add command -label Hello
+ list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1]
+} -result {0 {} {} {}}
+test winMenu-7.17 {ReconfigureWindowsMenu - system menu update pending} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -menu .m1.system
+ menu .m1.system -tearoff 0
+ . configure -menu .m1
+ list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1]
+} -result {0 {} {} {}}
+test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add cascade -menu .m1.system
+ menu .m1.system -tearoff 0
+ .m1.system add command -label Hello
+ update idletasks
+ . configure -menu .m1
+ list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1]
+} -result {0 {} {} {}}
+test winMenu-7.19 {ReconfigureWindowsMenu - column break} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label one
+ .m1 add command -label two -columnbreak 1
+ list [catch {update idletasks} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+
+
+#Don't know how to generate nested post menus
+
+test winMenu-8.1 {TkpPostMenu} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1 -postcommand "blork"
+ .m1 post 40 40
+} -returnCodes error -result {invalid command name "blork"}
+test winMenu-8.2 {TkpPostMenu} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1 -postcommand "blork"
+ .m1 post 40 40
+ destroy .m1
+} -returnCodes error -result {invalid command name "blork"}
+test winMenu-8.3 {TkpPostMenu} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1 -postcommand "destroy .m1"
+ list [.m1 post 40 40] [winfo exists .m1]
+} -result {{} 0}
+test winMenu-8.4 {TkpPostMenu - popup menu} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "winMenu-8.3: Hit ESCAPE."
+ list [.m1 post 40 40] [destroy .m1]
+} -result {{} {}}
+test winMenu-8.5 {TkpPostMenu - menu button} -constraints {
+ win userInteraction
+} -setup {
+ destroy .mb
+} -body {
+ menubutton .mb -text test -menu .mb.menu
+ menu .mb.menu
+ .mb.menu add command -label "winMenu-8.4 - Hit ESCAPE."
+ pack .mb
+ list [tk::MbPost .mb] [destroy .mb]
+} -result {{} {}}
+test winMenu-8.6 {TkpPostMenu - update not pending} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "winMenu-8.5 - Hit ESCAPE."
+ update idletasks
+ list [catch {.m1 post 40 40} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+
+
+test winMenu-9.1 {TkpMenuNewEntry} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [catch {.m1 add command} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+
+
+test winMenu-10.1 {TkwinMenuProc} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "winMenu-10.1: Hit ESCAPE."
+ list [.m1 post 40 40] [destroy .m1]
+} -result {{} {}}
+
+
+# Can't generate a WM_INITMENU without a Tk menu yet.
+
+test winMenu-11.1 {TkWinHandleMenuEvent - WM_INITMENU} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1 -postcommand "set foo test"
+ .m1 add command -label "winMenu-11.1: Hit ESCAPE."
+ list [.m1 post 40 40] [set foo] [unset foo] [destroy .m1]
+} -result {test test {} {}}
+test winMenu-11.2 {TkWinHandleMenuEvent - WM_COMMAND} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ menu .m1
+ .m1 add checkbutton -variable foo -label "winMenu-11.2: Please select this menu item."
+ list [.m1 post 40 40] [update] [set foo] [unset foo] [destroy .m1]
+} -result {{} {} 1 {} {}}
+test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
+ proc bgerror {args} {
+ global foo errorInfo
+ set foo [list $args $errorInfo]
+ }
+ menu .m1
+ .m1 add command -command {error 1} -label "winMenu-11.2: Please select this menu item."
+ list [.m1 post 40 40] [update] [set foo] [unset foo] [destroy .m1]
+} -result {{} {} {1 {1
+ while executing
+"error 1"
+ (menu invoke)}} {} {}}
+
+
+# Can't test WM_MENUCHAR
+
+test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "winMenu-11.3: Hit ESCAPE."
+ list [.m1 post 40 40] [destroy .m1]
+} -result {{} {}}
+test winMenu-11.5 {TkWinHandleMenuEvent - WM_MEASUREITEM} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label "winMenu-11.4: Hit ESCAPE" -hidemargin 1
+ list [.m1 post 40 40] [destroy .m1]
+} -result {{} {}}
+test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "winMenu-11.5: Hit ESCAPE."
+ list [.m1 post 40 40] [destroy .m1]
+} -result {{} {}}
+test winMenu-11.7 {TkWinHandleMenuEvent - WM_DRAWITEM - item disabled} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "winMenu-11.6: Hit ESCAPE." -state disabled
+ list [.m1 post 40 40] [destroy .m1]
+} -result {{} {}}
+test winMenu-11.8 {TkWinHandleMenuEvent - WM_INITMENU - not pending} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label "winMenu-11.7: Hit ESCAPE"
+ update idletasks
+ list [catch {.m1 post 40 40} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+
+
+test winMenu-12.1 {TkpSetWindowMenuBar} -constraints win -setup {
+ destroy .m1
+} -body {
+ . configure -menu ""
+ menu .m1
+ .m1 add command -label foo
+ list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [catch {destroy .m1} msg2] $msg2
+} -result {0 {} {} 0 {}}
+test winMenu-12.2 {TkpSetWindowMenuBar} -constraints win -setup {
+ destroy .m1
+} -body {
+ . configure -menu ""
+ menu .m1
+ .m1 add command -label foo
+ . configure -menu .m1
+ list [catch {. configure -menu ""} msg] $msg [catch {destroy .m1} msg2] $msg2
+} -result {0 {} 0 {}}
+test winMenu-12.3 {TkpSetWindowMenuBar - no update pending} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ . configure -menu ""
+ menu .m1 -tearoff 0
+ .m1 add command -label foo
+ update idletasks
+ list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1]
+} -result {0 {} {} {}}
+
+
+test winMenu-13.1 {TkpSetMainMenubar - nothing to do} -constraints {
+ emptyTest win
+} -body {}
+
+
+test winMenu-14.1 {GetMenuIndicatorGeometry} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test winMenu-14.2 {GetMenuIndicatorGeometry} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo -hidemargin 1
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+
+
+test winMenu-15.1 {GetMenuAccelGeometry} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label foo -accel Ctrl+U
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test winMenu-15.2 {GetMenuAccelGeometry} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test winMenu-15.3 {GetMenuAccelGeometry} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -accel "Ctrl+U"
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+
+
+test winMenu-16.1 {GetTearoffEntryGeometry} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "winMenu-19.1: Hit ESCAPE."
+ list [.m1 post 40 40] [destroy .m1]
+} -result {{} {}}
+
+
+test winMenu-17.1 {GetMenuSeparatorGeometry} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add separator
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+
+
+# Currently, the only callers to DrawWindowsSystemBitmap want things
+# centered vertically, and either centered or right aligned horizontally.
+test winMenu-18.1 {DrawWindowsSystemBitmap - center aligned} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo
+ .m1 invoke foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-18.2 {DrawWindowsSystemBitmap - right aligned} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test winMenu-19.1 {DrawMenuEntryIndicator - not checkbutton or radiobutton} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-19.2 {DrawMenuEntryIndicator - not selected} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-19.3 {DrawMenuEntryIndicator - checkbutton} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo
+ .m1 invoke foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-19.4 {DrawMenuEntryIndicator - radiobutton} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add radiobutton -label foo
+ .m1 invoke foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-19.5 {DrawMenuEntryIndicator - disabled} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo
+ .m1 invoke foo
+ .m1 entryconfigure foo -state disabled
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-19.6 {DrawMenuEntryIndicator - indicator not on} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo -indicatoron 0
+ .m1 invoke foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test winMenu-20.1 {DrawMenuEntryAccelerator - disabled} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1 -disabledforeground red
+ .m1 add command -label foo -accel "Ctrl+U" -state disabled
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-20.2 {DrawMenuEntryAccelerator - normal text} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -accel "Ctrl+U"
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-20.3 {DrawMenuEntryAccelerator - disabled, no disabledforeground} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -disabledforeground ""
+ .m1 add command -label foo -accel "Ctrl+U" -state disabled
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-20.4 {DrawMenuEntryAccelerator - cascade, drawArrow true} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-20.5 {DrawMenuEntryAccelerator - cascade, drawArrow false} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label "winMenu-23.5: Hit ESCAPE."
+ list [.m1 post 40 40] [destroy .m1]
+} -result {{} {}}
+
+
+test winMenu-21.1 {DrawMenuSeparator} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add separator
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test winMenu-22.1 {DrawMenuUnderline} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -underline 0
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test winMenu-23.1 {Don't know how to test MenuKeyBindProc} -constraints {
+ win emptyTest
+} -body {}
+
+
+test winMenu-24.1 {TkpInitializeMenuBindings called at boot time} -constraints {
+ win emptyTest
+} -body {}
+
+
+test winMenu-25.1 {DrawMenuEntryLabel - normal} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-25.2 {DrawMenuEntryLabel - disabled with fg} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -disabledforeground red
+ .m1 add command -label foo -state disabled
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-25.3 {DrawMenuEntryLabel - disabled with no fg} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -disabledforeground ""
+ .m1 add command -label foo -state disabled
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test winMenu-26.1 {TkpComputeMenubarGeometry} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label File
+ list [. configure -menu .m1] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+
+
+test winMenu-27.1 {DrawTearoffEntry} -constraints {
+ win userInteraction
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "winMenu-24.4: Hit ESCAPE."
+ list [.m1 post 40 40] [destroy .m1]
+} -result {{} {}}
+
+
+test winMenu-28.1 {TkpConfigureMenuEntry - update pending} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label Hello
+ list [catch {.m1 add command -label Two} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+test winMenu-28.2 {TkpConfigureMenuEntry - update not pending} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label One
+ update idletasks
+ list [catch {.m1 add command -label Two} msg] $msg [destroy .m1]
+} -result {0 {} {}}
+
+
+test winMenu-29.1 {TkpDrawMenuEntry - gc for active and not strict motif} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -activeforeground red
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.3 {TkpDrawMenuEntry - gc for active and strict motif} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ set tk_strictMotif 1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1] [set tk_strictMotif 0]
+} -result {{} {} 0}
+test winMenu-29.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -disabledforeground blue
+ .m1 add command -label foo -state disabled -background red
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -disabledforeground blue
+ .m1 add command -label foo -state disabled
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -disabledforeground ""
+ .m1 add command -label foo -state disabled
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.7 {TkpDrawMenuEntry - gc for normal - custom entry} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -foreground red
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.8 {TkpDrawMenuEntry - gc for normal} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.9 {TkpDrawMenuEntry - gc for indicator - custom entry} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo -selectcolor orange
+ .m1 invoke 1
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.10 {TkpDrawMenuEntry - gc for indicator} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label foo
+ .m1 invoke 1
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.11 {TkpDrawMenuEntry - border - custom entry} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -activebackground green
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.12 {TkpDrawMenuEntry - border} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.13 {TkpDrawMenuEntry - active border - strict motif} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ set tk_strictMotif 1
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1] [set tk_strictMotif 0]
+} -result {{} {} 0}
+test winMenu-29.14 {TkpDrawMenuEntry - active border - custom entry} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -activeforeground yellow
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.15 {TkpDrawMenuEntry - active border} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ .m1 entryconfigure 1 -state active
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.16 {TkpDrawMenuEntry - font - custom entry} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo -font "Helvectica 72"
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.17 {TkpDrawMenuEntry - font} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1 -font "Courier 72"
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.18 {TkpDrawMenuEntry - separator} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add separator
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.19 {TkpDrawMenuEntry - standard} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add cascade -label File -menu .m1.file
+ menu .m1.file
+ .m1.file add command -label foo
+ .m1 entryconfigure File -state disabled
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.21 {TkpDrawMenuEntry - indicator} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label winMenu-31.20
+ .m1 invoke winMenu-31.20
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-29.22 {TkpDrawMenuEntry - indicator} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label winMenu-31.21 -hidemargin 1
+ .m1 invoke winMenu-31.21
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test winMenu-30.1 {GetMenuLabelGeometry - image} -constraints {
+ testImageType win
+} -setup {
+ destroy .m1
+ catch {image delete image1}
+} -body {
+ menu .m1
+ image create test image1
+ .m1 add command -image image1
+ list [update idletasks] [destroy .m1] [image delete image1]
+} -result {{} {} {}}
+test winMenu-30.2 {GetMenuLabelGeometry - bitmap} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -bitmap questhead
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-30.3 {GetMenuLabelGeometry - no text} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-30.4 {GetMenuLabelGeometry - text} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "This is a test."
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+
+
+test winMenu-31.1 {DrawMenuEntryBackground} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ list [update] [destroy .m1]
+} -result {{} {}}
+test winMenu-31.2 {DrawMenuEntryBackground} -constraints win -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label foo
+ set tearoff [tk::TearOffMenu .m1 40 40]
+ $tearoff activate 0
+ list [update] [destroy .m1]
+} -result {{} {}}
+
+
+test winMenu-32.1 {TkpComputeStandardMenuGeometry - no entries} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.2 {TkpComputeStandardMenuGeometry - one entry} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "one"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.3 {TkpComputeStandardMenuGeometry - more than one entry} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "one"
+ .m1 add command -label "two"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.4 {TkpComputeStandardMenuGeometry - separator} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add separator
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.5 {TkpComputeStandardMenuGeometry - tearoff entry} -constraints {
+ unix nonUnixUserInteraction
+} -setup {
+ destroy .mb
+} -body {
+ menubutton .mb -text "test" -menu .mb.m
+ menu .mb.m
+ .mb.m add command -label test
+ pack .mb
+ catch {tk::MbPost .mb}
+ list [update] [destroy .mb]
+} -result {{} {}}
+test winMenu-32.6 {TkpComputeStandardMenuGeometry - standard label geometry} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.7 {TkpComputeStandardMenuGeometry - different font for entry} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -font "Helvetica 12"
+ .m1 add command -label "test" -font "Courier 12"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.8 {TkpComputeStandardMenuGeometry - second entry larger} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test"
+ .m1 add command -label "test test"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.9 {TkpComputeStandardMenuGeometry - first entry larger} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test test"
+ .m1 add command -label "test"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.10 {TkpComputeStandardMenuGeometry - accelerator} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test" -accel "Ctrl+S"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.11 {TkpComputeStandardMenuGeometry - second accel larger} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test" -accel "1"
+ .m1 add command -label "test" -accel "1 1"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.12 {TkpComputeStandardMenuGeometry - second accel smaller} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label "test" -accel "1 1"
+ .m1 add command -label "test" -accel "1"
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.13 {TkpComputeStandardMenuGeometry - indicator} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add checkbutton -label test
+ .m1 invoke 1
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.14 {TkpComputeStandardMenuGeometry - second indicator less or equal} -constraints {
+ testImageType win
+} -setup {
+ destroy .m1
+ catch {image delete image1}
+} -body {
+ image create test image1
+ menu .m1
+ .m1 add checkbutton -image image1
+ .m1 invoke 1
+ .m1 add checkbutton -label test
+ .m1 invoke 2
+ list [update idletasks] [destroy .m1] [image delete image1]
+} -result {{} {} {}}
+test winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger} -constraints {
+ testImageType unix
+} -setup {
+ destroy .m1
+ catch {image delete image1}
+} -body {
+ image create test image1
+ menu .m1
+ .m1 add checkbutton -image image1
+ .m1 invoke 1
+ .m1 add checkbutton -label test
+ .m1 invoke 2
+ list [update idletasks] [destroy .m1] [image delete image1]
+} -result {{} {} {}}
+test winMenu-32.16 {TkpComputeStandardMenuGeometry - zero sized menus} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.17 {TkpComputeStandardMenuGeometry - first column bigger} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add command -label one
+ .m1 add command -label two
+ .m1 add command -label three -columnbreak 1
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.18 {TkpComputeStandardMenuGeometry - second column bigger} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label one
+ .m1 add command -label two -columnbreak 1
+ .m1 add command -label three
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} -constraints {
+ win
+} -setup {
+ destroy .m1
+} -body {
+ menu .m1 -tearoff 0
+ .m1 add command -label one
+ .m1 add command -label two -columnbreak 1
+ .m1 add command -label three
+ .m1 add command -label four
+ .m1 add command -label five -columnbreak 1
+ .m1 add command -label six
+ list [update idletasks] [destroy .m1]
+} -result {{} {}}
+
+
+test winMenu-33.1 {TkpNotifyTopLevelCreate - no menu yet} -constraints {
+ win
+} -setup {
+ destroy .m1 .t2
+} -body {
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ list [update idletasks] [destroy .t2]
+} -result {{} {}}
+test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} -constraints win -setup {
+ destroy .m1 .t2
+} -body {
+ menu .m1
+ menu .m1.system
+ .m1 add cascade -menu .m1.system
+ .m1.system add separator
+ .m1.system add command -label foo
+ toplevel .t2 -menu .m1
+ wm geometry .t2 +0+0
+ list [update idletasks] [destroy .m1] [destroy .t2]
+} -result {{} {} {}}
+
+
+test winMenu-34.1 {TkpMenuInit called at boot time} -constraints {
+ emptyTest win
+} -body {}
+
+# cleanup
+deleteWindows
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
+
diff --git a/tk8.6/tests/winMsgbox.test b/tk8.6/tests/winMsgbox.test
new file mode 100644
index 0000000..0181103
--- /dev/null
+++ b/tk8.6/tests/winMsgbox.test
@@ -0,0 +1,300 @@
+# This file is a Tcl script to test the Windows specific message box
+#
+# Copyright (c) 2007 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+
+testConstraint getwindowinfo [expr {[llength [info command ::testgetwindowinfo]] > 0}]
+
+if {[testConstraint testwinevent]} {
+ catch {testwinevent debug 1}
+}
+
+proc Click {hwnd button} {
+ testwinevent $hwnd $button WM_COMMAND
+}
+
+proc GetWindowInfo {title button} {
+ global windowInfo
+ set windowInfo {}
+ set hwnd [testfindwindow $title "#32770"]
+ set windowInfo [testgetwindowinfo $hwnd]
+ array set a $windowInfo
+ set childinfo {} ; set childtext ""
+ foreach child $a(children) {
+ lappend childinfo $child [set info [testgetwindowinfo $child]]
+ array set ca $info
+ if {$ca(class) eq "Static"} {
+ append childtext $ca(text)
+ }
+ }
+ set a(children) $childinfo
+ set a(childtext) $childtext
+ set windowInfo [array get a]
+ testwinevent $hwnd $button WM_COMMAND
+}
+
+# -------------------------------------------------------------------------
+
+test winMsgbox-1.1 {tk_messageBox ok} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+} -body {
+ global windowInfo
+ set title "winMsgbox-1.0 [pid]"
+ after 100 [list GetWindowInfo $title 2]
+ tk_messageBox -icon info -type ok -title $title -message Message
+} -cleanup {
+ wm deiconify .
+} -result {ok}
+
+test winMsgbox-1.2 {tk_messageBox okcancel} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+} -body {
+ global windowInfo
+ set title "winMsgbox-1.1 [pid]"
+ after 100 [list GetWindowInfo $title 1]
+ tk_messageBox -icon info -type okcancel -title $title -message Message
+} -cleanup {
+ wm deiconify .
+} -result {ok}
+
+test winMsgbox-1.3 {tk_messageBox okcancel} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+} -body {
+ global windowInfo
+ set title "winMsgbox-1.2 [pid]"
+ after 100 [list GetWindowInfo $title 2]
+ tk_messageBox -icon info -type okcancel -title $title -message Message
+} -cleanup {
+ wm deiconify .
+} -result {cancel}
+
+test winMsgbox-1.4 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+} -body {
+ global windowInfo
+ set title "winMsgbox-1.3 [pid]"
+ after 100 [list GetWindowInfo $title 6]
+ tk_messageBox -icon info -type yesno -title $title -message Message
+} -cleanup {
+ wm deiconify .
+} -result {yes}
+
+test winMsgbox-1.5 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+} -body {
+ global windowInfo
+ set title "winMsgbox-1.4 [pid]"
+ after 100 [list GetWindowInfo $title 7]
+ tk_messageBox -icon info -type yesno -title $title -message Message
+} -cleanup {
+ wm deiconify .
+} -result {no}
+
+test winMsgbox-1.6 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+} -body {
+ global windowInfo
+ set title "winMsgbox-1.5 [pid]"
+ after 100 [list GetWindowInfo $title 3]
+ tk_messageBox -icon info -type abortretryignore -title $title -message Message
+} -cleanup {
+ wm deiconify .
+} -result {abort}
+
+test winMsgbox-1.7 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+} -body {
+ global windowInfo
+ set title "winMsgbox-1.6 [pid]"
+ after 100 [list GetWindowInfo $title 4]
+ tk_messageBox -icon info -type abortretryignore -title $title -message Message
+} -cleanup {
+ wm deiconify .
+} -result {retry}
+
+test winMsgbox-1.8 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+} -body {
+ global windowInfo
+ set title "winMsgbox-1.7 [pid]"
+ after 100 [list GetWindowInfo $title 5]
+ tk_messageBox -icon info -type abortretryignore -title $title -message Message
+} -cleanup {
+ wm deiconify .
+} -result {ignore}
+
+test winMsgbox-1.9 {tk_messageBox retrycancel} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+} -body {
+ global windowInfo
+ set title "winMsgbox-1.8 [pid]"
+ after 100 [list GetWindowInfo $title 4]
+ tk_messageBox -icon info -type retrycancel -title $title -message Message
+} -cleanup {
+ wm deiconify .
+} -result {retry}
+
+test winMsgbox-1.10 {tk_messageBox retrycancel} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+} -body {
+ global windowInfo
+ set title "winMsgbox-1.9 [pid]"
+ after 100 [list GetWindowInfo $title 2]
+ tk_messageBox -icon info -type retrycancel -title $title -message Message
+} -cleanup {
+ wm deiconify .
+} -result {cancel}
+
+test winMsgbox-1.11 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+} -body {
+ global windowInfo
+ set title "winMsgbox-1.10 [pid]"
+ after 100 [list GetWindowInfo $title 6]
+ tk_messageBox -icon info -type yesnocancel -title $title -message Message
+} -cleanup {
+ wm deiconify .
+} -result {yes}
+
+test winMsgbox-1.12 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+} -body {
+ global windowInfo
+ set title "winMsgbox-1.11 [pid]"
+ after 100 [list GetWindowInfo $title 7]
+ tk_messageBox -icon info -type yesnocancel -title $title -message Message
+} -cleanup {
+ wm deiconify .
+} -result {no}
+
+test winMsgbox-1.13 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+} -body {
+ global windowInfo
+ set title "winMsgbox-1.12 [pid]"
+ after 100 [list GetWindowInfo $title 2]
+ tk_messageBox -icon info -type yesnocancel -title $title -message Message
+} -cleanup {
+ wm deiconify .
+} -result {cancel}
+
+# -------------------------------------------------------------------------
+
+test winMsgbox-2.1 {tk_messageBox message} -constraints {win getwindowinfo} -setup {
+ wm iconify .
+ unset -nocomplain info
+} -body {
+ global windowInfo
+ set title "winMsgbox-2.0 [pid]"
+ set message "message"
+ after 100 [list GetWindowInfo $title 2]
+ set r [tk_messageBox -type ok -title $title -message $message]
+ array set info $windowInfo
+ lappend r $info(childtext)
+} -cleanup {
+ wm deiconify .
+} -result [list ok "message"]
+
+test winMsgbox-2.2 {tk_messageBox message (long)} -constraints {
+ win getwindowinfo
+} -setup {
+ wm iconify .
+ unset -nocomplain info
+} -body {
+ global windowInfo
+ set title "winMsgbox-2.1 [pid]"
+ set message [string repeat Ab 80]
+ after 100 [list GetWindowInfo $title 2]
+ set r [tk_messageBox -type ok -title $title -message $message]
+ array set info $windowInfo
+ lappend r $info(childtext)
+} -cleanup {
+ wm deiconify .
+} -result [list ok [string repeat Ab 80]]
+
+test winMsgbox-2.3 {tk_messageBox message (unicode)} -constraints {
+ win getwindowinfo
+} -setup {
+ wm iconify .
+ unset -nocomplain info
+} -body {
+ global windowInfo
+ set title "winMsgbox-2.2 [pid]"
+ set message "\u041f\u043e\u0438\u0441\u043a\u0020\u0441\u0442\u0440\u0430\u043d\u0438\u0446"
+ after 100 [list GetWindowInfo $title 2]
+ set r [tk_messageBox -type ok -title $title -message $message]
+ array set info $windowInfo
+ lappend r $info(childtext)
+} -cleanup {
+ wm deiconify .
+} -result [list ok "\u041f\u043e\u0438\u0441\u043a\u0020\u0441\u0442\u0440\u0430\u043d\u0438\u0446"]
+
+test winMsgbox-2.4 {tk_messageBox message (empty)} -constraints {
+ win getwindowinfo
+} -setup {
+ wm iconify .
+ unset -nocomplain info
+} -body {
+ global windowInfo
+ set title "winMsgbox-2.3 [pid]"
+ after 100 [list GetWindowInfo $title 2]
+ set r [tk_messageBox -type ok -title $title]
+ array set info $windowInfo
+ lappend r $info(childtext)
+} -cleanup {
+ wm deiconify .
+} -result [list ok ""]
+
+# -------------------------------------------------------------------------
+
+test winMsgbox-3.1 {tk_messageBox detail (sourceforge bug #1692927)} -constraints {
+ win getwindowinfo
+} -setup {
+ wm iconify .
+ unset -nocomplain info
+} -body {
+ global windowInfo
+ set title "winMsgbox-3.0 [pid]"
+ after 100 [list GetWindowInfo $title 2]
+ set r [tk_messageBox -type ok -title $title \
+ -message Hello -detail "Pleased to meet you"]
+ array set info $windowInfo
+ lappend r $info(childtext)
+} -cleanup {
+ wm deiconify .
+} -result [list ok "Hello\n\nPleased to meet you"]
+
+test winMsgbox-3.2 {tk_messageBox detail (unicode)} -constraints {
+ win getwindowinfo
+} -setup {
+ wm iconify .
+ unset -nocomplain info
+} -body {
+ global windowInfo
+ set title "winMsgbox-3.1 [pid]"
+ set message "\u041f\u043e\u0438\u0441\u043a"
+ set detail "\u0441\u0442\u0440\u0430\u043d\u0438\u0446"
+ after 100 [list GetWindowInfo $title 2]
+ set r [tk_messageBox -type ok -title $title -message $message -detail $detail]
+ array set info $windowInfo
+ lappend r $info(childtext)
+} -cleanup {
+ wm deiconify .
+} -result [list ok "\u041f\u043e\u0438\u0441\u043a\n\n\u0441\u0442\u0440\u0430\u043d\u0438\u0446"]
+
+# -------------------------------------------------------------------------
+
+if {[testConstraint testwinevent]} {
+ catch {testwinevent debug 0}
+}
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tk8.6/tests/winSend.test b/tk8.6/tests/winSend.test
new file mode 100644
index 0000000..0f3baf8
--- /dev/null
+++ b/tk8.6/tests/winSend.test
@@ -0,0 +1,407 @@
+# This file is a Tcl script to test out the "send" command and the
+# other procedures in the file tkSend.c. It is organized in the
+# standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# Compute a script that will load Tk into a child interpreter.
+
+foreach pkg [info loaded] {
+ if {[lindex $pkg 1] == "Tk"} {
+ set loadTk "load $pkg"
+ break
+ }
+}
+
+# Procedure to create a new application with a given name and class.
+
+proc newApp {name {safe {}}} {
+ global loadTk
+ if {[string compare $safe "-safe"] == 0} {
+ interp create -safe $name
+ } else {
+ interp create $name
+ }
+ $name eval [list set argv [list -name $name]]
+ catch {eval $loadTk $name}
+}
+
+set currentInterps [winfo interps]
+if {
+ [testConstraint win] &&
+ [llength [info commands send]] &&
+ [catch {exec [interpreter] &}] == 0
+} then {
+ # Wait until the child application has launched.
+ while {[llength [winfo interps]] == [llength $currentInterps]} {}
+
+ # Now find an interp to send to
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch -exact $currentInterps $interp] < 0} {
+ break
+ }
+ }
+
+ # Now we have found our interpreter we are going to send to.
+ # Make sure that it works first.
+ testConstraint winSend [expr {![catch {
+ send $interp {
+ console hide
+ update
+ }
+ }]}]
+} else {
+ testConstraint winSend 0
+}
+
+# setting up dde server is done when the first interp is created and
+# cannot be tested very easily.
+test winSend-1.1 {Tk_SetAppName - changing name of interp} winSend {
+ newApp testApp
+ list [testApp eval tk appname testApp2] [interp delete testApp]
+} {testApp2 {}}
+test winSend-1.2 {Tk_SetAppName - changing name - not front of linked list} winSend {
+ newApp testApp
+ newApp testApp2
+ list [testApp eval tk appname testApp3] [interp delete testApp] [interp delete testApp2]
+} {testApp3 {} {}}
+test winSend-1.3 {Tk_SetAppName - unique name - no conflicts} winSend {
+ newApp testApp
+ list [testApp eval tk appname testApp] [interp delete testApp]
+} {testApp {}}
+test winSend-1.4 {Tk_SetAppName - unique name - one conflict} winSend {
+ newApp testApp
+ newApp foobar
+ list [foobar eval tk appname testApp] [interp delete foobar] [interp delete testApp]
+} {{testApp #2} {} {}}
+test winSend-1.5 {Tk_SetAppName - unique name - one conflict} winSend {
+ newApp testApp
+ newApp foobar
+ newApp blaz
+ foobar eval tk appname testApp
+ list [blaz eval tk appname testApp] [interp delete foobar] [interp delete testApp] [interp delete blaz]
+} {{testApp #3} {} {} {}}
+test winSend-1.6 {Tk_SetAppName - safe interps} winSend {
+ newApp testApp -safe
+ list [catch {testApp eval send testApp {set foo a}} msg] $msg [interp delete testApp]
+} {1 {invalid command name "send"} {}}
+
+test winSend-2.1 {Tk_SendObjCmd - # of args} winSend {
+ list [catch {send tktest} msg] $msg
+} {1 {wrong # args: should be "send ?-option value ...? interpName arg ?arg ...?"}}
+test winSend-2.1a {Tk_SendObjCmd: arguments} winSend {
+ list [catch {send -bogus tktest} msg] $msg
+} {1 {bad option "-bogus": must be -async, -displayof, or --}}
+test winSend-2.1b {Tk_SendObjCmd: arguments} winSend {
+ list [catch {send -async bogus foo} msg] $msg
+} {1 {no registered server named "bogus"}}
+test winSend-2.1c {Tk_SendObjCmd: arguments} winSend {
+ list [catch {send -displayof . bogus foo} msg] $msg
+} {1 {no registered server named "bogus"}}
+test winSend-2.1d {Tk_SendObjCmd: arguments} winSend {
+ list [catch {send -- -bogus foo} msg] $msg
+} {1 {no registered server named "-bogus"}}
+test winSend-2.2 {Tk_SendObjCmd - sending to ourselves} winSend {
+ list [send [tk appname] {set foo a}]
+} {a}
+test winSend-2.3 {Tk_SendObjCmd - sending to ourselves in a different interpreter} winSend {
+ newApp testApp
+ list [catch {send testApp {set foo b}} msg] $msg [interp delete testApp]
+} {0 b {}}
+test winSend-2.4 {Tk_SendObjCmd - sending to ourselves in a different interp with errors} winSend {
+ newApp testApp
+ list [catch {send testApp {expr 2 / 0}} msg] $msg $errorCode $errorInfo [interp delete testApp]
+} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr 2 / 0\"\n invoked from within\n\"send testApp {expr 2 / 0}\"} {}"
+test winSend-2.5 {Tk_SendObjCmd - sending to another app async} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ list [catch {send -async $interp {set foo a}} msg] $msg
+} {0 {}}
+test winSend-2.6 {Tk_SendObjCmd - sending to another app sync - no error} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ list [catch {send $interp {set foo a}} msg] $msg
+} {0 a}
+test winSend-2.7 {Tk_SendObjCmd - sending to another app - error} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ list [catch {send $interp {expr 2 / 0}} msg] $msg $errorCode $errorInfo
+} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr 2 / 0\"\n invoked from within\n\"send \$interp {expr 2 / 0}\"}"
+
+test winSend-3.1 {TkGetInterpNames} winSend {
+ set origLength [llength $currentInterps]
+ set newLength [llength [winfo interps]]
+ expr {($newLength - 2) == $origLength}
+} {1}
+
+test winSend-4.1 {DeleteProc - changing name of app} winSend {
+ newApp a
+ list [a eval tk appname foo] [interp delete a]
+} {foo {}}
+test winSend-4.2 {DeleteProc - normal} winSend {
+ newApp a
+ list [interp delete a]
+} {{}}
+
+test winSend-5.1 {ExecuteRemoteObject - no error} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ list [send $interp {send [tk appname] {expr 2 / 1}}]
+} {2}
+test winSend-5.2 {ExecuteRemoteObject - error} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ list [catch {send $interp {send [tk appname] {expr 2 / 0}}} msg] $msg
+} {1 {divide by zero}}
+
+test winSend-6.1 {SendDDEServer - XTYP_CONNECT} winSend {
+ set foo "Hello, World"
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ set command "dde request Tk [tk appname] foo"
+ list [catch "send \{$interp\} \{$command\}" msg] $msg
+} {0 {Hello, World}}
+test winSend-6.2 {SendDDEServer - XTYP_CONNECT_CONFIRM} winSend {
+ set foo "Hello, World"
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ set command "dde request Tk [tk appname] foo"
+ list [catch "send \{$interp\} \{$command\}" msg] $msg
+} {0 {Hello, World}}
+test winSend-6.3 {SendDDEServer - XTYP_DISCONNECT} winSend {
+ set foo "Hello, World"
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ set command "dde request Tk [tk appname] foo"
+ list [catch "send \{$interp\} \{$command\}" msg] $msg
+} {0 {Hello, World}}
+test winSend-6.4 {SendDDEServer - XTYP_REQUEST variable} winSend {
+ set foo "Hello, World"
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ set command "dde request Tk [tk appname] foo"
+ list [catch "send \{$interp\} \{$command\}" msg] $msg
+} {0 {Hello, World}}
+test winSend-6.5 {SendDDEServer - XTYP_REQUEST array} winSend {
+ catch {unset foo}
+ set foo(test) "Hello, World"
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ set command "dde request Tk [tk appname] foo(test)"
+ list [catch "send \{$interp\} \{$command\}" msg] $msg [catch {unset foo}]
+} {0 {Hello, World} 0}
+test winSend-6.6 {SendDDEServer - XTYP_REQUEST return results} winSend {
+ set foo 3
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ set command "send [tk appname] {expr $foo + 1}"
+ list [catch "send \{$interp\} \{$command\}" msg] $msg
+} {0 4}
+test winSend-6.7 {SendDDEServer - XTYP_EXECUTE} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ set command "send [tk appname] {expr 4 / 2}"
+ list [catch "send \{$interp\} \{$command\}" msg] $msg
+} {0 2}
+test winSend-6.8 {SendDDEServer - XTYP_WILDCONNECT} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ set command "dde services Tk {}"
+ list [catch "send \{$interp\} \{$command\}"]
+} {0}
+
+test winSend-7.1 {DDEExitProc} winSend {
+ newApp testApp
+ list [interp delete testApp]
+} {{}}
+
+test winSend-8.1 {SendDdeConnect} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ list [send $interp {set tk foo}]
+} {foo}
+
+test winSend-9.1 {SetDDEError} winSend {
+ list [catch {dde execute Tk foo {set foo hello}} msg] $msg
+} {1 {dde command failed}}
+
+test winSend-10.1 {Tk_DDEObjCmd - wrong num args} winSend {
+ list [catch {dde} msg] $msg
+} {1 {wrong # args: should be "dde ?-async? serviceName topicName value"}}
+test winSend-10.2 {Tk_DDEObjCmd - unknown subcommand} winSend {
+ list [catch {dde foo} msg] $msg
+} {1 {bad command "foo": must be execute, request, or services}}
+test winSend-10.3 {Tk_DDEObjCmd - execute - wrong num args} winSend {
+ list [catch {dde execute} msg] $msg
+} {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}}
+test winSend-10.4 {Tk_DDEObjCmd - execute - wrong num args} winSend {
+ list [catch {dde execute 3 4 5 6 7} msg] $msg
+} {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}}
+test winSend-10.5 {Tk_DDEObjCmd - execute async - wrong num args} winSend {
+ list [catch {dde execute -async} msg] $msg
+} {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}}
+test winSend-10.6 {Tk_DDEObjCmd - request - wrong num args} winSend {
+ list [catch {dde request} msg] $msg
+} {1 {wrong # args: should be "dde request serviceName topicName value"}}
+test winSend-10.7 {Tk_DDEObjCmd - services wrong num args} winSend {
+ list [catch {dde services} msg] $msg
+} {1 {wrong # args: should be "dde services serviceName topicName"}}
+test winSend-10.8 {Tk_DDEObjCmd - null service name} winSend {
+ list [catch {dde services {} {tktest #2}}]
+} {0}
+test winSend-10.9 {Tk_DDEObjCmd - null topic name} winSend {
+ list [catch {dde services {Tk} {}}]
+} {0}
+test winSend-10.10 {Tk_DDEObjCmd - execute - nothing to execute} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ list [catch {dde execute Tk $interp {}} msg] $msg
+} {1 {cannot execute null data}}
+test winSend-10.11 {Tk_DDEObjCmd - execute - no such conversation} winSend {
+ list [catch {dde execute Tk foo {set foo hello}} msg] $msg
+} {1 {dde command failed}}
+test winSend-10.12 {Tk_DDEObjCmd - execute - async} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ list [catch {dde execute -async Tk $interp {set foo hello}} msg] $msg
+} {0 {}}
+test winSend-10.13 {Tk_DDEObjCmd - execute} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ list [catch {dde execute Tk $interp {set foo goodbye}} msg] $msg
+} {0 {}}
+test winSend-10.14 {Tk_DDEObjCmd - request - nothing to request} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ list [catch {dde request Tk $interp {}} msg] $msg
+} {1 {cannot request value of null data}}
+test winSend-10.15 {Tk_DDEObjCmd - request - invalid interp} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ list [catch {dde request Tk foo foo} msg] $msg
+} {1 {dde command failed}}
+test winSend-10.16 {Tk_DDEObjCmd - invalid variable} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ send $interp {unset foo}
+ list [catch {dde request Tk $interp foo} msg] $msg
+} {1 {remote server cannot handle this command}}
+test winSend-10.17 {Tk_DDEObjCmd - valid variable} winSend {
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch $currentInterps $interp] < 0} {
+ break
+ }
+ }
+ send $interp {set foo winSend-10.17}
+ list [catch {dde request Tk $interp foo} msg] $msg
+} {0 winSend-10.17}
+test winSend-10.18 {Tk_DDEObjCmd - services} winSend {
+ set currentService [list Tk [tk appname]]
+ list [catch {dde services Tk {}} msg] [expr [lsearch $msg $currentService] >= 0]
+} {0 1}
+
+# Get rid of the other app and all of its interps
+
+set newInterps [winfo interps]
+while {[llength $newInterps] != [llength $currentInterps]} {
+ foreach interp $newInterps {
+ if {[lsearch -exact $currentInterps $interp] < 0} {
+ catch {send $interp exit}
+ set newInterps [winfo interps]
+ break
+ }
+ }
+}
+
+# cleanup
+cleanupTests
+return
diff --git a/tk8.6/tests/winWm.test b/tk8.6/tests/winWm.test
new file mode 100644
index 0000000..ad4988d
--- /dev/null
+++ b/tk8.6/tests/winWm.test
@@ -0,0 +1,577 @@
+# This file tests is a Tcl script to test the procedures in the file
+# tkWinWm.c. It is organized in the standard fashion for Tcl tests.
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1996 by Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+
+
+test winWm-1.1 {TkWmMapWindow} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm override .t 1
+ wm geometry .t +0+0
+ update
+ list [winfo rootx .t] [winfo rooty .t]
+} -cleanup {
+ destroy .t
+} -result {0 0}
+test winWm-1.2 {TkWmMapWindow} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm transient .t .
+ update
+ wm iconify .
+ update
+ wm deiconify .
+ update
+ wm iconify .t
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {can't iconify ".t": it is a transient}
+test winWm-1.3 {TkWmMapWindow} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ update
+ toplevel .t2
+ update
+ expr {[winfo x .t] != [winfo x .t2]}
+} -cleanup {
+ destroy .t .t2
+} -result 1
+test winWm-1.4 {TkWmMapWindow} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm geometry .t +10+10
+ update
+ toplevel .t2
+ wm geometry .t2 +40+10
+ update
+ list [winfo x .t] [winfo x .t2]
+} -cleanup {
+ destroy .t .t2
+} -result {10 40}
+test winWm-1.5 {TkWmMapWindow} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm iconify .t
+ update
+ wm state .t
+} -result {iconic}
+
+
+test winWm-2.1 {TkpWmSetState} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm geometry .t 150x50+10+10
+ update
+ set result [wm state .t]
+ wm iconify .t
+ update
+ lappend result [wm state .t]
+ wm deiconify .t
+ update
+ lappend result [wm state .t]
+} -cleanup {
+ destroy .t
+} -result {normal iconic normal}
+test winWm-2.2 {TkpWmSetState} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm geometry .t 150x50+10+10
+ update
+ set result [wm state .t]
+ wm withdraw .t
+ update
+ lappend result [wm state .t]
+ wm iconify .t
+ update
+ lappend result [wm state .t]
+ wm deiconify .t
+ update
+ lappend result [wm state .t]
+} -cleanup {
+ destroy .t
+} -result {normal withdrawn iconic normal}
+test winWm-2.3 {TkpWmSetState} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm geometry .t 150x50+10+10
+ update
+ set result [wm state .t]
+ wm state .t withdrawn
+ update
+ lappend result [wm state .t]
+ wm state .t iconic
+ update
+ lappend result [wm state .t]
+ wm state .t normal
+ update
+ lappend result [wm state .t]
+} -cleanup {
+ destroy .t
+} -result {normal withdrawn iconic normal}
+test winWm-2.4 {TkpWmSetState} -constraints win -setup {
+ destroy .t
+ set result {}
+} -body {
+ toplevel .t
+ wm geometry .t 150x50+10+10
+ update
+ lappend result [list [wm state .t] [wm geometry .t]]
+ wm iconify .t
+ update
+ lappend result [list [wm state .t] [wm geometry .t]]
+ wm geometry .t 200x50+10+10
+ update
+ lappend result [list [wm state .t] [wm geometry .t]]
+ wm deiconify .t
+ update
+ lappend result [list [wm state .t] [wm geometry .t]]
+} -cleanup {
+ destroy .t
+} -result {{normal 150x50+10+10} {iconic 150x50+10+10} {iconic 150x50+10+10} {normal 200x50+10+10}}
+
+
+test winWm-3.1 {ConfigureTopLevel: window geometry propagation} -constraints {
+ win
+} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm geometry .t +0+0
+ button .t.b
+ pack .t.b
+ update
+ set x [winfo x .t.b]
+ destroy .t
+ toplevel .t
+ wm geometry .t +0+0
+ button .t.b
+ update
+ pack .t.b
+ update
+ expr {$x == [winfo x .t.b]}
+} -cleanup {
+ destroy .t
+} -result 1
+
+
+test winWm-4.1 {ConfigureTopLevel: menu resizing} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ frame .t.f -width 100 -height 50
+ pack .t.f
+ menu .t.m
+ .t.m add command -label "thisisreallylong"
+ .t configure -menu .t.m
+ wm geometry .t -0-0
+ update
+ set menuheight [winfo y .t]
+ .t.m add command -label "thisisreallylong"
+ wm geometry .t -0-0
+ update
+ set menuheight [expr {$menuheight - [winfo y .t]}]
+ destroy .t
+
+ toplevel .t
+ frame .t.f -width 150 -height 50 -background red
+ pack .t.f
+ wm geometry .t -0-0
+ update
+ set y [winfo y .t]
+ menu .t.m
+ .t.m add command -label foo
+ .t configure -menu .t.m
+ update
+ expr {$y - [winfo y .t] eq $menuheight + 1}
+} -cleanup {
+ destroy .t
+} -result 1
+
+
+# This test works on 8.0p2 but has not worked on anything since 8.2.
+# It would be very strange to have a windows application increase the size
+# of the clientarea when a menu wraps so I believe this test to be wrong.
+# Original result was {50 50 50} new result may depend on the default menu
+# font
+test winWm-5.1 {UpdateGeometryInfo: menu resizing} -constraints win -setup {
+ destroy .t
+ set result {}
+} -body {
+ toplevel .t
+ frame .t.f -width 150 -height 50 -background red
+ pack .t.f
+ update
+ set result [winfo height .t]
+ menu .t.m
+ .t.m add command -label foo
+ .t configure -menu .t.m
+ update
+ lappend result [winfo height .t]
+ .t.m add command -label "thisisreallylong"
+ .t.m add command -label "thisisreallylong"
+ update
+ lappend result [winfo height .t]
+} -cleanup {
+ destroy .t
+} -result {50 50 31}
+test winWm-5.2 {UpdateGeometryInfo: menu resizing} -constraints win -setup {
+ destroy .t
+} -body {
+ set result {}
+ toplevel .t
+ frame .t.f -width 150 -height 50 -background red
+ pack .t.f
+ wm geometry .t -0-0
+ update
+ set y [winfo rooty .t]
+ lappend result [winfo height .t]
+ menu .t.m
+ .t configure -menu .t.m
+ .t.m add command -label foo
+ .t.m add command -label "thisisreallylong"
+ .t.m add command -label "thisisreallylong"
+ update
+ lappend result [winfo height .t]
+ lappend result [expr {$y - [winfo rooty .t]}]
+ destroy .t
+ return $result
+} -cleanup {
+ destroy .t
+} -result {50 50 0}
+
+test winWm-6.1 {wm attributes} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm attributes .t
+} -cleanup {
+ destroy .t
+} -result {-alpha 1.0 -transparentcolor {} -disabled 0 -fullscreen 0 -toolwindow 0 -topmost 0}
+test winWm-6.2 {wm attributes} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm attributes .t -disabled
+} -cleanup {
+ destroy .t
+} -result {0}
+test winWm-6.3 {wm attributes} -constraints win -setup {
+ destroy .t
+} -body {
+ # This isn't quite the correct error message yet, but it works.
+ toplevel .t
+ wm attributes .t -foo
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}
+
+test winWm-6.4 {wm attributes -alpha} -constraints win -setup {
+ destroy .t
+} -body {
+ # Expect this to return all 1.0 {} on pre-2K/XP
+ toplevel .t
+ set res [wm attributes .t -alpha]
+ # we don't return on set yet
+ lappend res [wm attributes .t -alpha 0.5]
+ lappend res [wm attributes .t -alpha]
+ lappend res [wm attributes .t -alpha -100]
+ lappend res [wm attributes .t -alpha]
+ lappend res [wm attributes .t -alpha 100]
+ lappend res [wm attributes .t -alpha]
+ return $res
+} -cleanup {
+ destroy .t
+} -result {1.0 {} 0.5 {} 0.0 {} 1.0}
+
+test winWm-6.5 {wm attributes -alpha} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ wm attributes .t -alpha foo
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {expected floating-point number but got "foo"}
+
+test winWm-6.6 {wm attributes -alpha} -constraints win -setup {
+ destroy .t
+} -body {
+ # This test is just to show off -alpha
+ toplevel .t
+ wm attributes .t -alpha 0.2
+ pack [label .t.l -text "Alpha Toplevel" -font "Helvetica 18 bold"]
+ tk::PlaceWindow .t center
+ update
+ if {$::tcl_platform(osVersion) >= 5.0} {
+ for {set i 0.2} {$i < 0.99} {set i [expr {$i+0.02}]} {
+ wm attributes .t -alpha $i
+ update idle
+ after 20
+ }
+ for {set i 0.99} {$i > 0.2} {set i [expr {$i-0.02}]} {
+ wm attributes .t -alpha $i
+ update idle
+ after 20
+ }
+ }
+} -cleanup {
+ destroy .t
+} -result {}
+
+test winWm-6.7 {wm attributes -transparentcolor} -constraints win -setup {
+ destroy .t
+ set res {}
+} -body {
+ # Expect this to return all "" on pre-2K/XP
+ toplevel .t
+ lappend res [wm attributes .t -transparentcolor]
+ # we don't return on set yet
+ lappend res [wm attributes .t -trans black]
+ lappend res [wm attributes .t -trans]
+ lappend res [wm attributes .t -trans "#FFFFFF"]
+ lappend res [wm attributes .t -trans]
+} -cleanup {
+ destroy .t
+} -result [list {} {} black {} "#FFFFFF"]
+
+test winWm-6.8 {wm attributes -transparentcolor} -constraints win -setup {
+ destroy .t
+} -body {
+ destroy .t
+ toplevel .t
+ wm attributes .t -tr foo
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {unknown color name "foo"}
+
+
+test winWm-7.1 {deiconify on an unmapped toplevel will raise \
+ the window and set the focus} -constraints {
+ win
+} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ lower .t
+ focus -force .
+ wm deiconify .t
+ update
+ list [wm stackorder .t isabove .] [focus]
+} -cleanup {
+ destroy .t
+} -result {1 .t}
+
+test winWm-7.2 {deiconify on an already mapped toplevel\
+ will raise the window and set the focus} -constraints {
+ win
+} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ lower .t
+ update
+ focus -force .
+ wm deiconify .t
+ update
+ list [wm stackorder .t isabove .] [focus]
+} -cleanup {
+ destroy .t
+} -result {1 .t}
+
+test winWm-7.3 {UpdateWrapper must maintain Z order} -constraints win -setup {
+ destroy .t
+} -body {
+ destroy .t
+ toplevel .t
+ lower .t
+ update
+ set res [wm stackorder .t isbelow .]
+ wm resizable .t 0 0
+ update
+ list $res [wm stackorder .t isbelow .]
+} -cleanup {
+ destroy .t
+} -result {1 1}
+
+test winWm-7.4 {UpdateWrapper must maintain focus} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ focus -force .t
+ update
+ set res [focus]
+ wm resizable .t 0 0
+ update
+ list $res [focus]
+} -cleanup {
+ destroy .t
+} -result {.t .t}
+
+
+test winWm-8.1 {Tk_WmCmd procedure, "iconphoto" option} -constraints win -body {
+ wm iconph .
+} -returnCodes error -result {wrong # args: should be "wm iconphoto window ?-default? image1 ?image2 ...?"}
+test winWm-8.2 {Tk_WmCmd procedure, "iconphoto" option} -constraints win -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ image create photo blank16 -width 16 -height 16
+ image create photo blank32 -width 32 -height 32
+ # This should just make blank icons for the window
+ wm iconphoto .t blank16 blank32
+ image delete blank16 blank32
+} -cleanup {
+ destroy .t
+} -result {}
+
+test winWm-9.0 "Bug #2799589 - delayed activation of destroyed window" -constraints win -setup {
+ proc winwm90click {w} {
+ if {![winfo ismapped $w]} { update }
+ event generate $w <Enter>
+ focus -force $w
+ event generate $w <ButtonPress-1> -x 5 -y 5
+ event generate $w <ButtonRelease-1> -x 5 -y 5
+ }
+ proc winwm90proc3 {} {
+ global winwm90done winwm90check
+ set w .sd
+ toplevel $w
+ pack [button $w.b -text "OK" -command {set winwm90check 1}]
+ bind $w.b <Map> {after idle {winwm90click %W}}
+ update idletasks
+ tkwait visibility $w
+ grab $w
+ tkwait variable winwm90check
+ grab release $w
+ destroy $w
+ after idle {set winwm90done ok}
+ }
+ proc winwm90proc2 {w} { winwm90proc3; destroy $w }
+ proc winwm90proc1 {w} {
+ toplevel $w
+ pack [button $w.b -text "Do dialog" -command [list winwm90proc2 $w]]
+ bind $w.b <Map> {bind %W <Map> {}; after idle {winwm90click %W}}
+ }
+ global winwm90done
+ set winwm90done wait
+ toplevel .t
+} -body {
+ pack [button .t.b -text "Show" -command {winwm90proc1 .tx}]
+ bind .t.b <Map> {bind %W <Map> {}; after idle {winwm90click %W}}
+ after 5000 {set winwm90done timeout}
+ vwait winwm90done
+ set winwm90done
+} -cleanup {
+ foreach cmd {proc1 proc2 proc3 click} {
+ rename winwm90$cmd {}
+ }
+ destroy .tx .t .sd
+} -result {ok}
+
+test winWm-9.1 "delayed activation of grabbed destroyed window" -constraints win -setup {
+ proc winwm91click {w} {
+ if {![winfo ismapped $w]} { update }
+ event generate $w <Enter>
+ focus -force $w
+ event generate $w <ButtonPress-1> -x 5 -y 5
+ event generate $w <ButtonRelease-1> -x 5 -y 5
+ }
+ proc winwm91proc3 {} {
+ global winwm91done winwm91check
+ set w .sd
+ toplevel $w
+ pack [button $w.b -text "OK" -command {set winwm91check 1}]
+ bind $w.b <Map> {after idle {winwm91click %W}}
+ update idletasks
+ tkwait visibility $w
+ grab $w
+ tkwait variable winwm91check
+ #skip the release: #grab release $w
+ destroy $w
+ after idle {set winwm91done ok}
+ }
+ proc winwm91proc2 {w} { winwm91proc3; destroy $w }
+ proc winwm91proc1 {w} {
+ toplevel $w
+ pack [button $w.b -text "Do dialog" -command [list winwm91proc2 $w]]
+ bind $w.b <Map> {bind %W <Map> {}; after idle {winwm91click %W}}
+ }
+ destroy .t
+ global winwm91done
+ set winwm91done wait
+ toplevel .t
+} -body {
+ pack [button .t.b -text "Show" -command {winwm91proc1 .tx}]
+ bind .t.b <Map> {bind %W <Map> {}; after idle {winwm91click %W}}
+ after 5000 {set winwm91done timeout}
+ vwait winwm91done
+ set winwm91done
+} -cleanup {
+ foreach cmd {proc1 proc2 proc3 click} {
+ rename winwm91$cmd {}
+ }
+ destroy .tx .t .sd
+} -result {ok}
+
+test winWm-9.2 "check wm forget for unmapped parent (#3205464,#2967911)" -setup {
+ destroy .t
+ toplevel .t
+ set winwm92 {}
+ frame .t.f -background blue -height 200 -width 200
+ frame .t.f.x -background red -height 100 -width 100
+} -body {
+ pack .t.f.x
+ pack .t.f
+ lappend aid [after 2000 {set ::winwm92 timeout}] [after 100 {
+ wm manage .t.f
+ wm iconify .t
+ lappend aid [after 100 {
+ wm forget .t.f
+ wm deiconify .t
+ lappend aid [after 100 {
+ pack .t.f
+ lappend aid [after 100 {
+ set ::winwm92 [expr {
+ [winfo rooty .t.f.x] == 0 ? "failed" : "ok"}]}]
+ }]
+ }]
+ }]
+ vwait ::winwm92
+ foreach id $aid {
+ after cancel $id
+ }
+ set winwm92
+} -cleanup {
+ destroy .t.f.x .t.f .t
+ unset -nocomplain winwm92 aid id
+} -result ok
+
+destroy .t
+
+# cleanup
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
+
diff --git a/tk8.6/tests/window.test b/tk8.6/tests/window.test
new file mode 100644
index 0000000..fea695a
--- /dev/null
+++ b/tk8.6/tests/window.test
@@ -0,0 +1,351 @@
+# This file is a Tcl script to test the procedures in the file
+# tkWindow.c. It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+namespace import ::tk::test::loadTkCommand
+update
+
+# XXX This file is woefully incomplete. Right now it only tests
+# a few parts of a few procedures in tkWindow.c
+
+# ----------------------------------------------------------------------
+
+test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} -setup {
+ destroy .t
+} -body {
+ proc bgerror msg {
+ global x errorInfo
+ set x [list $msg $errorInfo]
+ }
+
+ set x unchanged
+ frame .t -width 100 -height 50
+ place .t -x 10 -y 10
+ bind .t <Destroy> {button .t.b -text hello; pack .t.b}
+ update
+ destroy .t
+ update
+ set x
+} -cleanup {
+ rename bgerror {}
+} -result {{can't create window: parent has been destroyed} {can't create window: parent has been destroyed
+ while executing
+"button .t.b -text hello"
+ (command bound to event)}}
+
+
+# Most of the tests below don't produce meaningful results; they
+# will simply dump core if there are bugs.
+
+test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup {
+ destroy .t
+} -body {
+ toplevel .t -width 300 -height 200
+ wm geometry .t +0+0
+ frame .t.f -width 200 -height 200 -relief raised -bd 2
+ place .t.f -x 0 -y 0
+ frame .t.f.f -width 100 -height 100 -relief raised -bd 2
+ place .t.f.f -relx 1 -rely 1 -anchor se
+ bind .t.f <Destroy> {destroy .t}
+ update
+ destroy .t.f
+} -result {}
+test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup {
+ destroy .t
+} -body {
+ toplevel .t -width 300 -height 200
+ wm geometry .t +0+0
+ frame .t.f -width 200 -height 200 -relief raised -bd 2
+ place .t.f -x 0 -y 0
+ frame .t.f.f -width 100 -height 100 -relief raised -bd 2
+ place .t.f.f -relx 1 -rely 1 -anchor se
+ bind .t.f.f <Destroy> {destroy .t}
+ update
+ destroy .t.f
+} -result {}
+test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup {
+ destroy .f
+} -body {
+ frame .f -width 80 -height 120 -relief raised -bd 2
+ place .f -relx 0.5 -rely 0.5 -anchor center
+ toplevel .f.t -width 300 -height 200
+ wm geometry .f.t +0+0
+ frame .f.t.f -width 200 -height 200 -relief raised -bd 2
+ place .f.t.f -x 0 -y 0
+ frame .f.t.f.f -width 100 -height 100 -relief raised -bd 2
+ place .f.t.f.f -relx 1 -rely 1 -anchor se
+ update
+ destroy .f
+} -result {}
+
+test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} -constraints {
+ unixOrWin
+} -body {
+ set code [loadTkCommand]
+ append code {
+ update
+ bind . <Destroy> exit
+ destroy .
+ }
+ set script [makeFile $code script]
+ if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
+ set error 1
+ } else {
+ set error 0
+ }
+ removeFile script
+ list $error $msg
+} -result {0 {}}
+
+test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints {
+ unixOrWin
+} -body {
+ set code [loadTkCommand]
+ append code {
+ toplevel .t
+ update
+ bind .t <Destroy> exit
+ destroy .t
+ }
+ set script [makeFile $code script]
+ if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
+ set error 1
+ } else {
+ set error 0
+ }
+ removeFile script
+ list $error $msg
+} -result {0 {}}
+
+test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints {
+ unixOrWin
+} -body {
+ set code [loadTkCommand]
+ append code {
+ toplevel .t
+ update
+ bind .t <Destroy> exit
+ destroy .
+ }
+ set script [makeFile $code script]
+ if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
+ set error 1
+ } else {
+ set error 0
+ }
+ removeFile script
+ list $error $msg
+} -result {0 {}}
+
+test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints {
+ unixOrWin
+} -body {
+ set code [loadTkCommand]
+ append code {
+ toplevel .t
+ toplevel .t.f
+ update
+ bind .t.f <Destroy> exit
+ destroy .
+ }
+ set script [makeFile $code script]
+ if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
+ set error 1
+ } else {
+ set error 0
+ }
+ removeFile script
+ list $error $msg
+} -result {0 {}}
+
+test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints {
+ unixOrWin
+} -body {
+ set code [loadTkCommand]
+ append code {
+ toplevel .t1
+ toplevel .t2
+ toplevel .t3
+ update
+ bind .t3 <Destroy> {destroy .t2}
+ bind .t2 <Destroy> {destroy .t1}
+ bind .t1 <Destroy> {exit 0}
+ destroy .t3
+ }
+ set script [makeFile $code script]
+ if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
+ set error 1
+ } else {
+ set error 0
+ }
+ removeFile script
+ list $error $msg
+} -result {0 {}}
+
+test window-2.9 {Tk_DestroyWindow, Destroy bindings evaluated after exit} -constraints {
+ unixOrWin
+} -body {
+ set code [loadTkCommand]
+ append code {
+ toplevel .t1
+ toplevel .t2
+ update
+ bind .t2 <Destroy> {puts "Destroy .t2" ; exit 1}
+ bind .t1 <Destroy> {puts "Destroy .t1" ; exit 0}
+ destroy .t2
+ }
+ set script [makeFile $code script]
+ if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
+ set error 1
+ } else {
+ set error 0
+ }
+ removeFile script
+ list $error $msg
+} -result {0 {Destroy .t2
+Destroy .t1}}
+
+test window-2.10 {Tk_DestroyWindow, Destroy binding evaluated once} -constraints {
+ unixOrWin
+} -body {
+ set code [loadTkCommand]
+ append code {
+ update
+ bind . <Destroy> {
+ puts "Destroy ."
+ bind . <Destroy> {puts "Re-Destroy ."}
+ exit 0
+ }
+ destroy .
+ }
+ set script [makeFile $code script]
+ if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
+ set error 1
+ } else {
+ set error 0
+ }
+ removeFile script
+ list $error $msg
+} -result {0 {Destroy .}}
+
+test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} -constraints {
+ unixOrWin
+} -body {
+ set code [loadTkCommand]
+ append code {
+ toplevel .t1
+ toplevel .t2
+ update
+ bind .t1 <Destroy> {
+ if {[catch {entry .t2.newchild}]} {
+ puts YES
+ } else {
+ puts NO
+ }
+ }
+ bind .t2 <Destroy> {exit}
+ destroy .t2
+ }
+ set script [makeFile $code script]
+ if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
+ set error 1
+ } else {
+ set error 0
+ }
+ removeFile script
+ list $error $msg
+} -result {0 YES}
+
+
+test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints {
+ unix testmenubar
+} -setup {
+ destroy .t
+} -body {
+ toplevel .t -width 300 -height 200
+ wm geometry .t +0+0
+ pack [entry .t.e]
+ frame .t.f -bd 2 -relief raised
+ testmenubar window .t .t.f
+ update
+ # If stacking order isn't handle properly, generates an X error.
+} -cleanup {
+ destroy .t
+} -result {}
+test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints {
+ unix testmenubar
+} -setup {
+ destroy .t
+} -body {
+ toplevel .t -width 300 -height 200
+ wm geometry .t +0+0
+ pack [entry .t.e]
+ pack [entry .t.e2]
+ update
+ frame .t.f -bd 2 -relief raised
+ raise .t.f .t.e
+ testmenubar window .t .t.f
+ update
+ # If stacking order isn't handled properly, generates an X error.
+} -cleanup {
+ destroy .t
+} -result {}
+
+
+test window-4.1 {Tk_NameToWindow procedure} -constraints {
+ testmenubar
+} -setup {
+ destroy .t
+} -body {
+ winfo geometry .t
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad window path name ".t"}
+test window-4.2 {Tk_NameToWindow procedure} -constraints {
+ testmenubar
+} -setup {
+ destroy .t
+} -body {
+ frame .t -width 100 -height 50
+ place .t -x 10 -y 10
+ update
+ winfo geometry .t
+} -cleanup {
+ destroy .t
+} -returnCodes ok -result {100x50+10+10}
+
+
+test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints {
+ unix testmenubar
+} -setup {
+ destroy .t
+} -body {
+ toplevel .t -width 300 -height 200
+ wm geometry .t +0+0
+ pack [entry .t.e]
+ pack [entry .t.e2]
+ frame .t.f -bd 2 -relief raised
+ testmenubar window .t .t.f
+ update
+ lower .t.e2 .t.f
+ update
+ # If stacking order isn't handled properly, generates an X error.
+} -cleanup {
+ destroy .t
+} -result {}
+
+
+# cleanup
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/winfo.test b/tk8.6/tests/winfo.test
new file mode 100644
index 0000000..14c2838
--- /dev/null
+++ b/tk8.6/tests/winfo.test
@@ -0,0 +1,485 @@
+# This file is a Tcl script to test out the "winfo" command. It is
+# organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+
+# eatColors --
+# Creates a toplevel window and allocates enough colors in it to
+# use up all the slots in the colormap.
+#
+# Arguments:
+# w - Name of toplevel window to create.
+# options - Options for w, such as "-colormap new".
+
+proc eatColors {w {options ""}} {
+ destroy $w
+ eval toplevel $w $options
+ wm geom $w +0+0
+ canvas $w.c -width 400 -height 200 -bd 0
+ pack $w.c
+ for {set y 0} {$y < 8} {incr y} {
+ for {set x 0} {$x < 40} {incr x} {
+ set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
+ $w.c create rectangle [expr 10*$x] [expr 20*$y] \
+ [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
+ -fill $color
+ }
+ }
+ update
+}
+
+# XXX - This test file is woefully incomplete. At present, only a
+# few of the winfo options are tested.
+
+# ----------------------------------------------------------------------
+
+test winfo-1.1 {"winfo atom" command} -body {
+ winfo atom
+} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"}
+test winfo-1.2 {"winfo atom" command} -body {
+ winfo atom a b
+} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"}
+test winfo-1.3 {"winfo atom" command} -body {
+ winfo atom a b c d
+} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"}
+test winfo-1.4 {"winfo atom" command} -body {
+ winfo atom -displayof geek foo
+} -returnCodes error -result {bad window path name "geek"}
+test winfo-1.5 {"winfo atom" command} -body {
+ winfo atom PRIMARY
+} -result 1
+test winfo-1.6 {"winfo atom" command} -body {
+ winfo atom -displayof . PRIMARY
+} -result 1
+
+
+test winfo-2.1 {"winfo atomname" command} -body {
+ winfo atomname
+} -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"}
+test winfo-2.2 {"winfo atomname" command} -body {
+ winfo atomname a b
+} -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"}
+test winfo-2.3 {"winfo atomname" command} -body {
+ winfo atomname a b c d
+} -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"}
+test winfo-2.4 {"winfo atomname" command} -body {
+ winfo atomname -displayof geek foo
+} -returnCodes error -result {bad window path name "geek"}
+test winfo-2.5 {"winfo atomname" command} -body {
+ winfo atomname 44215
+} -returnCodes error -result {no atom exists with id "44215"}
+test winfo-2.6 {"winfo atomname" command} -body {
+ winfo atomname 2
+} -result SECONDARY
+test winfo-2.7 {"winfo atom" command} -body {
+ winfo atomname -displayof . 2
+} -result SECONDARY
+
+
+test winfo-3.1 {"winfo colormapfull" command} -constraints {
+ defaultPseudocolor8
+} -body {
+ winfo colormapfull
+} -returnCodes error -result {wrong # args: should be "winfo colormapfull window"}
+test winfo-3.2 {"winfo colormapfull" command} -constraints {
+ defaultPseudocolor8
+} -body {
+ winfo colormapfull a b
+} -returnCodes error -result {wrong # args: should be "winfo colormapfull window"}
+test winfo-3.3 {"winfo colormapfull" command} -constraints {
+ defaultPseudocolor8
+} -body {
+ winfo colormapfull foo
+} -returnCodes error -result {bad window path name "foo"}
+test winfo-3.4 {"winfo colormapfull" command} -constraints {
+ unix defaultPseudocolor8
+} -body {
+ eatColors .t {-colormap new}
+ set result [list [winfo colormapfull .] [winfo colormapfull .t]]
+ .t.c delete 34
+ lappend result [winfo colormapfull .t]
+ .t.c create rectangle 30 30 80 80 -fill #441739
+ lappend result [winfo colormapfull .t]
+ .t.c create rectangle 40 40 90 90 -fill #ffeedd
+ lappend result [winfo colormapfull .t]
+ destroy .t.c
+ lappend result [winfo colormapfull .t]
+} -cleanup {
+ destroy .t
+} -result {0 1 0 0 1 0}
+
+
+
+test winfo-4.1 {"winfo containing" command} -body {
+ winfo containing 22
+} -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}
+test winfo-4.2 {"winfo containing" command} -body {
+ winfo containing a b c
+} -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}
+test winfo-4.3 {"winfo containing" command} -body {
+ winfo containing a b c d e
+} -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}
+test winfo-4.4 {"winfo containing" command} -body {
+ winfo containing -displayof geek 25 30
+} -returnCodes error -result {bad window path name "geek"}
+test winfo-4.5 {"winfo containing" command} -body {
+} -setup {
+ destroy .t
+} -body {
+ toplevel .t -width 550 -height 400
+ frame .t.f -width 80 -height 60 -bd 2 -relief raised
+ place .t.f -x 50 -y 50
+ wm geom .t +0+0
+ update
+
+ raise .t
+ winfo containing [winfo rootx .t.f] [winfo rooty .t.f]
+} -cleanup {
+ destroy .t
+} -result .t.f
+test winfo-4.6 {"winfo containing" command} -constraints {
+ nonPortable
+} -setup {
+ destroy .t
+} -body {
+ toplevel .t -width 550 -height 400
+ frame .t.f -width 80 -height 60 -bd 2 -relief raised
+ place .t.f -x 50 -y 50
+ wm geom .t +0+0
+ update
+
+ winfo containing [expr [winfo rootx .t.f]-1] [expr [winfo rooty .t.f]-1]
+} -cleanup {
+ destroy .t
+} -result .t
+test winfo-4.7 {"winfo containing" command} -setup {
+ destroy .t
+} -body {
+ toplevel .t -width 550 -height 400
+ frame .t.f -width 80 -height 60 -bd 2 -relief raised
+ place .t.f -x 50 -y 50
+ wm geom .t +0+0
+ update
+
+ set x [winfo containing -display .t.f [expr [winfo rootx .t]+600] \
+ [expr [winfo rooty .t.f]+450]]
+ expr {($x == ".") || ($x == "")}
+} -cleanup {
+ destroy .t
+} -result {1}
+
+
+test winfo-5.1 {"winfo interps" command} -body {
+ winfo interps a
+} -returnCodes error -result {wrong # args: should be "winfo interps ?-displayof window?"}
+test winfo-5.2 {"winfo interps" command} -body {
+ winfo interps a b c
+} -returnCodes error -result {wrong # args: should be "winfo interps ?-displayof window?"}
+test winfo-5.3 {"winfo interps" command} -body {
+ winfo interps -displayof geek
+} -returnCodes error -result {bad window path name "geek"}
+test winfo-5.4 {"winfo interps" command} -constraints unix -body {
+ expr {[lsearch -exact [winfo interps] [tk appname]] >= 0}
+} -result {1}
+test winfo-5.5 {"winfo interps" command} -constraints unix -body {
+ expr {[lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0}
+} -result {1}
+
+
+test winfo-6.1 {"winfo exists" command} -body {
+ winfo exists
+} -returnCodes error -result {wrong # args: should be "winfo exists window"}
+test winfo-6.2 {"winfo exists" command} -body {
+ winfo exists a b
+} -returnCodes error -result {wrong # args: should be "winfo exists window"}
+test winfo-6.3 {"winfo exists" command} -body {
+ winfo exists gorp
+} -result {0}
+test winfo-6.4 {"winfo exists" command} -body {
+ winfo exists .
+} -result {1}
+test winfo-6.5 {"winfo exists" command} -setup {
+ destroy .b
+} -body {
+ button .b -text "Test button"
+ set x [winfo exists .b]
+ pack .b
+ update
+ bind .b <Destroy> {lappend x [winfo exists .x]}
+ destroy .b
+ lappend x [winfo exists .x]
+} -result {1 0 0}
+
+
+test winfo-7.1 {"winfo pathname" command} -body {
+ winfo pathname
+} -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"}
+test winfo-7.2 {"winfo pathname" command} -body {
+ winfo pathname a b
+} -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"}
+test winfo-7.3 {"winfo pathname" command} -body {
+ winfo pathname a b c d
+} -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"}
+test winfo-7.4 {"winfo pathname" command} -body {
+ winfo pathname -displayof geek 25
+} -returnCodes error -result {bad window path name "geek"}
+test winfo-7.5 {"winfo pathname" command} -body {
+ winfo pathname xyz
+} -returnCodes error -result {expected integer but got "xyz"}
+test winfo-7.6 {"winfo pathname" command} -body {
+ winfo pathname 224
+} -returnCodes error -result {window id "224" doesn't exist in this application}
+test winfo-7.7 {"winfo pathname" command} -setup {
+ destroy .b
+ button .b -text "Help"
+ update
+} -body {
+ winfo pathname -displayof .b [winfo id .]
+} -cleanup {
+ destroy .b
+} -result {.}
+test winfo-7.8 {"winfo pathname" command} -constraints {
+ unix testwrapper
+} -body {
+ winfo pathname [testwrapper .]
+} -result {}
+
+
+test winfo-8.1 {"winfo pointerx" command} -setup {
+ destroy .b
+ button .b -text "Help"
+ update
+} -body {
+ catch [winfo pointerx .b]
+} -body {
+ catch [winfo pointerx .b]
+} -result 1
+test winfo-8.2 {"winfo pointery" command} -setup {
+ destroy .b
+ button .b -text "Help"
+ update
+} -body {
+ catch [winfo pointery .b]
+} -body {
+ catch [winfo pointerx .b]
+} -result 1
+test winfo-8.3 {"winfo pointerxy" command} -setup {
+ destroy .b
+ button .b -text "Help"
+ update
+} -body {
+ catch [winfo pointerxy .b]
+} -body {
+ catch [winfo pointerx .b]
+} -result 1
+
+
+test winfo-9.1 {"winfo viewable" command} -body {
+ winfo viewable
+} -returnCodes error -result {wrong # args: should be "winfo viewable window"}
+test winfo-9.2 {"winfo viewable" command} -body {
+ winfo viewable foo
+} -returnCodes error -result {bad window path name "foo"}
+test winfo-9.3 {"winfo viewable" command} -body {
+ winfo viewable .
+} -result {1}
+test winfo-9.4 {"winfo viewable" command} -body {
+ wm iconify .
+ winfo viewable .
+} -cleanup {
+ wm deiconify .
+} -result {0}
+test winfo-9.5 {"winfo viewable" command} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -width 100 -height 100 -relief raised -bd 2
+ place .f1 -x 0 -y 0
+ frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
+ place .f1.f2 -x 0 -y 0
+ update
+ list [winfo viewable .f1] [winfo viewable .f1.f2]
+} -cleanup {
+ deleteWindows
+} -result {1 1}
+test winfo-9.6 {"winfo viewable" command} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -width 100 -height 100 -relief raised -bd 2
+ frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
+ place .f1.f2 -x 0 -y 0
+ update
+ list [winfo viewable .f1] [winfo viewable .f1.f2]
+} -cleanup {
+ deleteWindows
+} -result {0 0}
+test winfo-9.7 {"winfo viewable" command} -setup {
+ deleteWindows
+} -body {
+ frame .f1 -width 100 -height 100 -relief raised -bd 2
+ place .f1 -x 0 -y 0
+ frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
+ place .f1.f2 -x 0 -y 0
+ update
+ wm iconify .
+ list [winfo viewable .f1] [winfo viewable .f1.f2]
+} -cleanup {
+ wm deiconify .
+ deleteWindows
+} -result {0 0}
+
+
+test winfo-10.1 {"winfo visualid" command} -body {
+ winfo visualid
+} -returnCodes error -result {wrong # args: should be "winfo visualid window"}
+test winfo-10.2 {"winfo visualid" command} -body {
+ winfo visualid gorp
+} -returnCodes error -result {bad window path name "gorp"}
+test winfo-10.3 {"winfo visualid" command} -body {
+ expr {2 + [winfo visualid .] - [winfo visualid .]}
+} -result {2}
+
+
+test winfo-11.1 {"winfo visualid" command} -body {
+ winfo visualsavailable
+} -returnCodes error -result {wrong # args: should be "winfo visualsavailable window ?includeids?"}
+test winfo-11.2 {"winfo visualid" command} -body {
+ winfo visualsavailable gorp
+} -returnCodes error -result {bad window path name "gorp"}
+test winfo-11.3 {"winfo visualid" command} -body {
+ winfo visualsavailable . includeids foo
+} -returnCodes error -result {wrong # args: should be "winfo visualsavailable window ?includeids?"}
+test winfo-11.4 {"winfo visualid" command} -body {
+ llength [lindex [winfo visualsa .] 0]
+} -result {2}
+test winfo-11.5 {"winfo visualid" command} -body {
+ llength [lindex [winfo visualsa . includeids] 0]
+} -result {3}
+test winfo-11.6 {"winfo visualid" command} -body {
+ set x [lindex [lindex [winfo visualsa . includeids] 0] 2]
+ expr $x + 2 - $x
+} -result {2}
+
+
+test winfo-12.1 {GetDisplayOf procedure} -body {
+ winfo atom - foo x
+} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"}
+test winfo-12.2 {GetDisplayOf procedure} -body {
+ winfo atom -d bad_window x
+} -returnCodes error -result {bad window path name "bad_window"}
+
+
+# Some embedding tests
+#
+test winfo-13.1 {root coordinates of embedded toplevel} -setup {
+ deleteWindows
+} -body {
+ frame .con -container 1
+ pack .con -expand yes -fill both
+ toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0
+ button .emb.b
+ pack .emb.b -expand yes -fill both
+ update
+
+ list rootx [expr {[winfo rootx .emb] == [winfo rootx .con]}] \
+ rooty [expr {[winfo rooty .emb] == [winfo rooty .con]}]
+} -cleanup {
+ deleteWindows
+} -result {rootx 1 rooty 1}
+
+test winfo-13.2 {destroying embedded toplevel} -setup {
+ deleteWindows
+} -body {
+ frame .con -container 1
+ pack .con -expand yes -fill both
+ toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0
+ button .emb.b
+ pack .emb.b -expand yes -fill both
+ update
+
+ destroy .emb
+ update
+ list embedded [winfo exists .emb.b] container [winfo exists .con]
+} -cleanup {
+ deleteWindows
+} -result {embedded 0 container 1}
+
+test winfo-13.3 {destroying container window} -setup {
+ deleteWindows
+} -body {
+ frame .con -container 1
+ pack .con -expand yes -fill both
+ toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0
+ button .emb.b
+ pack .emb.b -expand yes -fill both
+ update
+
+ destroy .con
+ update
+ list child [winfo exists .emb.b] parent [winfo exists .emb]
+} -cleanup {
+ deleteWindows
+} -result {child 0 parent 0}
+
+test winfo-13.4 {[winfo containing] with embedded windows} -setup {
+ deleteWindows
+} -body {
+ frame .con -container 1
+ pack .con -expand yes -fill both
+ toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0
+ button .emb.b
+ pack .emb.b -expand yes -fill both
+ update
+
+ button .b
+ pack .b -expand yes -fill both
+ update
+ string compare .emb.b \
+ [winfo containing [winfo rootx .emb.b] [winfo rooty .emb.b]]
+} -cleanup {
+ deleteWindows
+} -result 0
+
+
+test winfo-14.1 {usage} -body {
+ winfo ismapped
+} -returnCodes error -result {wrong # args: should be "winfo ismapped window"}
+
+test winfo-14.2 {usage} -body {
+ winfo ismapped . .
+} -returnCodes error -result {wrong # args: should be "winfo ismapped window"}
+
+test winfo-14.3 {initially unmapped} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ winfo ismapped .t
+} -cleanup {
+ destroy .t
+} -result 0
+
+test winfo-14.4 {mapped at idle time} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ update idletasks
+ winfo ismapped .t
+} -cleanup {
+ destroy .t
+} -result 1
+
+deleteWindows
+# cleanup
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/wm.test b/tk8.6/tests/wm.test
new file mode 100644
index 0000000..afcc2cd
--- /dev/null
+++ b/tk8.6/tests/wm.test
@@ -0,0 +1,2321 @@
+# This file is a Tcl script to test out Tk's interactions with the window
+# manager, including the "wm" command. It is organized in the standard fashion
+# for Tcl tests.
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+# This file tests window manager interactions that work across platforms.
+# Window manager tests that only work on a specific platform should be placed
+# in unixWm.test or winWm.test.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+wm deiconify .
+if {![winfo ismapped .]} {
+ tkwait visibility .
+}
+
+proc stdWindow {} {
+ destroy .t
+ toplevel .t -width 100 -height 50
+ wm geom .t +0+0
+ update
+}
+
+# [raise] and [lower] may return before the window manager has completed the
+# operation. The raiseDelay procedure idles for a while to give the operation
+# a chance to complete.
+#
+
+proc raiseDelay {} {
+ after 100; update
+}
+
+# How to carry out a small delay while processing events
+
+proc eventDelay {{delay 200}} {
+ after $delay "set done 1" ; vwait done
+}
+
+deleteWindows
+
+##############################################################################
+
+stdWindow
+
+test wm-1.1 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body {
+ wm
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+# Next test will fail every time set of subcommands is changed
+test wm-1.2 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body {
+ wm foo
+} -result {bad option "foo": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, forget, frame, geometry, grid, group, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, manage, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw}
+test wm-1.3 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body {
+ wm command
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-1.4 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body {
+ wm aspect bogus
+} -result {bad window path name "bogus"}
+test wm-1.5 {Tk_WmObjCmd procedure, miscellaneous errors} -body {
+ button .b -text hello
+ wm geometry .b
+} -returnCodes error -cleanup {
+ destroy .b
+} -result {window ".b" isn't a top-level window}
+
+
+### wm aspect ###
+test wm-aspect-1.1 {usage} -returnCodes error -body {
+ wm aspect
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-aspect-1.2 {usage} -returnCodes error -body {
+ wm aspect . _
+} -result {wrong # args: should be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"}
+test wm-aspect-1.3 {usage} -returnCodes error -body {
+ wm aspect . _ _ _
+} -result {wrong # args: should be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"}
+test wm-aspect-1.4 {usage} -returnCodes error -body {
+ wm aspect . _ _ _ _ _
+} -result {wrong # args: should be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"}
+test wm-aspect-1.5 {usage} -returnCodes error -body {
+ wm aspect . bad 14 15 16
+} -result {expected integer but got "bad"}
+test wm-aspect-1.6 {usage} -returnCodes error -body {
+ wm aspect . 13 foo 15 16
+} -result {expected integer but got "foo"}
+test wm-aspect-1.7 {usage} -returnCodes error -body {
+ wm aspect . 13 14 bar 16
+} -result {expected integer but got "bar"}
+test wm-aspect-1.8 {usage} -returnCodes error -body {
+ wm aspect . 13 14 15 baz
+} -result {expected integer but got "baz"}
+test wm-aspect-1.9 {usage} -returnCodes error -body {
+ wm aspect . 0 14 15 16
+} -result {aspect number can't be <= 0}
+test wm-aspect-1.10 {usage} -returnCodes error -body {
+ wm aspect . 13 0 15 16
+} -result {aspect number can't be <= 0}
+test wm-aspect-1.11 {usage} -returnCodes error -body {
+ wm aspect . 13 14 0 16
+} -result {aspect number can't be <= 0}
+test wm-aspect-1.12 {usage} -returnCodes error -body {
+ wm aspect . 13 14 15 0
+} -result {aspect number can't be <= 0}
+
+test wm-aspect-2.1 {setting and reading values} -setup {
+ set result {}
+} -body {
+ lappend result [wm aspect .t]
+ wm aspect .t 3 4 10 2
+ lappend result [wm aspect .t]
+ wm aspect .t {} {} {} {}
+ lappend result [wm aspect .t]
+} -result [list {} {3 4 10 2} {}]
+
+
+### wm attributes ###
+test wm-attributes-1.1 {usage} -returnCodes error -body {
+ wm attributes
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-attributes-1.2.1 {usage} -constraints win -returnCodes error -body {
+ # This is the wrong error to output - unix has it right, but it's
+ # not critical.
+ wm attributes . _
+} -result {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}
+test wm-attributes-1.2.2 {usage} -constraints win -returnCodes error -body {
+ wm attributes . -alpha 1.0 -disabled
+} -result {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}
+test wm-attributes-1.2.3 {usage} -constraints win -returnCodes error -body {
+ # This is the wrong error to output - unix has it right, but it's
+ # not critical.
+ wm attributes . -to
+} -result {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}
+test wm-attributes-1.2.4 {usage} -constraints {unix notAqua} -returnCodes error -body {
+ wm attributes . _
+} -result {bad attribute "_": must be -alpha, -topmost, -zoomed, -fullscreen, or -type}
+test wm-attributes-1.2.5 {usage} -constraints aqua -returnCodes error -body {
+ wm attributes . _
+} -result {bad attribute "_": must be -alpha, -modified, -notify, or -titlepath}
+
+
+### wm client ###
+test wm-client-1.1 {usage} -returnCodes error -body {
+ wm client
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-client-1.2 {usage} -returnCodes error -body {
+ wm client . _ _
+} -result {wrong # args: should be "wm client window ?name?"}
+
+test wm-client-2.1 {setting and reading values} -setup {
+ set result {}
+} -body {
+ lappend result [wm client .t]
+ wm client .t Miffo
+ lappend result [wm client .t]
+ wm client .t {}
+ lappend result [wm client .t]
+} -result [list {} Miffo {}]
+
+deleteWindows
+
+test wm-attributes-1.3.0 {default -fullscreen value} -constraints win -body {
+ toplevel .t
+ wm attributes .t -fullscreen
+} -cleanup {
+ deleteWindows
+} -result 0
+test wm-attributes-1.3.1 {change -fullscreen before map} -constraints win -body {
+ toplevel .t
+ wm attributes .t -fullscreen 1
+ wm attributes .t -fullscreen
+} -cleanup {
+ deleteWindows
+} -result 1
+test wm-attributes-1.3.2 {change -fullscreen before map} -constraints win -body {
+ toplevel .t
+ wm attributes .t -fullscreen 1
+ update
+ wm attributes .t -fullscreen
+} -cleanup {
+ deleteWindows
+} -result 1
+test wm-attributes-1.3.3 {change -fullscreen after map} -constraints win -body {
+ toplevel .t
+ update
+ wm attributes .t -fullscreen 1
+ wm attributes .t -fullscreen
+} -cleanup {
+ deleteWindows
+} -result 1
+test wm-attributes-1.3.4 {change -fullscreen after map} -setup {
+ set booleans [list]
+} -constraints win -body {
+ toplevel .t
+ update
+ lappend booleans [wm attributes .t -fullscreen]
+ wm attributes .t -fullscreen 1
+ lappend booleans [wm attributes .t -fullscreen]
+ # Query above should not clear fullscreen state
+ lappend booleans [wm attributes .t -fullscreen]
+ wm attributes .t -fullscreen 0
+ lappend booleans [wm attributes .t -fullscreen]
+} -cleanup {
+ deleteWindows
+} -result {0 1 1 0}
+test wm-attributes-1.3.5 {change -fullscreen after map} -setup {
+ set results [list]
+ set normal_geom "301x302+101+102"
+ set fullscreen_geom "[winfo screenwidth .]x[winfo screenheight .]+0+0"
+} -constraints win -body {
+ toplevel .t
+ wm geom .t $normal_geom
+ update
+ lappend results [string equal [wm geom .t] $normal_geom]
+ wm attributes .t -fullscreen 1
+ lappend results [string equal [wm geom .t] $fullscreen_geom]
+ wm attributes .t -fullscreen 0
+ lappend results [string equal [wm geom .t] $normal_geom]
+} -cleanup {
+ deleteWindows
+} -result {1 1 1}
+test wm-attributes-1.3.6 {state change does not change -fullscreen} -constraints win -body {
+ toplevel .t
+ update
+ wm attributes .t -fullscreen 1
+ wm withdraw .t
+ wm deiconify .t
+ wm attributes .t -fullscreen
+} -cleanup {
+ deleteWindows
+} -result 1
+test wm-attributes-1.3.7 {state change does not change -fullscreen} -constraints win -body {
+ toplevel .t
+ update
+ wm attributes .t -fullscreen 1
+ wm iconify .t
+ wm deiconify .t
+ wm attributes .t -fullscreen
+} -cleanup {
+ deleteWindows
+} -result 1
+test wm-attributes-1.3.8 {override-redirect not compatible with fullscreen attribute} -constraints win -body {
+ toplevel .t
+ update
+ wm overrideredirect .t 1
+ wm attributes .t -fullscreen 1
+} -returnCodes error -cleanup {
+ deleteWindows
+} -result {can't set fullscreen attribute for ".t": override-redirect flag is set}
+test wm-attributes-1.3.9 {max height too small} -constraints win -body {
+ toplevel .t
+ update
+ wm maxsize .t 5000 450
+ wm attributes .t -fullscreen 1
+} -returnCodes error -cleanup {
+ deleteWindows
+} -result {can't set fullscreen attribute for ".t": max width/height is too small}
+test wm-attributes-1.3.10 {max height too small} -constraints win -body {
+ toplevel .t
+ update
+ wm maxsize .t 450 5000
+ wm attributes .t -fullscreen 1
+} -returnCodes error -cleanup {
+ deleteWindows
+} -result {can't set fullscreen attribute for ".t": max width/height is too small}
+test wm-attributes-1.3.11 {another attribute, then -fullscreen} -constraints win -body {
+ toplevel .t
+ update
+ wm attributes .t -alpha 1.0 -fullscreen 1
+ wm attributes .t -fullscreen
+} -cleanup {
+ deleteWindows
+} -result 1
+test wm-attributes-1.3.12 {another attribute, then -fullscreen, then another} -constraints win -body {
+ toplevel .t
+ update
+ wm attributes .t -toolwindow 0 -fullscreen 1 -topmost 0
+ wm attributes .t -fullscreen
+} -cleanup {
+ deleteWindows
+} -result 1
+
+test wm-attributes-1.4.0 {setting/unsetting fullscreen does not change the focus} -setup {
+ set results [list]
+} -constraints win -body {
+ focus -force .
+ toplevel .t
+ lower .t
+ update
+ lappend results [focus]
+
+ wm attributes .t -fullscreen 1
+ eventDelay
+ lappend results [focus]
+
+ wm attributes .t -fullscreen 0
+ eventDelay
+ lappend results [focus]
+} -cleanup {
+ deleteWindows
+} -result {. . .}
+test wm-attributes-1.4.1 {setting fullscreen does not generate FocusIn on wrapper create} -setup {
+ catch {unset focusin}
+} -constraints win -body {
+ focus -force .
+ toplevel .t
+ pack [entry .t.e]
+ lower .t
+ bind .t <FocusIn> {lappend focusin %W}
+ eventDelay
+
+ lappend focusin 1
+ focus -force .t.e
+ eventDelay
+
+ lappend focusin 2
+ wm attributes .t -fullscreen 1
+ eventDelay
+
+ lappend focusin 3
+ wm attributes .t -fullscreen 0
+ eventDelay
+
+ lappend focusin final [focus]
+} -cleanup {
+ bind . <FocusIn> {}
+ bind .t <FocusIn> {}
+ deleteWindows
+} -result {1 .t .t.e 2 3 final .t.e}
+
+test wm-attributes-1.5.0 {fullscreen stackorder} -setup {
+ set results [list]
+} -constraints win -body {
+ toplevel .t
+ lappend results [wm stackorder .]
+ eventDelay
+ lappend results [wm stackorder .]
+
+ # Default stacking is on top of other windows on the display. Setting the
+ # fullscreen attribute does not change this.
+ wm attributes .t -fullscreen 1
+ eventDelay
+ lappend results [wm stackorder .]
+} -cleanup {
+ deleteWindows
+} -result {. {. .t} {. .t}}
+test wm-attributes-1.5.1 {fullscreen stackorder} -setup {
+ set results [list]
+} -constraints win -body {
+ toplevel .t
+ lower .t
+ eventDelay
+ lappend results [wm stackorder .]
+
+ # If stacking order is explicitly set, then setting the fullscreen
+ # attribute should not change it.
+ wm attributes .t -fullscreen 1
+ eventDelay
+ lappend results [wm stackorder .]
+} -cleanup {
+ deleteWindows
+} -result {{.t .} {.t .}}
+test wm-attributes-1.5.2 {fullscreen stackorder} -setup {
+ set results [list]
+} -constraints win -body {
+ toplevel .t
+ # lower forces the window to be mapped, it would not be otherwise
+ lower .t
+ lappend results [wm stackorder .]
+
+ # If stacking order is explicitly set for an unmapped window, then setting
+ # the fullscreen attribute should not change it.
+ wm attributes .t -fullscreen 1
+ eventDelay
+ lappend results [wm stackorder .]
+} -cleanup {
+ deleteWindows
+} -result {{.t .} {.t .}}
+test wm-attributes-1.5.3 {fullscreen stackorder} -setup {
+ set results [list]
+} -constraints win -body {
+ toplevel .t
+ eventDelay
+ lappend results [wm stackorder .]
+
+ wm attributes .t -fullscreen 1
+ eventDelay
+ lappend results [wm stackorder .]
+
+ # Unsetting the fullscreen attribute should not change the stackorder.
+ wm attributes .t -fullscreen 0
+ eventDelay
+ lappend results [wm stackorder .]
+} -cleanup {
+ deleteWindows
+} -result {{. .t} {. .t} {. .t}}
+test wm-attributes-1.5.4 {fullscreen stackorder} -setup {
+ set results [list]
+} -constraints win -body {
+ toplevel .t
+ lower .t
+ eventDelay
+ lappend results [wm stackorder .]
+
+ wm attributes .t -fullscreen 1
+ eventDelay
+ lappend results [wm stackorder .]
+
+ # Unsetting the fullscreen attribute should not change the stackorder.
+ wm attributes .t -fullscreen 0
+ eventDelay
+ lappend results [wm stackorder .]
+} -cleanup {
+ deleteWindows
+} -result {{.t .} {.t .} {.t .}}
+test wm-attributes-1.5.5 {fullscreen stackorder} -setup {
+ set results [list]
+} -constraints win -body {
+ toplevel .a
+ toplevel .b
+ toplevel .c
+ raise .a
+ raise .b
+ raise .c
+ eventDelay
+ lappend results [wm stackorder .]
+
+ wm attributes .b -fullscreen 1
+ eventDelay
+ lappend results [wm stackorder .]
+
+ # Unsetting the fullscreen attribute should not change the stackorder.
+ wm attributes .b -fullscreen 0
+ eventDelay
+ lappend results [wm stackorder .]
+} -cleanup {
+ deleteWindows
+} -result {{. .a .b .c} {. .a .b .c} {. .a .b .c}}
+
+
+stdWindow
+
+
+### wm colormapwindows ###
+test wm-colormapwindows-1.1 {usage} -returnCodes error -body {
+ wm colormapwindows
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-colormapwindows-1.2 {usage} -returnCodes error -body {
+ wm colormapwindows . _ _
+} -result {wrong # args: should be "wm colormapwindows window ?windowList?"}
+test wm-colormapwindows-1.3 {usage} -returnCodes error -body {
+ wm colormapwindows . "a \{"
+} -result {unmatched open brace in list}
+test wm-colormapwindows-1.4 {usage} -returnCodes error -body {
+ wm colormapwindows . foo
+} -result {bad window path name "foo"}
+
+test wm-colormapwindows-2.1 {reading values} -body {
+ toplevel .t2 -width 200 -height 200 -colormap new
+ wm geom .t2 +0+0
+ frame .t2.a -width 100 -height 30
+ frame .t2.b -width 100 -height 30 -colormap new
+ pack .t2.a .t2.b -side top
+ update
+ set x [wm colormapwindows .t2]
+ frame .t2.c -width 100 -height 30 -colormap new
+ pack .t2.c -side top
+ update
+ list $x [wm colormapwindows .t2]
+} -cleanup {
+ destroy .t2
+} -result {{.t2.b .t2} {.t2.b .t2.c .t2}}
+test wm-colormapwindows-2.2 {setting and reading values} -body {
+ toplevel .t2 -width 200 -height 200
+ wm geom .t2 +0+0
+ frame .t2.a -width 100 -height 30
+ frame .t2.b -width 100 -height 30
+ frame .t2.c -width 100 -height 30
+ pack .t2.a .t2.b .t2.c -side top
+ wm colormapwindows .t2 {.t2.b .t2.a}
+ wm colormapwindows .t2
+} -cleanup {
+ destroy .t2
+} -result {.t2.b .t2.a}
+
+
+### wm command ###
+test wm-command-1.1 {usage} -returnCodes error -body {
+ wm command
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-command-1.2 {usage} -returnCodes error -body {
+ wm command . _ _
+} -result {wrong # args: should be "wm command window ?value?"}
+test wm-command-1.3 {usage} -returnCodes error -body {
+ wm command . "a \{"
+} -result {unmatched open brace in list}
+
+test wm-command-2.1 {setting and reading values} -setup {
+ set result {}
+} -body {
+ lappend result [wm command .t]
+ wm command .t [list Miffo Foo]
+ lappend result [wm command .t]
+ wm command .t {}
+ lappend result [wm command .t]
+} -result [list {} [list Miffo Foo] {}]
+
+
+### wm deiconify ###
+test wm-deiconify-1.1 {usage} -returnCodes error -body {
+ wm deiconify
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-deiconify-1.2 {usage} -returnCodes error -body {
+ wm deiconify . _
+} -result {wrong # args: should be "wm deiconify window"}
+test wm-deiconify-1.3 {usage} -returnCodes error -body {
+ wm deiconify _
+} -result {bad window path name "_"}
+test wm-deiconify-1.4 {usage} -setup {
+ destroy .icon
+} -body {
+ toplevel .icon -width 50 -height 50 -bg red
+ wm iconwindow .t .icon
+ wm deiconify .icon
+} -returnCodes error -cleanup {
+ destroy .icon
+} -result {can't deiconify .icon: it is an icon for .t}
+# test embedded window for Windows
+test wm-deiconify-1.5 {usage} -constraints win -setup {
+ destroy .embed
+} -body {
+ frame .t.f -container 1
+ toplevel .embed -use [winfo id .t.f]
+ wm deiconify .embed
+} -returnCodes error -cleanup {
+ destroy .t.f .embed
+} -result {can't deiconify .embed: the container does not support the request}
+# test embedded window for other platforms
+test wm-deiconify-1.6 {usage} -constraints !win -setup {
+ destroy .embed
+} -body {
+ frame .t.f -container 1
+ toplevel .embed -use [winfo id .t.f]
+ wm deiconify .embed
+} -returnCodes error -cleanup {
+ destroy .t.f .embed
+} -result {can't deiconify .embed: it is an embedded window}
+
+deleteWindows
+test wm-deiconify-2.1 {a window that has never been mapped\
+ should not be mapped by a call to deiconify} -body {
+ toplevel .t
+ wm deiconify .t
+ winfo ismapped .t
+} -cleanup {
+ deleteWindows
+} -result 0
+test wm-deiconify-2.2 {a window that has already been\
+ mapped should be mapped by deiconify} -body {
+ toplevel .t
+ update idletasks
+ wm withdraw .t
+ wm deiconify .t
+ winfo ismapped .t
+} -cleanup {
+ deleteWindows
+} -result 1
+test wm-deiconify-2.3 {geometry for an unmapped window\
+ should not be calculated by a call to deiconify,\
+ it should be done at idle time} -setup {
+ set results {}
+} -body {
+ toplevel .t -width 200 -height 200
+ lappend results [wm geometry .t]
+ wm deiconify .t
+ lappend results [wm geometry .t]
+ update idletasks
+ lappend results [lindex [split \
+ [wm geometry .t] +] 0]
+} -cleanup {
+ deleteWindows
+} -result {1x1+0+0 1x1+0+0 200x200}
+test wm-deiconify-2.4 {invoking destroy after a deiconify\
+ should not result in a crash because of a callback\
+ set on the toplevel} -body {
+ toplevel .t
+ wm withdraw .t
+ wm deiconify .t
+ destroy .t
+ update
+} -cleanup {
+ deleteWindows
+}
+
+
+### wm focusmodel ###
+test wm-focusmodel-1.1 {usage} -returnCodes error -body {
+ wm focusmodel
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-focusmodel-1.2 {usage} -returnCodes error -body {
+ wm focusmodel . _ _
+} -result {wrong # args: should be "wm focusmodel window ?active|passive?"}
+test wm-focusmodel-1.3 {usage} -returnCodes error -body {
+ wm focusmodel . bogus
+} -result {bad argument "bogus": must be active or passive}
+
+stdWindow
+
+test wm-focusmodel-2.1 {setting and reading values} -setup {
+ set result {}
+} -body {
+ lappend result [wm focusmodel .t]
+ wm focusmodel .t active
+ lappend result [wm focusmodel .t]
+ wm focusmodel .t passive
+ lappend result [wm focusmodel .t]
+} -result {passive active passive}
+
+
+### wm frame ###
+test wm-frame-1.1 {usage} -returnCodes error -body {
+ wm frame
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-frame-1.2 {usage} -returnCodes error -body {
+ wm frame . _
+} -result {wrong # args: should be "wm frame window"}
+
+
+### wm geometry ###
+test wm-geometry-1.1 {usage} -returnCodes error -body {
+ wm geometry
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-geometry-1.2 {usage} -returnCodes error -body {
+ wm geometry . _ _
+} -result {wrong # args: should be "wm geometry window ?newGeometry?"}
+test wm-geometry-1.3 {usage} -returnCodes error -body {
+ wm geometry . bogus
+} -result {bad geometry specifier "bogus"}
+
+test wm-geometry-2.1 {setting values} -body {
+ wm geometry .t 150x150+50+50
+ update
+ set result [wm geometry .t]
+ wm geometry .t {}
+ update
+ return [list $result [string equal [wm geometry .t] $result]]
+} -cleanup {
+ unset result
+} -match glob -result [list 150x150+*+* 0]
+
+
+### wm grid ###
+test wm-grid-1.1 {usage} -returnCodes error -body {
+ wm grid
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-grid-1.2 {usage} -returnCodes error -body {
+ wm grid . _
+} -result {wrong # args: should be "wm grid window ?baseWidth baseHeight widthInc heightInc?"}
+test wm-grid-1.3 {usage} -returnCodes error -body {
+ wm grid . _ _ _
+} -result {wrong # args: should be "wm grid window ?baseWidth baseHeight widthInc heightInc?"}
+test wm-grid-1.4 {usage} -returnCodes error -body {
+ wm grid . _ _ _ _ _
+} -result {wrong # args: should be "wm grid window ?baseWidth baseHeight widthInc heightInc?"}
+test wm-grid-1.5 {usage} -returnCodes error -body {
+ wm grid . bad 14 15 16
+} -result {expected integer but got "bad"}
+test wm-grid-1.6 {usage} -returnCodes error -body {
+ wm grid . 13 foo 15 16
+} -result {expected integer but got "foo"}
+test wm-grid-1.7 {usage} -returnCodes error -body {
+ wm grid . 13 14 bar 16
+} -result {expected integer but got "bar"}
+test wm-grid-1.8 {usage} -returnCodes error -body {
+ wm grid . 13 14 15 baz
+} -result {expected integer but got "baz"}
+test wm-grid-1.9 {usage} -returnCodes error -body {
+ wm grid . -1 14 15 16
+} -result {baseWidth can't be < 0}
+test wm-grid-1.10 {usage} -returnCodes error -body {
+ wm grid . 13 -1 15 16
+} -result {baseHeight can't be < 0}
+test wm-grid-1.11 {usage} -returnCodes error -body {
+ wm grid . 13 14 -1 16
+} -result {widthInc can't be <= 0}
+test wm-grid-1.12 {usage} -returnCodes error -body {
+ wm grid . 13 14 15 -1
+} -result {heightInc can't be <= 0}
+
+test wm-grid-2.1 {setting and reading values} -setup {
+ set result {}
+} -body {
+ lappend result [wm grid .t]
+ wm grid .t 3 4 10 2
+ lappend result [wm grid .t]
+ wm grid .t {} {} {} {}
+ lappend result [wm grid .t]
+} -result [list {} {3 4 10 2} {}]
+
+
+### wm group ###
+test wm-group-1.1 {usage} -returnCodes error -body {
+ wm group
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-group-1.2 {usage} -returnCodes error -body {
+ wm group .t 12 13
+} -result {wrong # args: should be "wm group window ?pathName?"}
+test wm-group-1.3 {usage} -returnCodes error -body {
+ wm group .t bogus
+} -result {bad window path name "bogus"}
+
+test wm-group-2.1 {setting and reading values} -setup {
+ set result {}
+} -body {
+ lappend result [wm group .t]
+ wm group .t .
+ lappend result [wm group .t]
+ wm group .t {}
+ lappend result [wm group .t]
+} -result [list {} . {}]
+
+
+### wm iconbitmap ###
+test wm-iconbitmap-1.1 {usage} -returnCodes error -body {
+ wm iconbitmap
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-iconbitmap-1.2.1 {usage} -constraints unix -returnCodes error -body {
+ wm iconbitmap .t 12 13
+} -result {wrong # args: should be "wm iconbitmap window ?bitmap?"}
+test wm-iconbitmap-1.2.2 {usage} -constraints win -returnCodes error -body {
+ wm iconbitmap .t 12 13 14
+} -result {wrong # args: should be "wm iconbitmap window ?-default? ?image?"}
+test wm-iconbitmap-1.3 {usage} -constraints win -returnCodes error -body {
+ wm iconbitmap .t 12 13
+} -result {illegal option "12" must be "-default"}
+test wm-iconbitmap-1.4 {usage} -returnCodes error -body {
+ wm iconbitmap .t bad-bitmap
+} -result {bitmap "bad-bitmap" not defined}
+
+test wm-iconbitmap-2.1 {setting and reading values} -setup {
+ set result {}
+} -body {
+ lappend result [wm iconbitmap .t]
+ wm iconbitmap .t hourglass
+ lappend result [wm iconbitmap .t]
+ wm iconbitmap .t {}
+ lappend result [wm iconbitmap .t]
+} -result [list {} hourglass {}]
+
+
+### wm iconify ###
+test wm-iconify-1.1 {usage} -returnCodes error -body {
+ wm iconify
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-iconify-1.2 {usage} -returnCodes error -body {
+ wm iconify .t _
+} -result {wrong # args: should be "wm iconify window"}
+
+destroy .t2
+test wm-iconify-2.1 {Misc errors} -body {
+ toplevel .t2
+ wm overrideredirect .t2 1
+ wm iconify .t2
+} -returnCodes error -cleanup {
+ destroy .t2
+} -result {can't iconify ".t2": override-redirect flag is set}
+test wm-iconify-2.2 {Misc errors} -body {
+ toplevel .t2
+ wm geom .t2 +0+0
+ wm transient .t2 .t
+ wm iconify .t2
+} -returnCodes error -cleanup {
+ destroy .t2
+} -result {can't iconify ".t2": it is a transient}
+test wm-iconify-2.3 {Misc errors} -body {
+ toplevel .t2
+ wm geom .t2 +0+0
+ wm iconwindow .t .t2
+ wm iconify .t2
+} -returnCodes error -cleanup {
+ destroy .t2
+} -result {can't iconify .t2: it is an icon for .t}
+# test embedded window for Windows
+test wm-iconify-2.4.1 {Misc errors} -constraints win -setup {
+ destroy .t2
+} -body {
+ frame .t.f -container 1
+ toplevel .t2 -use [winfo id .t.f]
+ wm iconify .t2
+} -returnCodes error -cleanup {
+ destroy .t2 .r.f
+} -result {can't iconify .t2: the container does not support the request}
+# test embedded window for other platforms
+test wm-iconify-2.4.2 {Misc errors} -constraints !win -setup {
+ destroy .t2
+} -body {
+ frame .t.f -container 1
+ toplevel .t2 -use [winfo id .t.f]
+ wm iconify .t2
+} -returnCodes error -cleanup {
+ destroy .t2 .r.f
+} -result {can't iconify .t2: it is an embedded window}
+
+test wm-iconify-3.1 {iconify behavior} -body {
+ toplevel .t2
+ wm geom .t2 -0+0
+ update
+ set result [winfo ismapped .t2]
+ wm iconify .t2
+ update
+ lappend result [winfo ismapped .t2]
+} -cleanup {
+ destroy .t2
+} -result {1 0}
+
+
+### wm iconmask ###
+test wm-iconmask-1.1 {usage} -returnCodes error -body {
+ wm iconmask
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-iconmask-1.2 {usage} -returnCodes error -body {
+ wm iconmask .t 12 13
+} -result {wrong # args: should be "wm iconmask window ?bitmap?"}
+test wm-iconmask-1.3 {usage} -returnCodes error -body {
+ wm iconmask .t bad-bitmap
+} -result {bitmap "bad-bitmap" not defined}
+
+test wm-iconmask-2.1 {setting and reading values} -setup {
+ set result {}
+} -body {
+ lappend result [wm iconmask .t]
+ wm iconmask .t hourglass
+ lappend result [wm iconmask .t]
+ wm iconmask .t {}
+ lappend result [wm iconmask .t]
+} -result [list {} hourglass {}]
+
+
+### wm iconname ###
+test wm-iconname-1.1 {usage} -returnCodes error -body {
+ wm iconname
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-iconname-1.2 {usage} -returnCodes error -body {
+ wm iconname .t 12 13
+} -result {wrong # args: should be "wm iconname window ?newName?"}
+
+test wm-iconname-2.1 {setting and reading values} -setup {
+ set result {}
+} -body {
+ lappend result [wm iconname .t]
+ wm iconname .t ThisIconHasAName
+ lappend result [wm iconname .t]
+ wm iconname .t {}
+ lappend result [wm iconname .t]
+} -result [list {} ThisIconHasAName {}]
+
+
+### wm iconphoto ###
+test wm-iconphoto-1.1 {usage} -returnCodes error -body {
+ wm iconphoto
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-iconphoto-1.2 {usage} -returnCodes error -body {
+ wm iconphoto .
+} -result {wrong # args: should be "wm iconphoto window ?-default? image1 ?image2 ...?"}
+test wm-iconphoto-1.3 {usage} -returnCodes error -body {
+ wm iconphoto . notanimage
+} -result {can't use "notanimage" as iconphoto: not a photo image}
+test wm-iconphoto-1.4 {usage} -returnCodes error -body {
+ # we currently have no return info
+ wm iconphoto . -default
+} -result {wrong # args: should be "wm iconphoto window ?-default? image1 ?image2 ...?"}
+
+# All other iconphoto tests are platform specific
+
+
+### wm iconposition ###
+test wm-iconposition-1.1 {usage} -returnCodes error -body {
+ wm iconposition
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-iconposition-1.2 {usage} -returnCodes error -body {
+ wm iconposition .t 12
+} -result {wrong # args: should be "wm iconposition window ?x y?"}
+test wm-iconposition-1.3 {usage} -returnCodes error -body {
+ wm iconposition .t 12 13 14
+} -result {wrong # args: should be "wm iconposition window ?x y?"}
+test wm-iconposition-1.4 {usage} -returnCodes error -body {
+ wm iconposition .t bad 13
+} -result {expected integer but got "bad"}
+test wm-iconposition-1.5 {usage} -returnCodes error -body {
+ wm iconposition .t 13 lousy
+} -result {expected integer but got "lousy"}
+
+test wm-iconposition-2.1 {setting and reading values} -setup {
+ set result {}
+} -body {
+ lappend result [wm iconposition .t]
+ wm iconposition .t 10 20
+ lappend result [wm iconposition .t]
+ wm iconposition .t {} {}
+ lappend result [wm iconposition .t]
+} -result [list {} {10 20} {}]
+
+
+### wm iconwindow ###
+test wm-iconwindow-1.1 {usage} -returnCodes error -body {
+ wm iconwindow
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-iconwindow-1.2 {usage} -returnCodes error -body {
+ wm iconwindow .t 12 13
+} -result {wrong # args: should be "wm iconwindow window ?pathName?"}
+test wm-iconwindow-1.3 {usage} -returnCodes error -body {
+ wm iconwindow .t bogus
+} -result {bad window path name "bogus"}
+test wm-iconwindow-1.4 {usage} -setup {
+ destroy .b
+} -body {
+ button .b -text Help
+ wm iconwindow .t .b
+} -returnCodes error -cleanup {
+ destroy .b
+} -result {can't use .b as icon window: not at top level}
+test wm-iconwindow-1.5 {usage} -setup {
+ destroy .icon .t2
+} -body {
+ toplevel .icon -width 50 -height 50 -bg green
+ toplevel .t2
+ wm geom .t2 -0+0
+ wm iconwindow .t2 .icon
+ wm iconwindow .t .icon
+} -returnCodes error -cleanup {
+ destroy .t2 .icon
+} -result {.icon is already an icon for .t2}
+
+test wm-iconwindow-2.1 {setting and reading values} -setup {
+ destroy .icon
+ set result {}
+} -body {
+ lappend result [wm iconwindow .t]
+ toplevel .icon -width 50 -height 50 -bg green
+ wm iconwindow .t .icon
+ lappend result [wm iconwindow .t]
+ wm iconwindow .t {}
+ destroy .icon
+ lappend result [wm iconwindow .t]
+} -result {{} .icon {}}
+
+
+### wm maxsize ###
+test wm-maxsize-1.1 {usage} -returnCodes error -body {
+ wm maxsize
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-maxsize-1.2 {usage} -returnCodes error -body {
+ wm maxsize . a
+} -result {wrong # args: should be "wm maxsize window ?width height?"}
+test wm-maxsize-1.3 {usage} -returnCodes error -body {
+ wm maxsize . a b c
+} -result {wrong # args: should be "wm maxsize window ?width height?"}
+test wm-maxsize-1.4 {usage} -returnCodes error -body {
+ wm maxsize . x 100
+} -result {expected integer but got "x"}
+test wm-maxsize-1.5 {usage} -returnCodes error -body {
+ wm maxsize . 100 bogus
+} -result {expected integer but got "bogus"}
+test wm-maxsize-1.6 {usage} -setup {
+ destroy .t2
+} -body {
+ toplevel .t2
+ wm maxsize .t2 300 200
+ wm maxsize .t2
+} -cleanup {
+ destroy .t2
+} -result {300 200}
+test wm-maxsize-1.7 {maxsize must be <= screen size} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ lassign [wm maxsize .t] t_width t_height
+ set s_width [winfo screenwidth .t]
+ set s_height [winfo screenheight .t]
+ expr {($t_width <= $s_width) && ($t_height <= $s_height)}
+} -cleanup {
+ destroy .t
+} -result 1
+
+destroy .t
+test wm-maxsize-2.1 {setting the maxsize to a value smaller\
+ than the current size will resize a toplevel} -body {
+ toplevel .t -width 300 -height 300
+ update
+ wm maxsize .t 200 150
+ # UpdateGeometryInfo invoked at idle
+ update
+ lrange [split [wm geom .t] x+] 0 1
+} -cleanup {
+ destroy .t
+} -result {200 150}
+test wm-maxsize-2.2 {setting the maxsize to a value smaller\
+ than the current size will resize a gridded toplevel} -body {
+ toplevel .t
+ wm grid .t 0 0 50 50
+ wm geometry .t 6x6
+ update
+ wm maxsize .t 4 3
+ # UpdateGeometryInfo invoked at idle
+ update
+ lrange [split [wm geom .t] x+] 0 1
+} -cleanup {
+ destroy .t
+} -result {4 3}
+test wm-maxsize-2.3 {attempting to resize to a value\
+ bigger than the current maxsize will set it to the max size} -body {
+ toplevel .t -width 200 -height 200
+ wm maxsize .t 300 250
+ update
+ wm geom .t 400x300
+ update
+ lrange [split [wm geom .t] x+] 0 1
+} -cleanup {
+ destroy .t
+} -result {300 250}
+test wm-maxsize-2.4 {attempting to resize to a value bigger than the\
+ current maxsize will set it to the max size when gridded} -body {
+ toplevel .t
+ wm grid .t 1 1 50 50
+ wm geom .t 4x4
+ wm maxsize .t 6 5
+ update
+ wm geom .t 8x6
+ update
+ lrange [split [wm geom .t] x+] 0 1
+} -cleanup {
+ destroy .t
+} -result {6 5}
+test wm-maxsize-2.5 {Use max size if window size is not explicitly set\
+ and the reqWidth/reqHeight are bigger than the max size} -body {
+ toplevel .t
+ pack [frame .t.f -width 400 -height 400]
+ update idletasks
+ set req [list [winfo reqwidth .t] [winfo reqheight .t]]
+ wm maxsize .t 300 300
+ update
+ list $req [lrange [split [wm geom .t] x+] 0 1]
+} -cleanup {
+ destroy .t
+} -result {{400 400} {300 300}}
+
+
+### wm minsize ###
+test wm-minsize-1.1 {usage} -returnCodes error -body {
+ wm minsize
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-minsize-1.2 {usage} -returnCodes error -body {
+ wm minsize . a
+} -result {wrong # args: should be "wm minsize window ?width height?"}
+test wm-minsize-1.3 {usage} -returnCodes error -body {
+ wm minsize . a b c
+} -result {wrong # args: should be "wm minsize window ?width height?"}
+test wm-minsize-1.4 {usage} -returnCodes error -body {
+ wm minsize . x 100
+} -result {expected integer but got "x"}
+test wm-minsize-1.5 {usage} -returnCodes error -body {
+ wm minsize . 100 bogus
+} -result {expected integer but got "bogus"}
+test wm-minsize-1.6 {usage} -setup {
+ destroy .t2
+} -body {
+ toplevel .t2
+ wm minsize .t2 300 200
+ wm minsize .t2
+} -cleanup {
+ destroy .t2
+} -result {300 200}
+
+test wm-minsize-2.1 {setting the minsize to a value larger\
+ than the current size will resize a toplevel} -body {
+ toplevel .t -width 200 -height 200
+ update
+ wm minsize .t 400 300
+ # UpdateGeometryInfo invoked at idle
+ update
+ lrange [split [wm geom .t] x+] 0 1
+} -cleanup {
+ destroy .t
+} -result {400 300}
+test wm-minsize-2.2 {setting the minsize to a value larger\
+ than the current size will resize a gridded toplevel} -body {
+ toplevel .t
+ wm grid .t 1 1 50 50
+ wm geom .t 4x4
+ update
+ wm minsize .t 8 8
+ # UpdateGeometryInfo invoked at idle
+ update
+ lrange [split [wm geom .t] x+] 0 1
+} -cleanup {
+ destroy .t
+} -result {8 8}
+test wm-minsize-2.3 {attempting to resize to a value\
+ smaller than the current minsize will set it to the minsize} -body {
+ toplevel .t -width 400 -height 400
+ wm minsize .t 300 300
+ update
+ wm geom .t 200x200
+ update
+ lrange [split [wm geom .t] x+] 0 1
+} -cleanup {
+ destroy .t
+} -result {300 300}
+test wm-minsize-2.4 {attempting to resize to a value smaller than the\
+ current minsize will set it to the minsize when gridded} -body {
+ toplevel .t
+ wm grid .t 1 1 50 50
+ wm geom .t 8x8
+ wm minsize .t 6 6
+ update
+ wm geom .t 4x4
+ update
+ lrange [split [wm geom .t] x+] 0 1
+} -cleanup {
+ destroy .t
+} -result {6 6}
+test wm-minsize-2.5 {Use min size if window size is not explicitly set\
+ and the reqWidth/reqHeight are smaller than the min size} -setup {
+ set result [list]
+} -body {
+ toplevel .t
+ pack [frame .t.f -width 250 -height 250]
+ update idletasks
+ lappend result [list [winfo reqwidth .t] [winfo reqheight .t]]
+ wm minsize .t 300 300
+ update
+ lappend result [lrange [split [wm geom .t] x+] 0 1]
+} -cleanup {
+ destroy .t
+} -result {{250 250} {300 300}}
+
+stdWindow
+
+### wm overrideredirect ###
+test wm-overrideredirect-1.1 {usage} -returnCodes error -body {
+ wm overrideredirect
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-overrideredirect-1.2 {usage} -returnCodes error -body {
+ wm overrideredirect .t 1 2
+} -result {wrong # args: should be "wm overrideredirect window ?boolean?"}
+test wm-overrideredirect-1.3 {usage} -returnCodes error -body {
+ wm overrideredirect .t boo
+} -result {expected boolean value but got "boo"}
+
+test wm-overrideredirect-2.1 {setting and reading values} -setup {
+ set result {}
+} -body {
+ lappend result [wm overrideredirect .t]
+ wm overrideredirect .t true
+ lappend result [wm overrideredirect .t]
+ wm overrideredirect .t off
+ lappend result [wm overrideredirect .t]
+} -result {0 1 0}
+
+
+### wm positionfrom ###
+test wm-positionfrom-1.1 {usage} -returnCodes error -body {
+ wm positionfrom
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-positionfrom-1.2 {usage} -returnCodes error -body {
+ wm positionfrom .t 1 2
+} -result {wrong # args: should be "wm positionfrom window ?user/program?"}
+test wm-positionfrom-1.3 {usage} -returnCodes error -body {
+ wm positionfrom .t none
+} -result {bad argument "none": must be program or user}
+
+test wm-positionfrom-2.1 {setting and reading values} -setup {
+ destroy .t2
+ set result {}
+} -body {
+ toplevel .t2
+ wm positionfrom .t user
+ lappend result [wm positionfrom .t]
+ wm positionfrom .t program
+ lappend result [wm positionfrom .t]
+ wm positionfrom .t {}
+ lappend result [wm positionfrom .t]
+} -cleanup {
+ destroy .t2
+} -result {user program {}}
+
+
+### wm protocol ###
+test wm-protocol-1.1 {usage} -returnCodes error -body {
+ wm protocol
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-protocol-1.2 {usage} -returnCodes error -body {
+ wm protocol .t 1 2 3
+} -result {wrong # args: should be "wm protocol window ?name? ?command?"}
+
+test wm-protocol-2.1 {setting and reading values} -body {
+ wm protocol .t {foo a} {a b c}
+ wm protocol .t bar {test script for bar}
+ wm protocol .t
+} -cleanup {
+ wm protocol .t {foo a} {}
+ wm protocol .t bar {}
+} -result {bar {foo a}}
+test wm-protocol-2.2 {setting and reading values} -setup {
+ set result {}
+} -body {
+ wm protocol .t foo {a b c}
+ wm protocol .t bar {test script for bar}
+ lappend result [wm protocol .t foo] [wm protocol .t bar]
+ wm protocol .t foo {}
+ wm protocol .t bar {}
+ lappend result [wm protocol .t foo] [wm protocol .t bar]
+} -result {{a b c} {test script for bar} {} {}}
+test wm-protocol-2.3 {setting and reading values} -body {
+ wm protocol .t foo {a b c}
+ wm protocol .t foo {test script}
+ wm protocol .t foo
+} -cleanup {
+ wm protocol .t foo {}
+} -result {test script}
+
+
+### wm resizable ###
+test wm-resizable-1.1 {usage} -returnCodes error -body {
+ wm resizable
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-resizable-1.2 {usage} -returnCodes error -body {
+ wm resizable .t 1
+} -result {wrong # args: should be "wm resizable window ?width height?"}
+test wm-resizable-1.3 {usage} -returnCodes error -body {
+ wm resizable .t 1 2 3
+} -result {wrong # args: should be "wm resizable window ?width height?"}
+test wm-resizable-1.4 {usage} -returnCodes error -body {
+ wm resizable .t bad 0
+} -result {expected boolean value but got "bad"}
+test wm-resizable-1.5 {usage} -returnCodes error -body {
+ wm resizable .t 1 bad
+} -result {expected boolean value but got "bad"}
+
+test wm-resizable-2.1 {setting and reading values} {
+ wm resizable .t 0 1
+ set result [wm resizable .t]
+ wm resizable .t 1 0
+ lappend result [wm resizable .t]
+ wm resizable .t 1 1
+ lappend result [wm resizable .t]
+} {0 1 {1 0} {1 1}}
+
+
+### wm sizefrom ###
+test wm-sizefrom-1.1 {usage} -returnCodes error -body {
+ wm sizefrom
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-sizefrom-1.2 {usage} -returnCodes error -body {
+ wm sizefrom .t 1 2
+} -result {wrong # args: should be "wm sizefrom window ?user|program?"}
+test wm-sizefrom-1.4 {usage} -returnCodes error -body {
+ wm sizefrom .t bad
+} -result {bad argument "bad": must be program or user}
+
+test wm-sizefrom-2.1 {setting and reading values} {
+ set result [list [wm sizefrom .t]]
+ wm sizefrom .t user
+ lappend result [wm sizefrom .t]
+ wm sizefrom .t program
+ lappend result [wm sizefrom .t]
+ wm sizefrom .t {}
+ lappend result [wm sizefrom .t]
+} {{} user program {}}
+
+destroy .t
+
+### wm stackorder ###
+test wm-stackorder-1.1 {usage} -returnCodes error -body {
+ wm stackorder
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-stackorder-1.2 {usage} -returnCodes error -body {
+ wm stackorder . _
+} -result {wrong # args: should be "wm stackorder window ?isabove|isbelow window?"}
+test wm-stackorder-1.3 {usage} -returnCodes error -body {
+ wm stackorder . _ _ _
+} -result {wrong # args: should be "wm stackorder window ?isabove|isbelow window?"}
+test wm-stackorder-1.4 {usage} -returnCodes error -body {
+ wm stackorder . is .
+} -result {ambiguous argument "is": must be isabove or isbelow}
+test wm-stackorder-1.5 {usage} -returnCodes error -body {
+ wm stackorder _
+} -result {bad window path name "_"}
+test wm-stackorder-1.6 {usage} -returnCodes error -body {
+ wm stackorder . isabove _
+} -result {bad window path name "_"}
+test wm-stackorder-1.7 {usage} -body {
+ toplevel .t
+ button .t.b
+ wm stackorder .t.b
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {window ".t.b" isn't a top-level window}
+test wm-stackorder-1.8 {usage} -body {
+ toplevel .t
+ button .t.b
+ pack .t.b
+ update
+ wm stackorder . isabove .t.b
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {window ".t.b" isn't a top-level window}
+test wm-stackorder-1.9 {usage} -body {
+ toplevel .t
+ button .t.b
+ pack .t.b
+ update
+ wm stackorder . isbelow .t.b
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {window ".t.b" isn't a top-level window}
+test wm-stackorder-1.10 {usage, isabove|isbelow toplevels must be mapped} -body {
+ toplevel .t
+ update
+ wm withdraw .t
+ wm stackorder .t isabove .
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {window ".t" isn't mapped}
+test wm-stackorder-1.11 {usage, isabove|isbelow toplevels must be mapped} -body {
+ toplevel .t
+ update
+ wm withdraw .t
+ wm stackorder . isbelow .t
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {window ".t" isn't mapped}
+deleteWindows
+
+test wm-stackorder-2.1 {stacking order} -body {
+ toplevel .t ; update
+ wm stackorder .
+} -cleanup {
+ destroy .t
+} -result {. .t}
+test wm-stackorder-2.2 {stacking order} -body {
+ toplevel .t ; update
+ raise .
+ raiseDelay
+ wm stackorder .
+} -cleanup {
+ destroy .t
+} -result {.t .}
+test wm-stackorder-2.3 {stacking order} -body {
+ toplevel .t ; update
+ toplevel .t2 ; update
+ raise .
+ raiseDelay
+ raise .t2
+ raiseDelay
+ wm stackorder .
+} -cleanup {
+ destroy .t .t2
+} -result {.t . .t2}
+test wm-stackorder-2.4 {stacking order} -body {
+ toplevel .t ; update
+ toplevel .t2 ; update
+ raise .
+ lower .t2
+ raiseDelay
+ wm stackorder .
+} -cleanup {
+ destroy .t .t2
+} -result {.t2 .t .}
+test wm-stackorder-2.5 {stacking order} -setup {
+ destroy .parent
+} -body {
+ toplevel .parent ; update
+ destroy .parent.child1
+ toplevel .parent.child1 ; update
+ destroy .parent.child2
+ toplevel .parent.child2 ; update
+ destroy .extra
+ toplevel .extra ; update
+ raise .parent
+ lower .parent.child2
+ raiseDelay
+ wm stackorder .parent
+} -cleanup {
+ deleteWindows
+} -result {.parent.child2 .parent.child1 .parent}
+test wm-stackorder-2.6 {stacking order: non-toplevel widgets ignored} -body {
+ toplevel .t1
+ button .t1.b
+ pack .t1.b
+ update
+ wm stackorder .
+} -cleanup {
+ destroy .t1
+} -result {. .t1}
+test wm-stackorder-2.7 {stacking order: no children returns self} -setup {
+ deleteWindows
+} -body {
+ wm stackorder .
+} -result {.}
+
+deleteWindows
+
+test wm-stackorder-3.1 {unmapped toplevel} -body {
+ toplevel .t1 ; update
+ toplevel .t2 ; update
+ wm iconify .t1
+ wm stackorder .
+} -cleanup {
+ destroy .t1 .t2
+} -result {. .t2}
+test wm-stackorder-3.2 {unmapped toplevel} -body {
+ toplevel .t1 ; update
+ toplevel .t2 ; update
+ wm withdraw .t2
+ wm stackorder .
+} -cleanup {
+ destroy .t1 .t2
+} -result {. .t1}
+test wm-stackorder-3.3 {unmapped toplevel} -body {
+ toplevel .t1 ; update
+ toplevel .t2 ; update
+ wm withdraw .t2
+ wm stackorder .t2
+} -cleanup {
+ destroy .t1 .t2
+} -result {}
+test wm-stackorder-3.4 {unmapped toplevel} -body {
+ toplevel .t1 ; update
+ toplevel .t1.t2 ; update
+ wm withdraw .t1.t2
+ wm stackorder .t1
+} -cleanup {
+ destroy .t1
+} -result {.t1}
+test wm-stackorder-3.5 {unmapped toplevel} -body {
+ toplevel .t1 ; update
+ toplevel .t1.t2 ; update
+ wm withdraw .t1
+ wm stackorder .t1
+} -cleanup {
+ destroy .t1
+} -result {.t1.t2}
+test wm-stackorder-3.6 {unmapped toplevel} -body {
+ toplevel .t1 ; update
+ toplevel .t1.t2 ; update
+ toplevel .t1.t2.t3 ; update
+ wm withdraw .t1.t2
+ wm stackorder .t1
+} -cleanup {
+ destroy .t1
+} -result {.t1 .t1.t2.t3}
+test wm-stackorder-3.7 {unmapped toplevel, mapped children returned} -body {
+ toplevel .t1 ; update
+ toplevel .t1.t2 ; update
+ wm withdraw .t1
+ wm stackorder .t1
+} -cleanup {
+ destroy .t1
+} -result {.t1.t2}
+test wm-stackorder-3.8 {toplevel mapped in idle callback} -body {
+ toplevel .t1
+ wm stackorder .
+} -cleanup {
+ destroy .t1
+} -result {.}
+deleteWindows
+
+test wm-stackorder-4.1 {wm stackorder isabove|isbelow} -body {
+ toplevel .t ; update
+ raise .t
+ wm stackorder . isabove .t
+} -cleanup {
+ destroy .t
+} -result {0}
+test wm-stackorder-4.2 {wm stackorder isabove|isbelow} -body {
+ toplevel .t ; update
+ raise .t
+ wm stackorder . isbelow .t
+} -cleanup {
+ destroy .t
+} -result {1}
+test wm-stackorder-4.3 {wm stackorder isabove|isbelow} -body {
+ toplevel .t ; update
+ raise .
+ raiseDelay
+ wm stackorder .t isa .
+} -cleanup {
+ destroy .t
+} -result {0}
+test wm-stackorder-4.4 {wm stackorder isabove|isbelow} -body {
+ toplevel .t ; update
+ raise .
+ raiseDelay
+ wm stackorder .t isb .
+} -cleanup {
+ destroy .t
+} -result {1}
+deleteWindows
+
+test wm-stackorder-5.1 {a menu is not a toplevel} -body {
+ toplevel .t
+ menu .t.m -type menubar
+ .t.m add cascade -label "File"
+ .t configure -menu .t.m
+ update
+ raise .
+ raiseDelay
+ wm stackorder .
+} -cleanup {
+ destroy .t
+} -result {.t .}
+test wm-stackorder-5.2 {A normal toplevel can't be\
+ raised above an overrideredirect toplevel} -body {
+ toplevel .t
+ wm overrideredirect .t 1
+ raise .
+ update
+ raiseDelay
+ wm stackorder . isabove .t
+} -cleanup {
+ destroy .t
+} -result 0
+test wm-stackorder-5.3 {An overrideredirect window\
+ can be explicitly lowered} -body {
+ toplevel .t
+ wm overrideredirect .t 1
+ lower .t
+ update
+ raiseDelay
+ wm stackorder .t isbelow .
+} -cleanup {
+ destroy .t
+} -result 1
+
+test wm-stackorder-6.1 {An embedded toplevel does not\
+ appear in the stacking order} -body {
+ toplevel .real -container 1
+ toplevel .embd -bg blue -use [winfo id .real]
+ update
+ wm stackorder .
+} -cleanup {
+ deleteWindows
+} -result {. .real}
+
+
+stdWindow
+
+### wm title ###
+test wm-title-1.1 {usage} -returnCodes error -body {
+ wm title
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-title-1.2 {usage} -returnCodes error -body {
+ wm title . 1 2
+} -result {wrong # args: should be "wm title window ?newTitle?"}
+
+test wm-title-2.1 {setting and reading values} -setup {
+ destroy .t
+} -body {
+ toplevel .t
+ set result [wm title .t]
+ wm title .t Apa
+ lappend result [wm title .t]
+ wm title .t {}
+ lappend result [wm title .t]
+} -result {t Apa {}}
+
+
+### wm transient ###
+test wm-transient-1.1 {usage} -returnCodes error -body {
+ catch {destroy .t} ; toplevel .t
+ wm transient .t 1 2
+} -result {wrong # args: should be "wm transient window ?master?"}
+test wm-transient-1.2 {usage} -returnCodes error -body {
+ catch {destroy .t} ; toplevel .t
+ wm transient .t foo
+} -result {bad window path name "foo"}
+test wm-transient-1.3 {usage} -returnCodes error -body {
+ catch {destroy .t} ; toplevel .t
+ wm transient foo .t
+} -result {bad window path name "foo"}
+deleteWindows
+test wm-transient-1.4 {usage} -returnCodes error -body {
+ toplevel .master
+ toplevel .subject
+ wm transient .subject .master
+ wm iconify .subject
+} -cleanup {
+ deleteWindows
+} -result {can't iconify ".subject": it is a transient}
+test wm-transient-1.5 {usage} -returnCodes error -body {
+ toplevel .icon -bg blue
+ toplevel .top
+ wm iconwindow .top .icon
+ toplevel .dummy
+ wm transient .icon .dummy
+} -cleanup {
+ deleteWindows
+} -result {can't make ".icon" a transient: it is an icon for .top}
+test wm-transient-1.6 {usage} -returnCodes error -body {
+ toplevel .icon -bg blue
+ toplevel .top
+ wm iconwindow .top .icon
+ toplevel .dummy
+ wm transient .dummy .icon
+} -cleanup {
+ deleteWindows
+} -result {can't make ".icon" a master: it is an icon for .top}
+test wm-transient-1.7 {usage} -returnCodes error -body {
+ toplevel .master
+ wm transient .master .master
+} -cleanup {
+ deleteWindows
+} -result {can't make ".master" its own master}
+test wm-transient-1.8 {usage} -returnCodes error -body {
+ toplevel .master
+ frame .master.f
+ wm transient .master .master.f
+} -cleanup {
+ deleteWindows
+} -result {can't make ".master" its own master}
+
+test wm-transient-2.1 {basic get/set of master} -setup {
+ set results [list]
+} -body {
+ toplevel .master
+ toplevel .subject
+ lappend results [wm transient .subject]
+ wm transient .subject .master
+ lappend results [wm transient .subject]
+ wm transient .subject {}
+ lappend results [wm transient .subject]
+} -cleanup {
+ deleteWindows
+} -result {{} .master {}}
+test wm-transient-2.2 {first toplevel parent of non-toplevel master is used} -body {
+ toplevel .master
+ frame .master.f
+ toplevel .subject
+ wm transient .subject .master.f
+ wm transient .subject
+} -cleanup {
+ deleteWindows
+} -result {.master}
+
+test wm-transient-3.1 {transient toplevel is withdrawn
+ when mapped if master is withdrawn} -body {
+ toplevel .master
+ wm withdraw .master
+ update
+ toplevel .subject
+ wm transient .subject .master
+ update
+ list [wm state .subject] [winfo ismapped .subject]
+} -cleanup {
+ deleteWindows
+} -result {withdrawn 0}
+test wm-transient-3.2 {already mapped transient toplevel
+ takes on withdrawn state of master} -body {
+ toplevel .master
+ wm withdraw .master
+ update
+ toplevel .subject
+ update
+ wm transient .subject .master
+ update
+ list [wm state .subject] [winfo ismapped .subject]
+} -cleanup {
+ deleteWindows
+} -result {withdrawn 0}
+test wm-transient-3.3 {withdraw/deiconify on the master
+ also does a withdraw/deiconify on the transient} -setup {
+ set results [list]
+} -body {
+ toplevel .master
+ toplevel .subject
+ update
+ wm transient .subject .master
+ wm withdraw .master
+ update
+ lappend results [wm state .subject] [winfo ismapped .subject]
+ wm deiconify .master
+ update
+ lappend results [wm state .subject] [winfo ismapped .subject]
+} -cleanup {
+ deleteWindows
+} -result {withdrawn 0 normal 1}
+
+test wm-transient-4.1 {transient toplevel is withdrawn
+ when mapped if master is iconic} -body {
+ toplevel .master
+ wm iconify .master
+ update
+ toplevel .subject
+ wm transient .subject .master
+ update
+ list [wm state .subject] [winfo ismapped .subject]
+} -cleanup {
+ deleteWindows
+} -result {withdrawn 0}
+test wm-transient-4.2 {already mapped transient toplevel
+ is withdrawn if master is iconic} -body {
+ toplevel .master
+ raiseDelay
+ wm iconify .master
+ update
+ toplevel .subject
+ update
+ wm transient .subject .master
+ update
+ list [wm state .subject] [winfo ismapped .subject]
+} -cleanup {
+ deleteWindows
+} -result {withdrawn 0}
+test wm-transient-4.3 {iconify/deiconify on the master
+ does a withdraw/deiconify on the transient} -setup {
+ set results [list]
+} -body {
+ toplevel .master
+ toplevel .subject
+ update
+ wm transient .subject .master
+ wm iconify .master
+ update
+ lappend results [wm state .subject] [winfo ismapped .subject]
+ wm deiconify .master
+ update
+ lappend results [wm state .subject] [winfo ismapped .subject]
+} -cleanup {
+ deleteWindows
+} -result {withdrawn 0 normal 1}
+
+test wm-transient-5.1 {an error during transient command should not
+ cause the map/unmap binding to be deleted} -setup {
+ set results [list]
+} -body {
+ toplevel .master
+ toplevel .subject
+ update
+ wm transient .subject .master
+ # Expect a bad window path error here
+ lappend results [catch {wm transient .subject .bad}]
+ wm withdraw .master
+ update
+ lappend results [wm state .subject]
+ wm deiconify .master
+ update
+ lappend results [wm state .subject]
+} -cleanup {
+ deleteWindows
+} -result {1 withdrawn normal}
+test wm-transient-5.2 {remove transient property when master
+ is destroyed} -body {
+ toplevel .master
+ toplevel .subject
+ wm transient .subject .master
+ update
+ destroy .master
+ update
+ wm transient .subject
+} -cleanup {
+ deleteWindows
+} -result {}
+test wm-transient-5.3 {remove transient property from window
+ that had never been mapped when master is destroyed} -body {
+ toplevel .master
+ toplevel .subject
+ wm transient .subject .master
+ destroy .master
+ wm transient .subject
+} -cleanup {
+ deleteWindows
+} -result {}
+
+test wm-transient-6.1 {a withdrawn transient does not track
+ state changes in the master} -body {
+ toplevel .master
+ toplevel .subject
+ update
+ wm transient .subject .master
+ wm withdraw .subject
+ wm withdraw .master
+ wm deiconify .master
+ # idle handler should not map the transient
+ update
+ wm state .subject
+} -cleanup {
+ deleteWindows
+} -result {withdrawn}
+test wm-transient-6.2 {a withdrawn transient does not track
+ state changes in the master} -setup {
+ set results [list]
+} -body {
+ toplevel .master
+ toplevel .subject
+ update
+ wm transient .subject .master
+ wm withdraw .subject
+ wm withdraw .master
+ wm deiconify .master
+ # idle handler should not map the transient
+ update
+ lappend results [wm state .subject]
+ wm deiconify .subject
+ lappend results [wm state .subject]
+ wm withdraw .master
+ lappend results [wm state .subject]
+ wm deiconify .master
+ # idle handler should map transient
+ update
+ lappend results [wm state .subject]
+} -cleanup {
+ deleteWindows
+} -result {withdrawn normal withdrawn normal}
+test wm-transient-6.3 {a withdrawn transient does not track
+ state changes in the master} -body {
+ toplevel .master
+ toplevel .subject
+ update
+ # withdraw before making window a transient
+ wm withdraw .subject
+ wm transient .subject .master
+ wm withdraw .master
+ wm deiconify .master
+ # idle handler should not map the transient
+ update
+ wm state .subject
+} -cleanup {
+ deleteWindows
+} -result {withdrawn}
+
+# wm-transient-7.*: See SF Tk Bug #592201 "wm transient fails with two masters"
+# wm-transient-7.3 through 7.5 all caused panics on Unix in Tk 8.4b1.
+# 7.1 and 7.2 added to catch (potential) future errors.
+#
+test wm-transient-7.1 {Destroying transient} -body {
+ toplevel .t
+ toplevel .transient
+ wm transient .transient .t
+ destroy .transient
+ destroy .t
+ # OK: the above did not cause a panic.
+} -cleanup {
+ deleteWindows
+}
+test wm-transient-7.2 {Destroying master} -body {
+ toplevel .t
+ toplevel .transient
+ wm transient .transient .t
+ destroy .t
+ wm transient .transient
+} -cleanup {
+ deleteWindows
+} -result {}
+test wm-transient-7.3 {Reassign transient, destroy old master} -body {
+ toplevel .t1
+ toplevel .t2
+ toplevel .transient
+ wm transient .transient .t1
+ wm transient .transient .t2
+ destroy .t1 ;# Caused panic in 8.4b1
+ destroy .t2
+ destroy .transient
+} -cleanup {
+ deleteWindows
+}
+test wm-transient-7.4 {Reassign transient, destroy new master} -body {
+ toplevel .t1
+ toplevel .t2
+ toplevel .transient
+ wm transient .transient .t1
+ wm transient .transient .t2
+ destroy .t2 ;# caused panic in 8.4b1
+ destroy .t1
+ destroy .transient
+} -cleanup {
+ deleteWindows
+}
+test wm-transient-7.5 {Reassign transient, destroy transient} -body {
+ toplevel .t1
+ toplevel .t2
+ toplevel .transient
+ wm transient .transient .t1
+ wm transient .transient .t2
+ destroy .transient
+ destroy .t2 ;# caused panic in 8.4b1
+ destroy .t1 ;# so did this
+} -cleanup {
+ deleteWindows
+}
+
+test wm-transient-8.1 {transient to withdrawn window, Bug 1163496} -setup {
+ deleteWindows
+ set result {}
+} -body {
+ # Verifies that transients stay on top of their masters, even if they were
+ # made transients when those masters were withdrawn.
+ toplevel .t1; wm withdraw .t1; update
+ toplevel .t2; wm transient .t2 .t1; update
+ lappend result [winfo ismapped .t1] [winfo ismapped .t2]
+ wm deiconify .t1; update
+ lappend result [winfo ismapped .t1] [winfo ismapped .t2]
+ raise .t1; update
+ lappend result [lsearch -all -inline -glob [wm stackorder .] ".t?"]
+} -cleanup {
+ deleteWindows
+} -result {0 0 1 1 {.t1 .t2}}
+
+
+### wm state ###
+test wm-state-1.1 {usage} -returnCodes error -body {
+ wm state
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-state-1.2 {usage} -returnCodes error -body {
+ wm state . _ _
+} -result {wrong # args: should be "wm state window ?state?"}
+
+deleteWindows
+test wm-state-2.1 {initial state} -body {
+ toplevel .t
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {normal}
+test wm-state-2.2 {state change before map} -body {
+ toplevel .t
+ wm state .t withdrawn
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {withdrawn}
+test wm-state-2.3 {state change before map} -body {
+ toplevel .t
+ wm withdraw .t
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {withdrawn}
+test wm-state-2.4 {state change after map} -body {
+ toplevel .t
+ update
+ wm state .t withdrawn
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {withdrawn}
+test wm-state-2.5 {state change after map} -body {
+ toplevel .t
+ update
+ wm withdraw .t
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {withdrawn}
+test wm-state-2.6 {state change before map} -body {
+ toplevel .t
+ wm state .t iconic
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {iconic}
+test wm-state-2.7 {state change before map} -body {
+ toplevel .t
+ wm iconify .t
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {iconic}
+test wm-state-2.8 {state change after map} -body {
+ toplevel .t
+ update
+ wm state .t iconic
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {iconic}
+test wm-state-2.9 {state change after map} -body {
+ toplevel .t
+ update
+ wm iconify .t
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {iconic}
+test wm-state-2.10 {state change before map} -body {
+ toplevel .t
+ wm withdraw .t
+ wm state .t normal
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {normal}
+test wm-state-2.11 {state change before map} -body {
+ toplevel .t
+ wm withdraw .t
+ wm deiconify .t
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {normal}
+test wm-state-2.12 {state change after map} -body {
+ toplevel .t
+ update
+ wm withdraw .t
+ wm state .t normal
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {normal}
+test wm-state-2.13 {state change after map} -body {
+ toplevel .t
+ update
+ wm withdraw .t
+ wm deiconify .t
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {normal}
+test wm-state-2.14 {state change before map} -body {
+ toplevel .t
+ wm iconify .t
+ wm state .t normal
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {normal}
+test wm-state-2.15 {state change before map} -body {
+ toplevel .t
+ wm iconify .t
+ wm deiconify .t
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {normal}
+test wm-state-2.16 {state change after map} -body {
+ toplevel .t
+ update
+ wm iconify .t
+ wm state .t normal
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {normal}
+test wm-state-2.17 {state change after map} -body {
+ toplevel .t
+ update
+ wm iconify .t
+ wm deiconify .t
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {normal}
+test wm-state-2.18 {state change after map} -constraints win -body {
+ toplevel .t
+ update
+ wm state .t zoomed
+ wm state .t
+} -cleanup {
+ deleteWindows
+} -result {zoomed}
+
+
+### wm withdraw ###
+test wm-withdraw-1.1 {usage} -returnCodes error -body {
+ wm withdraw
+} -result {wrong # args: should be "wm option window ?arg ...?"}
+test wm-withdraw-1.2 {usage} -returnCodes error -body {
+ wm withdraw . _
+} -result {wrong # args: should be "wm withdraw window"}
+
+deleteWindows
+test wm-withdraw-2.1 {Misc errors} -body {
+ toplevel .t
+ toplevel .t2
+ wm iconwindow .t .t2
+ wm withdraw .t2
+} -returnCodes error -cleanup {
+ deleteWindows
+} -result {can't withdraw .t2: it is an icon for .t}
+
+test wm-withdraw-3.1 {} -setup {
+ set result {}
+} -body {
+ toplevel .t
+ update
+ wm withdraw .t
+ lappend result [wm state .t] [winfo ismapped .t]
+ wm deiconify .t
+ lappend result [wm state .t] [winfo ismapped .t]
+} -cleanup {
+ deleteWindows
+} -result {withdrawn 0 normal 1}
+
+
+### Misc. wm tests ###
+test wm-deletion-epoch-1.1 {Deletion epoch on multiple displays} -constraints altDisplay -body {
+ # See Tk Bug #671330 "segfault when e.g. deiconifying destroyed window"
+ set w [toplevel .t -screen $env(TK_ALT_DISPLAY)]
+ wm deiconify $w ;# this caches the WindowRep
+ destroy .t
+ wm deiconify $w
+} -returnCodes error -result {bad window path name ".t"} -cleanup {
+ deleteWindows
+}
+
+### Docking test (manage, forget) ###
+test wm-manage-1.1 {managing a frame} -setup {
+ set result [list]
+} -body {
+ toplevel .t
+ frame .t.f
+ pack [label .t.f.l -text hello]
+ wm manage .t.f
+ raise .t.f
+ update
+ lappend result [winfo manage .t.f]
+ lappend result [winfo toplevel .t.f]
+} -cleanup {
+ deleteWindows
+} -result {wm .t.f}
+test wm-manage-1.2 {managing a toplevel} -setup {
+ set result [list]
+} -body {
+ toplevel .t
+ pack [label .t.l -text hello]
+ wm manage .t
+ raise .t
+ update
+ lappend result [winfo manage .t]
+ lappend result [winfo toplevel .t]
+} -cleanup {
+ deleteWindows
+} -result {wm .t}
+test wm-manage-1.3 {managing a labelframe} -setup {
+ set result [list]
+} -body {
+ toplevel .t
+ labelframe .t.f -text Labelframe
+ pack [label .t.f.l -text hello]
+ wm manage .t.f
+ raise .t.f
+ update
+ lappend result [winfo manage .t.f]
+ lappend result [winfo toplevel .t.f]
+} -cleanup {
+ deleteWindows
+} -result {wm .t.f}
+test wm-manage-1.4 {managing a ttk::frame} -setup {
+ set result [list]
+} -body {
+ toplevel .t
+ ttk::frame .t.f
+ pack [label .t.f.l -text hello]
+ wm manage .t.f
+ raise .t.f
+ update
+ lappend result [winfo manage .t.f]
+ lappend result [winfo toplevel .t.f]
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result "window \".t.f\" is not manageable: must be a frame, labelframe or toplevel"
+test wm-manage-1.5 {managing a text widget} -setup {
+ set result [list]
+} -body {
+ toplevel .t
+ text .t.f
+ .t.f insert end "Manage text\n" {}
+ wm manage .t.f
+ raise .t.f
+ update
+ lappend result [winfo manage .t.f]
+ lappend result [winfo toplevel .t.f]
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result "window \".t.f\" is not manageable: must be a frame, labelframe or toplevel"
+test wm-manage-1.6 {managing a button} -setup {
+ set result [list]
+} -body {
+ toplevel .t
+ button .t.f -text Button
+ wm manage .t.f
+ raise .t.f
+ update
+ lappend result [winfo manage .t.f]
+ lappend result [winfo toplevel .t.f]
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result "window \".t.f\" is not manageable: must be a frame, labelframe or toplevel"
+test wm-manage-1.7 {managing a frame} -setup {
+ set result [list]
+} -body {
+ toplevel .t
+ frame .t.f
+ pack [label .t.f.l -text Label]
+ pack .t.f
+ update
+ lappend result [winfo manage .t.f]
+ lappend result [winfo toplevel .t.f]
+ wm manage .t.f
+ raise .t.f
+ update
+ lappend result [winfo manage .t.f]
+ lappend result [winfo toplevel .t.f]
+ wm forget .t.f
+ pack .t.f
+ update
+ lappend result [winfo manage .t.f]
+ lappend result [winfo toplevel .t.f]
+} -cleanup {
+ deleteWindows
+} -result {pack .t wm .t.f pack .t}
+test wm-manage-1.8 {unmanaging a toplevel} -setup {
+ set result [list]
+} -body {
+ toplevel .t
+ toplevel .t.t
+ button .t.t.b -text "Manage This"
+ pack .t.t.b
+ update
+ lappend result [winfo manage .t.t]
+ lappend result [winfo toplevel .t.t.b]
+ wm forget .t.t
+ wm forget .t.t ; # second call should be a no-op
+ pack .t.t
+ update
+ lappend result [winfo manage .t.t]
+ lappend result [winfo toplevel .t.t.b]
+ wm manage .t.t
+ wm manage .t.t ; # second call should be a no-op
+ wm deiconify .t.t
+ update
+ lappend result [winfo manage .t.t]
+ lappend result [winfo toplevel .t.t.b]
+} -cleanup {
+ deleteWindows
+} -result {wm .t.t pack .t wm .t.t}
+
+test wm-forget-1.1 "bug #2009788: forget toplevel can cause crash" -body {
+ toplevel .parent
+ toplevel .parent.child
+ wm forget .parent.child
+ winfo exists .parent.child
+} -cleanup {
+ deleteWindows
+} -result {1}
+test wm-forget-1.2 "bug #2009788: forget toplevel can cause crash" -body {
+ toplevel .parent
+ update
+ toplevel .parent.child
+ wm forget .parent.child
+ winfo exists .parent.child
+} -cleanup {
+ deleteWindows
+} -result {1}
+test wm-forget-1.3 "bug #2009788: forget toplevel can cause crash" -body {
+ toplevel .parent
+ toplevel .parent.child
+ wm forget .parent.child
+ wm manage .parent.child
+ winfo exists .parent.child
+} -cleanup {
+ deleteWindows
+} -result {1}
+test wm-forget-1.4 "pack into unmapped toplevel causes crash" -body {
+ toplevel .parent
+ toplevel .parent.child
+ wm forget .parent.child
+ pack [button .parent.child.button -text Hello]
+ after 250 {destroy .parent}
+ tkwait window .parent
+} -cleanup {
+ deleteWindows
+} -result {}
+
+test wm-forget-2 {bug [e9112ef96e] - [wm forget] doesn't completely} -setup {
+ catch {destroy .l .f.b .f}
+ set res {}
+} -body {
+ label .l -text "Top Dot"
+ frame .f
+ button .f.b -text Hello -command "puts Hello!"
+ pack .l -side top
+ pack .f.b
+ pack .f -side bottom
+ update
+ set res [winfo manager .f]
+ pack forget .f
+ update
+ lappend res [winfo manager .f]
+ wm manage .f
+ update
+ lappend res [winfo manager .f]
+ wm forget .f
+ update
+ lappend res [winfo manager .f]
+} -cleanup {
+ destroy .l .f.b .f
+ unset res
+} -result {pack {} wm {}}
+
+# FIXME:
+
+# Test delivery of virtual events to the WM. We could check to see if the
+# window was raised after a button click for example. This sort of testing may
+# not be possible.
+
+##############################################################################
+
+deleteWindows
+cleanupTests
+catch {unset results}
+catch {unset focusin}
+return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tk8.6/tests/xmfbox.test b/tk8.6/tests/xmfbox.test
new file mode 100644
index 0000000..f50329c
--- /dev/null
+++ b/tk8.6/tests/xmfbox.test
@@ -0,0 +1,166 @@
+# xmfbox.test --
+#
+# This file is a Tcl script to test the file dialog that's used
+# when the tk_strictMotif flag is set. Because the file dialog
+# runs in a modal loop, the only way to test it sufficiently is
+# to call the internal Tcl procedures in xmfbox.tcl directly.
+#
+# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
+# All rights reserved.
+
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+
+set testPWD [pwd]
+catch {unset data foo}
+
+proc cleanup {} {
+ global testPWD
+
+ set err0 [catch {
+ cd $testPWD
+ } msg0]
+
+ set err1 [catch {
+ if [file exists ./~nosuchuser1] {
+ file delete ./~nosuchuser1
+ }
+ } msg1]
+
+ set err2 [catch {
+ if [file exists ./~nosuchuser2] {
+ file delete ./~nosuchuser2
+ }
+ } msg2]
+
+ set err3 [catch {
+ if [file exists ./~nosuchuser3] {
+ file delete ./~nosuchuser3
+ }
+ } msg3]
+
+ set err4 [catch {
+ if [file exists ./~nosuchuser4] {
+ file delete ./~nosuchuser4
+ }
+ } msg4]
+
+ if {$err0 || $err1 || $err2 || $err3 || $err4} {
+ error [list $msg0 $msg1 $msg2 $msg3 $msg4]
+ }
+ catch {unset foo}
+ destroy .foo
+}
+
+# ----------------------------------------------------------------------
+
+test xmfbox-1.1 {tk::MotifFDialog_Create, -parent switch} -constraints {
+ unix
+} -setup {
+ catch {unset foo}
+} -body {
+ set x [tk::MotifFDialog_Create foo open {-parent .}]
+} -cleanup {
+ destroy $x
+} -result {.foo}
+
+test xmfbox-1.2 {tk::MotifFDialog_Create, -parent switch} -constraints {
+ unix
+} -setup {
+ catch {unset foo}
+ deleteWindows
+} -body {
+ toplevel .bar
+ wm geometry .bar +0+0
+ set x [tk::MotifFDialog_Create foo open {-parent .bar}]
+} -cleanup {
+ destroy $x
+ destroy .bar
+} -result {.bar.foo}
+
+
+test xmfbox-2.1 {tk::MotifFDialog_InterpFilter, ~ in dir names} -constraints {
+ unix
+} -body {
+ cleanup
+ file mkdir ./~nosuchuser1
+ set x [tk::MotifFDialog_Create foo open {}]
+ $::tk::dialog::file::foo(fEnt) delete 0 end
+ $::tk::dialog::file::foo(fEnt) insert 0 [pwd]/~nosuchuser1
+ set kk [tk::MotifFDialog_InterpFilter $x]
+} -result "$testPWD/~nosuchuser1 *"
+
+test xmfbox-2.2 {tk::MotifFDialog_InterpFilter, ~ in file names} -constraints {
+ unix
+} -body {
+ cleanup
+ close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}]
+ set x [tk::MotifFDialog_Create foo open {}]
+ $::tk::dialog::file::foo(fEnt) delete 0 end
+ $::tk::dialog::file::foo(fEnt) insert 0 [pwd]/~nosuchuser1
+ set kk [tk::MotifFDialog_InterpFilter $x]
+} -result "$testPWD ./~nosuchuser1"
+
+test xmfbox-2.3 {tk::MotifFDialog_Update, ~ in file names} -constraints {
+ unix
+} -body {
+ cleanup
+ close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}]
+ set x [tk::MotifFDialog_Create foo open {}]
+ $::tk::dialog::file::foo(fEnt) delete 0 end
+ $::tk::dialog::file::foo(fEnt) insert 0 [pwd]/~nosuchuser1
+ tk::MotifFDialog_InterpFilter $x
+ tk::MotifFDialog_Update $x
+ $::tk::dialog::file::foo(fList) get end
+} -result {~nosuchuser1}
+
+test xmfbox-2.4 {tk::MotifFDialog_LoadFile, ~ in file names} -constraints {
+ unix
+} -body {
+ cleanup
+ close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}]
+ set x [tk::MotifFDialog_Create foo open {}]
+ set i [lsearch [$::tk::dialog::file::foo(fList) get 0 end] ~nosuchuser1]
+ expr {$i >= 0}
+} -result 1
+
+test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} -constraints {
+ unix
+} -body {
+ cleanup
+ close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}]
+ set x [tk::MotifFDialog_Create foo open {}]
+ set i [lsearch [$::tk::dialog::file::foo(fList) get 0 end] ~nosuchuser1]
+ $::tk::dialog::file::foo(fList) selection clear 0 end
+ $::tk::dialog::file::foo(fList) selection set $i
+ tk::MotifFDialog_BrowseFList $x
+ $::tk::dialog::file::foo(sEnt) get
+} -result "$testPWD/~nosuchuser1"
+
+test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} -constraints {
+ unix
+} -body {
+ cleanup
+ close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}]
+ set x [tk::MotifFDialog_Create foo open {}]
+ set i [lsearch [$::tk::dialog::file::foo(fList) get 0 end] ~nosuchuser1]
+ $::tk::dialog::file::foo(fList) selection clear 0 end
+ $::tk::dialog::file::foo(fList) selection set $i
+ tk::MotifFDialog_BrowseFList $x
+ tk::MotifFDialog_ActivateFList $x
+ list $::tk::dialog::file::foo(selectPath) \
+ $::tk::dialog::file::foo(selectFile) $tk::Priv(selectFilePath)
+} -result "$testPWD ~nosuchuser1 $testPWD/~nosuchuser1"
+
+# cleanup
+cleanup
+cleanupTests
+return
+
+# Local variables:
+# mode: tcl
+# End: