Import Tk 8.5.15 (as of svn r89086)

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.

tests/all.tcl

@@ -0,0 +1,20 @@
+# 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 Tcl 8.5
+package require tcltest 2.2
+package require Tk ;# This is the Tk test suite; fail early if no Tk!
+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

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}
+
+
+
+
+
+
+
+
+
+
+
+
+

tests/bell.test

@@ -0,0 +1,46 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test bell-1.1 {bell command} {
+    list [catch {bell a} msg] $msg
+} {1 {bad option "a": must be -displayof or -nice}}
+test bell-1.2 {bell command} {
+    list [catch {bell a b} msg] $msg
+} {1 {bad option "a": must be -displayof or -nice}}
+test bell-1.3 {bell command} {
+    list [catch {bell -displayof gorp} msg] $msg
+} {1 {bad window path name "gorp"}}
+test bell-1.4 {bell command} {
+    list [catch {bell -nice -displayof} msg] $msg
+} {1 {wrong # args: should be "bell ?-displayof window? ?-nice?"}}
+test bell-1.5 {bell command} {
+    list [catch {bell -nice -nice -nice} msg] $msg
+} {0 {}}
+test bell-1.6 {bell command} {
+    list [catch {bell -displayof . -nice} msg] $msg
+} {0 {}}
+test bell-1.7 {bell command} {
+    list [catch {bell -nice -displayof . -nice} msg] $msg
+} {1 {wrong # args: should be "bell ?-displayof window? ?-nice?"}}
+test bell-1.8 {bell command} {
+    puts "Bell should ring now ..."
+    flush stdout
+    after 200
+    bell -displayof .
+    after 200
+    bell -nice
+    after 200
+    bell
+} {}
+
+# cleanup
+cleanupTests
+return

tests/bevel.tcl

@@ -0,0 +1,139 @@
+# 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
+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
+
+
+
+
+
+
+
+
+
+
+
+
+

tests/bgerror.test

@@ -0,0 +1,58 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test bgerror-1.1 {bgerror / tkerror compat} {
+    set errRes {}
+    proc tkerror {err} {
+	global errRes;
+	set errRes $err;
+    }
+    after 0 {error err1}
+    vwait errRes;
+    set errRes;
+} err1
+
+test bgerror-1.2 {bgerror / tkerror compat / accumulation} {
+    set errRes {}
+    proc tkerror {err} {
+	global errRes;
+	lappend errRes $err;
+    }
+    after 0 {error err1}
+    after 0 {error err2}
+    after 0 {error err3}
+    update
+    set errRes;
+} {err1 err2 err3}
+
+test bgerror-1.3 {bgerror / tkerror compat / accumulation / break} {
+    set errRes {}
+    proc tkerror {err} {
+	global errRes;
+	lappend errRes $err;
+	return -code break "skip!";
+    }
+    after 0 {error err1}
+    after 0 {error err2}
+    after 0 {error err3}
+    update
+    set errRes;
+} err1
+
+catch {rename tkerror {}}
+
+# some testing of the default error dialog
+# would be needed too, but that's not easy at all
+# to emulate.
+
+# cleanup
+cleanupTests
+return

tests/bitmap.test

@@ -0,0 +1,91 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} testbitmap {
+    set x gray25
+    lindex $x 0
+    destroy .b1
+    button .b1 -bitmap $x
+    lindex $x 0
+    testbitmap gray25
+} {{1 0}}
+test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} testbitmap {
+    set x gray25
+    destroy .b1 .b2
+    button .b1 -bitmap $x
+    destroy .b1
+    set result {}
+    lappend result [testbitmap gray25]
+    button .b2 -bitmap $x
+    lappend result [testbitmap gray25]
+} {{} {{1 1}}}
+test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} testbitmap {
+    set x gray25
+    destroy .b1 .b2
+    button .b1 -bitmap $x
+    set result {}
+    lappend result [testbitmap gray25]
+    button .b2 -bitmap $x
+    pack .b1 .b2 -side top
+    lappend result [testbitmap gray25]
+} {{{1 1}} {{2 1}}}
+
+test bitmap-2.1 {Tk_GetBitmap procedure} {
+    destroy .b1
+    list [catch {button .b1 -bitmap bad_name} msg] $msg
+} {1 {bitmap "bad_name" not defined}}
+test bitmap-2.2 {Tk_GetBitmap procedure} {
+    destroy .b1
+    list [catch {button .b1 -bitmap @xyzzy} msg] $msg
+} {1 {error reading bitmap file "xyzzy"}}
+
+test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} testbitmap {
+    set x questhead
+    destroy .b1 .b2 .b3
+    button .b1 -bitmap $x
+    button .b3 -bitmap $x
+    button .b2 -bitmap $x
+    set result {}
+    lappend result [testbitmap questhead]
+    destroy .b1
+    lappend result [testbitmap questhead]
+    destroy .b2
+    lappend result [testbitmap questhead]
+    destroy .b3
+    lappend result [testbitmap questhead]
+} {{{3 1}} {{2 1}} {{1 1}} {}}
+
+test bitmap-4.1 {FreeBitmapObjProc} testbitmap {
+    destroy .b
+    set x [format questhead]
+    button .b -bitmap $x
+    set y [format questhead]
+    .b configure -bitmap $y
+    set z [format 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
+    set result
+} {{{1 3}} {{1 2}} {{1 1}} {}}
+
+destroy .t
+
+# cleanup
+cleanupTests
+return

tests/border.test

@@ -0,0 +1,161 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+if {[testConstraint pseudocolor8]} {
+    toplevel .t -visual {pseudocolor 8} -colormap new
+    wm geom .t +0+0
+}
+
+test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} testborder {
+    set x orange
+    lindex $x 0
+    destroy .b1
+    button .b1 -bg $x -text .b1
+    lindex $x 0
+    testborder orange
+} {{1 0}}
+test border-1.3 {Tk_AllocBorderFromObj - discard stale border} testborder {
+    set x orange
+    destroy .b1 .b2
+    button .b1 -bg $x -text First
+    destroy .b1
+    set result {}
+    lappend result [testborder orange]
+    button .b2 -bg $x -text Second
+    lappend result [testborder orange]
+} {{} {{1 1}}}
+test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} testborder {
+    set x orange
+    destroy .b1 .b2
+    button .b1 -bg $x -text First
+    set result {}
+    lappend result [testborder orange]
+    button .b2 -bg $x -text Second
+    pack .b1 .b2 -side top
+    lappend result [testborder orange]
+} {{{1 1}} {{2 1}}}
+test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {pseudocolor8 testborder} {
+    set x purple
+    destroy .b1 .b2 .t.b
+    button .b1 -bg $x -text First
+    pack .b1 -side top
+    set result {}
+    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]
+} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
+
+test border-3.1 {Tk_Free3DBorder - reference counts} {pseudocolor8 testborder} {
+    set x purple
+    destroy .b1 .b2 .t.b
+    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
+    set result {}
+    lappend result [testborder purple]
+    destroy .b1
+    lappend result [testborder purple]
+    destroy .b2
+    lappend result [testborder purple]
+    destroy .t.b
+    lappend result [testborder purple]
+} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
+test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder} {
+    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 -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
+    set result {}
+    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]
+} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
+
+test border-4.1 {FreeBorderObjProc} testborder {
+    destroy .b
+    set x [format purple]
+    button .b -bg $x -text .b1
+    set y [format purple]
+    .b configure -bg $y
+    set z [format purple]
+    .b configure -bg $z
+    set result {}
+    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
+    set result
+} {{{1 3}} {{1 2}} {{1 1}} {}}
+
+catch {destroy .b}
+button .b
+test border-5.1 {Tk_GetReliefFromObj} {
+    .b configure -relief flat
+    .b cget -relief
+} {flat}
+test border-5.2 {Tk_GetReliefFromObj} {
+    .b configure -relief groove
+    .b cget -relief
+} {groove}
+test border-5.3 {Tk_GetReliefFromObj} {
+    .b configure -relief raised
+    .b cget -relief
+} {raised}
+test border-5.4 {Tk_GetReliefFromObj} {
+    .b configure -relief ridge
+    .b cget -relief
+} {ridge}
+test border-5.5 {Tk_GetReliefFromObj} {
+    .b configure -relief solid
+    .b cget -relief
+} {solid}
+test border-5.6 {Tk_GetReliefFromObj} {
+    .b configure -relief sunken
+    .b cget -relief
+} {sunken}
+test border-5.7 {Tk_GetReliefFromObj - error} {
+    list [catch {.b configure -relief upanddown} msg] $msg
+} {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}}
+
+if {[testConstraint pseudocolor8]} {
+    destroy .t
+}
+
+# cleanup
+cleanupTests
+return

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 ""
+} {}
+
+
+
+
+
+
+
+
+
+
+
+
+

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
+    }
+}
+
+
+
+
+
+
+
+
+
+
+
+
+

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
+    }
+}
+
+
+
+
+
+
+
+
+
+
+
+
+

tests/button.test

@@ -0,0 +1,836 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+proc bogusTrace args {
+    error "trace aborted"
+}
+catch {unset value}
+catch {unset value2}
+
+# Create entries in the option database to be sure that geometry options
+# like border width have predictable values.
+
+option add *Button.borderWidth 2
+option add *Button.highlightThickness 2
+option add *Button.font {Helvetica -12 bold}
+
+eval image delete [image names]
+if {[testConstraint testImageType]} {
+    image create test image1
+}
+label .l -text Label
+button .b -text Button
+checkbutton .c -text Checkbutton
+radiobutton .r -text Radiobutton
+pack .l .b .c .r
+update
+set i 1
+foreach test {
+    {-activebackground #012345 #012345 non-existent
+	    {unknown color name "non-existent"} {1 1 1 1}}
+    {-activeforeground #ff0000 #ff0000 non-existent
+	    {unknown color name "non-existent"} {1 1 1 1}}
+    {-anchor nw nw bogus
+	    {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+	    {1 1 1 1}}
+    {-background #ff0000 #ff0000 non-existent
+	    {unknown color name "non-existent"} {1 1 1 1}}
+    {-bd 4 4 badValue {bad screen distance "badValue"} {1 1 1 1}}
+    {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}
+	    {1 1 1 1}}
+    {-bitmap questhead questhead badValue {bitmap "badValue" not defined}
+	    {1 1 1 1}}
+    {-borderwidth 1.3 1.3 badValue {bad screen distance "badValue"} {1 1 1 1}}
+    {-command "set x" {set x} {} {} {0 1 1 1}}
+    {-compound left left bogus
+	    {bad compound "bogus": must be bottom, center, left, none, right, or top}
+	    {1 1 1 1}}
+    {-cursor arrow arrow badValue {bad cursor spec "badValue"} {1 1 1 1}}
+    {-default active active huh?
+	    {bad default "huh?": must be active, disabled, or normal}
+	    {0 1 0 0}}
+    {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}
+	    {1 1 1 1}}
+    {-fg #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}}
+    {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist} {1 1 1 1}}
+    {-foreground #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}}
+    {-height 18 18 20.0 {expected integer but got "20.0"} {1 1 1 1}}
+    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}
+	    {1 1 1 1}}
+    {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}
+	    {1 1 1 1}}
+    {-highlightthickness 6m 6m badValue {bad screen distance "badValue"}
+	    {1 1 1 1}}
+    {-image image1 image1 bogus {image "bogus" doesn't exist} {1 1 1 1}}
+    {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}
+	    {0 0 1 1}}
+    {-justify right right bogus
+	    {bad justification "bogus": must be left, right, or center}
+	    {1 1 1 1}}
+    {-offrelief flat flat 1.5
+	    {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+	    {0 0 1 1}}
+    {-offvalue lousy lousy {} {} {0 0 1 0}}
+    {-onvalue fantastic fantastic {} {} {0 0 1 0}}
+    {-overrelief "" "" 1.5
+	    {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+	    {0 1 1 1}}
+    {-padx 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}}
+    {-pady 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}}
+    {-repeatdelay 100 100 foo {expected integer but got "foo"} {0 1 0 0}}
+    {-repeatinterval 100 100 foo {expected integer but got "foo"} {0 1 0 0}}
+    {-relief flat flat 1.5
+	    {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+	    {1 1 1 1}}
+    {-selectcolor #110022 #110022 bogus {unknown color name "bogus"} {0 0 1 1}}
+    {-selectimage image1 image1 bogus {image "bogus" doesn't exist} {0 0 1 1}}
+    {-state normal normal bogus
+	    {bad state "bogus": must be active, disabled, or normal}
+	    {1 1 1 1}}
+    {-takefocus "any string" "any string" {} {} {1 1 1 1}}
+    {-text "Sample text" {Sample text} {} {} {1 1 1 1}}
+    {-textvariable i i {} {} {1 1 1 1}}
+    {-tristateimage image1 image1 bogus {image "bogus" doesn't exist}
+	    {0 0 1 1}}
+    {-tristatevalue unknowable unknowable {} {} {0 0 1 1}}
+    {-underline 5 5 3p {expected integer but got "3p"} {1 1 1 1}}
+    {-value anyString anyString {} {} {0 0 0 1}}
+    {-width 402 402 3p {expected integer but got "3p"} {1 1 1 1}}
+    {-wraplength 100 100 6x {bad screen distance "6x"} {1 1 1 1}}
+} {
+    lassign $test name value okResult badValue badResult classes
+    foreach w {.l .b .c .r} hasOption $classes {
+	set classname [winfo class $w]
+	if {$hasOption} {
+	    test button-1.$i "configuration option $name for $classname" \
+		-constraints testImageType -body "
+		    $w configure $name [list $value]
+		    lindex \[$w configure $name] 4
+		" -result $okResult
+	    incr i
+	    if {$badValue ne ""} {
+		test button-1.$i "configuration option $name for $classname" \
+		    -constraints testImageType \
+		    -body [list $w configure $name $badValue] \
+		    -returnCodes error -result $badResult
+		incr i
+	    }
+	    $w configure $name [lindex [$w configure $name] 3]
+	} else {
+	    test button-1.$i "configuration option $name for $classname" \
+		-constraints testImageType \
+		-body [list $w configure $name $value] \
+		-returnCodes error -result "unknown option \"$name\""
+	    incr i
+	}
+    }
+}
+test button-1.$i {configuration options} {
+    # Additional check to make sure that -selectcolor may be empty in
+    # checkbox widgets
+    .c configure -selectcolor {}
+} {}
+
+test button-3.1 {ButtonCreate - not enough cd ../unix
+} {
+    list [catch {button} msg] $msg
+} {1 {wrong # args: should be "button pathName ?options?"}}
+test button-3.2 {ButtonCreate procedure - setting label class} {
+    catch {destroy .x}
+    label .x
+    winfo class .x
+} {Label}
+test button-3.3 {ButtonCreate - setting button class} {
+    catch {destroy .x}
+    button .x
+    winfo class .x
+} {Button}
+test button-3.4 {ButtonCreate - setting checkbutton class} {
+    catch {destroy .x}
+    checkbutton .x
+    winfo class .x
+} {Checkbutton}
+test button-3.5 {ButtonCreate - setting radiobutton class} {
+    catch {destroy .x}
+    radiobutton .x
+    winfo class .x
+} {Radiobutton}
+rename button gorp
+test button-3.6 {ButtonCreate - setting class} {
+    catch {destroy .x}
+    gorp .x
+    winfo class .x
+} {Button}
+rename gorp button
+test button-3.7 {ButtonCreate - bad window name} {
+    list [catch {button foo} msg] $msg
+} {1 {bad window path name "foo"}}
+test button-3.8 {ButtonCreate procedure - error in default option value} {
+    catch {destroy .funny}
+    option add *funny.background bogus
+    list [catch {button .funny} msg] $msg $errorInfo
+} {1 {unknown color name "bogus"} {unknown color name "bogus"
+    (database entry for "-background" in widget ".funny")
+    invoked from within
+"button .funny"}}
+test button-3.9 {ButtonCreate procedure - option error} {
+    catch {destroy .x}
+    list [catch {button .x -gorp foo} msg] $msg [winfo exists .x]
+} {1 {unknown option "-gorp"} 0}
+test button-3.10 {ButtonCreate procedure - return value} {
+    catch {destroy .abcd}
+    set x [button .abcd]
+    destroy .abc
+    set x
+} {.abcd}
+
+test button-4.1 {ButtonWidgetCmd - too few arguments} {
+    list [catch {.b} msg] $msg
+} {1 {wrong # args: should be ".b option ?arg arg ...?"}}
+test button-4.2 {ButtonWidgetCmd - bad option name} {
+    list [catch {.b c} msg] $msg
+} {1 {ambiguous option "c": must be cget, configure, flash, or invoke}}
+test button-4.3 {ButtonWidgetCmd - bad option name} {
+    list [catch {.b bogus} msg] $msg
+} {1 {bad option "bogus": must be cget, configure, flash, or invoke}}
+test button-4.4 {ButtonWidgetCmd procedure, "cget" option} {
+    list [catch {.b cget a b} msg] $msg
+} {1 {wrong # args: should be ".b cget option"}}
+test button-4.5 {ButtonWidgetCmd procedure, "cget" option} {
+    list [catch {.b cget -gorp} msg] $msg
+} {1 {unknown option "-gorp"}}
+test button-4.6 {ButtonWidgetCmd procedure, "cget" option} {
+    .b configure -highlightthickness 3
+    .b cget -highlightthickness
+} {3}
+test button-4.7 {ButtonWidgetCmd procedure, "cget" option} {
+    catch {.l cget -disabledforeground}
+} {0}
+test button-4.8 {ButtonWidgetCmd procedure, "cget" option} {
+    catch {.b cget -disabledforeground}
+} {0}
+test button-4.9 {ButtonWidgetCmd procedure, "cget" option} {
+    list [catch {.b cget -variable} msg] $msg
+} {1 {unknown option "-variable"}}
+test button-4.10 {ButtonWidgetCmd procedure, "cget" option} {
+    catch {.c cget -variable}
+} {0}
+test button-4.11 {ButtonWidgetCmd procedure, "cget" option} {
+    list [catch {.c cget -value} msg] $msg
+} {1 {unknown option "-value"}}
+test button-4.12 {ButtonWidgetCmd procedure, "cget" option} {
+    catch {.r cget -value}
+} {0}
+test button-4.13 {ButtonWidgetCmd procedure, "cget" option} {
+    list [catch {.r cget -onvalue} msg] $msg
+} {1 {unknown option "-onvalue"}}
+test button-4.14 {ButtonWidgetCmd procedure, "configure" option} {
+    llength [.c configure]
+} {41}
+test button-4.15 {ButtonWidgetCmd procedure, "configure" option} {
+    list [catch {.b configure -gorp} msg] $msg
+} {1 {unknown option "-gorp"}}
+test button-4.16 {ButtonWidgetCmd procedure, "configure" option} {
+    list [catch {.b co -bg #ffffff -fg} msg] $msg
+} {1 {value for "-fg" missing}}
+test button-4.17 {ButtonWidgetCmd procedure, "configure" option} {
+    .b configure -fg #123456
+    .b configure -bg #654321
+    lindex [.b configure -fg] 4
+} {#123456}
+.c configure -variable value -onvalue 1 -offvalue 0
+.r configure -variable value2 -value red
+test button-4.18 {ButtonWidgetCmd procedure, "deselect" option} {
+    list [catch {.c deselect foo} msg] $msg
+} {1 {wrong # args: should be ".c deselect"}}
+test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} {
+    list [catch {.l deselect} msg] $msg
+} {1 {bad option "deselect": must be cget or configure}}
+test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} {
+    list [catch {.b deselect} msg] $msg
+} {1 {bad option "deselect": must be cget, configure, flash, or invoke}}
+test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} {
+    set value 1
+    .c d
+    set value
+} {0}
+test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} {
+    set value2 green
+    .r deselect
+    set value2
+} {green}
+test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} {
+    set value2 red
+    .r deselect
+    set value2
+} {}
+test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} -body {
+    set value 1
+    trace variable value w bogusTrace
+    set result [list [catch {.c deselect} msg] $msg $errorInfo $value]
+    trace vdelete value w bogusTrace
+    set result
+} -match glob -result {1 {can't set "value": trace aborted} {*trace aborted
+    while executing
+*
+".c deselect"} 0}
+test button-4.25 {ButtonWidgetCmd procedure, "deselect" option} -body {
+    set value2 red
+    trace variable value2 w bogusTrace
+    set result [list [catch {.r deselect} msg] $msg $errorInfo $value2]
+    trace vdelete value2 w bogusTrace
+    set result
+} -match glob -result {1 {can't set "value2": trace aborted} {*trace aborted
+    while executing
+*
+".r deselect"} {}}
+test button-4.26 {ButtonWidgetCmd procedure, "flash" option} {
+    list [catch {.b flash foo} msg] $msg
+} {1 {wrong # args: should be ".b flash"}}
+test button-4.27 {ButtonWidgetCmd procedure, "flash" option} {
+    list [catch {.l flash} msg] $msg
+} {1 {bad option "flash": must be cget or configure}}
+test button-4.28 {ButtonWidgetCmd procedure, "flash" option} {
+    list [catch {.b flash} msg] $msg
+} {0 {}}
+test button-4.29 {ButtonWidgetCmd procedure, "flash" option} {
+    list [catch {.c flash} msg] $msg
+} {0 {}}
+test button-4.30 {ButtonWidgetCmd procedure, "flash" option} {
+    list [catch {.r f} msg] $msg
+} {0 {}}
+test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} {
+    list [catch {.b invoke foo} msg] $msg
+} {1 {wrong # args: should be ".b invoke"}}
+test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} {
+    list [catch {.l invoke} msg] $msg
+} {1 {bad option "invoke": must be cget or configure}}
+test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} {
+    .b configure -command {set x invoked}
+    set x "not invoked"
+    .b invoke
+    set x
+} {invoked}
+test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} {
+    .b configure -command {set x invoked} -state disabled
+    set x "not invoked"
+    .b invoke
+    set x
+} {not invoked}
+test button-4.35 {ButtonWidgetCmd procedure, "invoke" option} {
+    set value bogus
+    .c configure -command {set x invoked} -variable value -onvalue 1 \
+	    -offvalue 0
+    set x "not invoked"
+    .c invoke
+    list $x $value
+} {invoked 1}
+test button-4.36 {ButtonWidgetCmd procedure, "invoke" option} {
+    set value2 green
+    .r configure -command {set x invoked} -variable value2 -value red
+    set x "not invoked"
+    .r i
+    list $x $value2
+} {invoked red}
+test button-4.37 {ButtonWidgetCmd procedure, "select" option} {
+    list [catch {.l select} msg] $msg
+} {1 {bad option "select": must be cget or configure}}
+test button-4.38 {ButtonWidgetCmd procedure, "select" option} {
+    list [catch {.b select} msg] $msg
+} {1 {bad option "select": must be cget, configure, flash, or invoke}}
+test button-4.39 {ButtonWidgetCmd procedure, "select" option} {
+    list [catch {.c select foo} msg] $msg
+} {1 {wrong # args: should be ".c select"}}
+test button-4.40 {ButtonWidgetCmd procedure, "select" option} {
+    set value bogus
+    .c configure -command {} -variable value -onvalue lovely -offvalue 0
+    .c s
+    set value
+} {lovely}
+test button-4.41 {ButtonWidgetCmd procedure, "select" option} {
+    set value2 green
+    .r configure -command {} -variable value2 -value red
+    .r select
+    set value2
+} {red}
+test button-4.42 {ButtonWidgetCmd procedure, "select" option} -body {
+    set value2 yellow
+    trace variable value2 w bogusTrace
+    set result [list [catch {.r select} msg] $msg $errorInfo $value2]
+    trace vdelete value2 w bogusTrace
+    set result
+} -match glob -result {1 {can't set "value2": trace aborted} {*trace aborted
+    while executing
+*
+".r select"} red}
+test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} {
+    list [catch {.l toggle} msg] $msg
+} {1 {bad option "toggle": must be cget or configure}}
+test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} {
+    list [catch {.b toggle} msg] $msg
+} {1 {bad option "toggle": must be cget, configure, flash, or invoke}}
+test button-4.45 {ButtonWidgetCmd procedure, "toggle" option} {
+    list [catch {.r toggle} msg] $msg
+} {1 {bad option "toggle": must be cget, configure, deselect, flash, invoke, or select}}
+test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} {
+    list [catch {.c toggle foo} msg] $msg
+} {1 {wrong # args: should be ".c toggle"}}
+test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} {
+    set value bogus
+    .c configure -command {} -variable value -onvalue sunshine -offvalue rain
+    .c toggle
+    set result $value
+    .c toggle
+    lappend result $value
+    .c toggle
+    lappend result $value
+} {sunshine rain sunshine}
+test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} -body {
+    .c configure -onvalue xyz -offvalue abc
+    set value xyz
+    trace variable value w bogusTrace
+    set result [list [catch {.c toggle} msg] $msg $errorInfo $value]
+    trace vdelete value w bogusTrace
+    set result
+} -match glob -result {1 {can't set "value": trace aborted} {*trace aborted
+    while executing
+*
+".c toggle"} abc}
+test button-4.49 {ButtonWidgetCmd procedure, "toggle" option} -body {
+    .c configure -onvalue xyz -offvalue abc
+    set value abc
+    trace variable value w bogusTrace
+    set result [list [catch {.c toggle} msg] $msg $errorInfo $value]
+    trace vdelete value w bogusTrace
+    set result
+} -match glob -result {1 {can't set "value": trace aborted} {*trace aborted
+    while executing
+*
+".c toggle"} xyz}
+test button-4.50 {ButtonWidgetCmd procedure, "toggle" option} {
+    catch {unset value}; set value(1) 1;
+    set result [list [catch {.c toggle} msg] $msg $errorInfo]
+    unset value;
+    set result
+} {1 {can't set "value": variable is array} {can't set "value": variable is array
+    while executing
+".c toggle"}}
+
+test button-5.1 {DestroyButton procedure} testImageType {
+    image create test image1
+    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
+} {}
+
+test button-6.1 {ConfigureButton - textvariable trace} {
+    catch {destroy .b1}
+    button .b1 -bd 4 -bg green
+    catch {.b1 configure -bd 7 -bg green -fg bogus}
+    list [catch {.b1 configure -bd 7 -bg red -fg bogus} msg] \
+	    $msg [.b1 cget -bd] [.b1 cget -bg]
+} {1 {unknown color name "bogus"} 4 green}
+test button-6.2 {ConfigureButton - textvariable trace} {
+    catch {destroy .b1}
+    set x From-x
+    set y From-y
+    button .b1 -textvariable x
+    .b1 configure -textvariable y
+    set x New
+    lindex [.b1 configure -text] 4
+} {From-y}
+test button-6.2a {ConfigureButton - variable traces} {
+    catch {destroy .b1}
+    catch {unset x}
+    checkbutton .b1 -variable x
+    set x 1
+    set y 1
+    .b1 configure -textvariable y
+    set x 0
+    .b1 toggle
+    set y
+} {1}
+test button-6.3 {ConfigureButton - image handling} testImageType {
+    catch {destroy .b1}
+    eval image delete [image names]
+    image create test image1
+    image create test image2
+    button .b1 -image image1
+    image delete image1
+    .b1 configure -image image2
+    image names
+} {image2}
+test button-6.5 {ConfigureButton - default value for variable} {
+    catch {destroy .b1}
+    checkbutton .b1
+    .b1 cget -variable
+} {b1}
+test button-6.6 {ConfigureButton - setting selected state from variable} {
+    catch {destroy .b1}
+    set x 0
+    set y Shiny
+    checkbutton .b1 -variable x
+    .b1 configure -variable y -onvalue Shiny
+    .b1 toggle
+    set y
+} 0
+test button-6.7 {ConfigureButton - setting selected state from variable} {
+    catch {destroy .b1}
+    catch {unset x}
+    checkbutton .b1 -variable x -offvalue Bogus
+    set x
+} Bogus
+test button-6.8 {ConfigureButton - setting selected state from variable} {
+    catch {destroy .b1}
+    catch {unset x}
+    radiobutton .b1 -variable x
+    set x
+} {}
+test button-6.9 {ConfigureButton - error in setting variable} {
+    catch {destroy .b1}
+    catch {unset x}
+    trace variable x w bogusTrace
+    set result [list [catch {radiobutton .b1 -variable x} msg] $msg]
+    trace vdelete x w bogusTrace
+    set result
+} {1 {can't set "x": trace aborted}}
+test button-6.10 {ConfigureButton - bad image name} {
+    catch {destroy .b1}
+    list [catch {button .b1 -image bogus} msg] $msg
+} {1 {image "bogus" doesn't exist}}
+test button-6.11 {ConfigureButton - setting variable from current text value} {
+    catch {destroy .b1}
+    catch {unset x}
+    button .b1 -textvariable x -text "Button 1"
+    set x
+} {Button 1}
+test button-6.12 {ConfigureButton - using current value of variable} {
+    catch {destroy .b1}
+    set x Override
+    button .b1 -textvariable x -text "Button 1"
+    set x
+} {Override}
+test button-6.13 {ConfigureButton - variable handling} {
+    catch {destroy .b1}
+    catch {unset x}
+    trace variable x w bogusTrace
+    set result [list [catch {radiobutton .b1 -text foo -textvariable x} msg] \
+	    $msg $x]
+    trace vdelete x w bogusTrace
+    set result
+} {1 {can't set "x": trace aborted} foo}
+test button-6.14 {ConfigureButton - -width option} {
+    catch {destroy .b1}
+    button .b1 -text "Button 1"
+    list [catch {.b1 configure -width 1i} msg] $msg $errorInfo
+} {1 {expected integer but got "1i"} {expected integer but got "1i"
+    (processing -width option)
+    invoked from within
+".b1 configure -width 1i"}}
+test button-6.15 {ConfigureButton - -height option} {
+    catch {destroy .b1}
+    button .b1 -text "Button 1"
+    list [catch {.b1 configure -height 0.5c} msg] $msg $errorInfo
+} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c"
+    (processing -height option)
+    invoked from within
+".b1 configure -height 0.5c"}}
+test button-6.16 {ConfigureButton - -width option} {
+    catch {destroy .b1}
+    button .b1 -bitmap questhead
+    list [catch {.b1 configure -width abc} msg] $msg $errorInfo
+} {1 {bad screen distance "abc"} {bad screen distance "abc"
+    (processing -width option)
+    invoked from within
+".b1 configure -width abc"}}
+test button-6.17 {ConfigureButton - -height option} testImageType {
+    catch {destroy .b1}
+    eval image delete [image names]
+    image create test image1
+    button .b1 -image image1
+    list [catch {.b1 configure -height 0.5x} msg] $msg $errorInfo
+} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x"
+    (processing -height option)
+    invoked from within
+".b1 configure -height 0.5x"}}
+test button-6.18 {ConfigureButton - computing geometry} {nonPortable fonts} {
+    catch {destroy .b1}
+    button .b1 -text "Sample text" -width 10 -height 2
+    pack .b1
+    set result "[winfo reqwidth .b1] [winfo reqheight .b1]"
+    .b1 configure -bitmap questhead
+    lappend result [winfo reqwidth .b1] [winfo reqheight .b1]
+} {102 46 20 12}
+test button-6.19 {ConfigureButton - computing geometry} {
+    catch {destroy .b1}
+    button .b1 -text "Button 1"
+    set old [winfo reqwidth .b1]
+    .b1 configure -text "Much longer text"
+    set new [winfo reqwidth .b1]
+    expr $old == $new
+} {0}
+
+test button-7.1 {ButtonEventProc procedure} {
+    catch {destroy .b1}
+    button .b1 -text "Test Button" -command {
+	destroy .b1
+	set x [list [winfo exists .b1] [info commands .b1]]
+    }
+    .b1 invoke
+    set x
+} {0 {}}
+test button-7.2 {ButtonEventProc procedure} {
+    deleteWindows
+    button .b1 -bg #543210
+    rename .b1 .b2
+    set x {}
+    lappend x [winfo children .]
+    lappend x [.b2 cget -bg]
+    destroy .b1
+    lappend x [info command .b*] [winfo children .]
+} {.b1 #543210 {} {}}
+
+test button-8.1 {ButtonCmdDeletedProc procedure} {
+    deleteWindows
+    button .b1
+    rename .b1 {}
+    list [info command .b*] [winfo children .]
+} {{} {}}
+
+test button-9.1 {TkInvokeButton procedure} {
+    catch {destroy .b1}
+    set x 0
+    checkbutton .b1 -variable x
+    set result $x
+    .b1 invoke
+    lappend result $x
+    .b1 invoke
+    lappend result $x
+} {0 1 0}
+test button-9.2 {TkInvokeButton procedure} {
+    catch {destroy .b1}
+    set x 0
+    checkbutton .b1 -variable x
+    trace variable x w bogusTrace
+    set result [list [catch {.b1 invoke} msg] $msg $x]
+    trace vdelete x w bogusTrace
+    set result
+} {1 {can't set "x": trace aborted} 1}
+test button-9.3 {TkInvokeButton procedure} {
+    catch {destroy .b1}
+    set x 1
+    checkbutton .b1 -variable x
+    trace variable x w bogusTrace
+    set result [list [catch {.b1 invoke} msg] $msg $x]
+    trace vdelete x w bogusTrace
+    set result
+} {1 {can't set "x": trace aborted} 0}
+test button-9.4 {TkInvokeButton procedure} {
+    catch {destroy .b1}
+    set x 0
+    radiobutton .b1 -variable x -value red
+    set result $x
+    .b1 invoke
+    lappend result $x
+    .b1 invoke
+    lappend result $x
+} {0 red red}
+test button-9.5 {TkInvokeButton procedure} -body {
+    catch {destroy .b1}
+    radiobutton .b1 -variable x -value red
+    set x green
+    trace variable x w bogusTrace
+    set result [list [catch {.b1 invoke} msg] $msg $errorInfo $x]
+    trace vdelete x w bogusTrace
+    set result
+} -match glob -result {1 {can't set "x": trace aborted} {*trace aborted
+    while executing
+*
+".b1 invoke"} red}
+test button-9.6 {TkInvokeButton procedure} {
+    deleteWindows
+    set result untouched
+    button .b1 -command {set result invoked}
+    list [catch {.b1 invoke} msg] $msg $result
+} {0 invoked invoked}
+test button-9.7 {TkInvokeButton procedure} {
+    deleteWindows
+    set result untouched
+    set x 0
+    checkbutton .b1 -variable x -command {set result "invoked $x"}
+    list [catch {.b1 invoke} msg] $msg $result
+} {0 {invoked 1} {invoked 1}}
+test button-9.8 {TkInvokeButton procedure} {
+    deleteWindows
+    set result untouched
+    set x 0
+    radiobutton .b1 -variable x -value red -command {set result "invoked $x"}
+    list [catch {.b1 invoke} msg] $msg $result
+} {0 {invoked red} {invoked red}}
+
+test button-10.1 {ButtonVarProc procedure} {
+    deleteWindows
+    set x 1
+    checkbutton .b1 -variable x
+    unset x
+    set result [info exists x]
+    .b1 toggle
+    lappend result $x
+    set x 0
+    .b1 toggle
+    lappend result $x
+} {0 1 1}
+test button-10.2 {ButtonVarProc procedure} {
+    deleteWindows
+    set x 0
+    checkbutton .b1 -variable x
+    set x 44
+    .b1 toggle
+    set x
+} {1}
+test button-10.3 {ButtonVarProc procedure} {
+    deleteWindows
+    set x 1
+    checkbutton .b1 -variable x
+    set x 44
+    .b1 toggle
+    set x
+} {1}
+test button-10.4 {ButtonVarProc procedure} {
+    deleteWindows
+    set x 0
+    checkbutton .b1 -variable x
+    set x 1
+    .b1 toggle
+    set x
+} {0}
+test button-10.5 {ButtonVarProc procedure} {
+    deleteWindows
+    set x 1
+    checkbutton .b1 -variable x
+    set x 1
+    .b1 toggle
+    set x
+} {0}
+test button-10.6 {ButtonVarProc procedure} {
+    deleteWindows
+    set x 0
+    checkbutton .b1 -variable x
+    set x 0
+    .b1 toggle
+    set x
+} {1}
+test button-10.7 {ButtonVarProc procedure} {
+    deleteWindows
+    set x 1
+    checkbutton .b1 -variable x
+    set x 0
+    .b1 toggle
+    set x
+} {1}
+test button-10.8 {ButtonVarProc procedure, can't read variable} {
+    # This test does nothing but produce a core dump if there's a prbblem.
+    deleteWindows
+    catch {unset a}
+    checkbutton .b1 -variable a
+    unset a
+    set a(32) 0
+    unset a
+} {}
+
+test button-11.1 {ButtonTextVarProc procedure} {
+    deleteWindows
+    set x Label
+    button .b1 -textvariable x
+    unset x
+    set result [list $x [lindex [.b1 configure -text] 4]]
+    set x New
+    lappend result [lindex [.b1 configure -text] 4]
+} {Label Label New}
+test button-11.2 {ButtonTextVarProc procedure} {
+    deleteWindows
+    # Windows buttons have a default min width, so we have to
+    # set this to be longer to force the wider button.
+    set x ExtraLongLabel
+    button .b1 -textvariable x
+    set old [winfo reqwidth .b1]
+    set x New
+    set new [winfo reqwidth .b1]
+    list [lindex [.b1 configure -text] 4] [expr $old == $new]
+} {New 0}
+
+test button-12.1 {ButtonImageProc procedure} testImageType {
+    deleteWindows
+    eval image delete [image names]
+    image create test image1
+    label .b1 -image image1 -padx 0 -pady 0 -bd 0
+    pack .b1
+    set result "[winfo reqwidth .b1] [winfo reqheight .b1]"
+    image1 changed 0 0 0 0 80 100
+    lappend result [winfo reqwidth .b1] [winfo reqheight .b1]
+} {30 15 80 100}
+
+deleteWindows
+set l [interp hidden]
+
+test button-13.1 {button widget vs hidden commands} {
+    catch {destroy .b}
+    button .b -text hello
+    interp hide {} .b
+    destroy .b
+    list [winfo children .] [interp hidden]
+} [list {} $l]
+
+deleteWindows
+
+test button-14.1 {size behaviouor} {
+    set res {}
+    foreach class {label button radiobutton checkbutton} {
+	eval destroy [winfo children .]
+
+	$class .a -text Hej 
+	$class .b -text Hej -width 10 -height 1
+	$class .c -text "" -width 10 -height 1
+
+	for {set t 0} {$t < 2} {incr t} {
+	    set res2 {}
+	    # With -width, width should not be affected by text change
+	    lappend res2 [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+	    # With -height, height should not be affected by text change
+	    lappend res2 [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+	    # A one line text should be as high as -height 1
+	    lappend res2 [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+	    lappend res $res2
+	    
+	    # Do the second round with another font
+	    .a configure -font "Arial 20"
+	    .b configure -font "Arial 20"
+	    .c configure -font "Arial 20"
+	}
+    }
+    set res
+} {{1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1}}
+
+deleteWindows
+
+option clear
+
+# cleanup
+cleanupTests
+return

tests/canvImg.test

@@ -0,0 +1,391 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+eval image delete [image names]
+canvas .c
+pack .c
+update
+if {[testConstraint testImageType]} {
+    image create test foo -variable x
+    image create test foo2 -variable y
+    foo2 changed 0 0 0 0 80 60
+}
+test canvImg-1.1 {options for image items} {
+    .c delete all
+    .c create image 50 50 -anchor nw -tags i1
+    .c itemconfigure i1 -anchor
+} {-anchor {} {} center nw}
+test canvImg-1.2 {options for image items} {
+    .c delete all
+    list [catch {.c create image 50 50 -anchor gorp -tags i1} msg] $msg
+} {1 {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center}}
+test canvImg-1.3 {options for image items} testImageType {
+    .c delete all
+    .c create image 50 50 -image foo -tags i1
+    .c itemconfigure i1 -image
+} {-image {} {} {} foo}
+test canvImg-1.4 {options for image items} {
+    .c delete all
+    list [catch {.c create image 50 50 -image unknown -tags i1} msg] $msg
+} {1 {image "unknown" doesn't exist}}
+test canvImg-1.5 {options for image items} testImageType {
+    .c delete all
+    .c create image 50 50 -image foo -tags {i1 foo}
+    .c itemconfigure i1 -tags
+} {-tags {} {} {} {i1 foo}}
+
+test canvImg-2.1 {CreateImage procedure} {
+    list [catch {.c create image 40} msg] $msg
+} {1 {wrong # coordinates: expected 2, got 1}}
+test canvImg-2.2 {CreateImage procedure} {
+    list [catch {.c create image 40 50 60} msg] $msg
+} {1 {unknown option "60"}}
+test canvImg-2.3 {CreateImage procedure} {
+    .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]
+} {center {} {}}
+test canvImg-2.4 {CreateImage procedure} {
+    list [catch {.c create image xyz 40} msg] $msg
+} {1 {bad screen distance "xyz"}}
+test canvImg-2.5 {CreateImage procedure} {
+    list [catch {.c create image 50 qrs} msg] $msg
+} {1 {bad screen distance "qrs"}}
+test canvImg-2.6 {CreateImage procedure} testImageType {
+    list [catch {.c create image 50 50 -gorp foo} msg] $msg
+} {1 {unknown option "-gorp"}}
+
+test canvImg-3.1 {ImageCoords procedure} testImageType {
+    .c delete all
+    .c create image 50 100 -image foo -tags i1
+    .c coords i1
+} {50.0 100.0}
+test canvImg-3.2 {ImageCoords procedure} testImageType {
+    .c delete all
+    .c create image 50 100 -image foo -tags i1
+    list [catch {.c coords i1 dumb 100} msg] $msg
+} {1 {bad screen distance "dumb"}}
+test canvImg-3.3 {ImageCoords procedure} testImageType {
+    .c delete all
+    .c create image 50 100 -image foo -tags i1
+    list [catch {.c coords i1 250 dumb0} msg] $msg
+} {1 {bad screen distance "dumb0"}}
+test canvImg-3.4 {ImageCoords procedure} testImageType {
+    .c delete all
+    .c create image 50 100 -image foo -tags i1
+    list [catch {.c coords i1 250} msg] $msg
+} {1 {wrong # coordinates: expected 2, got 1}}
+test canvImg-3.5 {ImageCoords procedure} testImageType {
+    .c delete all
+    .c create image 50 100 -image foo -tags i1
+    list [catch {.c coords i1 250 300 400} msg] $msg
+} {1 {wrong # coordinates: expected 0 or 2, got 3}}
+
+test canvImg-4.1 {ConfiugreImage procedure} testImageType {
+    .c delete all
+    .c create image 50 100 -image foo -tags i1
+    update
+    set x {}
+    .c itemconfigure i1 -image {}
+    update
+    list $x [.c bbox i1]
+} {{{foo free}} {}}
+test canvImg-4.2 {ConfiugreImage procedure} testImageType {
+    .c delete all
+    .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]
+} {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60 30 30}} {50 100 130 160}}
+test canvImg-4.3 {ConfiugreImage procedure} testImageType {
+    .c delete all
+    .c create image 50 100 -image foo -tags i1 -anchor nw
+    update
+    set x {}
+    set y {}
+    list [catch {.c itemconfigure i1 -image lousy} msg] $msg
+} {1 {image "lousy" doesn't exist}}
+
+test canvImg-5.1 {DeleteImage procedure} testImageType {
+    image create test xyzzy -variable z
+    .c delete all
+    .c create image 50 100 -image xyzzy -tags i1
+    update
+    set names [lsort [image names]]
+    image delete xyzzy
+    set z {}
+    set names2 [lsort [image names]]
+    .c delete i1
+    update
+    list $names $names2 $z [lsort [image names]]
+} {{foo foo2 xyzzy} {foo foo2} {} {foo foo2}}
+test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} {
+    .c delete all
+    .c create image 50 100 -tags i1
+    update
+    .c delete i1
+    update
+} {}
+
+test canvImg-6.1 {ComputeImageBbox procedure} testImageType {
+    .c delete all
+    .c create image 15.51 17.51 -image foo -tags i1 -anchor nw
+    .c bbox i1
+} {16 18 46 33}
+test canvImg-6.2 {ComputeImageBbox procedure} testImageType {
+    .c delete all
+    .c create image 15.49 17.49 -image foo -tags i1 -anchor nw
+    .c bbox i1
+} {15 17 45 32}
+test canvImg-6.3 {ComputeImageBbox procedure} {
+    .c delete all
+    .c create image 20 30 -tags i1 -anchor nw
+    .c bbox i1
+} {}
+test canvImg-6.4 {ComputeImageBbox procedure} testImageType {
+    .c delete all
+    .c create image 20 30 -image foo -tags i1 -anchor nw
+    .c bbox i1
+} {20 30 50 45}
+test canvImg-6.5 {ComputeImageBbox procedure} testImageType {
+    .c delete all
+    .c create image 20 30 -image foo -tags i1 -anchor n
+    .c bbox i1
+} {5 30 35 45}
+test canvImg-6.6 {ComputeImageBbox procedure} testImageType {
+    .c delete all
+    .c create image 20 30 -image foo -tags i1 -anchor ne
+    .c bbox i1
+} {-10 30 20 45}
+test canvImg-6.7 {ComputeImageBbox procedure} testImageType {
+    .c delete all
+    .c create image 20 30 -image foo -tags i1 -anchor e
+    .c bbox i1
+} {-10 23 20 38}
+test canvImg-6.8 {ComputeImageBbox procedure} testImageType {
+    .c delete all
+    .c create image 20 30 -image foo -tags i1 -anchor se
+    .c bbox i1
+} {-10 15 20 30}
+test canvImg-6.9 {ComputeImageBbox procedure} testImageType {
+    .c delete all
+    .c create image 20 30 -image foo -tags i1 -anchor s
+    .c bbox i1
+} {5 15 35 30}
+test canvImg-6.10 {ComputeImageBbox procedure} testImageType {
+    .c delete all
+    .c create image 20 30 -image foo -tags i1 -anchor sw
+    .c bbox i1
+} {20 15 50 30}
+test canvImg-6.11 {ComputeImageBbox procedure} testImageType {
+    .c delete all
+    .c create image 20 30 -image foo -tags i1 -anchor w
+    .c bbox i1
+} {20 23 50 38}
+test canvImg-6.12 {ComputeImageBbox procedure} testImageType {
+    .c delete all
+    .c create image 20 30 -image foo -tags i1 -anchor center
+    .c bbox i1
+} {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} {nonPortable testImageType} {
+    .c delete all
+    .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
+} {{foo display 4 9 12 6 30 30}}
+test canvImg-7.2 {DisplayImage procedure, no image} {
+    .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
+} {}
+
+.c delete all
+if {[testConstraint testImageType]} {
+    .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 {}
+foreach check {
+    {canvImg-8.1   {50 70 80 81}     {70 90}  rect}
+    {canvImg-8.2   {50 70 80 79}     {70 90}  image}
+    {canvImg-8.3   {99 70 110 81}    {90 90}  rect}
+    {canvImg-8.4   {101 70 110 79}   {90 90}  image}
+    {canvImg-8.5   {99 100 110 115}  {90 110} rect}
+    {canvImg-8.6   {101 100 110 115} {90 110} image}
+    {canvImg-8.7   {99 134 110 145}  {90 125} rect}
+    {canvImg-8.8   {101 136 110 145} {90 125} image}
+    {canvImg-8.9   {50 134 80 145}   {70 125} rect}
+    {canvImg-8.10  {50 136 80 145}   {70 125} image}
+    {canvImg-8.11  {20 134 31 145}   {40 125} rect}
+    {canvImg-8.12  {20 136 29 145}   {40 125} image}
+    {canvImg-8.13  {20 100 31 115}   {40 110} rect}
+    {canvImg-8.14  {20 100 29 115}   {40 110} image}
+    {canvImg-8.15  {20 70 31 80}     {40 90}  rect}
+    {canvImg-8.16  {20 70 29 79}     {40 90}  image}
+    {canvImg-8.17  {60 70 69 109}    {70 110} image}
+    {canvImg-8.18  {60 70 71 111}    {70 110} rect}
+} {
+    lassign $check name rectCoords testPoint result
+    test $name {ImageToPoint procedure} testImageType {
+	.c coords rect {*}$rectCoords
+	.c gettags [.c find closest {*}$testPoint]
+    } $result
+}
+
+.c delete all
+if {[testConstraint testImageType]} {
+    .c create image 50 100 -image foo -tags image -anchor nw
+}
+test canvImg-8.19 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 60 0 70 99]
+} {}
+test canvImg-8.20 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 60 0 70 99.999]
+} {}
+test canvImg-8.21 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 60 0 70 101]
+} {image}
+test canvImg-8.22 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 81 105 120 115]
+} {}
+test canvImg-8.23 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 80.001 105 120 115]
+} {}
+test canvImg-8.24 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 79 105 120 115]
+} {image}
+test canvImg-8.25 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 60 116 70 150]
+} {}
+test canvImg-8.26 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 60 115.001 70 150]
+} {}
+test canvImg-8.27 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 60 114 70 150]
+} {image}
+test canvImg-8.28 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 0 105 49 115]
+} {}
+test canvImg-8.29 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 0 105 50 114.999]
+} {}
+test canvImg-8.30 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 0 105 51 115]
+} {image}
+test canvImg-8.31 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 0 0 49.999 99.999]
+} {}
+test canvImg-8.32 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 0 0 51 101]
+} {image}
+test canvImg-8.33 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 80 0 150 100]
+} {}
+test canvImg-8.34 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 79 0 150 101]
+} {image}
+test canvImg-8.35 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 80.001 115.001 150 180]
+} {}
+test canvImg-8.36 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 79 114 150 180]
+} {image}
+test canvImg-8.37 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 0 115 50 180]
+} {}
+test canvImg-8.38 {ImageToArea procedure} testImageType {
+    .c gettags [.c find overlapping 0 114 51 180]
+} {image}
+test canvImg-8.39 {ImageToArea procedure} testImageType {
+    .c gettags [.c find enclosed 0 0 200 200]
+} {image}
+test canvImg-8.40 {ImageToArea procedure} testImageType {
+    .c gettags [.c find enclosed 49.999 99.999 80.001 115.001]
+} {image}
+test canvImg-8.41 {ImageToArea procedure} testImageType {
+    .c gettags [.c find enclosed 51 100 80 115]
+} {}
+test canvImg-8.42 {ImageToArea procedure} testImageType {
+    .c gettags [.c find enclosed 50 101 80 115]
+} {}
+test canvImg-8.43 {ImageToArea procedure} testImageType {
+    .c gettags [.c find enclosed 50 100 79 115]
+} {}
+test canvImg-8.44 {ImageToArea procedure} testImageType {
+    .c gettags [.c find enclosed 50 100 80 114]
+} {}
+
+test canvImg-9.1 {DisplayImage procedure} testImageType {
+    .c delete all
+    .c create image 50 100 -image foo -tags image -anchor nw
+    .c scale image 25 0 2.0 1.5
+    .c bbox image
+} {75 150 105 165}
+
+test canvImg-10.1 {TranslateImage procedure} testImageType {
+    .c delete all
+    .c create image 50 100 -image foo -tags image -anchor nw
+    update
+    set x {}
+    foo changed 2 4 6 8 30 15
+    update
+    set x
+} {{foo display 2 4 6 8 30 30}}
+
+test canvImg-11.1 {TranslateImage procedure} testImageType {
+    .c delete all
+    .c create image 50 100 -image foo -tags image -anchor nw
+    update
+    set x {}
+    foo changed 2 4 6 8 40 50
+    update
+    set x
+} {{foo display 0 0 40 50 30 30}}
+test canvImg-11.2 {ImageChangedProc procedure} testImageType {
+    .c delete all
+    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
+} {30 75 70 125}
+test canvImg-11.3 {ImageChangedProc procedure} testImageType {
+    .c delete all
+    image create test foo -variable x
+    foo changed 0 0 0 0 40 50
+    .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
+    set y
+} {{foo2 display 0 0 20 40 50 40}}
+
+# cleanup
+cleanupTests
+return

tests/canvPs.test

@@ -0,0 +1,181 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+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
+
+test canvPs-3.1 {test ps generation with an embedded window} -setup {
+    set bar [makeFile {} bar.ps]
+    file delete $bar
+} -constraints {
+    notAqua
+} -body {
+    destroy .c
+    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 {
+    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 {
+    destroy .c
+    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 {
+    removeFile bar.ps
+} -result 1
+
+test canvPs-4.1 {test ps generation with single-point uncolored poly, bug 734498} {} {
+    destroy .c
+    pack [canvas .c]
+    .c create poly 10 20 10 20
+    catch {.c postscript}
+} 0
+
+# cleanup
+unset -nocomplain foo bar
+deleteWindows
+cleanupTests
+return

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

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
+
+
+
+
+
+
+
+
+
+
+
+
+

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
+
+
+
+
+
+
+
+
+
+
+
+
+

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

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
+}
+
+
+
+
+
+
+
+
+
+
+
+
+

tests/canvRect.test

@@ -0,0 +1,328 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+canvas .c -width 400 -height 300 -bd 2 -relief sunken
+pack .c
+bind .c <1> {
+    puts "button down at (%x,%y)"
+}
+update
+
+set i 1
+.c create rectangle 20 20 80 80 -tag test
+foreach test {
+    {-fill #ff0000 #ff0000
+	    non-existent {unknown color name "non-existent"}}
+    {-outline #123456 #123456
+	    bad_color {unknown color name "bad_color"}}
+    {-stipple gray50 gray50
+	    bogus {bitmap "bogus" not defined}}
+    {-tags {test a b c} {test a b c}
+	    {} {}}
+    {-width 6.0 6.0
+	    abc {bad screen distance "abc"}}
+} {
+    lassign $test name goodValue goodResult badValue badResult
+    test canvRect-1.$i "configuration options: good value for $name" {
+	.c itemconfigure test $name $goodValue
+	list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name]
+    } [list $goodResult $goodResult]
+    incr i
+    if {$badValue ne ""} {
+	test canvRect-1.$i "configuration options: bad value for $name" -body {
+	    .c itemconfigure test $name $badValue
+	} -returnCodes error -result $badResult
+    }
+    incr i
+}
+test canvRect-1.$i {configuration options} {
+    .c itemconfigure test -tags {test xyz}
+    .c itemcget xyz -tags
+} {test xyz}
+
+test canvRect-2.1 {CreateRectOval procedure} {
+    list [catch {.c create rect} msg] $msg
+} {1 {wrong # args: should be ".c create rect coords ?arg arg ...?"}}
+test canvRect-2.2 {CreateRectOval procedure} {
+    list [catch {.c create oval x y z} msg] $msg
+} {1 {wrong # coordinates: expected 0 or 4, got 3}}
+test canvRect-2.3 {CreateRectOval procedure} {
+    list [catch {.c create rectangle x 2 3 4} msg] $msg
+} {1 {bad screen distance "x"}}
+test canvRect-2.4 {CreateRectOval procedure} {
+    list [catch {.c create rectangle 1 y 3 4} msg] $msg
+} {1 {bad screen distance "y"}}
+test canvRect-2.5 {CreateRectOval procedure} {
+    list [catch {.c create rectangle 1 2 z 4} msg] $msg
+} {1 {bad screen distance "z"}}
+test canvRect-2.6 {CreateRectOval procedure} {
+    list [catch {.c create rectangle 1 2 3 q} msg] $msg
+} {1 {bad screen distance "q"}}
+test canvRect-2.7 {CreateRectOval procedure} {
+    .c create rectangle 1 2 3 4 -tags x
+    set result {}
+    foreach element [.c coords x] {
+	lappend result [format %.1f $element]
+    }
+    set result
+} {1.0 2.0 3.0 4.0}
+test canvRect-2.8 {CreateRectOval procedure} {
+    list [catch {.c create rectangle 1 2 3 4 -gorp foo} msg] $msg
+} {1 {unknown option "-gorp"}}
+
+.c delete withtag all
+.c create rectangle 10 20 30 40 -tags x
+test canvRect-3.1 {RectOvalCoords procedure} {
+    set result {}
+    foreach element [.c coords x] {
+	lappend result [format %.1f $element]
+    }
+    set result
+} {10.0 20.0 30.0 40.0}
+test canvRect-3.2 {RectOvalCoords procedure} {
+    list [catch {.c coords x a 2 3 4} msg] $msg
+} {1 {bad screen distance "a"}}
+test canvRect-3.3 {RectOvalCoords procedure} {
+    list [catch {.c coords x 1 b 3 4} msg] $msg
+} {1 {bad screen distance "b"}}
+test canvRect-3.4 {RectOvalCoords procedure} {
+    list [catch {.c coords x 1 2 c 4} msg] $msg
+} {1 {bad screen distance "c"}}
+test canvRect-3.5 {RectOvalCoords procedure} {
+    list [catch {.c coords x 1 2 3 d} msg] $msg
+} {1 {bad screen distance "d"}}
+test canvRect-3.6 {RectOvalCoords procedure} {nonPortable} {
+    # Non-portable due to rounding differences.
+    .c coords x 10 25 15 40
+    .c bbox x
+} {9 24 16 41}
+test canvRect-3.7 {RectOvalCoords procedure} {
+    list [catch {.c coords x 1 2 3 4 5} msg] $msg
+} {1 {wrong # coordinates: expected 0 or 4, got 5}}
+
+.c delete withtag all
+.c create rectangle 10 20 30 40 -tags x -width 1
+test canvRect-4.1 {ConfigureRectOval procedure} {
+    list [catch {.c itemconfigure x -width abc} msg] $msg \
+	    [.c itemcget x -width]
+} {1 {bad screen distance "abc"} 1.0}
+test canvRect-4.2 {ConfigureRectOval procedure} {
+    list [catch {.c itemconfigure x -width -5} msg] $msg
+} {1 {bad screen distance "-5"}}
+test canvRect-4.3 {ConfigureRectOval procedure} {nonPortable} {
+    # Non-portable due to rounding differences.
+    .c itemconfigure x -width 10
+    .c bbox x
+} {5 15 35 45}
+# I can't come up with any good tests for DeleteRectOval.
+
+.c delete withtag all
+.c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
+test canvRect-5.1 {ComputeRectOvalBbox procedure} {nonPortable} {
+    # Non-portable due to rounding differences:
+    .c coords x 20 15 10 5
+    .c bbox x
+} {10 5 20 15}
+test canvRect-5.2 {ComputeRectOvalBbox procedure} {nonPortable} {
+    # Non-portable due to rounding differences:
+    .c coords x 10 20 30 10
+    .c itemconfigure x -width 1 -outline red
+    .c bbox x
+} {9 9 31 21}
+test canvRect-5.3 {ComputeRectOvalBbox procedure} {nonPortable} {
+    # Non-portable due to rounding differences:
+    .c coords x 10 20 30 10
+    .c itemconfigure x -width 2 -outline red
+    .c bbox x
+} {9 9 31 21}
+test canvRect-5.4 {ComputeRectOvalBbox procedure} {nonPortable} {
+    # Non-portable due to rounding differences:
+    .c coords x 10 20 30 10
+    .c itemconfigure x -width 3 -outline red
+    .c bbox x
+} {8 8 32 22}
+
+# I can't come up with any good tests for DisplayRectOval.
+
+.c delete withtag all
+set x  [.c create rectangle 10 20 30 35 -tags x -fill green]
+set y [.c create rectangle 15 25 25 30  -tags y -fill red]
+test canvRect-6.1 {RectToPoint procedure} {
+    .c itemconfigure y -outline {}
+    list [.c find closest 14.9 28] [.c find closest 15.1 28] \
+	    [.c find closest 24.9 28] [.c find closest 25.1 28]
+} "$x $y $y $x"
+test canvRect-6.2 {RectToPoint procedure} {
+    .c itemconfigure y -outline {}
+    list [.c find closest 20 24.9] [.c find closest 20 25.1] \
+	    [.c find closest 20 29.9]  [.c find closest 20 30.1]
+} "$x $y $y $x"
+test canvRect-6.3 {RectToPoint procedure} {
+    .c itemconfigure y -width 1 -outline black
+    list [.c find closest 14.4 28] [.c find closest 14.6 28] \
+	    [.c find closest 25.4 28] [.c find closest 25.6 28]
+} "$x $y $y $x"
+test canvRect-6.4 {RectToPoint procedure} {
+    .c itemconfigure  y -width 1 -outline black
+    list [.c find closest 20 24.4] [.c find closest 20 24.6] \
+	    [.c find closest 20 30.4] [.c find closest 20 30.6]
+} "$x $y $y $x"
+.c itemconfigure x -fill {} -outline black -width 3
+.c itemconfigure y -outline {}
+test canvRect-6.5 {RectToPoint procedure} {
+    list [.c find closest 13.2 28] [.c find closest 13.3 28] \
+	    [.c find closest 26.7 28] [.c find closest 26.8 28]
+} "$x $y $y $x"
+test canvRect-6.6 {RectToPoint procedure} {
+    list [.c find closest 20 23.2] [.c find closest 20 23.3] \
+	    [.c find closest 20 31.7] [.c find closest 20 31.8]
+} "$x $y $y $x"
+.c delete withtag all
+set x [.c create rectangle 10 20 30 40 -outline {} -fill black]
+set y [.c create rectangle 40 40 50 50 -outline {} -fill black]
+test canvRect-6.7 {RectToPoint procedure} {
+    list [.c find closest 35 35] [.c find closest 36 36] \
+	    [.c find closest 37 37] [.c find closest 38 38]
+} "$x $y $y $y"
+
+.c delete withtag all
+set x  [.c create rectangle 10 20 30 35 -fill green -outline {}]
+set y [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+set z [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+test canvRect-7.1 {RectToArea procedure} {
+    list [.c find overlapping 20 50 38 60] \
+	    [.c find overlapping 20 50 39 60] \
+	    [.c find overlapping 20 50 70 60] \
+	    [.c find overlapping 61 50 70 60] \
+	    [.c find overlapping 62 50 70 60]
+} "{} $y $y $y {}"
+test canvRect-7.2 {RectToArea procedure} {
+    list [.c find overlapping 45 20 55 43] \
+	    [.c find overlapping 45 20 55 44] \
+	    [.c find overlapping 45 20 55 80] \
+	    [.c find overlapping 45 71 55 80] \
+	    [.c find overlapping 45 72 55 80]
+} "{} $y $y $y {}"
+test canvRect-7.3 {RectToArea procedure} {
+    list [.c find overlapping 5 25 9.9 30] [.c find overlapping 5 25 10.1 30]
+} "{} $x"
+test canvRect-7.4 {RectToArea procedure} {
+    list [.c find overlapping 102 152 118 168] \
+	    [.c find overlapping 101 152 118 168] \
+	    [.c find overlapping 102 151 118 168] \
+	    [.c find overlapping 102 152 119 168] \
+	    [.c find overlapping 102 152 118 169]
+} "{} $z $z $z $z"
+test canvRect-7.5 {RectToArea procedure} {
+    list [.c find enclosed 20 40 38 80] \
+	    [.c find enclosed 20 40 39 80] \
+	    [.c find enclosed 20 40 70 80] \
+	    [.c find enclosed 61 40 70 80] \
+	    [.c find enclosed 62 40 70 80]
+} "{} {} $y {} {}"
+test canvRect-7.6 {RectToArea procedure} {
+    list [.c find enclosed 20 20 65 43] \
+	    [.c find enclosed 20 20 65 44] \
+	    [.c find enclosed 20 20 65 80] \
+	    [.c find enclosed 20 71 65 80] \
+	    [.c find enclosed 20 72 65 80]
+} "{} {} $y {} {}"
+
+.c delete withtag all
+set x  [.c create oval 50 100 200 150 -fill green -outline {}]
+set y [.c create oval 50 100 200 150 -fill red -outline black -width 3]
+set z [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
+test canvRect-8.1 {OvalToArea procedure} {
+    list [.c find overlapping 20 120 48 130] \
+	    [.c find overlapping 20 120 49 130] \
+	    [.c find overlapping 20 120 50.2 130] \
+	    [.c find overlapping 20 120 300 130] \
+	    [.c find overlapping 60 120 190 130] \
+	    [.c find overlapping 199.9 120 300 130] \
+	    [.c find overlapping 201 120 300 130] \
+	    [.c find overlapping 202 120 300 130]
+} "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}"
+test canvRect-8.2 {OvalToArea procedure} {
+    list [.c find overlapping 100 50 150 98] \
+	    [.c find overlapping 100 50 150 99] \
+	    [.c find overlapping 100 50 150 100.1] \
+	    [.c find overlapping 100 50 150 200] \
+	    [.c find overlapping 100 110 150 140] \
+	    [.c find overlapping 100 149.9 150 200] \
+	    [.c find overlapping 100 151 150 200] \
+	    [.c find overlapping 100 152 150 200]
+} "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}"
+test canvRect-8.3 {OvalToArea procedure} {
+    list [.c find overlapping 176 104 177 105] \
+	    [.c find overlapping 187 116 188 117] \
+	    [.c find overlapping 192 142 193 143] \
+	    [.c find overlapping 180 138 181 139] \
+	    [.c find overlapping 61 142 62 143] \
+	    [.c find overlapping 65 137 66 136] \
+	    [.c find overlapping 62 108 63 109] \
+	    [.c find overlapping 68 115 69 116]
+} "{} {$x $y} {} {$x $y} {} {$x $y} {} {$x $y}"
+
+test canvRect-9.1 {ScaleRectOval procedure} {
+    .c delete withtag all
+    .c create rect 100 300 200 350 -tags x
+    .c scale x 50 100 2 4
+    .c coords x
+} {150.0 900.0 350.0 1100.0}
+
+test canvRect-10.1 {TranslateRectOval procedure} {
+    .c delete withtag all
+    .c create rect 100 300 200 350 -tags x
+    .c move x 100 -10
+    .c coords x
+} {200.0 290.0 300.0 340.0}
+
+# This test is non-portable because different color information
+# will get generated on different displays (e.g. mono displays
+# vs. color).
+test canvRect-11.1 {RectOvalToPostscript procedure} {nonPortable macCrash} {
+    # Crashes on Mac because the XGetImage() call isn't implemented, causing a
+    # dereference of NULL.
+    
+    .c configure -bd 0 -highlightthickness 0
+    .c delete withtag all
+    .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
+} {-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

tests/canvText.test

@@ -0,0 +1,575 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+canvas .c -width 400 -height 300 -bd 2 -relief sunken
+pack .c
+update
+
+set i 1
+.c create text 20 20 -tag test
+
+set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+set ay [font metrics $font -linespace]
+set ax [font measure $font 0]
+
+
+foreach test {
+    {-anchor nw nw xyz {bad anchor position "xyz": must be n, ne, e, se, s, sw, w, nw, or center}}
+    {-fill #ff0000 #ff0000 xyz {unknown color name "xyz"}}
+    {-fill {} {} {} {}}
+    {-font {Times 40} {Times 40} {} {font "" doesn't exist}}
+    {-justify left left xyz {bad justification "xyz": must be left, right, or center}}
+    {-stipple gray50 gray50 xyz {bitmap "xyz" not defined}}
+    {-tags {test a b c} {test a b c} {} {}}
+    {-text xyz xyz {} {}}
+    {-underline 0 0 xyz {expected integer but got "xyz"}}
+    {-width 6 6 xyz {bad screen distance "xyz"}}
+} {
+    lassign $test name goodValue goodResult badValue badResult
+    test canvText-1.$i "configuration options: good value for $name" {
+	.c itemconfigure test $name $goodValue
+	list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name]
+    } [list $goodResult $goodResult]
+    incr i
+    if {$badValue ne ""} {
+	test canvText-1.$i "configuration options: bad value for $name" -body {
+	    .c itemconfigure test $name $badValue
+	} -returnCodes error -result $badResult
+    }
+    incr i
+}
+test canvText-1.$i {configuration options} {
+    .c itemconfigure test -tags {test xyz}
+    .c itemcget xyz -tags
+} {test xyz}
+
+.c delete test
+.c create text 20 20 -tag test
+
+test canvText-2.1 {CreateText procedure: args} {
+    list [catch {.c create text} msg] $msg
+} {1 {wrong # args: should be ".c create text coords ?arg arg ...?"}}
+test canvText-2.2 {CreateText procedure: args} {
+    list [catch {.c create text xyz 0} msg] $msg
+} {1 {bad screen distance "xyz"}}
+test canvText-2.3 {CreateText procedure: args} {
+    list [catch {.c create text 0 xyz} msg] $msg
+} {1 {bad screen distance "xyz"}}
+test canvText-2.4 {CreateText procedure: args} {
+    list [catch {.c create text 0 0 -xyz xyz} msg] $msg
+} {1 {unknown option "-xyz"}}
+test canvText-2.5 {CreateText procedure} {
+    .c create text 0 0 -tags x
+    set x [.c coords x]
+    .c delete x
+    set x
+} {0.0 0.0}
+
+focus -force .c
+.c focus test
+.c coords test 0 0
+update
+
+test canvText-3.1 {TextCoords procedure} {
+    .c coords test
+} {0.0 0.0}
+test canvText-3.2 {TextCoords procedure} {
+    list [catch {.c coords test xyz 0} msg] $msg
+} {1 {bad screen distance "xyz"}}
+test canvText-3.3 {TextCoords procedure} {
+    list [catch {.c coords test 0 xyz} msg] $msg
+} {1 {bad screen distance "xyz"}}
+test canvText-3.4 {TextCoords procedure} {
+    .c coords test 10 10
+    set result {}
+    foreach element [.c coords test] {
+	lappend result [format %.1f $element]
+    }
+    set result
+} {10.0 10.0}
+test canvText-3.5 {TextCoords procedure} {
+    list [catch {.c coords test 10} msg] $msg
+} {1 {wrong # coordinates: expected 2, got 1}}
+test canvText-3.6 {TextCoords procedure} {
+    list [catch {.c coords test 10 10 10} msg] $msg
+} {1 {wrong # coordinates: expected 0 or 2, got 3}}
+
+test canvText-4.1 {ConfigureText procedure} {
+    list [catch {.c itemconfig test -fill xyz} msg] $msg
+} {1 {unknown color name "xyz"}}
+test canvText-4.2 {ConfigureText procedure} {
+    .c itemconfig test -fill blue
+    .c itemcget test -fill
+} {blue}
+test canvText-4.3 {ConfigureText procedure: construct font gcs} {
+    .c itemconfig test -font "times 20" -fill black -stipple gray50
+    list [.c itemcget test -font] [.c itemcget test -fill] [.c itemcget test -stipple]
+} {{times 20} black gray50}
+test canvText-4.4 {ConfigureText procedure: construct cursor gc} {
+    .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
+} {}
+test canvText-4.5 {ConfigureText procedure: adjust selection} {
+    set x {}
+    .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]
+} {cdefg 1 cdefg cd cdef cd}
+test canvText-4.6 {ConfigureText procedure: adjust cursor} {
+    .c itemconfig test -text "abcdefghi"
+    set x {}
+    .c icursor test 6
+    .c dchars test 4 end
+    .c index test insert
+} {4}
+
+test canvText-5.1 {ConfigureText procedure: adjust cursor} {
+    .c create text 10 10 -tag x -fill blue -font "times 40" -stipple gray50 -text "xyz"
+    .c delete x
+} {}
+
+test canvText-6.1 {ComputeTextBbox procedure} {fonts nonPortable} {
+    .c itemconfig test -font $font -text 0
+    .c coords test 0 0
+    set x {}
+    lappend x [.c itemconfig test -anchor n; .c bbox test]
+    lappend x [.c itemconfig test -anchor nw; .c bbox test]
+    lappend x [.c itemconfig test -anchor w; .c bbox test]
+    lappend x [.c itemconfig test -anchor sw; .c bbox test]
+    lappend x [.c itemconfig test -anchor s; .c bbox test]
+    lappend x [.c itemconfig test -anchor se; .c bbox test]
+    lappend x [.c itemconfig test -anchor e; .c bbox test]
+    lappend x [.c itemconfig test -anchor ne; .c bbox test]
+    lappend x [.c itemconfig test -anchor center; .c bbox test]
+} "{[expr -$ax/2-1] 0 [expr $ax/2+1] $ay}\
+{-1 0 [expr $ax+1] $ay}\
+{-1 [expr -$ay/2] [expr $ax+1] [expr $ay/2]}\
+{-1 -$ay [expr $ax+1] 0}\
+{[expr -$ax/2-1] -$ay [expr $ax/2+1] 0}\
+{[expr -$ax-1] -$ay 1 0}\
+{[expr -$ax-1] [expr -$ay/2] 1 [expr $ay/2]}\
+{[expr -$ax-1] 0 1 $ay}\
+{[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]}"
+
+focus .c
+.c focus test
+.c itemconfig test -text "abcd\nefghi\njklmnopq"
+test canvText-7.0 {DisplayText procedure: stippling} {
+    .c itemconfig test -stipple gray50
+    update
+    .c itemconfig test -stipple {}
+    update
+} {}
+test canvText-7.2 {DisplayText procedure: draw selection} {
+    .c select from test 0
+    .c select to test end
+    update
+    selection get
+} "abcd\nefghi\njklmnopq"
+test canvText-7.3 {DisplayText procedure: selection} {
+    .c select from test 0
+    .c select to test end
+    update
+    selection get
+} "abcd\nefghi\njklmnopq"
+test canvText-7.4 {DisplayText procedure: one line selection} {
+    .c select from test 2
+    .c select to test 3
+    update
+} {}
+test canvText-7.5 {DisplayText procedure: multi-line selection} {
+    .c select from test 2
+    .c select to test 12
+    update
+} {}
+test canvText-7.6 {DisplayText procedure: draw cursor} {
+    .c icursor test 3
+    update
+} {}
+test canvText-7.7 {DisplayText procedure: selected text different color} {
+    .c config -selectforeground blue
+    .c itemconfig test -anchor n
+    update
+} {}
+test canvText-7.8 {DisplayText procedure: not selected} {
+    .c select clear
+    update
+} {}
+test canvText-7.9 {DisplayText procedure: select end} {
+    catch {destroy .t}
+    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
+} {}
+
+test canvText-8.1 {TextInsert procedure: 0 length insert} {
+    .c insert test end {}
+} {}
+test canvText-8.2 {TextInsert procedure: before beginning/after end} {
+    # Can't test this because GetTextIndex filters out those numbers.
+} {}
+test canvText-8.3 {TextInsert procedure: inserting in a selected item} {
+    .c itemconfig test -text "abcdefg"
+    .c select from test 2
+    .c select to test 4
+    .c insert test 1 "xyz"
+    .c itemcget test -text
+} {axyzbcdefg}
+test canvText-8.4 {TextInsert procedure: inserting before selection} {
+    .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]
+} {5 7}
+test canvText-8.5 {TextInsert procedure: inserting in selection} {
+    .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]
+} {2 7}
+test canvText-8.6 {TextInsert procedure: inserting after selection} {
+    .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]
+} {2 4}
+test canvText-8.7 {TextInsert procedure: inserting in unselected item} {
+    .c itemconfig test -text "abcdefg"
+    .c select clear
+    .c insert test 5 "xyz"
+    .c itemcget test -text
+} {abcdexyzfg}
+test canvText-8.8 {TextInsert procedure: inserting before cursor} {
+    .c itemconfig test -text "abcdefg"
+    .c icursor test 3
+    .c insert test 2 "xyz"
+    .c index test insert
+} {6}
+test canvText-8.9 {TextInsert procedure: inserting after cursor} {
+    .c itemconfig test -text "abcdefg"
+    .c icursor test 3
+    .c insert test 4 "xyz"
+    .c index test insert
+} {3}
+
+test canvText-9.1 {TextInsert procedure: before beginning/after end} {
+    # Can't test this because GetTextIndex filters out those numbers.
+} {}
+test canvText-9.2 {TextInsert procedure: start > end} {
+    .c itemconfig test -text "abcdefg"
+    .c dchars test 4 2
+    .c itemcget test -text
+} {abcdefg}
+test canvText-9.3 {TextInsert procedure: deleting from a selected item} {
+    .c itemconfig test -text "abcdefg"
+    .c select from test 2
+    .c select to test 4
+    .c dchars test 3 5
+    .c itemcget test -text
+} {abcg}
+test canvText-9.4 {TextInsert procedure: deleting before start} {
+    .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]
+} {3 7}
+test canvText-9.5 {TextInsert procedure: keep start > first char deleted} {
+    .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]
+} {2 3}
+test canvText-9.6 {TextInsert procedure: deleting inside selection} {
+    .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]
+} {4 7}
+test canvText-9.7 {TextInsert procedure: keep end > first char deleted} {
+    .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]
+} {4 5}
+test canvText-9.8 {TextInsert procedure: selectFirst > selectLast: deselect} {
+    .c itemconfig test -text "abcdefghijk"
+    .c select from test 4
+    .c select to test 8
+    .c dchars test 3 10
+    list [catch {.c index test sel.first} msg] $msg
+} {1 {selection isn't in item}}
+test canvText-9.9 {TextInsert procedure: selectFirst <= selectLast} {
+    .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]
+} {4 4}
+test canvText-9.10 {TextInsert procedure: move anchor} {
+    .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]
+} {1 2}
+test canvText-9.11 {TextInsert procedure: keep anchor >= first} {
+    .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]
+} {1 4}
+test canvText-9.12 {TextInsert procedure: anchor doesn't move} {
+    .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]
+} {2 8}
+test canvText-9.13 {TextInsert procedure: move cursor} {
+    .c itemconfig test -text "abcdefghijk"
+    .c icursor test 6
+    .c dchars test 2 4
+    .c index test insert
+} {3}
+test canvText-9.14 {TextInsert procedure: keep cursor >= first} {
+    .c itemconfig test -text "abcdefghijk"
+    .c icursor test 6
+    .c dchars test 2 10
+    .c index test insert
+} {2}
+test canvText-9.15 {TextInsert procedure: cursor doesn't move} {
+    .c itemconfig test -text "abcdefghijk"
+    .c icursor test 5
+    .c dchars test 7 9
+    .c index test insert
+} {5}
+
+test canvText-10.1 {TextToPoint procedure} {
+    .c coords test 0 0
+    .c itemconfig test -text 0 -anchor center
+    .c index test @0,0
+} {0}
+
+test canvText-11.1 {TextToArea procedure} {
+    .c coords test 0 0
+    .c itemconfig test -text 0 -anchor center
+    .c find overlapping 0 0 1 1
+} [.c find withtag test]
+test canvText-11.2 {TextToArea procedure} {
+    .c coords test 0 0
+    .c itemconfig test -text 0 -anchor center
+    .c find overlapping 1000 1000 1001 1001
+} {}
+
+test canvText-12.1 {ScaleText procedure} {
+    .c coords test 100 100
+    .c scale all 50 50 2 2
+    format {%.6g %.6g} {*}[.c coords test]
+} {150 150}
+
+test canvText-13.1 {TranslateText procedure} {
+    .c coords test 100 100
+    .c move all 10 10
+    format {%.6g %.6g} {*}[.c coords test]
+} {110 110}
+
+.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
+test canvText-14.1 {GetTextIndex procedure} {
+    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]
+} {15 12 5 8 0 0 10 15}
+test canvText-14.2 {GetTextIndex procedure: select error} {
+    .c select clear
+    list [catch {.c index test sel.first} msg] $msg
+} {1 {selection isn't in item}}
+test canvText-14.3 {GetTextIndex procedure: select error} {
+    .c select clear
+    list [catch {.c index test sel.last} msg] $msg
+} {1 {selection isn't in item}}
+test canvText-14.4 {GetTextIndex procedure: select error} {
+    .c select clear
+    list [catch {.c index test sel.} msg] $msg
+} {1 {bad index "sel."}}
+test canvText-14.5 {GetTextIndex procedure: bad int or unknown index} {
+    list [catch {.c index test xyz} msg] $msg
+} {1 {bad index "xyz"}}
+test canvText-14.6 {select clear errors} -body {
+    .c select clear test
+} -returnCodes error -result "wrong \# args: should be \".c select clear\""
+
+test canvText-15.1 {SetTextCursor procedure} {
+    .c itemconfig -text "abcdefg"
+    .c icursor test 3
+    .c index test insert
+} {3}
+
+test canvText-16.1 {GetSelText procedure} {
+    .c itemconfig test -text "abcdefghijklmno" -anchor nw
+    .c select from test 5
+    .c select to test 8
+    selection get
+} {fghi}
+
+set font {Courier 12 italic}
+set ax [font measure $font 0]
+set ay [font metrics $font -linespace]
+
+test canvText-17.1 {TextToPostscript procedure} {
+    .c delete all
+    .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 "/Courier-Oblique" $x] end]
+} "/Courier-Oblique findfont [font actual $font -size] scalefont ISOEncode setfont
+0.000 0.000 0.000 setrgbcolor AdjustColor
+100 200 \[
+\[(000)\]
+\[(000)\]
+\[(00)\]
+] $ay -0.5 0.0 0 false DrawText
+grestore
+restore showpage
+
+%%Trailer
+end
+%%EOF
+"
+
+test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} {
+    catch {destroy .c}
+    canvas .c
+    pack .c
+    .c delete all
+    .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 + $i] [expr $y2 + 1]
+} 1
+
+test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} {
+    catch {destroy .c}
+    set c [canvas .c -bg black -width 964]
+    pack $c
+    $c delete all
+    after 1000 "set done 1" ; vwait done
+
+    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
+    eval {$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
+    eval {$c create rect} [$c bbox tbox2] -outline red
+
+    after 1000 "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]
+
+    set results
+} {{Yeah } Yeah- 4 4}
+
+
+# cleanup
+cleanupTests
+return

tests/canvWind.test

@@ -0,0 +1,129 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} {
+    catch {destroy .t}
+    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]]
+} {{1 23} {1 -29} {0 -29} {1 225} {0 225}}
+test canvWind-1.2 {DisplayWinItem, windows off-screen vertically} {
+    catch {destroy .t}
+    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]]
+} {{1 3} {1 -49} {0 -49} {1 205} {0 205}}
+test canvWind-1.3 {DisplayWinItem, windows off-screen horizontally} {
+    catch {destroy .t}
+    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]]
+} {{1 23} {1 -59} {0 -59} {1 275} {0 275}}
+test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} {
+    catch {destroy .t}
+    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]]
+} {{1 3} {1 -79} {0 -79} {1 255} {0 255}}
+catch {destroy .t}
+
+# cleanup
+cleanupTests
+return

tests/canvas.test

@@ -0,0 +1,544 @@
+# 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.
+# All rights reserved.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# XXX - This test file is woefully incomplete.  At present, only a
+# few of the features are tested.
+
+canvas .c
+pack .c
+update
+set i 1
+foreach {testname testinfo} {
+    canvas-1.1 {-background #ff0000 #ff0000
+	non-existent {unknown color name "non-existent"}}
+    canvas-1.2 {-bg #ff0000 #ff0000
+	non-existent {unknown color name "non-existent"}}
+    canvas-1.3 {-bd 4 4 badValue {bad screen distance "badValue"}}
+    canvas-1.4 {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
+    canvas-1.5 {-closeenough 24 24.0
+	bogus {expected floating-point number but got "bogus"}}
+    canvas-1.6 {-confine true 1 silly {expected boolean value but got "silly"}}
+    canvas-1.7 {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
+    canvas-1.8 {-height 2.1 2 x42 {bad screen distance "x42"}}
+    canvas-1.9 {-highlightbackground #112233 #112233
+	ugly {unknown color name "ugly"}}
+    canvas-1.10 {-highlightcolor #110022 #110022
+	bogus {unknown color name "bogus"}}
+    canvas-1.11 {-highlightthickness 18 18
+	badValue {bad screen distance "badValue"}}
+    canvas-1.12 {-insertbackground #110022 #110022
+	bogus {unknown color name "bogus"}}
+    canvas-1.13 {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}}
+    canvas-1.14 {-insertofftime 100 100 3.2 {expected integer but got "3.2"}}
+    canvas-1.15 {-insertontime 100 100 3.2 {expected integer but got "3.2"}}
+    canvas-1.16 {-insertwidth 1.3 1 6x {bad screen distance "6x"}}
+    canvas-1.17 {-relief groove groove
+	1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
+    canvas-1.18 {-selectbackground #110022 #110022
+	bogus {unknown color name "bogus"}}
+    canvas-1.19 {-selectborderwidth 1.3 1
+	badValue {bad screen distance "badValue"}}
+    canvas-1.20 {-selectforeground #654321 #654321
+	bogus {unknown color name "bogus"}}
+    canvas-1.21 {-takefocus "any string" "any string" {} {}}
+    canvas-1.22 {-width 402 402 xyz {bad screen distance "xyz"}}
+    canvas-1.23 {-xscrollcommand {Some command} {Some command} {} {}}
+    canvas-1.24 {-yscrollcommand {Another command} {Another command} {} {}}
+} {
+    lassign $testinfo name goodValue goodResult badValue badResult
+    test $testname-good "configuration options: good value for $name" {
+	.c configure $name $goodValue
+	lindex [.c configure $name] 4
+    } $goodResult
+    incr i
+    if {$badValue ne ""} {
+	test $testname-bad "configuration options: bad value for $name" -body {
+	    .c configure $name $badValue
+	} -returnCodes error -result $badResult
+    }
+    .c configure $name [lindex [.c configure $name] 3]
+    incr i
+}
+test canvas-1.25 {configure throws error on bad option} {
+    set res [list [catch {.c configure -gorp foo}]]
+    .c create rect 10 10 100 100
+    lappend res [catch {.c configure -gorp foo}]
+    set res
+} [list 1 1]
+
+catch {destroy .c}
+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} {
+    set i [.c create rect 10 10 100 100]
+    list [catch {.c bind $i <a>} msg] $msg
+} {0 {}}
+test canvas-2.2 {CanvasWidgetCmd, bind option} {
+    set i [.c create rect 10 10 100 100]
+    list [catch {.c bind $i <} msg] $msg
+} {1 {no event type or button # or keysym}}
+test canvas-2.3 {CanvasWidgetCmd, xview option} {
+    .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]
+} {{0.0 0.3} {0.4 0.7}}
+test canvas-2.4 {CanvasWidgetCmd, xview option} {nonPortable} {
+    # 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]
+} {{0.6 0.9} {0.66 0.96}}
+
+catch {destroy .c}
+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} {
+    .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]
+} {{0.0 0.5} {0.1875 0.6875}}
+test canvas-3.2 {CanvasWidgetCmd, yview option} {
+    .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]
+} {{0.0 0.5} {0.1 0.6}}
+
+test canvas-4.1 {ButtonEventProc procedure} {
+    deleteWindows
+    canvas .c1 -bg #543210
+    rename .c1 .c2
+    set x {}
+    lappend x [winfo children .]
+    lappend x [.c2 cget -bg]
+    destroy .c1
+    lappend x [info command .c*] [winfo children .]
+} {.c1 #543210 {} {}}
+
+test canvas-5.1 {ButtonCmdDeletedProc procedure} {
+    deleteWindows
+    canvas .c1
+    rename .c1 {}
+    list [info command .c*] [winfo children .]
+} {{} {}}
+
+catch {destroy .c}
+canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \
+	-borderwidth 2 -highlightthickness 3
+pack .c
+update
+test canvas-6.1 {CanvasSetOrigin procedure} {
+    .c configure -xscrollincrement 0 -yscrollincrement 0
+    .c xview moveto 0
+    .c yview moveto 0
+    update
+    list [.c canvasx 0] [.c canvasy 0]
+} {-205.0 -105.0}
+test canvas-6.2 {CanvasSetOrigin procedure} {
+    .c configure -xscrollincrement 20 -yscrollincrement 10
+    set x ""
+    foreach i {.08 .10 .48 .50} {
+	.c xview moveto $i
+	update
+	lappend x [.c canvasx 0]
+    }
+    set x
+} {-165.0 -145.0 35.0 55.0}
+test canvas-6.3 {CanvasSetOrigin procedure} {
+    .c configure -xscrollincrement 20 -yscrollincrement 10
+    set x ""
+    foreach i {.06 .08 .70 .72} {
+	.c yview moveto $i
+	update
+	lappend x [.c canvasy 0]
+    }
+    set x
+} {-95.0 -85.0 35.0 45.0}
+test canvas-6.4 {CanvasSetOrigin procedure} {
+    .c configure -xscrollincrement 20 -yscrollincrement 10
+    .c xview moveto 1.0
+    .c canvasx 0
+} {215.0}
+test canvas-6.5 {CanvasSetOrigin procedure} {
+    .c configure -xscrollincrement 20 -yscrollincrement 10
+    .c yview moveto 1.0
+    .c canvasy 0
+} {55.0}
+
+deleteWindows
+
+set l [lsort [interp hidden]]
+test canvas-7.1 {canvas widget vs hidden commands} -setup {
+    catch {destroy .c}
+} -body {
+    canvas .c
+    interp hide {} .c
+    destroy .c
+    list [winfo children .] [lsort [interp hidden]]
+} -result [list {} $l]
+
+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
+} -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"]
+    set res {}
+    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"]
+} -body {
+    .c find withtag {a&&"tag with spaces"z}
+} -returnCodes error -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]
+} -body {
+    set result {}
+    .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
+
+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} {
+    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
+    }
+    set ::x
+} okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok
+
+test canvas-14.1 {canvas scan SF bug 581560} -setup {
+    destroy .c
+    canvas .c
+} -body {
+    .c scan
+} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}
+test canvas-14.2 {canvas scan} -setup {
+    destroy .c
+    canvas .c
+} -body {
+    .c scan bogus
+} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}
+test canvas-14.3 {canvas scan} -setup {
+    destroy .c
+    canvas .c
+} -body {
+    .c scan mark
+} -returnCodes error -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 {}
+
+set i 0
+proc create {w type args} {
+    eval [list $w create $type] $args
+}
+foreach type {arc bitmap image line oval polygon rect text window} {
+    incr i
+    test canvas-15.$i "basic types check: $type requires coords" -setup {
+	destroy .c
+	canvas .c
+    } -body {
+	.c create $type
+    } -returnCodes error -result [format {wrong # args: should be ".c create %s coords ?arg arg ...?"} $type]
+    incr i
+    test canvas-15.$i "basic coords check: $type coords are paired" -setup {
+	destroy .c
+	canvas .c
+    } -match glob -body {
+	.c create $type 0
+    } -returnCodes error -result "wrong # coordinates: expected*"
+}
+
+test canvas-16.1 {arc coords check} -setup {
+    destroy .c
+    canvas .c
+} -body {
+    set id [.c create arc {0 10 20 30} -start 33]
+    .c itemcget $id -start
+} -result {33.0}
+
+test canvas-17.1 {default smooth method handling} -setup {
+    destroy .c
+    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]
+    }
+    set result
+} -result {0 true true true raw raw true}
+
+destroy .c
+
+# cleanup
+cleanupTests
+return

tests/choosedir.test

@@ -0,0 +1,146 @@
+# 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.1
+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 .
+
+foreach opt {-initialdir -mustexist -parent -title} {
+    test choosedir-1.1$opt "tk_chooseDirectory command" unix {
+	list [catch {tk_chooseDirectory $opt} msg] $msg
+    } [list 1 "value for \"$opt\" missing"]
+}
+test choosedir-1.2 "tk_chooseDirectory command" unix {
+    list [catch {tk_chooseDirectory -foo bar} msg] $msg
+} [list 1 "bad option \"-foo\": must be -initialdir, -mustexist, -parent, or -title"]
+test choosedir-1.3 "tk_chooseDirectory command" unix {
+    list [catch {tk_chooseDirectory -parent foo.bar} msg] $msg
+} {1 {bad window path name "foo.bar"}}
+
+
+test choosedir-2.1 "tk_chooseDirectory command, cancel gives null" {unix notAqua} {
+    ToPressButton $parent cancel
+    tk_chooseDirectory -title "Press Cancel" -parent $parent
+} ""
+
+test choosedir-3.1 "tk_chooseDirectory -mustexist 1" {unix notAqua} {
+    # 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
+} $real
+test choosedir-3.2 "tk_chooseDirectory -mustexist 0" {unix notAqua} {
+    ToEnterDirsByKey $parent [list $fake $fake]
+    tk_chooseDirectory -title "Enter \"$fake\", press OK" \
+	    -parent $parent -mustexist 0
+} $fake
+
+test choosedir-4.1 "tk_chooseDirectory command, initialdir" {unix notAqua} {
+    ToPressButton $parent ok
+    tk_chooseDirectory -title "Press Ok" -parent $parent -initialdir $real
+} $real
+test choosedir-4.2 "tk_chooseDirectory command, initialdir" {unix notAqua} {
+    ToEnterDirsByKey $parent [list $fake $fake]
+    tk_chooseDirectory \
+	    -title "Enter \"$fake\" and press Ok" \
+	    -parent $parent -initialdir $real
+} $fake
+test choosedir-4.3 "tk_chooseDirectory, -initialdir {}" {unix notAqua} {
+    catch {unset ::tk::dialog::file::__tk_choosedir}
+    ToPressButton $parent ok
+    tk_chooseDirectory \
+	    -title "Press OK" \
+	    -parent $parent -initialdir ""
+} [pwd]
+
+test choosedir-5.1 "tk_chooseDirectory, handles {} entry text" {unix notAqua} {
+    ToEnterDirsByKey $parent [list "" $real $real]
+    tk_chooseDirectory -title "Clear entry, Press OK; Enter $real, press OK" \
+	    -parent $parent
+} $real
+
+# cleanup
+removeDirectory choosedirTest
+cleanupTests
+return

tests/clipboard.test

@@ -0,0 +1,244 @@
+# 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.1
+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} {
+    clipboard clear
+    clipboard append "test"
+    clipboard get
+} {test}
+test clipboard-1.2 {ClipboardHandler procedure} {
+    clipboard clear
+    clipboard append "test"
+    clipboard append "ing"
+    clipboard get
+} {testing}
+test clipboard-1.3 {ClipboardHandler procedure} {
+    clipboard clear
+    clipboard append "t"
+    clipboard append "e"
+    clipboard append "s"
+    clipboard append "t"
+    clipboard get
+} {test}
+test clipboard-1.4 {ClipboardHandler procedure} {
+    clipboard clear
+    clipboard append $longValue
+    clipboard get
+} "$longValue"
+test clipboard-1.5 {ClipboardHandler procedure} {
+    clipboard clear
+    clipboard append $longValue
+    clipboard append "test"
+    clipboard get
+} "${longValue}test"
+test clipboard-1.6 {ClipboardHandler procedure} {
+    clipboard clear
+    clipboard append -t TEST $longValue
+    clipboard append -t STRING "test"
+    list [clipboard get -t STRING] \
+	[clipboard get -t TEST]
+} [list test $longValue]
+test clipboard-1.7 {ClipboardHandler procedure} {
+    clipboard clear
+    clipboard append -t TEST [string range $longValue 1 4000]
+    clipboard append -t STRING "test"
+    list [clipboard get -t STRING] \
+	[clipboard get -t TEST]
+} [list test [string range $longValue 1 4000]]
+test clipboard-1.8 {ClipboardHandler procedure} {
+    clipboard clear
+    clipboard append ""
+    clipboard get
+} {}
+test clipboard-1.9 {ClipboardHandler procedure} {
+    clipboard clear
+    clipboard append ""
+    clipboard append "Test"
+    clipboard get
+} {Test}
+
+##############################################################################
+
+test clipboard-2.1 {ClipboardAppHandler procedure} {
+    set oldAppName [tk appname]
+    tk appname UnexpectedName
+    clipboard clear
+    clipboard append -type NEW_TYPE Data
+    set result [selection get -selection CLIPBOARD -type TK_APPLICATION]
+    tk appname $oldAppName
+    set result
+} {UnexpectedName}
+
+##############################################################################
+
+test clipboard-3.1 {ClipboardWindowHandler procedure} {
+    set oldAppName [tk appname]
+    tk appname UnexpectedName
+    clipboard clear
+    clipboard append -type NEW_TYPE Data
+    set result [selection get -selection CLIPBOARD -type TK_WINDOW]
+    tk appname $oldAppName
+    set result
+} {.}
+
+##############################################################################
+
+test clipboard-4.1 {ClipboardLostSel procedure} {
+    clipboard clear
+    clipboard append "Test"
+    selection clear -s CLIPBOARD
+    list [catch {clipboard get} msg] $msg
+} {1 {CLIPBOARD selection doesn't exist or form "STRING" not defined}}
+test clipboard-4.2 {ClipboardLostSel procedure} {
+    clipboard clear
+    clipboard append "Test"
+    clipboard append -t TEST "Test2"
+    selection clear -s CLIPBOARD
+    list [catch {clipboard get} msg] $msg \
+	[catch {clipboard get -t TEST} msg] $msg
+} {1 {CLIPBOARD selection doesn't exist or form "STRING" not defined} 1 {CLIPBOARD selection doesn't exist or form "TEST" not defined}}
+test clipboard-4.3 {ClipboardLostSel procedure} {
+    clipboard clear
+    clipboard append "Test"
+    clipboard append -t TEST "Test2"
+    clipboard append "Test3"
+    selection clear -s CLIPBOARD
+    list [catch {clipboard get} msg] $msg \
+	[catch {clipboard get -t TEST} msg] $msg
+} {1 {CLIPBOARD selection doesn't exist or form "STRING" not defined} 1 {CLIPBOARD selection doesn't exist or form "TEST" not defined}}
+
+##############################################################################
+
+test clipboard-5.1 {Tk_ClipboardClear procedure} {
+    clipboard clear
+    clipboard append -t TEST "test"
+    set result [lsort [clipboard get TARGETS]]
+    clipboard clear
+    list $result [lsort [clipboard get TARGETS]]
+} {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test clipboard-5.2 {Tk_ClipboardClear procedure} {
+    clipboard clear
+    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]]
+} {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} {
+    clipboard clear
+    clipboard append "first chunk"
+    selection own -s CLIPBOARD .
+    list [catch {
+	clipboard append " second chunk"
+	clipboard get
+    } msg] $msg
+} {0 {first chunk second chunk}}
+test clipboard-6.2 {Tk_ClipboardAppend procedure} unix {
+    setupbg
+    clipboard clear
+    clipboard append -f INTEGER -t TEST "16"
+    set result [dobg {clipboard get TEST}]
+    cleanupbg
+    set result
+} {0x10 }
+test clipboard-6.3 {Tk_ClipboardAppend procedure} {
+    clipboard clear
+    clipboard append -f INTEGER -t TEST "16"
+    list [catch {clipboard append -t TEST "test"} msg] $msg
+} {1 {format "STRING" does not match current format "INTEGER" for TEST}}
+
+##############################################################################
+
+test clipboard-7.1 {Tk_ClipboardCmd procedure} {
+    list [catch {clipboard} msg] $msg
+} {1 {wrong # args: should be "clipboard option ?arg arg ...?"}}
+test clipboard-7.2 {Tk_ClipboardCmd procedure} {
+    clipboard clear
+    list [catch {clipboard append --} msg] $msg \
+	    [selection get -selection CLIPBOARD]
+} {0 {} --}
+test clipboard-7.3 {Tk_ClipboardCmd procedure} {
+    clipboard clear
+    list [catch {clipboard append -- information} msg] $msg \
+	    [selection get -selection CLIPBOARD]
+} {0 {} information}
+test clipboard-7.4 {Tk_ClipboardCmd procedure} {
+    list [catch {clipboard append --x a b} msg] $msg
+} {1 {bad option "--x": must be -displayof, -format, or -type}}
+test clipboard-7.5 {Tk_ClipboardCmd procedure} {
+    list [catch {clipboard append -- a b} msg] $msg
+} {1 {wrong # args: should be "clipboard append ?options? data"}}
+test clipboard-7.6 {Tk_ClipboardCmd procedure} {
+    clipboard clear
+    list [catch {clipboard append -format} msg] $msg \
+	    [selection get -selection CLIPBOARD]
+} {0 {} -format}
+test clipboard-7.7 {Tk_ClipboardCmd procedure} {
+    list [catch {clipboard append -displayofoo f} msg] $msg
+} {1 {bad option "-displayofoo": must be -displayof, -format, or -type}}
+test clipboard-7.8 {Tk_ClipboardCmd procedure} {
+    list [catch {clipboard append -type TEST} msg] $msg
+} {1 {wrong # args: should be "clipboard append ?options? data"}}
+test clipboard-7.9 {Tk_ClipboardCmd procedure} {
+    list [catch {clipboard append -displayof foo "test"} msg] $msg
+} {1 {bad window path name "foo"}}
+
+test clipboard-7.10 {Tk_ClipboardCmd procedure} {
+    list [catch {clipboard clear -displayof} msg] $msg
+} {1 {wrong # args: should be "clipboard clear ?-displayof window?"}}
+test clipboard-7.11 {Tk_ClipboardCmd procedure} {
+    list [catch {clipboard clear -displayofoo f} msg] $msg
+} {1 {bad option "-displayofoo": must be -displayof}}
+test clipboard-7.12 {Tk_ClipboardCmd procedure} {
+    list [catch {clipboard clear foo} msg] $msg
+} {1 {wrong # args: should be "clipboard clear ?-displayof window?"}}
+test clipboard-7.13 {Tk_ClipboardCmd procedure} {
+    list [catch {clipboard clear -displayof foo} msg] $msg
+} {1 {bad window path name "foo"}}
+
+test clipboard-7.14 {Tk_ClipboardCmd procedure} {
+    list [catch {clipboard error} msg] $msg
+} {1 {bad option "error": must be append, clear, or get}}
+
+test clipboard-7.15 {Tk_ClipboardCmd procedure} {
+    clipboard clear
+    list [catch {clipboard append -displayof} msg] $msg \
+	    [selection get -selection CLIPBOARD]
+} {0 {} -displayof}
+test clipboard-7.16 {Tk_ClipboardCmd procedure} {
+    clipboard clear
+    list [catch {clipboard append -type} msg] $msg \
+	    [selection get -selection CLIPBOARD]
+} {0 {} -type}
+
+# cleanup
+cleanupTests
+return

tests/clrpick.test

@@ -0,0 +1,201 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+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} {
+    list [catch {tk_chooseColor -foo} msg] $msg
+} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}}
+
+catch {tk_chooseColor -foo 1} msg
+regsub -all ,      $msg "" options
+regsub \"-foo\" $options "" options
+
+foreach option $options {
+    if {[string index $option 0] eq "-"} {
+	test clrpick-1.2$option {tk_chooseColor command} -body {
+	    tk_chooseColor $option
+	} -returnCodes error -result "value for \"$option\" missing"
+    }
+}
+
+test clrpick-1.3 {tk_chooseColor command} {
+    list [catch {tk_chooseColor -foo bar} msg] $msg
+} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}}
+test clrpick-1.4 {tk_chooseColor command} {
+    list [catch {tk_chooseColor -initialcolor} msg] $msg
+} {1 {value for "-initialcolor" missing}}
+test clrpick-1.5 {tk_chooseColor command} {
+    list [catch {tk_chooseColor -parent foo.bar} msg] $msg
+} {1 {bad window path name "foo.bar"}}
+test clrpick-1.6 {tk_chooseColor command} {
+    list [catch {tk_chooseColor -initialcolor badbadbaadcolor} msg] $msg
+} {1 {unknown color name "badbadbaadcolor"}}
+test clrpick-1.7 {tk_chooseColor command} {
+    list [catch {tk_chooseColor -initialcolor ##badbadbaadcolor} msg] $msg
+} {1 {invalid color name "##badbadbaadcolor"}}
+
+set isNative [expr {[info commands tk::dialog::color::] eq ""}]
+
+proc ToPressButton {parent btn} {
+    global isNative
+    if {!$isNative} {
+	after 200 "SendButtonPress $parent $btn mouse"
+    }
+}
+
+proc ToChooseColorByKey {parent r g b} {
+    global isNative
+    if {!$isNative} {
+	after 200 ChooseColorByKey $parent $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 $parent 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
+    }
+}
+
+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
+# 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
+
+set color #404040
+test clrpick-2.1 {tk_chooseColor command} \
+	{nonUnixUserInteraction colorsLeftover} {
+    ToPressButton $parent ok
+    tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color \
+	    -parent $parent
+} "$color"
+set color #808040
+test clrpick-2.2 {tk_chooseColor command} \
+	{nonUnixUserInteraction colorsLeftover} {
+    set colors "128 128 64"
+    ToChooseColorByKey $parent 128 128 64
+    tk_chooseColor -parent $parent -title "choose $colors"
+} "$color"
+test clrpick-2.3 {tk_chooseColor command} \
+	{nonUnixUserInteraction colorsLeftover} {
+    ToPressButton $parent ok
+    tk_chooseColor -parent $parent -title "Press OK"
+} "$color"
+test clrpick-2.4 {tk_chooseColor command} {nonUnixUserInteraction} {
+    ToPressButton $parent cancel
+    tk_chooseColor -parent $parent -title "Press Cancel"
+} ""
+
+set color "#000000"
+test clrpick-3.1 {tk_chooseColor: background events} {nonUnixUserInteraction} {
+    after 1 {set x 53}
+    ToPressButton $parent ok
+    tk_chooseColor -parent $parent -title "Press OK" -initialcolor $color
+} "#000000"
+test clrpick-3.2 {tk_chooseColor: background events} {nonUnixUserInteraction} {
+    after 1 {set x 53}
+    ToPressButton $parent cancel
+    tk_chooseColor -parent $parent -title "Press Cancel"
+} ""
+
+test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} {unix notAqua} {
+    after 50 {set ::scr [winfo screen .__tk__color]}
+    ToPressButton $parent cancel
+    tk_chooseColor -parent $parent
+    set ::scr
+} [winfo screen $parent]
+
+# cleanup
+cleanupTests
+return

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
+
+
+
+
+
+
+
+
+
+
+
+
+

tests/cmds.test

@@ -0,0 +1,42 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+update
+
+test cmds-1.1 {tkwait visibility, argument errors} {
+    list [catch {tkwait visibility} msg] $msg
+} {1 {wrong # args: should be "tkwait variable|visibility|window name"}}
+test cmds-1.2 {tkwait visibility, argument errors} {
+    list [catch {tkwait visibility foo bar} msg] $msg
+} {1 {wrong # args: should be "tkwait variable|visibility|window name"}}
+test cmds-1.3 {tkwait visibility, argument errors} {
+    list [catch {tkwait visibility bad_window} msg] $msg
+} {1 {bad window path name "bad_window"}}
+test cmds-1.4 {tkwait visibility, waiting for window to be mapped} {
+    button .b -text "Test"
+    set x init
+    after 100 {set x delay; place .b -x 0 -y 0}
+    tkwait visibility .b
+    destroy .b
+    set x
+} {delay}
+test cmds-1.5 {tkwait visibility, window gets deleted} {
+    frame .f
+    button .f.b -text "Test"
+    pack .f.b
+    set x init
+    after 100 {set x deleted; destroy .f}
+    list [catch {tkwait visibility .f.b} msg] $msg $x
+} {1 {window ".f.b" was deleted before its visibility changed} deleted}
+
+# cleanup
+cleanupTests
+return

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

tests/config.test

@@ -0,0 +1,890 @@
+# 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.1
+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.
+
+    foreach t {alltypes chain2 chain1 configerror internal new notenoughparams
+	    twowindows} {
+	while {[testobjconfig info $t] != ""} {
+	    testobjconfig delete $t
+	}
+    }
+}
+
+if {[testConstraint testobjconfig]} {
+    killTables
+}
+
+test config-1.1 {Tk_CreateOptionTable - reference counts} testobjconfig {
+    deleteWindows
+    killTables
+    set x {}
+    testobjconfig alltypes .a
+    lappend x [testobjconfig info alltypes]
+    testobjconfig alltypes .b
+    lappend x [testobjconfig info alltypes]
+    deleteWindows
+    set x
+} {{1 16 -boolean} {2 16 -boolean}}
+test config-1.2 {Tk_CreateOptionTable - synonym initialization} testobjconfig {
+    deleteWindows
+    testobjconfig alltypes .a -synonym green
+    .a cget -color
+} {green}
+test config-1.3 {Tk_CreateOptionTable - option database initialization} testobjconfig {
+    deleteWindows
+    option clear
+    testobjconfig alltypes .a
+    option add *b.string different
+    testobjconfig alltypes .b
+    list [.a cget -string] [.b cget -string]
+} {foo different}
+test config-1.4 {Tk_CreateOptionTable - option database initialization} testobjconfig {
+    deleteWindows
+    option clear
+    testobjconfig alltypes .a
+    option add *b.String bar
+    testobjconfig alltypes .b
+    list [.a cget -string] [.b cget -string]
+} {foo bar}
+test config-1.5 {Tk_CreateOptionTable - default initialization} testobjconfig {
+    deleteWindows
+    testobjconfig alltypes .a
+    .a cget -relief
+} {raised}
+test config-1.6 {Tk_CreateOptionTable - chained tables} testobjconfig {
+    deleteWindows
+    killTables
+    testobjconfig chain1 .a
+    testobjconfig chain2 .b
+    testobjconfig info chain2
+} {1 4 -three 2 2 -one}
+test config-1.7 {Tk_CreateOptionTable - chained tables} testobjconfig {
+    deleteWindows
+    killTables
+    testobjconfig chain2 .b
+    testobjconfig chain1 .a
+    testobjconfig info chain2
+} {1 4 -three 2 2 -one}
+test config-1.8 {Tk_CreateOptionTable - chained tables} testobjconfig {
+    deleteWindows
+    testobjconfig chain1 .a
+    testobjconfig chain2 .b
+    list [catch {.a cget -four} msg] $msg [.a cget -one] \
+	    [.b cget -four] [.b cget -one]
+} {1 {unknown option "-four"} one four one}
+
+test config-2.1 {Tk_DeleteOptionTable - reference counts} testobjconfig {
+    deleteWindows
+    killTables
+    testobjconfig chain1 .a
+    testobjconfig chain2 .b
+    testobjconfig chain2 .c
+    deleteWindows
+    set x {}
+    testobjconfig delete chain2
+    lappend x [testobjconfig info chain2] [testobjconfig info chain1]
+    testobjconfig delete chain2
+    lappend x [testobjconfig info chain2] [testobjconfig info chain1]
+} {{1 4 -three 2 2 -one} {2 2 -one} {} {1 2 -one}}
+
+# No tests for DestroyOptionHashTable; couldn't figure out how to test.
+
+test config-3.1 {Tk_InitOptions - priority of chained tables} testobjconfig {
+    deleteWindows
+    testobjconfig chain1 .a
+    testobjconfig chain2 .b
+    list [.a cget -two] [.b cget -two]
+} {two {two and a half}}
+test config-3.2 {Tk_InitOptions - initialize from database} testobjconfig {
+    deleteWindows
+    option clear
+    option add *a.color blue
+    testobjconfig alltypes .a
+    list [.a cget -color]
+} {blue}
+test config-3.3 {Tk_InitOptions - initialize from database} testobjconfig {
+    deleteWindows
+    option clear
+    option add *a.justify bogus
+    testobjconfig alltypes .a
+    list [.a cget -justify]
+} {left}
+test config-3.4 {Tk_InitOptions - initialize from widget class} testobjconfig {
+    deleteWindows
+    testobjconfig alltypes .a
+    list [.a cget -color]
+} {red}
+test config-3.5 {Tk_InitOptions - no initial value} testobjconfig {
+    deleteWindows
+    testobjconfig alltypes .a
+    .a cget -anchor
+} {}
+test config-3.6 {Tk_InitOptions - bad initial value} testobjconfig {
+    deleteWindows
+    option clear
+    option add *a.color non-existent
+    list [catch {testobjconfig alltypes .a} msg] $msg $errorInfo
+} {1 {unknown color name "non-existent"} {unknown color name "non-existent"
+    (database entry for "-color" in widget ".a")
+    invoked from within
+"testobjconfig alltypes .a"}}
+option clear
+test config-3.7 {Tk_InitOptions - bad initial value} testobjconfig {
+    deleteWindows
+    list [catch {testobjconfig configerror} msg] $msg $errorInfo
+} {1 {expected integer but got "bogus"} {expected integer but got "bogus"
+    (default value for "-int")
+    invoked from within
+"testobjconfig configerror"}}
+option clear
+
+test config-4.1 {DoObjConfig - boolean} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -boolean 0} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}]
+} {0 .foo 0 0 0}
+test config-4.2 {DoObjConfig - boolean} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -boolean 1} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}]
+} {0 .foo 0 1 0}
+test config-4.3 {DoObjConfig - invalid boolean} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -boolean {}} msg] $msg
+} {1 {expected boolean value but got ""}}
+test config-4.4 {DoObjConfig - boolean internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -boolean 0
+    .foo cget -boolean
+} {0}
+test config-4.5 {DoObjConfig - integer} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -integer 3} msg] $msg [catch {.foo cget -integer} result] $result [catch {rename .foo {}}]
+} {0 .foo 0 3 0}
+test config-4.6 {DoObjConfig - invalid integer} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -integer bar} msg] $msg
+} {1 {expected integer but got "bar"}}
+test config-4.7 {DoObjConfig - integer internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -integer 421
+    .foo cget -integer
+} {421}
+test config-4.8 {DoObjConfig - double} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -double 3.14} msg] $msg [catch {.foo cget -double} result] $result [catch {rename .foo {}}]
+} {0 .foo 0 3.14 0}
+test config-4.9 {DoObjConfig - invalid double} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -double bar} msg] $msg
+} {1 {expected floating-point number but got "bar"}}
+test config-4.10 {DoObjConfig - double internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -double 62.75
+    .foo cget -double
+} {62.75}
+test config-4.11 {DoObjConfig - string} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -string test} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo]
+} {0 .foo 0 test {}}
+test config-4.12 {DoObjConfig - null string} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -string {}} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo]
+} {0 .foo 0 {} {}}
+test config-4.13 {DoObjConfig - string internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -string "this is a test"
+    .foo cget -string
+} {this is a test}
+test config-4.14 {DoObjConfig - string table} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -stringtable two} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo]
+} {0 .foo 0 two {}}
+test config-4.15 {DoObjConfig - invalid string table} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -stringtable foo} msg] $msg
+} {1 {bad stringtable "foo": must be one, two, three, or four}}
+test config-4.16 {DoObjConfig - new string table} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo -stringtable two
+    list [catch {.foo configure -stringtable three} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo]
+} {0 16 0 three {}}
+test config-4.17 {DoObjConfig - stringtable internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -stringtable "four"
+    .foo cget -stringtable
+} {four}
+test config-4.18 {DoObjConfig - color} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -color blue} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
+} {0 .foo 0 blue {}}
+test config-4.19 {DoObjConfig - invalid color} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -color xxx} msg] $msg
+} {1 {unknown color name "xxx"}}
+test config-4.20 {DoObjConfig - color internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -color purple
+    .foo cget -color
+} {purple}
+test config-4.21 {DoObjConfig - null color} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -color {}} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
+} {0 .foo 0 {} {}}
+test config-4.22 {DoObjConfig - getting rid of old color} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo -color #333333
+    list [catch {.foo configure -color #444444} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
+} {0 32 0 #444444 {}}
+test config-4.23 {DoObjConfig - font} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
+} {0 .foo 0 {Helvetica 72} {}}
+test config-4.24 {DoObjConfig - new font} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig alltypes .foo -font {Courier 12}
+    list [catch {.foo configure -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
+} {0 64 0 {Helvetica 72} {}}
+test config-4.25 {DoObjConfig - invalid font} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -font {Helvetica 12 foo}} msg] $msg
+} {1 {unknown font style "foo"}}
+test config-4.26 {DoObjConfig - null font} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -font {}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
+} {0 .foo 0 {} {}}
+test config-4.27 {DoObjConfig - font internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -font {Times 16}
+    .foo cget -font
+} {Times 16}
+test config-4.28 {DoObjConfig - bitmap} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -bitmap gray75} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
+} {0 .foo 0 gray75 {}}
+test config-4.29 {DoObjConfig - new bitmap} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo -bitmap gray75
+    list [catch {.foo configure -bitmap gray50} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
+} {0 128 0 gray50 {}}
+test config-4.30 {DoObjConfig - invalid bitmap} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -bitmap foo} msg] $msg
+} {1 {bitmap "foo" not defined}}
+test config-4.31 {DoObjConfig - null bitmap} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -bitmap {}} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
+} {0 .foo 0 {} {}}
+test config-4.32 {DoObjConfig - bitmap internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -bitmap gray25
+    .foo cget -bitmap
+} {gray25}
+test config-4.33 {DoObjConfig - border} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -border green} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
+} {0 .foo 0 green {}}
+test config-4.34 {DoObjConfig - invalid border} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -border xxx} msg] $msg
+} {1 {unknown color name "xxx"}}
+test config-4.35 {DoObjConfig - null border} testobjconfig {
+    catch {rename .foo {}}
+    list [catch {testobjconfig alltypes .foo -border {}} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
+} {0 .foo 0 {} {}}
+test config-4.36 {DoObjConfig - border internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -border #123456
+    .foo cget -border
+} {#123456}
+test config-4.37 {DoObjConfig - getting rid of old border} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo -border #333333
+    list [catch {.foo configure -border #444444} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
+} {0 256 0 #444444 {}}
+test config-4.38 {DoObjConfig - relief} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo]
+} {0 .foo 0 flat {}}
+test config-4.39 {DoObjConfig - invalid relief} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -relief foo} msg] $msg
+} {1 {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken}}
+test config-4.40 {DoObjConfig - new relief} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo -relief raised
+    list [catch {.foo configure -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo]
+} {0 512 0 flat {}}
+test config-4.41 {DoObjConfig - relief internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -relief ridge
+    .foo cget -relief
+} {ridge}
+test config-4.42 {DoObjConfig - cursor} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
+} {0 .foo 0 arrow {}}
+test config-4.43 {DoObjConfig - invalid cursor} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -cursor foo} msg] $msg
+} {1 {bad cursor spec "foo"}}
+test config-4.44 {DoObjConfig - null cursor} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -cursor {}} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
+} {0 .foo 0 {} {}}
+test config-4.45 {DoObjConfig - new cursor} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo -cursor xterm
+    list [catch {.foo configure -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
+} {0 1024 0 arrow {}}
+test config-4.46 {DoObjConfig - cursor internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -cursor watch
+    .foo cget -cursor
+} {watch}
+test config-4.47 {DoObjConfig - justify} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -justify center} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo]
+} {0 .foo 0 center {}}
+test config-4.48 {DoObjConfig - invalid justify} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -justify foo} msg] $msg
+} {1 {bad justification "foo": must be left, right, or center}}
+test config-4.49 {DoObjConfig - new justify} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo -justify left
+    list [catch {.foo configure -justify right} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo]
+} {0 2048 0 right {}}
+test config-4.50 {DoObjConfig - justify internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -justify center
+    .foo cget -justify
+} {center}
+test config-4.51 {DoObjConfig - anchor} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -anchor center} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo]
+} {0 .foo 0 center {}}
+test config-4.52 {DoObjConfig - invalid anchor} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -anchor foo} msg] $msg
+} {1 {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center}}
+test config-4.53 {DoObjConfig - new anchor} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo -anchor e
+    list [catch {.foo configure -anchor n} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo]
+} {0 4096 0 n {}}
+test config-4.54 {DoObjConfig - anchor internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -anchor sw
+    .foo cget -anchor
+} {sw}
+test config-4.55 {DoObjConfig - pixel} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -pixel 42} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo]
+} {0 .foo 0 42 {}}
+test config-4.56 {DoObjConfig - invalid pixel} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -pixel foo} msg] $msg
+} {1 {bad screen distance "foo"}}
+test config-4.57 {DoObjConfig - new pixel} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo -pixel 42m
+    list [catch {.foo configure -pixel 3c} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo]
+} {0 8192 0 3c {}}
+test config-4.58 {DoObjConfig - pixel internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -pixel [winfo screenmmwidth .]m
+    .foo cget -pixel
+} [winfo screenwidth .]
+test config-4.59 {DoObjConfig - window} testobjconfig {
+    catch {destroy .foo}
+    catch {destroy .bar}
+    toplevel .bar
+    list [catch {testobjconfig twowindows .foo -window .bar} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar]
+} {0 .foo 0 .bar {} {}}
+test config-4.60 {DoObjConfig - invalid window} testobjconfig {
+    catch {destroy .foo}
+    toplevel .bar
+    list [catch {testobjconfig twowindows .foo -window foo} msg] $msg [destroy .bar]
+} {1 {bad window path name "foo"} {}}
+test config-4.61 {DoObjConfig - null window} testobjconfig {
+    catch {destroy .foo}
+    catch {destroy .bar}
+    toplevel .bar
+    list [catch {testobjconfig twowindows .foo -window {}} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo]
+} {0 .foo 0 {} {}}
+test config-4.62 {DoObjConfig - new window} testobjconfig {
+    catch {destroy .foo}
+    catch {destroy .bar}
+    catch {destroy .blamph}
+    toplevel .bar
+    toplevel .blamph
+    testobjconfig twowindows .foo -window .bar
+    list [catch {.foo configure -window .blamph} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar] [destroy .blamph]
+} {0 0 0 .blamph {} {} {}}
+test config-4.63 {DoObjConfig - window internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -window .
+    .foo cget -window
+} {.}
+test config-4.64 {DoObjConfig - releasing old values} testobjconfig {
+    # 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.
+
+    catch {rename .foo {}}
+    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 {}
+} {}
+test config-4.65 {DoObjConfig - releasing old values} testobjconfig {
+    # 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.
+
+    catch {rename .foo {}}
+    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 {}
+} {}
+test config-4.66 {DoObjConfig - custom} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -custom test} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo]
+} {0 .foo 0 TEST {}}
+test config-4.67 {DoObjConfig - null custom} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -custom {}} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo]
+} {0 .foo 0 {} {}}
+test config-4.68 {DoObjConfig - custom internal value} testobjconfig {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -custom "this is a test"
+    .foo cget -custom
+} {THIS IS A TEST}
+
+test config-5.1 {ObjectIsEmpty - object is already string} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo -color [format ""]
+    .foo cget -color
+} {}
+test config-5.2 {ObjectIsEmpty - object is already string} testobjconfig {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -color [format " "]} msg] $msg
+} {1 {unknown color name " "}}
+test config-5.3 {ObjectIsEmpty - must convert back to string} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo -color [list]
+    .foo cget -color
+} {}
+
+deleteWindows
+if {[testConstraint testobjconfig]} {
+    testobjconfig chain2 .a
+    testobjconfig alltypes .b
+}
+test config-6.1 {GetOptionFromObj - cached answer} testobjconfig {
+    list [.a cget -three] [.a cget -three]
+} {three three}
+test config-6.2 {GetOptionFromObj - exact match} testobjconfig {
+    .a cget -one
+} {one}
+test config-6.3 {GetOptionFromObj - abbreviation} testobjconfig {
+    .a cget -fo
+} {four}
+test config-6.4 {GetOptionFromObj - ambiguous abbreviation} testobjconfig {
+    list [catch {.a cget -on} msg] $msg
+} {1 {unknown option "-on"}}
+test config-6.5 {GetOptionFromObj - duplicate options in different tables} testobjconfig {
+    .a cget -tw
+} {two and a half}
+test config-6.6 {GetOptionFromObj - synonym} testobjconfig {
+    .b cget -synonym
+} {red}
+
+deleteWindows
+if {[testConstraint testobjconfig]} {
+    testobjconfig alltypes .a
+}
+test config-7.1 {Tk_SetOptions - basics} testobjconfig {
+    .a configure -color green -rel sunken
+     list [.a cget -color] [.a cget -relief]
+} {green sunken}
+test config-7.2 {Tk_SetOptions - bogus option name} testobjconfig {
+    list [catch {.a configure -bogus} msg] $msg
+} {1 {unknown option "-bogus"}}
+test config-7.3 {Tk_SetOptions - synonym} testobjconfig {
+    .a configure -synonym blue
+    .a cget -color
+} {blue}
+test config-7.4 {Tk_SetOptions - missing value} testobjconfig {
+    list [catch {.a configure -color green -relief} msg] $msg [.a cget -color]
+} {1 {value for "-relief" missing} green}
+test config-7.5 {Tk_SetOptions - saving old values} testobjconfig {
+    .a configure -color red -int 7 -relief raised -double 3.14159
+    list [catch {.a csave -color green -int 432 -relief sunken \
+	    -double 2.0 -color bogus} msg] $msg [.a cget -color] \
+	    [.a cget -int] [.a cget -relief] [.a cget -double]
+} {1 {unknown color name "bogus"} red 7 raised 3.14159}
+test config-7.6 {Tk_SetOptions - error in DoObjConfig call} testobjconfig {
+    list [catch {.a configure -color bogus} msg] $msg $errorInfo
+} {1 {unknown color name "bogus"} {unknown color name "bogus"
+    (processing "-color" option)
+    invoked from within
+".a configure -color bogus"}}
+test config-7.7 {Tk_SetOptions - synonym name in error message} testobjconfig {
+    list [catch {.a configure -synonym bogus} msg] $msg $errorInfo
+} {1 {unknown color name "bogus"} {unknown color name "bogus"
+    (processing "-synonym" option)
+    invoked from within
+".a configure -synonym bogus"}}
+test config-7.8 {Tk_SetOptions - returning mask} testobjconfig {
+    format %x [.a configure -color red -int 7 -relief raised -double 3.14159]
+} {226}
+test config-7.9 {Tk_SetOptions - error in DoObjConfig with custom option} testobjconfig {
+    list [catch {.a configure -custom bad} msg] $msg $errorInfo
+} {1 {expected good value, got "BAD"} {expected good value, got "BAD"
+    (processing "-custom" option)
+    invoked from within
+".a configure -custom bad"}}
+
+test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} testobjconfig {
+    deleteWindows
+    testobjconfig alltypes .a
+    list [catch {.a csave -color green -color black -color blue \
+	    -color #ffff00 -color #ff00ff -color bogus} msg] $msg \
+	    [.a cget -color]
+} {1 {unknown color name "bogus"} red}
+test config-8.2 {Tk_RestoreSavedOptions - freeing object memory} testobjconfig {
+    deleteWindows
+    testobjconfig alltypes .a
+    .a csave -color green -color black -color blue -color #ffff00 \
+	    -color #ff00ff
+} {32}
+test config-8.3 {Tk_RestoreSavedOptions - boolean internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a
+    list [catch {.a csave -boolean 0 -color bogus}] [.a cget -boolean]
+} {1 1}
+test config-8.4 {Tk_RestoreSavedOptions - integer internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a
+    list [catch {.a csave -integer 24 -color bogus}] [.a cget -integer]
+} {1 148962237}
+test config-8.5 {Tk_RestoreSavedOptions - double internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a
+    list [catch {.a csave -double 62.4 -color bogus}] [.a cget -double]
+} {1 3.14159}
+test config-8.6 {Tk_RestoreSavedOptions - string internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a
+    list [catch {.a csave -string "A long string" -color bogus}] \
+	    [.a cget -string]
+} {1 foo}
+test config-8.7 {Tk_RestoreSavedOptions - string table internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a
+    list [catch {.a csave -stringtable three -color bogus}] \
+	    [.a cget -stringtable]
+} {1 one}
+test config-8.8 {Tk_RestoreSavedOptions - color internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a
+    list [catch {.a csave -color green -color bogus}] [.a cget -color]
+} {1 red}
+test config-8.9 {Tk_RestoreSavedOptions - font internal form} {testobjconfig nonPortable} {
+    deleteWindows
+    testobjconfig internal .a
+    list [catch {.a csave -font {Times 12} -color bogus}] [.a cget -font]
+} {1 {Helvetica 12}}
+test config-8.10 {Tk_RestoreSavedOptions - bitmap internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a
+    list [catch {.a csave -bitmap questhead -color bogus}] [.a cget -bitmap]
+} {1 gray50}
+test config-8.11 {Tk_RestoreSavedOptions - border internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a
+    list [catch {.a csave -border brown -color bogus}] [.a cget -border]
+} {1 blue}
+test config-8.12 {Tk_RestoreSavedOptions - relief internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a
+    list [catch {.a csave -relief sunken -color bogus}] [.a cget -relief]
+} {1 raised}
+test config-8.13 {Tk_RestoreSavedOptions - cursor internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a
+    list [catch {.a csave -cursor watch -color bogus}] [.a cget -cursor]
+} {1 xterm}
+test config-8.14 {Tk_RestoreSavedOptions - justify internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a
+    list [catch {.a csave -justify right -color bogus}] [.a cget -justify]
+} {1 left}
+test config-8.15 {Tk_RestoreSavedOptions - anchor internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a
+    list [catch {.a csave -anchor center -color bogus}] [.a cget -anchor]
+} {1 n}
+test config-8.16 {Tk_RestoreSavedOptions - window internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a -window .a
+    list [catch {.a csave -window .a -color bogus}] [.a cget -window]
+} {1 .a}
+test config-8.17 {Tk_RestoreSavedOptions - custom internal form} testobjconfig {
+    deleteWindows
+    testobjconfig internal .a -custom "foobar"
+    list [catch {.a csave -custom "barbaz" -color bogus}] [.a cget -custom]
+} {1 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} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig internal .foo
+    .foo configure -string "two words"
+    destroy .foo
+} {}
+test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig internal .foo
+    .foo configure -color yellow
+    destroy .foo
+} {}
+test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo
+    .foo configure -color [format blue]
+    destroy .foo
+} {}
+test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig internal .foo
+    .foo configure -font {Courier 20}
+    destroy .foo
+} {}
+test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo
+    .foo configure -font [format {Courier 24}]
+    destroy .foo
+} {}
+test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig internal .foo
+    .foo configure -bitmap gray75
+    destroy .foo
+} {}
+test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo
+    .foo configure -bitmap [format gray75]
+    destroy .foo
+} {}
+test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig internal .foo
+    .foo configure -border orange
+    destroy .foo
+} {}
+test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo
+    .foo configure -border [format blue]
+    destroy .foo
+} {}
+test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig internal .foo
+    .foo configure -cursor cross
+    destroy .foo
+} {}
+test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo
+    .foo configure -cursor [format watch]
+    destroy .foo
+} {}
+test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo
+    .foo configure -integer [format 27]
+    destroy .foo
+} {}
+test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} testobjconfig {
+    catch {destroy .fpp}
+    testobjconfig internal .foo
+    .foo configure -custom "foobar"
+    destroy .foo
+} {}
+
+test config-10.1 {Tk_GetOptionInfo - one item} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo
+    .foo configure -relief groove
+    .foo configure -relief
+} {-relief relief Relief raised groove}
+test config-10.2 {Tk_GetOptionInfo - one item, synonym} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo
+    .foo configure -color black
+    .foo configure -synonym
+} {-color color Color red black}
+test config-10.3 {Tk_GetOptionInfo - all items} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig alltypes .foo -font {Helvetica 18} -integer 13563
+    .foo configure
+} {{-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} testobjconfig {
+    catch {destroy .foo}
+    testobjconfig chain2 .foo -one asdf -three xyzzy
+    .foo configure
+} {{-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}}}
+
+deleteWindows
+if {[testConstraint testobjconfig]} {
+    testobjconfig alltypes .a
+}
+test config-11.1 {GetConfigList - synonym} testobjconfig {
+    lindex [.a configure] end
+} {-synonym -color}
+test config-11.2 {GetConfigList - null database names} testobjconfig {
+    .a configure -justify
+} {-justify {} {} left left}
+test config-11.3 {GetConfigList - null default and current value} testobjconfig {
+    .a configure -anchor
+} {-anchor anchor Anchor {} {}}
+
+deleteWindows
+if {[testConstraint testobjconfig]} {
+    testobjconfig internal .a
+}
+test config-12.1 {GetObjectForOption - boolean} testobjconfig {
+    .a configure -boolean 0
+    .a cget -boolean
+} {0}
+test config-12.2 {GetObjectForOption - integer} testobjconfig {
+    .a configure -integer 1247
+    .a cget -integer
+} {1247}
+test config-12.3 {GetObjectForOption - double} testobjconfig {
+    .a configure -double -88.82
+    .a cget -double
+} {-88.82}
+test config-12.4 {GetObjectForOption - string} testobjconfig {
+    .a configure -string "test value"
+    .a cget -string
+} {test value}
+test config-12.5 {GetObjectForOption - stringTable} testobjconfig {
+    .a configure -stringtable "two"
+    .a cget -stringtable
+} {two}
+test config-12.6 {GetObjectForOption - color} testobjconfig {
+    .a configure -color "green"
+    .a cget -color
+} {green}
+test config-12.7 {GetObjectForOption - font} testobjconfig {
+    .a configure -font {Times 36}
+    .a cget -font
+} {Times 36}
+test config-12.8 {GetObjectForOption - bitmap} testobjconfig {
+    .a configure -bitmap "questhead"
+    .a cget -bitmap
+} {questhead}
+test config-12.9 {GetObjectForOption - border} testobjconfig {
+    .a configure -border #33217c
+    .a cget -border
+} {#33217c}
+test config-12.10 {GetObjectForOption - relief} testobjconfig {
+    .a configure -relief groove
+    .a cget -relief
+} {groove}
+test config-12.11 {GetObjectForOption - cursor} testobjconfig {
+    .a configure -cursor watch
+    .a cget -cursor
+} {watch}
+test config-12.12 {GetObjectForOption - justify} testobjconfig {
+    .a configure -justify right
+    .a cget -justify
+} {right}
+test config-12.13 {GetObjectForOption - anchor} testobjconfig {
+    .a configure -anchor e
+    .a cget -anchor
+} {e}
+test config-12.14 {GetObjectForOption - pixels} testobjconfig {
+    .a configure -pixel 193.2
+    .a cget -pixel
+} {193}
+test config-12.15 {GetObjectForOption - window} testobjconfig {
+    .a configure -window .a
+    .a cget -window
+} {.a}
+test config-12.16 {GetObjectForOption -custom} testobjconfig {
+    .a configure -custom foobar
+    .a cget -custom
+} {FOOBAR}
+test config-12.17 {GetObjectForOption - null values} testobjconfig {
+    .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]
+} {{} {} {} {} {} {} {} {}}
+
+test config-13.1 {proper cleanup of options with widget destroy} {
+    foreach type {
+	button canvas entry frame listbox menu menubutton message
+	scale scrollbar text radiobutton checkbutton
+    } {
+	destroy .w
+	$type .w -cursor crosshair
+	destroy .w
+    }
+} {}
+
+deleteWindows
+
+test config-14.1 {Tk_CreateOptionTable - use with namespace import} {
+    namespace export -clear *
+    foreach type {
+	button canvas entry frame listbox menu menubutton message
+	scale scrollbar spinbox text radiobutton checkbutton
+    } {
+	namespace eval ::foo [subst {
+	    namespace import -force ::$type
+	    ::foo::$type .a
+	    ::foo::$type .b
+	}
+	]
+	destroy .a .b
+    }
+} {}
+
+# cleanup
+deleteWindows
+if {[testConstraint testobjconfig]} {
+    killTables
+}
+cleanupTests
+return

tests/constraints.tcl

@@ -0,0 +1,250 @@
+if {[namespace exists tk::test]} {
+    deleteWindows
+    wm geometry . {}
+    raise .
+    return
+}
+
+package require Tcl 8.4
+
+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 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 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
+.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
+namespace import -force tcltest::bytestring
+
+deleteWindows
+wm geometry . {}
+raise .
+

tests/cursor.test

@@ -0,0 +1,313 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} {testcursor} {
+    set x watch
+    lindex $x 0
+    destroy .b1
+    button .b1 -cursor $x
+    lindex $x 0
+    testcursor watch
+} {{1 0}}
+test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} {testcursor} {
+    set x watch
+    destroy .b1 .b2
+    button .b1 -cursor $x
+    destroy .b1
+    set result {}
+    lappend result [testcursor watch]
+    button .b2 -cursor $x
+    lappend result [testcursor watch]
+} {{} {{1 1}}}
+test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} {testcursor} {
+    set x watch
+    destroy .b1 .b2
+    button .b1 -cursor $x
+    set result {}
+    lappend result [testcursor watch]
+    button .b2 -cursor $x
+    pack .b1 .b2 -side top
+    lappend result [testcursor watch]
+} {{{1 1}} {{2 1}}}
+
+test cursor-2.1 {Tk_GetCursor procedure} {
+    destroy .b1
+    list [catch {button .b1 -cursor bad_name} msg] $msg
+} {1 {bad cursor spec "bad_name"}}
+test cursor-2.2 {Tk_GetCursor procedure} {
+    destroy .b1
+    list [catch {button .b1 -cursor @xyzzy} msg] $msg
+} {1 {bad cursor spec "@xyzzy"}}
+# Next two tests need a helper file with a very specific name and
+# controlled format.
+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-2.3 {Tk_GetCursor procedure: cursor specs are lists} win {
+    destroy .b1
+    button .b1 -cursor [list @$wincur(file)]
+} {.b1}
+test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} win {
+    destroy .b1
+    button .b1 -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}]
+} {.b1}
+removeDirectory $wincur(dir)
+unset wincur
+
+test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} {testcursor} {
+    set x heart
+    destroy .b1 .b2 .b3
+    button .b1 -cursor $x
+    button .b3 -cursor $x
+    button .b2 -cursor $x
+    set result {}
+    lappend result [testcursor heart]
+    destroy .b1
+    lappend result [testcursor heart]
+    destroy .b2
+    lappend result [testcursor heart]
+    destroy .b3
+    lappend result [testcursor heart]
+} {{{3 1}} {{2 1}} {{1 1}} {}}
+
+test cursor-4.1 {FreeCursorObjProc} {testcursor} {
+    destroy .b
+    set x [format heart]
+    button .b -cursor $x
+    set y [format heart]
+    .b configure -cursor $y
+    set z [format 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
+} {{{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.
+
+foreach {testName cursor} {
+    cursor-6.1  X_cursor
+    cursor-6.2  arrow
+    cursor-6.3  based_arrow_down
+    cursor-6.4  based_arrow_up
+    cursor-6.5  boat
+    cursor-6.6  bogosity
+    cursor-6.7  bottom_left_corner
+    cursor-6.8  bottom_right_corner
+    cursor-6.9  bottom_side
+    cursor-6.10 bottom_tee
+    cursor-6.11 box_spiral
+    cursor-6.12 center_ptr
+    cursor-6.13 circle
+    cursor-6.14 clock
+    cursor-6.15 coffee_mug
+    cursor-6.16 cross
+    cursor-6.17 cross_reverse
+    cursor-6.18 crosshair
+    cursor-6.19 diamond_cross
+    cursor-6.20 dot
+    cursor-6.21 dotbox
+    cursor-6.22 double_arrow
+    cursor-6.23 draft_large
+    cursor-6.24 draft_small
+    cursor-6.25 draped_box
+    cursor-6.26 exchange
+    cursor-6.27 fleur
+    cursor-6.28 gobbler
+    cursor-6.29 gumby
+    cursor-6.30 hand1
+    cursor-6.31 hand2
+    cursor-6.32 heart
+    cursor-6.33 icon
+    cursor-6.34 iron_cross
+    cursor-6.35 left_ptr
+    cursor-6.36 left_side
+    cursor-6.37 left_tee
+    cursor-6.38 leftbutton
+    cursor-6.39 ll_angle
+    cursor-6.40 lr_angle
+    cursor-6.41 man
+    cursor-6.42 middlebutton
+    cursor-6.43 mouse
+    cursor-6.44 pencil
+    cursor-6.45 pirate
+    cursor-6.46 plus
+    cursor-6.47 question_arrow
+    cursor-6.48 right_ptr
+    cursor-6.49 right_side
+    cursor-6.50 right_tee
+    cursor-6.51 rightbutton
+    cursor-6.52 rtl_logo
+    cursor-6.53 sailboat
+    cursor-6.54 sb_down_arrow
+    cursor-6.55 sb_h_double_arrow
+    cursor-6.56 sb_left_arrow
+    cursor-6.57 sb_right_arrow
+    cursor-6.58 sb_up_arrow
+    cursor-6.59 sb_v_double_arrow
+    cursor-6.60 shuttle
+    cursor-6.61 sizing
+    cursor-6.62 spider
+    cursor-6.63 spraycan
+    cursor-6.64 star
+    cursor-6.65 target
+    cursor-6.66 tcross
+    cursor-6.67 top_left_arrow
+    cursor-6.68 top_left_corner
+    cursor-6.69 top_right_corner
+    cursor-6.70 top_side
+    cursor-6.71 top_tee
+    cursor-6.72 trek
+    cursor-6.73 ul_angle
+    cursor-6.74 umbrella
+    cursor-6.75 ur_angle
+    cursor-6.76 watch
+    cursor-6.77 xterm
+} {
+    test $testName "check cursor-font cursor $cursor" -setup {
+	button .b -text $cursor
+    } -body {
+	.b configure -cursor $cursor
+    } -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.80 {} -setup {
+    button .b -text CButton
+} -body {
+    .b configure -cursor none
+    .b cget -cursor
+} -cleanup {
+    destroy .b
+} -result none
+
+test cursor-6.81 {} -setup {
+    button .b -text CButton
+} -body {
+    .b configure -cursor none
+    .b configure -cursor {}
+    .b cget -cursor
+} -cleanup {
+    destroy .b
+} -result {}
+
+test cursor-6.82 {} -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.83 {} -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
+
+foreach {testName cursor} {
+    cursor-7.1 no
+    cursor-7.2 starting
+    cursor-7.3 size
+    cursor-7.4 size_ne_sw
+    cursor-7.5 size_ns
+    cursor-7.6 size_nw_se
+    cursor-7.7 size_we
+    cursor-7.8 uparrow
+    cursor-7.9 wait
+} {
+    test $testName "check Windows cursor $cursor" -constraints win -setup {
+	button .b -text $cursor
+    } -body {
+	.b configure -cursor $cursor
+    } -cleanup {
+	destroy .b
+    } -result {}
+}
+
+# -------------------------------------------------------------------------
+
+destroy .t
+
+# cleanup
+cleanupTests
+return

tests/dialog.test

@@ -0,0 +1,58 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test dialog-1.1 {tk_dialog command} -body {
+    list [catch {tk_dialog} msg] $msg
+} -match glob -result {1 {wrong # args: should be "tk_dialog w title text bitmap default *"}}
+test dialog-1.2 {tk_dialog command} {
+    list [catch {tk_dialog foo foo foo foo foo} msg] $msg
+} {1 {bad window path name "foo"}}
+test dialog-1.3 {tk_dialog command} {
+    set res [list [catch {tk_dialog .d foo foo fooBitmap foo} msg] $msg]
+    destroy .d
+    set res
+} {1 {bitmap "fooBitmap" not defined}}
+
+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
+}
+
+proc HitReturn {w} {
+    event generate $w <Enter>
+    focus -force $w
+    event generate $w <KeyPress> -keysym Return
+}
+
+test dialog-2.0 {tk_dialog operation} {
+    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
+    set res
+} {0}
+test dialog-2.1 {tk_dialog operation} {
+    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
+    set res
+} {1}
+test dialog-2.2 {tk_dialog operation} {
+    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
+    set res
+} {-1}
+
+cleanupTests
+return

tests/embed.test

@@ -0,0 +1,70 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+global tcl_platform
+
+test embed-1.1 {TkpUseWindow procedure, bad window identifier} {
+    deleteWindows
+    list [catch {toplevel .t -use xyz} msg] $msg
+} {1 {expected integer but got "xyz"}}
+
+test embed-1.2 {CreateFrame procedure, bad window identifier} {
+    deleteWindows
+    list [catch {toplevel .t -container xyz} msg] $msg
+} {1 {expected boolean value but got "xyz"}}
+
+test embed-1.3 {CreateFrame procedure, both -use and
+        -container is invalid } {
+    deleteWindows
+    toplevel .container -container 1
+    list [catch {toplevel .t -use [winfo id .container] \
+        -container 1} msg] $msg
+} {1 {A window cannot have both the -use and the -container option set.}}
+
+if {$tcl_platform(platform) == "windows"} {
+
+# testing window embedding for Windows platform
+
+test embed-1.4.win {TkpUseWindow procedure, -container must be set} {
+    deleteWindows
+    toplevel .container
+    list [catch {toplevel .embd -use [winfo id .container]} err] $err
+} {1 {the window to use is not a Tk container}}
+
+test embed-1.5.win {TkpUseWindow procedure, -container must be set} {
+    deleteWindows
+    frame .container
+    list [catch {toplevel .embd -use [winfo id .container]} err] $err
+} {1 {the window to use is not a Tk container}}
+
+} else {
+
+# testing window embedding for other platforms
+
+test embed-1.4.nonwin {TkpUseWindow procedure, -container must be set} {
+    deleteWindows
+    toplevel .container
+    list [catch {toplevel .embd -use [winfo id .container]} err] $err
+} {1 {window ".container" doesn't have -container option set}}
+
+test embed-1.5.nonwin {TkpUseWindow procedure, -container must be set} {
+    deleteWindows
+    frame .container
+    list [catch {toplevel .embd -use [winfo id .container]} err] $err
+} {1 {window ".container" doesn't have -container option set}}
+
+}
+
+# FIXME: test cases common to unixEmbed.test and macEmbed.test should
+# be moved here.
+
+cleanupTests
+return
+

tests/event.test

@@ -0,0 +1,784 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# 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} {
+    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
+    }
+    set x {}
+    destroy .b
+    set x
+} {destroy}
+test event-1.2 {event generate <Alt-z>} {
+	catch {destroy .e}
+	catch {unset ::event12result}
+	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
+} 1
+
+test event-2.1(keypress) {type into entry widget and hit Return} {
+    destroy .t
+    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
+} {HELLO 1}
+test event-2.2(keypress) {type into entry widget and then delete some text} {
+    destroy .t
+    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
+} MEL
+test event-2.3(keypress) {type into entry widget, triple click,\
+	hit Delete key, and then type some more} {
+    destroy .t
+    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]
+} {JUMP UP}
+test event-1.4(keypress) {type into text widget and hit Return} {
+    destroy .t
+    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
+} [list "HELLO\n\n" 1]
+test event-2.5(keypress) {type into text widget and then delete some text} {
+    destroy .t
+    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
+} MEL
+test event-2.6(keypress) {type into text widget, triple click,\
+	hit Delete key, and then type some more} {
+    destroy .t
+    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]
+} {JUMP UP}
+
+test event-3.1(click-drag) {click and drag in a text widget, this tests\
+	tkTextSelectTo in text.tcl} {
+    destroy .t
+    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]
+
+} {{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} {
+    destroy .t
+    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]
+
+} {{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} {
+    destroy .t
+    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]
+
+    set 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} {
+    destroy .t
+    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]
+
+    set 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} {
+    destroy .t
+    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]
+
+    set 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} {
+    destroy .t
+    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>
+    set motion
+} nomotion
+
+test event-7.1(double-click) {A double click on a lone character
+	in a text widget should select that character} {
+    destroy .t
+    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]
+
+    set 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} {knownBug} {
+    destroy .t
+    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]
+
+    set result
+} {3 A 4 A}
+
+# cleanup
+
+destroy .t
+
+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

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};

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

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};

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};

tests/focus.test

@@ -0,0 +1,639 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+button .b -text .b -relief raised -bd 2
+pack .b
+
+proc focusSetup {} {
+    catch {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
+    catch {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
+}
+
+# Make sure the window manager knows who has focus
+catch {fixfocus}
+
+# 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.
+
+setupbg
+proc focusClear {} {
+    global x;
+    after 200 {set x 1}
+    tkwait variable x
+    dobg {focus -force .; update}
+    update
+}
+
+focusSetup
+if {[testConstraint altDisplay]} {
+    focusSetupAlt
+}
+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"
+}
+
+test focus-1.1 {Tk_FocusCmd procedure} unix {
+    focusClear
+    focus
+} {}
+test focus-1.2 {Tk_FocusCmd procedure} {unix altDisplay} {
+    focus .alt.b
+    focus
+} {}
+test focus-1.3 {Tk_FocusCmd procedure} unix {
+    focusClear
+    focus .t.b3
+    focus
+} {}
+test focus-1.4 {Tk_FocusCmd procedure} unix {
+    list [catch {focus ""} msg] $msg
+} {0 {}}
+test focus-1.5 {Tk_FocusCmd procedure} unix {
+    focusClear
+    focus -force .t
+    focus .t.b3
+    focus
+} {.t.b3}
+test focus-1.6 {Tk_FocusCmd procedure} unix {
+    list [catch {focus .gorp} msg] $msg
+} {1 {bad window path name ".gorp"}}
+test focus-1.7 {Tk_FocusCmd procedure} unix {
+    list [catch {focus .gorp a} msg] $msg
+} {1 {bad option ".gorp": must be -displayof, -force, or -lastfor}}
+test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} unix {
+    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
+    set x
+} {.t2.f2 .t2 .t2}
+test focus-1.9 {Tk_FocusCmd procedure, -displayof option} unix {
+    list [catch {focus -displayof} msg] $msg
+} {1 {wrong # args: should be "focus -displayof window"}}
+test focus-1.10 {Tk_FocusCmd procedure, -displayof option} unix {
+    list [catch {focus -displayof a b} msg] $msg
+} {1 {wrong # args: should be "focus -displayof window"}}
+test focus-1.11 {Tk_FocusCmd procedure, -displayof option} unix {
+    list [catch {focus -displayof .lousy} msg] $msg
+} {1 {bad window path name ".lousy"}}
+test focus-1.12 {Tk_FocusCmd procedure, -displayof option} unix {
+    focusClear
+    focus .t
+    focus -displayof .t.b3
+} {}
+test focus-1.13 {Tk_FocusCmd procedure, -displayof option} unix {
+    focusClear
+    focus -force .t
+    focus -displayof .t.b3
+} {.t}
+test focus-1.14 {Tk_FocusCmd procedure, -displayof option} {unix altDisplay} {
+    focus -force .alt.c
+    focus -displayof .alt
+} {.alt.c}
+test focus-1.15 {Tk_FocusCmd procedure, -force option} unix {
+    list [catch {focus -force} msg] $msg
+} {1 {wrong # args: should be "focus -force window"}}
+test focus-1.16 {Tk_FocusCmd procedure, -force option} unix {
+    list [catch {focus -force a b} msg] $msg
+} {1 {wrong # args: should be "focus -force window"}}
+test focus-1.17 {Tk_FocusCmd procedure, -force option} unix {
+    list [catch {focus -force foo} msg] $msg
+} {1 {bad window path name "foo"}}
+test focus-1.18 {Tk_FocusCmd procedure, -force option} unix {
+    list [catch {focus -force ""} msg] $msg
+} {0 {}}
+test focus-1.19 {Tk_FocusCmd procedure, -force option} unix {
+    focusClear
+    focus .t.b1
+    set x  [list [focus]]
+    focus -force .t.b1
+    lappend x [focus]
+} {{} .t.b1}
+test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} unix {
+    list [catch {focus -lastfor} msg] $msg
+} {1 {wrong # args: should be "focus -lastfor window"}}
+test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} unix {
+    list [catch {focus -lastfor 1 2} msg] $msg
+} {1 {wrong # args: should be "focus -lastfor window"}}
+test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} unix {
+    list [catch {focus -lastfor who_knows?} msg] $msg
+} {1 {bad window path name "who_knows?"}}
+test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} unix {
+    focus .b
+    focus .t.b1
+    list [focus -lastfor .] [focus -lastfor .t.b3]
+} {.b .t.b1}
+test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} unix {
+    destroy .t
+    focusSetup
+    update
+    focus -lastfor .t.b2
+} {.t}
+test focus-1.25 {Tk_FocusCmd procedure} unix {
+    list [catch {focus -unknown} msg] $msg
+} {1 {bad option "-unknown": must be -displayof, -force, or -lastfor}}
+
+test focus-2.1 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} {
+    focus -force .b
+    destroy .t
+    focusSetup
+    update
+    set focusInfo {}
+    event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor \
+	    -sendevent 0x54217567
+    list $focusInfo
+} {{}}
+test focus-2.2 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} {
+    focus -force .b
+    destroy .t
+    focusSetup
+    update
+    set focusInfo {}
+    event gen .t <FocusIn> -detail NotifyAncestor -sendevent 0x547321ac
+    list $focusInfo [focus]
+} {{in .t NotifyAncestor
+} .b}
+test focus-2.3 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} {
+    focus -force .b
+    destroy .t
+    focusSetup
+    update
+    set focusInfo {}
+    event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
+    update
+    list $focusInfo [focus -lastfor .t]
+} {{out .b NotifyNonlinear
+out . NotifyNonlinearVirtual
+in .t NotifyNonlinear
+} .t}
+test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} \
+	{unix nonPortable testwrapper} {
+    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
+    }
+    set 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} \
+	{unix nonPortable testwrapper} {
+    focusSetup
+    focus .t.b1
+    update
+    event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
+    list $focusInfo [focus]
+} {{out . NotifyNonlinear
+in .t NotifyNonlinearVirtual
+in .t.b1 NotifyNonlinear
+} .t.b1}
+test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} \
+	{unix testwrapper} {
+    focus .t.b1
+    focus .
+    update
+    event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
+    set focusInfo {}
+    set x [focus]
+    event gen . <KeyPress-x>
+    list $x $focusInfo
+} {.t.b1 {press .t.b1 x}}
+test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} \
+	{unix testwrapper} {
+    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]
+    }
+    set result
+} {{} .t.b1 {} {} .t.b1 .t.b1 {}}
+test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} \
+	{unix testwrapper} {
+    focus -force .t.b1
+    event gen .t.b1 <FocusOut> -detail NotifyAncestor
+    focus
+} {.t.b1}
+test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} \
+	{unix testwrapper} {
+    focus .t.b1
+    event gen [testwrapper .] <FocusOut> -detail NotifyAncestor
+    focus
+} {}
+test focus-2.10 {TkFocusFilterEvent procedure, Enter events} \
+	{unix testwrapper} {
+    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
+    }
+    set result
+} {.t.b1 {} .t.b1 .t.b1 .t.b1}
+test focus-2.11 {TkFocusFilterEvent procedure, Enter events} \
+	{unix testwrapper} {
+    focusClear
+    set focusInfo {}
+    event gen [testwrapper .t] <Enter> -detail NotifyAncestor
+    update
+    set focusInfo
+} {}
+test focus-2.12 {TkFocusFilterEvent procedure, Enter events} \
+	{unix testwrapper} {
+    focus -force .b
+    update
+    set focusInfo {}
+    event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
+    update
+    set focusInfo
+} {}
+test focus-2.13 {TkFocusFilterEvent procedure, Enter events} \
+	{unix testwrapper} {
+    focus .t.b1
+    focusClear
+    event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
+    set focusInfo {}
+    update
+    set focusInfo
+} {in .t NotifyVirtual
+in .t.b1 NotifyAncestor
+}
+test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} {unix testwrapper} {
+    focusClear
+    catch {destroy .t2}
+    toplevel .t2
+    wm withdraw .t2
+    update
+    set focusInfo {}
+    event gen [testwrapper .t2] <Enter> -detail NotifyAncestor -focus 1
+    update
+    destroy .t2
+} {}
+test focus-2.15 {TkFocusFilterEvent procedure, Leave events} \
+	{unix testwrapper} {
+    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]
+    }
+    set result
+} {{} .t.b1 {} {} {}}
+test focus-2.16 {TkFocusFilterEvent procedure, Leave events} \
+	{unix testwrapper} {
+    set result {}
+    focus .t.b1
+    event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
+    update
+    set focusInfo {}
+    event gen [testwrapper .t] <Leave> -detail NotifyAncestor
+    update
+    set focusInfo
+} {out .t.b1 NotifyAncestor
+out .t NotifyVirtual
+}
+test focus-2.17 {TkFocusFilterEvent procedure, Leave events} \
+	{unix testwrapper} {
+    set result {}
+    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]
+} {{out .t.b1 NotifyAncestor
+out .t NotifyVirtual
+} {}}
+
+test focus-3.1 {SetFocus procedure, create record on focus} \
+	{unix testwrapper} {
+    toplevel .t2 -width 250 -height 100
+    wm geometry .t2 +0+0
+    update
+    focus -force .t2
+    update
+    focus
+} {.t2}
+catch {destroy .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} {unix testwrapper} {
+    update
+    button .b2 -text "Another button"
+    focus .b2
+    update
+} {}
+catch {destroy .b2}
+update
+# 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} \
+	{unix testwrapper} {
+    focusSetup
+    focus -force .t.b2
+    update
+} {}
+test focus-3.4 {SetFocus procedure, delaying claim of X focus} \
+	{unix testwrapper} {
+    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
+} {}
+catch {destroy .t2}
+test focus-3.5 {SetFocus procedure, generating events} {unix testwrapper} {
+    focusSetup
+    focusClear
+    set focusInfo {}
+    focus -force .t.b2
+    update
+    set focusInfo
+} {in .t NotifyVirtual
+in .t.b2 NotifyAncestor
+}
+test focus-3.6 {SetFocus procedure, generating events} {unix testwrapper} {
+    focusSetup
+    focus -force .b
+    update
+    set focusInfo {}
+    focus .t.b2
+    update
+    set focusInfo
+} {out .b NotifyNonlinear
+out . NotifyNonlinearVirtual
+in .t NotifyNonlinearVirtual
+in .t.b2 NotifyNonlinear
+}
+test focus-3.7 {SetFocus procedure, generating events} \
+	{unix nonPortable testwrapper} {
+    # Non-portable because some platforms generate extra events.
+
+    focusSetup
+    focusClear
+    set focusInfo {}
+    focus .t.b2
+    update
+    set focusInfo
+} {}
+
+test focus-4.1 {TkFocusDeadWindow procedure} {unix testwrapper} {
+    focusSetup
+    update
+    focus -force .b
+    update
+    destroy .t
+    focus
+} {.b}
+test focus-4.2 {TkFocusDeadWindow procedure} {unix testwrapper} {
+    focusSetup
+    update
+    focus -force .t.b2
+    focus .b
+    update
+    destroy .t.b2
+    update
+    focus
+} {.b}
+
+# Non-portable due to wm-specific redirection of input focus when
+# windows are deleted:
+
+test focus-4.3 {TkFocusDeadWindow procedure} {unix nonPortable testwrapper} {
+    focusSetup
+    update
+    focus .t
+    update
+    destroy .t
+    update
+    focus
+} {}
+test focus-4.4 {TkFocusDeadWindow procedure} {unix testwrapper} {
+    focusSetup
+    focus -force .t.b2
+    update
+    destroy .t.b2
+    focus
+} {.t}
+
+# 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.
+
+setupbg
+test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} \
+	{unix testwrapper secureserver} {
+    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]
+} {.t {} {}}
+
+catch {destroy .t}
+bind all <FocusIn> {}
+bind all <FocusOut> {}
+bind all <KeyPress> {}
+cleanupbg
+fixfocus
+
+test focus-6.1 {miscellaneous - embedded application in same process} \
+	{unix testwrapper} {
+    eval interp delete [interp slaves]
+    catch {destroy .t}
+    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}]]
+    interp delete child
+    set 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} \
+	{unix testwrapper} {
+    eval interp delete [interp slaves]
+    catch {destroy .t}
+    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}]]
+    cleanupbg
+    set 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
+bind all <FocusIn> {}
+bind all <FocusOut> {}
+
+# cleanup
+cleanupTests
+return

tests/focusTcl.test

@@ -0,0 +1,278 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+proc setup1 w {
+    if {$w == "."} {
+	set w ""
+    }
+    foreach i {a b c d} {
+	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} {
+	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
+    }
+}
+
+option add *takeFocus 1
+option add *highlightThickness 2
+. configure -takefocus 1 -highlightthickness 2
+test focusTcl-1.1 {tk_focusNext procedure, no children} {
+    tk_focusNext .
+} {.}
+setup1 .
+test focusTcl-1.2 {tk_focusNext procedure, basic tree traversal} {
+    tk_focusNext .
+} {.a}
+test focusTcl-1.3 {tk_focusNext procedure, basic tree traversal} {
+    tk_focusNext .a
+} {.b}
+test focusTcl-1.4 {tk_focusNext procedure, basic tree traversal} {
+    tk_focusNext .b
+} {.b.x}
+test focusTcl-1.5 {tk_focusNext procedure, basic tree traversal} {
+    tk_focusNext .b.x
+} {.b.y}
+test focusTcl-1.6 {tk_focusNext procedure, basic tree traversal} {
+    tk_focusNext .b.y
+} {.b.z}
+test focusTcl-1.7 {tk_focusNext procedure, basic tree traversal} {
+    tk_focusNext .b.z
+} {.c}
+test focusTcl-1.8 {tk_focusNext procedure, basic tree traversal} {
+    tk_focusNext .c
+} {.d}
+test focusTcl-1.9 {tk_focusNext procedure, basic tree traversal} {
+    tk_focusNext .d
+} {.}
+foreach w {.b .b.x .b.y .c .d} {
+    $w configure -takefocus 0
+}
+test focusTcl-1.10 {tk_focusNext procedure, basic tree traversal} {
+    tk_focusNext .a
+} {.b.z}
+test focusTcl-1.11 {tk_focusNext procedure, basic tree traversal} {
+    tk_focusNext .b.z
+} {.}
+test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} {
+    deleteWindows
+    setup1 .
+    update
+    . configure -takefocus 0
+    tk_focusNext .d
+} {.a}
+. configure -takefocus 1
+
+deleteWindows
+setup1 .
+toplevel .t
+wm geom .t +0+0
+toplevel .t2
+wm geom .t2 -0+0
+raise .t .a
+test focusTcl-2.1 {tk_focusNext procedure, toplevels} {
+    tk_focusNext .a
+} {.b}
+test focusTcl-2.2 {tk_focusNext procedure, toplevels} {
+    tk_focusNext .d
+} {.}
+test focusTcl-2.3 {tk_focusNext procedure, toplevels} {
+    tk_focusNext .t
+} {.t}
+setup1 .t
+raise .t.b
+test focusTcl-2.4 {tk_focusNext procedure, toplevels} {
+    tk_focusNext .t
+} {.t.a}
+test focusTcl-2.5 {tk_focusNext procedure, toplevels} {
+    tk_focusNext .t.b.z
+} {.t}
+
+deleteWindows
+test focusTcl-3.1 {tk_focusPrev procedure, no children} {
+    tk_focusPrev .
+} {.}
+setup1 .
+test focusTcl-3.2 {tk_focusPrev procedure, basic tree traversal} {
+    tk_focusPrev .
+} {.d}
+test focusTcl-3.3 {tk_focusPrev procedure, basic tree traversal} {
+    tk_focusPrev .d
+} {.c}
+test focusTcl-3.4 {tk_focusPrev procedure, basic tree traversal} {
+    tk_focusPrev .c
+} {.b.z}
+test focusTcl-3.5 {tk_focusPrev procedure, basic tree traversal} {
+    tk_focusPrev .b.z
+} {.b.y}
+test focusTcl-3.6 {tk_focusPrev procedure, basic tree traversal} {
+    tk_focusPrev .b.y
+} {.b.x}
+test focusTcl-3.7 {tk_focusPrev procedure, basic tree traversal} {
+    tk_focusPrev .b.x
+} {.b}
+test focusTcl-3.8 {tk_focusPrev procedure, basic tree traversal} {
+    tk_focusPrev .b
+} {.a}
+test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} {
+    tk_focusPrev .a
+} {.}
+
+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} {
+    tk_focusPrev .
+} {.d}
+test focusTcl-4.2 {tk_focusPrev procedure, toplevels} {
+    tk_focusPrev .b
+} {.a}
+test focusTcl-4.3 {tk_focusPrev procedure, toplevels} {
+    tk_focusPrev .t
+} {.t}
+setup1 .t
+update
+.t configure -takefocus 0
+raise .t.b
+test focusTcl-4.4 {tk_focusPrev procedure, toplevels} {
+    tk_focusPrev .t
+} {.t.b.z}
+test focusTcl-4.5 {tk_focusPrev procedure, toplevels} {
+    tk_focusPrev .t.a
+} {.t.b.z}
+
+deleteWindows
+test focusTcl-5.1 {tkFocusOK procedure, -takefocus 0} {
+    deleteWindows
+    setup1 .
+    .b.x configure -takefocus 0
+    tk_focusNext .b
+} {.b.y}
+test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} {
+    deleteWindows
+    setup1 .
+    pack forget .b
+    update
+    .b configure -takefocus ""
+    .b.y configure -takefocus ""
+    .b.z configure -takefocus ""
+    list [tk_focusNext .a] [tk_focusNext .b.x]
+} {.c .c}
+test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} {
+    proc t w {
+	if {$w == ".b.x"} {
+	    return 1
+	} elseif {$w == ".b.y"} {
+	    return ""
+	}
+	return 0
+    }
+    deleteWindows
+    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]
+} {.b.x .d}
+test focusTcl-5.4 {tkFocusOK procedure, -takefocus ""} {
+    deleteWindows
+    setup1 .
+    .b.x configure -takefocus ""
+    update
+    tk_focusNext .b
+} {.b.x}
+test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} {
+    deleteWindows
+    setup1 .
+    .b.x configure -takefocus ""
+    pack unpack .b.x
+    update
+    tk_focusNext .b
+} {.b.y}
+test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} {
+    deleteWindows
+    setup1 .
+    foreach w {.b.x .b.y .b.z} {
+	$w configure -takefocus ""
+    }
+    pack unpack .b
+    update
+    tk_focusNext .b
+} {.c}
+test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} {
+    deleteWindows
+    setup1 .
+    .b.y configure -takefocus 1
+    pack unpack .b.y
+    update
+    tk_focusNext .b.x
+} {.b.z}
+test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} {
+    proc always args {return 1}
+    deleteWindows
+    setup1 .
+    .b.y configure -takefocus always
+    pack unpack .b.y
+    update
+    tk_focusNext .b.x
+} {.b.y}
+test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} {
+    deleteWindows
+    setup1 .
+    foreach w {.b.x .b.y .b.z} {
+	$w configure -takefocus ""
+    }
+    update
+    .b.x configure -state disabled
+    tk_focusNext .b
+} {.b.y}
+test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} {
+    deleteWindows
+    setup1 .
+    foreach w {.a .b .c .d} {
+	$w configure -takefocus ""
+    }
+    update
+    bind .a <Key> {foo}
+    list [tk_focusNext .] [tk_focusNext .a]
+} {.a .b.x}
+test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} {
+    deleteWindows
+    setup1 .
+    foreach w {.a .b .c .d} {
+	$w configure -takefocus ""
+    }
+    update
+    bind Frame <Key> {foo}
+    list [tk_focusNext .] [tk_focusNext .a]
+} {.a .b}
+
+bind Frame <Key> {}
+. configure -takefocus 0 -highlightthickness 0
+option clear
+
+# cleanup
+cleanupTests
+return

tests/frame.test

@@ -0,0 +1,916 @@
+# 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.1
+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} {
+    frame .f -class NewFrame
+    list [.f configure -class] [catch {.f configure -class Different} msg] $msg
+} {{-class class Class Frame NewFrame} 1 {can't modify -class option after widget is created}}
+catch {destroy .f}
+test frame-1.2 {frame configuration options} {
+    frame .f -colormap new
+    list [.f configure -colormap] [catch {.f configure -colormap .} msg] $msg
+} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}}
+catch {destroy .f}
+test frame-1.3 {frame configuration options} {
+    frame .f -visual default
+    list [.f configure -visual] [catch {.f configure -visual best} msg] $msg
+} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}}
+catch {destroy .f}
+test frame-1.4 {frame configuration options} {
+    list [catch {frame .f -screen bogus} msg] $msg
+} {1 {unknown option "-screen"}}
+test frame-1.5 {frame configuration options} {
+    set result [list [catch {frame .f -container true} msg] $msg \
+	    [.f configure -container]]
+    destroy .f
+    set result
+} {0 .f {-container container Container 0 1}}
+test frame-1.6 {frame configuration options} {
+    list [catch {frame .f -container bogus} msg] $msg
+} {1 {expected boolean value but got "bogus"}}
+test frame-1.7 {frame configuration options} {
+    frame .f
+    set result [list [catch {.f configure -container 1} msg] $msg]
+    destroy .f
+    set result
+} {1 {can't modify -container option after widget is created}}
+test frame-1.8 {frame configuration options} {
+    # 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
+} {}
+
+frame .f
+set i 9
+foreach test {
+    {-background #ff0000 #ff0000 non-existent
+	    {unknown color name "non-existent"}}
+    {-bd 4 4 badValue {bad screen distance "badValue"}}
+    {-bg #00ff00 #00ff00 non-existent
+	    {unknown color name "non-existent"}}
+    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
+    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
+    {-height 100 100 not_a_number {bad screen distance "not_a_number"}}
+    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
+    {-highlightcolor #123456 #123456 non-existent
+	    {unknown color name "non-existent"}}
+    {-highlightthickness 6 6 badValue {bad screen distance "badValue"}}
+    {-padx 3 3 badValue {bad screen distance "badValue"}}
+    {-pady 4 4 badValue {bad screen distance "badValue"}}
+    {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
+    {-takefocus "any string" "any string" {} {}}
+    {-width 32 32 badValue {bad screen distance "badValue"}}
+} {
+    lassign $test opt goodValue goodResult badValue badResult
+    test frame-1.$i {frame configuration options} {
+	.f configure $opt $goodValue
+	lindex [.f configure $opt] 4
+    } $goodResult
+    incr i
+    if {$badValue ne ""} {
+	test frame-1.$i {frame configuration options} -body {
+	    .f configure $opt $badValue
+	} -returnCodes error -result $badResult
+    }
+    .f configure $opt [lindex [.f configure $opt] 3]
+    incr i
+}
+destroy .f
+
+test frame-2.1 {toplevel configuration options} {
+    catch {destroy .t}
+    toplevel .t -width 200 -height 100 -class NewClass
+    wm geometry .t +0+0
+    list [.t configure -class] [catch {.t configure -class Another} msg] $msg
+} {{-class class Class Toplevel NewClass} 1 {can't modify -class option after widget is created}}
+test frame-2.2 {toplevel configuration options} {
+    catch {destroy .t}
+    toplevel .t -width 200 -height 100 -colormap new
+    wm geometry .t +0+0
+    list [.t configure -colormap] [catch {.t configure -colormap .} msg] $msg
+} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}}
+test frame-2.3 {toplevel configuration options} {
+    catch {destroy .t}
+    toplevel .t -width 200 -height 100
+    wm geometry .t +0+0
+    list [catch {.t configure -container 1} msg] $msg [.t configure -container]
+} {1 {can't modify -container option after widget is created} {-container container Container 0 0}}
+test frame-2.4 {toplevel configuration options} {
+    catch {destroy .t}
+    list [catch {toplevel .t -width 200 -height 100 -colormap bogus} msg] $msg
+} {1 {bad window path name "bogus"}}
+set default "[winfo visual .] [winfo depth .]"
+if {$tcl_platform(platform) == "windows"} {
+test frame-2.5 {toplevel configuration options} {
+    catch {destroy .t}
+    toplevel .t -width 200 -height 100
+    wm geometry .t +0+0
+    list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use]
+} {1 {window "0x44022" doesn't exist} {-use use Use {} {}}}
+} else {
+test frame-2.5 {toplevel configuration options} {
+    catch {destroy .t}
+    toplevel .t -width 200 -height 100
+    wm geometry .t +0+0
+    list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use]
+} {1 {can't modify -use option after widget is created} {-use use Use {} {}}}
+}
+
+test frame-2.6 {toplevel configuration options} {
+    catch {destroy .t}
+    toplevel .t -width 200 -height 100 -visual default
+    wm geometry .t +0+0
+    list [.t configure -visual] [catch {.t configure -visual best} msg] $msg
+} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}}
+test frame-2.7 {toplevel configuration options} {
+    catch {destroy .t}
+    list [catch {toplevel .t -width 200 -height 100 -visual who_knows?} msg] $msg
+} {1 {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
+test frame-2.8 {toplevel configuration options} haveDISPLAY {
+    catch {destroy .t}
+    toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
+    wm geometry .t +0+0
+    set cfg [string compare [.t configure -screen] \
+        "-screen screen Screen {} $env(DISPLAY)"]
+    list $cfg [catch {.t configure -screen another} msg] $msg
+} {0 1 {can't modify -screen option after widget is created}}
+test frame-2.9 {toplevel configuration options} {
+    catch {destroy .t}
+    list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg
+} {1 {couldn't connect to display "bogus"}}
+test frame-2.10 {toplevel configuration options} {
+    catch {destroy .t}
+    catch {destroy .x}
+    toplevel .t -container 1 -width 300 -height 120
+    wm geometry .t +0+0
+    set result [list \
+            [catch {toplevel .x -container 1 -use [winfo id .t]} msg] $msg]
+    destroy .t .x
+    set result
+} {1 {A window cannot have both the -use and the -container option set.}}
+test frame-2.11 {toplevel configuration options} {
+    # Make sure all options can be set to the default value
+    toplevel .f
+    set opts {}
+    foreach opt [.f configure] {
+        if {[llength $opt] == 5} {
+            lappend opts [lindex $opt 0] [lindex $opt 4]
+        }
+    }
+    eval toplevel .g $opts
+    destroy .f .g
+} {}
+
+catch {destroy .t}
+toplevel .t -width 300 -height 150
+wm geometry .t +0+0
+update
+set i 12
+foreach test {
+    {-background #ff0000 #ff0000 non-existent
+	    {unknown color name "non-existent"}}
+    {-bd 4 4 badValue {bad screen distance "badValue"}}
+    {-bg #00ff00 #00ff00 non-existent
+	    {unknown color name "non-existent"}}
+    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
+    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
+    {-height 100 100 not_a_number {bad screen distance "not_a_number"}}
+    {-highlightcolor #123456 #123456 non-existent
+	    {unknown color name "non-existent"}}
+    {-highlightthickness 3 3 badValue {bad screen distance "badValue"}}
+    {-padx 3 3 badValue {bad screen distance "badValue"}}
+    {-pady 4 4 badValue {bad screen distance "badValue"}}
+    {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
+    {-width 32 32 badValue {bad screen distance "badValue"}}
+} {
+    lassign $test opt goodValue goodResult badValue badResult
+    test frame-2.$i {toplevel configuration options} {
+	.t configure $opt $goodValue
+	lindex [.t configure $opt] 4
+    } $goodResult
+    incr i
+    if {$badValue ne ""} {
+	test frame-2.$i {toplevel configuration options} -body {
+	    .t configure $opt $badValue
+	} -returnCodes error -result $badResult
+    }
+    .t configure $opt [lindex [.t configure $opt] 3]
+    incr i
+}
+
+test frame-3.1 {TkCreateFrame procedure} -body {
+    frame
+} -returnCodes error -result {wrong # args: should be "frame pathName ?options?"}
+test frame-3.2 {TkCreateFrame procedure} -setup {
+    catch {destroy .f}
+    frame .f
+} -body {
+    .f configure -class
+} -cleanup {
+    destroy .f
+} -result {-class class Class Frame Frame}
+test frame-3.3 {TkCreateFrame procedure} -setup {
+    catch {destroy .t}
+    toplevel .t
+    wm geometry .t +0+0
+} -body {
+    .t configure -class
+} -cleanup {
+    destroy .t
+} -result {-class class Class Toplevel Toplevel}
+test frame-3.4 {TkCreateFrame procedure} {
+    catch {destroy .t}
+    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]
+} {350 black 90}
+
+# Be sure that the -class, -colormap, and -visual options are processed
+# before configuring the widget.
+
+test frame-3.5 {TkCreateFrame procedure} {
+    catch {destroy .f}
+    option add *NewFrame.background #123456
+    frame .f -class NewFrame
+    option clear
+    lindex [.f configure -background] 4
+} {#123456}
+test frame-3.6 {TkCreateFrame procedure} {
+    catch {destroy .f}
+    option add *NewFrame.background #123456
+    frame .f -class NewFrame
+    option clear
+    lindex [.f configure -background] 4
+} {#123456}
+test frame-3.7 {TkCreateFrame procedure} {
+    catch {destroy .f}
+    option add *NewFrame.background #332211
+    option add *f.class NewFrame
+    frame .f
+    option clear
+    list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]
+} {NewFrame #332211}
+test frame-3.8 {TkCreateFrame procedure} {
+    catch {destroy .f}
+    option add *Silly.background #122334
+    option add *f.Class Silly
+    frame .f
+    option clear
+    list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]
+} {Silly #122334}
+test frame-3.9 {TkCreateFrame procedure, -use option} -setup {
+    catch {destroy .t}
+    catch {destroy .x}
+} -constraints unix -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 {
+    destroy .t
+} -result {0 0 140 300}
+test frame-3.10 {TkCreateFrame procedure, -use option} -setup {
+    catch {destroy .t}
+    catch {destroy .x}
+} -constraints unix -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} {defaultPseudocolor8 nonPortable} {
+    catch {destroy .t}
+    toplevel .t -width 300 -height 200 -bg #475601
+    wm geometry .t +0+0
+    update
+    colorsFree .t
+} {0}
+test frame-3.12 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} {
+    catch {destroy .t}
+    toplevel .t -width 300 -height 200 -bg #475601 -colormap new
+    wm geometry .t +0+0
+    update
+    colorsFree .t
+} {1}
+test frame-3.13 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} {
+    catch {destroy .t}
+    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
+} {1}
+test frame-3.14 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} {
+    catch {destroy .t}
+    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
+} {1}
+test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -setup {
+    catch {destroy .t}
+    catch {destroy .x}
+} -constraints {defaultPseudocolor8 unix nonPortable} -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} {defaultPseudocolor8 nonPortable} {
+    catch {destroy .t}
+    toplevel .t -width 300 -height 200 -bg #475601 -visual default
+    wm geometry .t +0+0
+    update
+    colorsFree .t
+} {0}
+test frame-3.17 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} {
+    catch {destroy .t}
+    toplevel .t -width 300 -height 200 -bg #475601 -visual default \
+	    -colormap new
+    wm geometry .t +0+0
+    update
+    colorsFree .t
+} {1}
+test frame-3.18 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} {
+    catch {destroy .t}
+    toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 
+    wm geometry .t +0+0
+    update
+    colorsFree .t 131 131 131
+} {1}
+test frame-3.19 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} {
+    catch {destroy .t}
+    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]
+} {1 {grayscale 8}}
+test frame-3.20 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} {
+    catch {destroy .t}
+    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]
+} {1 {grayscale 8}}
+test frame-3.21 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} {
+    catch {destroy .t}
+    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
+} {1}
+if {[testConstraint defaultPseudocolor8]} {
+    destroy .t1
+}
+test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup {
+    catch {destroy .t}
+} -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 {
+    destroy .t
+} -result {200 200 1 1}
+test frame-3.23 {TkCreateFrame procedure} -setup {
+    catch {destroy .f}
+} -body {
+    frame .f -gorp glob
+} -returnCodes error -result {unknown option "-gorp"}
+test frame-3.24 {TkCreateFrame procedure} -setup {
+    catch {destroy .t}
+} -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} {
+    catch {destroy .f}
+    catch {frame .f -gorp glob}
+    winfo exists .f
+} 0
+test frame-4.2 {TkCreateFrame procedure} {
+    catch {destroy .f}
+    list [frame .f -width 200 -height 100] [winfo exists .f]
+} {.f 1}
+
+catch {destroy .f}
+frame .f -highlightcolor black
+test frame-5.1 {FrameWidgetCommand procedure} {
+    list [catch .f msg] $msg
+} {1 {wrong # args: should be ".f option ?arg arg ...?"}}
+test frame-5.2 {FrameWidgetCommand procedure, cget option} {
+    list [catch {.f cget} msg] $msg
+} {1 {wrong # args: should be ".f cget option"}}
+test frame-5.3 {FrameWidgetCommand procedure, cget option} {
+    list [catch {.f cget a b} msg] $msg
+} {1 {wrong # args: should be ".f cget option"}}
+test frame-5.4 {FrameWidgetCommand procedure, cget option} {
+    list [catch {.f cget -gorp} msg] $msg
+} {1 {unknown option "-gorp"}}
+test frame-5.5 {FrameWidgetCommand procedure, cget option} {
+    .f cget -highlightcolor
+} {black}
+test frame-5.6 {FrameWidgetCommand procedure, cget option} {
+    list [catch {.f cget -screen} msg] $msg
+} {1 {unknown option "-screen"}}
+test frame-5.7 {FrameWidgetCommand procedure, cget option} {
+    catch {destroy .t}
+    toplevel .t
+    catch {.t cget -screen}
+} {0}
+catch {destroy .t}
+test frame-5.8 {FrameWidgetCommand procedure, configure option} {
+    llength [.f configure]
+} {18}
+test frame-5.9 {FrameWidgetCommand procedure, configure option} {
+    list [catch {.f configure -gorp} msg] $msg
+} {1 {unknown option "-gorp"}}
+test frame-5.10 {FrameWidgetCommand procedure, configure option} {
+    list [catch {.f configure -gorp bogus} msg] $msg
+} {1 {unknown option "-gorp"}}
+test frame-5.11 {FrameWidgetCommand procedure, configure option} {
+    list [catch {.f configure -width 200 -height} msg] $msg
+} {1 {value for "-height" missing}}
+test frame-5.12 {FrameWidgetCommand procedure} {
+    list [catch {.f swizzle} msg] $msg
+} {1 {bad option "swizzle": must be cget or configure}}
+test frame-5.13 {FrameWidgetCommand procedure, configure option} {
+    llength [. configure]
+} {21}
+
+test frame-6.1 {ConfigureFrame procedure} {
+    catch {destroy .f}
+    frame .f -width 150
+    list [winfo reqwidth .f] [winfo reqheight .f]
+} {150 1}
+test frame-6.2 {ConfigureFrame procedure} {
+    catch {destroy .f}
+    frame .f -height 97
+    list [winfo reqwidth .f] [winfo reqheight .f]
+} {1 97}
+test frame-6.3 {ConfigureFrame procedure} {
+    catch {destroy .f}
+    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]
+} {1 1 100 180 100 180}
+
+test frame-7.1 {FrameEventProc procedure} {
+    frame .frame2
+    set result [info commands .frame2]
+    destroy .frame2
+    lappend result [info commands .frame2]
+} {.frame2 {}}
+test frame-7.2 {FrameEventProc procedure} {
+    deleteWindows
+    frame .f1 -bg #543210
+    rename .f1 .f2
+    set x {}
+    lappend x [winfo children .]
+    lappend x [.f2 cget -bg]
+    destroy .f1
+    lappend x [info command .f*] [winfo children .]
+} {.f1 #543210 {} {}}
+
+test frame-8.1 {FrameCmdDeletedProc procedure} {
+    deleteWindows
+    frame .f1
+    rename .f1 {}
+    list [info command .f*] [winfo children .]
+} {{} {}}
+test frame-8.2 {FrameCmdDeletedProc procedure} {
+    deleteWindows
+    toplevel .f1 -menu .m
+    wm geometry .f1 +0+0
+    update
+    rename .f1 {}
+    update
+    list [info command .f*] [winfo children .]
+} {{} {}}
+#
+# This one fails with the dash-patch!!!! Still don't know why  :-(
+#
+#test frame-8.3 {FrameCmdDeletedProc procedure} {
+#    eval destroy [winfo children .]
+#    toplevel .f1 -menu .m
+#    wm geometry .f1 +0+0
+#    menu .m
+#    update
+#    rename .f1 {}
+#    update
+#    set result [list [info command .f*] [winfo children .]]
+#    eval destroy [winfo children .]
+#    set result
+#} {{} .m}
+
+test frame-9.1 {MapFrame procedure} {
+    catch {destroy .t}
+    toplevel .t -width 100 -height 400
+    wm geometry .t +0+0
+    set result [winfo ismapped .t]
+    update idletasks
+    lappend result [winfo ismapped .t]
+} {0 1}
+test frame-9.2 {MapFrame procedure} {
+    catch {destroy .t}
+    toplevel .t -width 100 -height 400
+    wm geometry .t +0+0
+    destroy .t
+    update
+    winfo exists .t
+} {0}
+test frame-9.3 {MapFrame procedure, window deleted while mapping} {
+    toplevel .t2 -width 200 -height 200
+    wm geometry .t2 +0+0
+    tkwait visibility .t2
+    catch {destroy .t}
+    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
+} {0}
+
+set l [interp hidden]
+deleteWindows
+
+test frame-10.1 {frame widget vs hidden commands} {
+    catch {destroy .t}
+    frame .t
+    interp hide {} .t
+    destroy .t
+    list [winfo children .] [interp hidden]
+} [list {} $l]
+
+test frame-11.1 {TkInstallFrameMenu} {
+    catch {destroy .t}
+    menu .m1
+    .m1 add cascade -menu .m1.system
+    menu .m1.system -tearoff 0
+    .m1.system add command -label foo
+    list [toplevel .t -menu .m1] [destroy .m1] [destroy .t]
+} {.t {} {}}
+test frame-11.2 {TkInstallFrameMenu - frame renamed} {
+    catch {destroy .t}
+    catch {rename foo {}}
+    menu .m1
+    .m1 add cascade -menu .m1.system
+    menu .m1.system -tearoff 0
+    .m1.system add command -label foo
+    toplevel .t
+    list [rename .t foo] [destroy .t] [destroy foo] [destroy .m1]
+} {{} {} {} {}}
+
+test frame-12.1 {FrameWorldChanged procedure} {
+    # Test -bd -padx and -pady
+    destroy .f
+    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
+    set result [list [winfo x .f.f] [winfo y .f.f] \
+            [winfo width .f.f] [winfo height .f.f]]
+    destroy .f
+    set result
+} {5 6 30 28}
+test frame-12.2 {FrameWorldChanged procedure} {
+    # Test all -labelanchor positions
+    destroy .f
+    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}]
+    }
+    destroy .f
+    set result
+} {1 1 1 1 1 1 1 1 1 1 1 1}
+test frame-12.3 {FrameWorldChanged procedure} {
+    # Check reaction on font change
+    destroy .f
+    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]
+    destroy .f
+    font delete myfont
+    expr {($h2 - $h1) - ($y2 - $y1)}
+} {0}
+
+test frame-13.1 {labelframe configuration options} {
+    labelframe .f -class NewFrame
+    list [.f configure -class] [catch {.f configure -class Different} msg] $msg
+} {{-class class Class Labelframe NewFrame} 1 {can't modify -class option after widget is created}}
+catch {destroy .f}
+test frame-13.2 {labelframe configuration options} {
+    list [catch {labelframe .f -colormap new} msg] $msg
+} {0 .f}
+catch {destroy .f}
+test frame-13.3 {labelframe configuration options} {
+    list [catch {labelframe .f -visual default} msg] $msg
+} {0 .f}
+catch {destroy .f}
+test frame-13.4 {labelframe configuration options} {
+    list [catch {labelframe .f -screen bogus} msg] $msg
+} {1 {unknown option "-screen"}}
+test frame-13.5 {labelframe configuration options} {
+    set result [list [catch {labelframe .f -container true} msg] $msg \
+	    [.f configure -container]]
+    destroy .f
+    set result
+} {0 .f {-container container Container 0 1}}
+test frame-13.6 {labelframe configuration options} {
+    list [catch {labelframe .f -container bogus} msg] $msg
+} {1 {expected boolean value but got "bogus"}}
+test frame-13.7 {labelframe configuration options} {
+    labelframe .f
+    set result [list [catch {.f configure -container 1} msg] $msg]
+    destroy .f
+    set result
+} {1 {can't modify -container option after widget is created}}
+labelframe .f
+set i 8
+foreach test {
+    {-background #ff0000 #ff0000 non-existent
+	    {unknown color name "non-existent"}}
+    {-bd 4 4 badValue {bad screen distance "badValue"}}
+    {-bg #00ff00 #00ff00 non-existent
+	    {unknown color name "non-existent"}}
+    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
+    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
+    {-fg #0000ff #0000ff non-existent
+	    {unknown color name "non-existent"}}
+    {-font {courier 8} {courier 8} {} {}}
+    {-foreground #ff0000 #ff0000 non-existent
+	    {unknown color name "non-existent"}}
+    {-height 100 100 not_a_number {bad screen distance "not_a_number"}}
+    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
+    {-highlightcolor #123456 #123456 non-existent
+	    {unknown color name "non-existent"}}
+    {-highlightthickness 6 6 badValue {bad screen distance "badValue"}}
+    {-labelanchor se se badValue {bad labelanchor "badValue": must be e, en, es, n, ne, nw, s, se, sw, w, wn, or ws}}
+    {-padx 3 3 badValue {bad screen distance "badValue"}}
+    {-pady 4 4 badValue {bad screen distance "badValue"}}
+    {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
+    {-takefocus "any string" "any string" {} {}}
+    {-text "any string" "any string" {} {}}
+    {-width 32 32 badValue {bad screen distance "badValue"}}
+} {
+    lassign $test name goodValue goodResult badValue badResult
+    test frame-13.$i {labelframe configuration options} {
+	.f configure $name $goodValue
+	lindex [.f configure $name] 4
+    } $goodResult
+    incr i
+    if {$badValue ne ""} {
+	test frame-13.$i {labelframe configuration options} -body {
+	    .f configure $name $badValue
+	} -returnCodes error -result $badResult
+    }
+    .f configure $name [lindex [.f configure $name] 3]
+    incr i
+}
+destroy .f
+
+test frame-14.1 {labelframe labelwidget option} {
+    # Test that label is moved in stacking order
+    destroy .f .l
+    label .l -text Mupp -font {helvetica 8}
+    labelframe .f -labelwidget .l
+    pack .f
+    frame .f.f -width 50 -height 50
+    pack .f.f
+    update
+    set res [list [winfo children .] [winfo width .f] \
+            [expr {[winfo height .f] - [winfo height .l]}]]
+    destroy .f .l
+    set res
+} {{.f .l} 54 52}
+test frame-14.2 {labelframe labelwidget option} {
+    # Test the labelframe's reaction if the label is destroyed
+    destroy .f .l
+    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]}]
+    destroy .f
+    set res
+} {.l 12 {} 4}
+test frame-14.3 {labelframe labelwidget option} {
+    # Test the labelframe's reaction if the label is stolen
+    destroy .f .l
+    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]}]
+    destroy .f .l
+    set res
+} {.l 12 {} 4}
+test frame-14.4 {labelframe labelwidget option} {
+    # Test the label's reaction if the labelframe is destroyed
+    destroy .f .l
+    label .l -text Mupp
+    labelframe .f -labelwidget .l
+    pack .f
+    update
+    set res [list [winfo manager .l]]
+    destroy .f
+    lappend res [winfo manager .l]
+    destroy .l
+    set res
+} {labelframe {}}
+test frame-14.5 {labelframe labelwidget option} {
+    # Test that the labelframe reacts on changes in label
+    destroy .f .l
+    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}]
+    destroy .f .l
+    set res
+} {12 12 1 12 1}
+test frame-14.6 {labelframe labelwidget option} {
+    # 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.
+    destroy .f
+    labelframe .f
+    pack .f
+    label .f.l -text Mupp
+    .f configure -labelwidget .f.l
+    update
+    destroy .f
+} {}
+
+catch {destroy .f}
+rename eatColors {}
+rename colorsFree {}
+
+# cleanup
+cleanupTests
+return
+

tests/geometry.test

@@ -0,0 +1,249 @@
+# 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.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+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} {
+    place .b1 -x 120 -y 80
+    update
+    list [winfo x .b1] [winfo y .b1]
+} {120 80}
+test geometry-1.2 {Tk_ManageGeometry procedure} {
+    foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+	place forget $w
+    }
+    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]
+} {0 0}
+
+test geometry-2.1 {Tk_GeometryRequest procedure} {
+    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]
+} {1 1 150 300 1x1+0+0 150x300+10+20 100x80+10+20}
+catch {destroy .f2}
+
+test geometry-3.1 {Tk_SetInternalBorder procedure} {
+    foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+	place forget $w
+    }
+    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]
+} {72 37 75 40}
+.f configure -bd 2
+
+test geometry-4.1 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} {
+    foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+	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 .b1 -in .f.f.f -x 50 -y 5
+    update
+    list [winfo x .b1] [winfo y .b1]
+} {91 46}
+test geometry-4.2 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} {
+    foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+	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 .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]
+} {101 41 61 61 101 61}
+test geometry-4.3 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} {
+    foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+	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 .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]
+} {0 0 46 86 86 86}
+test geometry-4.4 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} {
+    foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+	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 .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]
+} {93 49 0 0 93 69}
+test geometry-4.5 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} {
+    foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+	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 .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]
+} {93 49 53 69 0 0}
+test geometry-4.6 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} {
+    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]
+} {54 9 56 71}
+test geometry-4.7 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} {
+    foreach w {.f .f.f .f.f.f .b1 .b2 .b3 .f.f.b4} {
+	place forget $w
+    }
+    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
+    bind .b1 <Configure> {}
+    set x
+} {init configure |}
+test geometry-4.8 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} {
+    foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+	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 .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]
+} {91 46 0 51 66 0 91 66 0}
+test geometry-4.9 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} {
+    foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
+	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 .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]
+} {1 0 1}
+test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} {
+    toplevel .t
+    wm geometry .t +0+0
+    tkwait visibility .t
+    update
+    frame .t.f 
+    pack .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
+} {1}
+
+catch {destroy .t}
+
+# cleanup
+cleanupTests
+return

tests/get.test

@@ -0,0 +1,78 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+button .b
+test get-1.1 {Tk_GetAnchorFromObj} {
+    .b configure -anchor n
+    .b cget -anchor
+} {n}
+test get-1.2 {Tk_GetAnchorFromObj} {
+    .b configure -anchor ne
+    .b cget -anchor
+} {ne}
+test get-1.3 {Tk_GetAnchorFromObj} {
+    .b configure -anchor e
+    .b cget -anchor
+} {e}
+test get-1.4 {Tk_GetAnchorFromObj} {
+    .b configure -anchor se
+    .b cget -anchor
+} {se}
+test get-1.5 {Tk_GetAnchorFromObj} {
+    .b configure -anchor s
+    .b cget -anchor
+} {s}
+test get-1.6 {Tk_GetAnchorFromObj} {
+    .b configure -anchor sw
+    .b cget -anchor
+} {sw}
+test get-1.7 {Tk_GetAnchorFromObj} {
+    .b configure -anchor w
+    .b cget -anchor
+} {w}
+test get-1.8 {Tk_GetAnchorFromObj} {
+    .b configure -anchor nw
+    .b cget -anchor
+} {nw}
+test get-1.9 {Tk_GetAnchorFromObj} {
+    .b configure -anchor n
+    .b cget -anchor
+} {n}
+test get-1.10 {Tk_GetAnchorFromObj} {
+    .b configure -anchor center
+    .b cget -anchor
+} {center}
+test get-1.11 {Tk_GetAnchorFromObj - error} {
+    list [catch {.b configure -anchor unknown} msg] $msg
+} {1 {bad anchor "unknown": must be n, ne, e, se, s, sw, w, nw, or center}}
+
+catch {destroy .b}
+button .b
+test get-2.1 {Tk_GetJustifyFromObj} {
+    .b configure -justify left
+    .b cget -justify
+} {left}
+test get-2.2 {Tk_GetJustifyFromObj} {
+    .b configure -justify right
+    .b cget -justify
+} {right}
+test get-2.3 {Tk_GetJustifyFromObj} {
+    .b configure -justify center
+    .b cget -justify
+} {center}
+test get-2.4 {Tk_GetJustifyFromObj - error} {
+    list [catch {.b configure -justify stupid} msg] $msg
+} {1 {bad justification "stupid": must be left, right, or center}}
+
+# cleanup
+cleanupTests
+return

tests/grab.test

@@ -0,0 +1,180 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# 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} {
+    list [catch {grab} msg] $msg
+} [list 1 "wrong # args: should be \"grab ?-global? window\" or \"grab option ?arg arg ...?\""]
+test grab-1.2 {Tk_GrabObjCmd} {
+    rename grab grabTest1.2
+    set res [list [catch {grabTest1.2} msg] $msg]
+    rename grabTest1.2 grab
+    set res
+} [list 1 "wrong # args: should be \"grabTest1.2 ?-global? window\" or \"grabTest1.2 option ?arg arg ...?\""]
+
+test grab-1.3 {Tk_GrabObjCmd, "grab ?-global? window"} {
+    list [catch {grab .foo bar baz} msg] $msg
+} [list 1 "wrong # args: should be \"grab ?-global? window\""]
+test grab-1.4 {Tk_GrabObjCmd, "grab ?-global? window"} {
+    catch {destroy .foo}
+    list [catch {grab .foo} msg] $msg
+} [list 1 "bad window path name \".foo\""]
+test grab-1.5 {Tk_GrabObjCmd, "grab ?-global? window"} {
+    list [catch {grab -foo bar} msg] $msg
+} [list 1 "bad option \"-foo\": must be -global"]
+test grab-1.6 {Tk_GrabObjCmd, "grab ?-global? window"} {
+    catch {destroy .foo}
+    list [catch {grab -global .foo} msg] $msg
+} [list 1 "bad window path name \".foo\""]
+
+test grab-1.7 {Tk_GrabObjCmd} {
+    list [catch {grab foo} msg] $msg
+} [list 1 "bad option \"foo\": must be current, release, set, or status"]
+
+test grab-1.8 {Tk_GrabObjCmd, "grab current ?window?"} {
+    list [catch {grab current foo bar} msg] $msg
+} [list 1 "wrong # args: should be \"grab current ?window?\""]
+test grab-1.9 {Tk_GrabObjCmd, "grab current ?window?"} {
+    catch {destroy .foo}
+    list [catch {grab current .foo} msg] $msg
+} [list 1 "bad window path name \".foo\""]
+
+test grab-1.10 {Tk_GrabObjCmd, "grab release window"} {
+    list [catch {grab release} msg] $msg
+} [list 1 "wrong # args: should be \"grab release window\""]
+test grab-1.11 {Tk_GrabObjCmd, "grab release window"} {
+    catch {destroy .foo}
+    list [catch {grab release .foo} msg] $msg
+} [list 0 ""]
+test grab-1.12 {Tk_GrabObjCmd, "grab release window"} {
+    list [catch {grab release foo} msg] $msg
+} [list 0 ""]
+
+test grab-1.13 {Tk_GrabObjCmd, "grab set ?-global? window"} {
+    list [catch {grab set} msg] $msg
+} [list 1 "wrong # args: should be \"grab set ?-global? window\""]
+test grab-1.14 {Tk_GrabObjCmd, "grab set ?-global? window"} {
+    list [catch {grab set foo bar baz} msg] $msg
+} [list 1 "wrong # args: should be \"grab set ?-global? window\""]
+test grab-1.15 {Tk_GrabObjCmd, "grab set ?-global? window"} {
+    catch {destroy .foo}
+    list [catch {grab set .foo} msg] $msg
+} [list 1 "bad window path name \".foo\""]
+test grab-1.16 {Tk_GrabObjCmd, "grab set ?-global? window"} {
+    list [catch {grab set -foo bar} msg] $msg
+} [list 1 "bad option \"-foo\": must be -global"]
+test grab-1.17 {Tk_GrabObjCmd, "grab set ?-global? window"} {
+    catch {destroy .foo}
+    list [catch {grab set -global .foo} msg] $msg
+} [list 1 "bad window path name \".foo\""]
+
+test grab-1.18 {Tk_GrabObjCmd, "grab status window"} {
+    list [catch {grab status} msg] $msg
+} [list 1 "wrong # args: should be \"grab status window\""]
+test grab-1.19 {Tk_GrabObjCmd, "grab status window"} {
+    list [catch {grab status foo bar} msg] $msg
+} [list 1 "wrong # args: should be \"grab status window\""]
+test grab-1.20 {Tk_GrabObjCmd, "grab status window"} {
+    catch {destroy .foo}
+    list [catch {grab status .foo} msg] $msg
+} [list 1 "bad window path name \".foo\""]
+
+test grab-2.1 {Tk_GrabObjCmd, grab status gives correct status} {
+    set curr [grab current .]
+    if { [string length $curr] > 0 } {
+	grab release $curr
+    }
+    set result [grab status .]
+    grab release .
+    set result
+} "none"
+test grab-2.2 {Tk_GrabObjCmd, grab status gives correct status} {
+    set curr [grab current .]
+    if { [string length $curr] > 0 } {
+	grab release $curr
+    }
+    grab .
+    set result [grab status .]
+    grab release .
+    set result
+} "local"
+test grab-2.3 {Tk_GrabObjCmd, grab status gives correct status} {
+    set curr [grab current .]
+    if { [string length $curr] > 0 } {
+	grab release $curr
+    }
+    grab -global .
+    set result [grab status .]
+    grab release .
+    set result
+} "global"
+
+test grab-3.1 {Tk_GrabObjCmd, grab current gives correct information} {
+    set curr [grab current .]
+    if { [string length $curr] > 0 } {
+	grab release $curr
+    }
+    set curr
+} ""
+test grab-3.2 {Tk_GrabObjCmd, grab current gives correct information} {
+    set curr [grab current .]
+    if { [string length $curr] > 0 } {
+	grab release $curr
+    }
+    grab .
+    set curr [grab current]
+    grab release .
+    set curr
+} "."
+
+test grab-4.1 {Tk_GrabObjCmd, grab release releases grab} {
+    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 .]
+} [list "local" "none" "global" "none"]
+
+test grab-5.1 {Tk_GrabObjCmd, grab set} {
+    set curr [grab current .]
+    if { [string length $curr] > 0 } {
+	grab release $curr
+    }
+    grab set .
+    set result [list [grab current .] [grab status .]]
+    grab release .
+    set result
+} [list "." "local"]
+test grab-5.2 {Tk_GrabObjCmd, grab set} {
+    set curr [grab current .]
+    if { [string length $curr] > 0 } {
+	grab release $curr
+    }
+    grab set -global .
+    set result [list [grab current .] [grab status .]]
+    grab release .
+    set result
+} [list "." "global"]
+
+cleanupTests
+return

tests/id.test

@@ -0,0 +1,91 @@
+# This file is a Tcl script to test out the procedures in the file
+# tkId.c, which recycle X resource identifiers.  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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test id-1.1 {WindowIdCleanup, delaying window release} {unix testwrapper} {
+    bind all <Destroy> {lappend x %W}
+    catch {unset map}
+    frame .f
+    set j 0
+    foreach i {a b c d e f g h i j k l m n o p q} {
+	toplevel .f.$i -height 50 -width 100
+	wm geometry .f.$i +$j+$j
+	incr j 10
+	update
+	set map([winfo id .f.$i]) .f.$i
+	set map([testwrapper .f.$i]) wrapper.f.$i
+    }
+    set x {}
+    destroy .f
+
+    # Destroy events should have occurred for all windows.
+    set result [list [lsort $x]]
+
+    set x {}
+    update idletasks
+    set reused {}
+    foreach i {a b c d e} {
+	set w .${i}2
+	frame $w -height 20 -width 100 -bd 2 -relief raised
+	pack $w
+	if [info exists map([winfo id $w])] {
+	    lappend reused $map([winfo id $w])
+	}
+	set map([winfo id $w]) $w
+    }
+
+    # No window ids should have been reused: stale Destroy events still
+    # pending in queue.
+    lappend result [lsort $reused]
+
+    # Wait a few seconds, then try again;  ids should still not have
+    # been re-used.
+
+    set y 0
+    after 2000 {set y 1}
+    tkwait variable y
+    foreach i {a b c} {
+	set w .${i}3
+	frame $w -height 20 -width 100 -bd 2 -relief raised
+	pack $w
+	if [info exists map([winfo id $w])] {
+	    lappend reused $map([winfo id $w])
+	}
+	set map([winfo id $w])] $w
+    }
+
+    # Ids should not yet have been reused.
+    lappend result [lsort $reused]
+
+
+    # Wait a few more seconds, to give ids enough time to be recycled.
+    set y 0
+    after 6000 {set y 1}
+    tkwait variable y
+    foreach i {a b c d e f} {
+	set w .${i}4
+	frame $w -height 20 -width 100 -bd 2 -relief raised
+	pack $w
+	if [info exists map([winfo id $w])] {
+	    lappend reused $map([winfo id $w])
+	}
+	set map([winfo id $w])] $w
+    }
+
+    # Ids should be reused now, due to time delay.  Destroy events should
+    # have been discarded.
+    lappend result [lsort $reused] [lsort $x]
+} {{.f .f.a .f.b .f.c .f.d .f.e .f.f .f.g .f.h .f.i .f.j .f.k .f.l .f.m .f.n .f.o .f.p .f.q} {} {} {.f.o .f.p .f.q wrapper.f.p wrapper.f.q} {}}
+bind all <Destroy> {}
+
+# cleanup
+cleanupTests
+return

tests/image.test

@@ -0,0 +1,439 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force ::tk::test::loadTkCommand
+
+eval image delete [image names]
+canvas .c -highlightthickness 2
+pack .c
+update
+test image-1.1 {Tk_ImageCmd procedure, "create" option} {
+    list [catch image msg] $msg
+} {1 {wrong # args: should be "image option ?args?"}}
+test image-1.2 {Tk_ImageCmd procedure, "create" option} {
+    list [catch {image gorp} msg] $msg
+} {1 {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width}}
+test image-1.3 {Tk_ImageCmd procedure, "create" option} {
+    list [catch {image create} msg] $msg
+} {1 {wrong # args: should be "image create type ?name? ?options?"}}
+test image-1.4 {Tk_ImageCmd procedure, "create" option} {
+    list [catch {image c bad_type} msg] $msg
+} {1 {image type "bad_type" doesn't exist}}
+test image-1.5 {Tk_ImageCmd procedure, "create" option} testImageType {
+    list [image create test myimage] [image names]
+} {myimage myimage}
+test image-1.6 {Tk_ImageCmd procedure, "create" option} testImageType {
+    scan [image create test] image%d first
+    image create test myimage
+    scan [image create test -variable x] image%d second
+    expr $second-$first
+} {1}
+test image-1.7 {Tk_ImageCmd procedure, "create" option} testImageType {
+    image delete myimage
+    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
+    set x
+} {{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} testImageType {
+    .c delete all
+    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
+    set x
+} {{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} testImageType {
+    .c delete all
+    eval image delete [image names]
+    list [catch {image create test -badName foo} msg] $msg [image names]
+} {1 {bad option name "-badName"} {}}
+test image-1.10 {Tk_ImageCmd procedure, "create" option with same name as main window} {
+    set code [loadTkCommand]
+    append code {
+	update
+	puts [list [catch {image create photo .} msg] $msg]
+	exit
+    }
+    set script [makeFile $code script]
+    set x [list [catch {exec [interpreter] <$script} msg] $msg]
+    removeFile script
+    set x
+} {0 {1 {images may not be named the same as the main window}}}
+test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} {
+    set code [loadTkCommand]
+    append code {
+	update
+	puts [list [catch {rename . foo;image create photo foo} msg] $msg]
+	exit
+    }
+    set script [makeFile $code script]
+    set x [list [catch {exec [interpreter] <$script} msg] $msg]
+    removeFile script
+    set x
+} {0 {1 {images may not be named the same as the main window}}}
+test image-1.12 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup {
+    set i [image create bitmap]
+    regexp {^image(\d+)$} $i -> serial
+    incr serial
+    proc image$serial {} {return works}
+    set j [image create bitmap]
+} -body {
+    image$serial
+} -cleanup {
+    rename image$serial {}
+    image delete $i $j
+} -result works
+
+test image-2.1 {Tk_ImageCmd procedure, "delete" option} {
+    list [catch {image delete} msg] $msg
+} {0 {}}
+test image-2.2 {Tk_ImageCmd procedure, "delete" option} testImageType {
+    .c delete all
+    eval image delete [image names]
+    image create test myimage
+    image create test img2
+    set result {}
+    lappend result [lsort [image names]]
+    image d myimage img2
+    lappend result [image names]
+} {{img2 myimage} {}}
+test image-2.3 {Tk_ImageCmd procedure, "delete" option} testImageType {
+    .c delete all
+    eval image delete [image names]
+    image create test myimage
+    image create test img2
+    list [catch {image delete myimage gorp img2} msg] $msg [image names]
+} {1 {image "gorp" doesn't exist} img2}
+
+test image-3.1 {Tk_ImageCmd procedure, "height" option} {
+    list [catch {image height} msg] $msg
+} {1 {wrong # args: should be "image height name"}}
+test image-3.2 {Tk_ImageCmd procedure, "height" option} {
+    list [catch {image height a b} msg] $msg
+} {1 {wrong # args: should be "image height name"}}
+test image-3.3 {Tk_ImageCmd procedure, "height" option} {
+    list [catch {image height foo} msg] $msg
+} {1 {image "foo" doesn't exist}}
+test image-3.4 {Tk_ImageCmd procedure, "height" option} testImageType {
+    image create test myimage
+    set x [image h myimage]
+    myimage changed 0 0 0 0 60 50
+    list $x [image height myimage]
+} {15 50}
+
+test image-4.1 {Tk_ImageCmd procedure, "names" option} {
+    list [catch {image names x} msg] $msg
+} {1 {wrong # args: should be "image names"}}
+test image-4.2 {Tk_ImageCmd procedure, "names" option} testImageType {
+    .c delete all
+    eval image delete [image names]
+    image create test myimage
+    image create test img2
+    image create test 24613
+    lsort [image names]
+} {24613 img2 myimage}
+test image-4.3 {Tk_ImageCmd procedure, "names" option} {
+    .c delete all
+    eval image delete [image names]
+    lsort [image names]
+} {}
+
+test image-5.1 {Tk_ImageCmd procedure, "type" option} {
+    list [catch {image type} msg] $msg
+} {1 {wrong # args: should be "image type name"}}
+test image-5.2 {Tk_ImageCmd procedure, "type" option} {
+    list [catch {image type a b} msg] $msg
+} {1 {wrong # args: should be "image type name"}}
+test image-5.3 {Tk_ImageCmd procedure, "type" option} {
+    list [catch {image type foo} msg] $msg
+} {1 {image "foo" doesn't exist}}
+test image-5.4 {Tk_ImageCmd procedure, "type" option} testImageType {
+    image create test myimage
+    image type myimage
+} {test}
+test image-5.5 {Tk_ImageCmd procedure, "type" option} testImageType {
+    image create test myimage
+    .c create image 50 50 -image myimage
+    image delete myimage
+    list [catch {image type myimage} msg] $msg
+} {1 {image "myimage" doesn't exist}}
+test image-5.6 {Tk_ImageCmd procedure, "type" option} testOldImageType {
+    image create oldtest myimage
+    image type myimage
+} {oldtest}
+test image-5.7 {Tk_ImageCmd procedure, "type" option} testOldImageType {
+    image create oldtest myimage
+    .c create image 50 50 -image myimage
+    image delete myimage
+    list [catch {image type myimage} msg] $msg
+} {1 {image "myimage" doesn't exist}}
+
+test image-6.1 {Tk_ImageCmd procedure, "types" option} {
+    list [catch {image types x} msg] $msg
+} {1 {wrong # args: should be "image types"}}
+test image-6.2 {Tk_ImageCmd procedure, "types" option} testImageType {
+    lsort [image types]
+} {bitmap oldtest photo test}
+
+test image-7.1 {Tk_ImageCmd procedure, "width" option} {
+    list [catch {image width} msg] $msg
+} {1 {wrong # args: should be "image width name"}}
+test image-7.2 {Tk_ImageCmd procedure, "width" option} {
+    list [catch {image width a b} msg] $msg
+} {1 {wrong # args: should be "image width name"}}
+test image-7.3 {Tk_ImageCmd procedure, "width" option} {
+    list [catch {image width foo} msg] $msg
+} {1 {image "foo" doesn't exist}}
+test image-7.4 {Tk_ImageCmd procedure, "width" option} testImageType {
+    image create test myimage
+    set x [image w myimage]
+    myimage changed 0 0 0 0 60 50
+    list $x [image width myimage]
+} {30 60}
+
+test image-8.1 {Tk_ImageCmd procedure, "inuse" option} testImageType {
+    catch {image delete myimage2}
+    image create test myimage2
+    set res {}
+    lappend res [image inuse myimage2]
+    catch {destroy .b}
+    button .b -image myimage2
+    lappend res [image inuse myimage2]
+    catch {destroy .b}
+    image delete myimage2
+    set res
+} [list 0 1]
+    
+
+test image-9.1 {Tk_ImageChanged procedure} testImageType {
+    .c delete all
+    eval image delete [image names]
+    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
+    set x
+} {{foo display 5 6 7 8 30 30}}
+test image-9.2 {Tk_ImageChanged procedure} testImageType {
+    .c delete all
+    eval image delete [image names]
+    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
+    set x
+} {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}}
+
+test image-10.1 {Tk_GetImage procedure} {
+    list [catch {.c create image 100 10 -image bad_name} msg] $msg
+} {1 {image "bad_name" doesn't exist}}
+test image-10.2 {Tk_GetImage procedure} testImageType {
+    image create test mytest
+    catch {destroy .l}
+    label .l -image mytest
+    image delete  mytest
+    set result [list [catch {label .l2 -image mytest} msg] $msg]
+    destroy .l
+    set result
+} {1 {image "mytest" doesn't exist}}
+
+test image-11.1 {Tk_FreeImage procedure} testImageType {
+    .c delete all
+    eval image delete [image names]
+    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 [image names] $x
+} {foo {{foo free} {foo display 0 0 30 15 103 121}}}
+test image-11.2 {Tk_FreeImage procedure} testImageType {
+    .c delete all
+    eval image delete [image names]
+    image create test foo -variable x
+    .c create image 50 50 -image foo -tags i1
+    set names [image names]
+    image delete foo
+    update
+    set names2 [image names]
+    set x {}
+    .c delete i1
+    pack forget .c
+    pack .c
+    update
+    list $names $names2 [image names] $x
+} {foo {} {} {}}
+
+# Non-portable, apparently due to differences in rounding:
+
+test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} \
+	{testImageType nonPortable} {
+    .c delete all
+    eval image delete [image names]
+    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
+    set x
+} {{foo display 0 0 5 5 50 50}}
+test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} \
+	{testImageType nonPortable} {
+    .c delete all
+    eval image delete [image names]
+    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
+    set x
+} {{foo display 10 0 20 5 30 50}}
+test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} \
+	{testImageType nonPortable} {
+    .c delete all
+    eval image delete [image names]
+    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
+    set x
+} {{foo display 10 10 20 5 30 30}}
+test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} \
+	{testImageType nonPortable} {
+    .c delete all
+    eval image delete [image names]
+    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
+    set x
+} {{foo display 0 10 5 5 50 30}}
+test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} \
+	{testImageType nonPortable} {
+    .c delete all
+    eval image delete [image names]
+    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
+    set x
+} {{foo display 0 0 30 15 70 70}}
+test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} \
+	{testImageType nonPortable} {
+    .c delete all
+    eval image delete [image names]
+    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
+    set x
+} {{foo display 5 5 20 5 30 30}}
+
+test image-13.1 {Tk_SizeOfImage procedure} testImageType {
+    eval image delete [image names]
+    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]
+} {30 15 85 60}
+
+test image-13.2 {DeleteImage procedure} testImageType {
+    .c delete all
+    eval image delete [image names]
+    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 | [image names] | [catch {image delete foo} msg] | $msg | [image names] |
+} {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |}
+
+test image-13.3 {Tk_SizeOfImage procedure} testOldImageType {
+    eval image delete [image names]
+    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]
+} {30 15 85 60}
+
+test image-13.4 {DeleteImage procedure} testOldImageType {
+    .c delete all
+    eval image delete [image names]
+    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 | [image names] | [catch {image delete foo} msg] | $msg | [image names] |
+} {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |}
+
+
+catch {image delete hidden}
+set l [image names]
+set h [interp hidden]
+
+test image-14.1 {image command vs hidden commands} {
+    catch {image delete hidden}
+    image create photo hidden
+    interp hide {} hidden
+    image delete hidden
+    list [image names] [interp hidden]
+} [list $l $h]
+
+eval image delete [image names]
+test image-15.1 {deleting image does not make widgets forget about it} {
+    .c delete all
+    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 [image names]
+    image delete foo
+    lappend x [image names]
+    image create photo foo -width 20 -height 20
+    lappend x [.c bbox i1] [image names]
+} {10 10 20 20 foo {} {10 10 30 30} foo}
+    
+destroy .c
+eval image delete [image names]
+
+# cleanup
+cleanupTests
+return

tests/imgBmap.test

@@ -0,0 +1,469 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+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
+
+eval image delete [image names]
+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} {
+    image create bitmap i1 -background #123456
+    lindex [i1 configure -background] 4
+} {#123456}
+test imageBmap-1.2 {options for bitmap images} {
+    set errMsg {}
+    image create bitmap i1 -background lousy
+    update
+    list $errMsg $errorInfo
+} {{unknown color name "lousy"} {unknown color name "lousy"
+    (while configuring image "i1")}}
+test imageBmap-1.3 {options for bitmap images} {
+    image create bitmap i1 -data $data1
+    lindex [i1 configure -data] 4
+} $data1
+test imageBmap-1.4 {options for bitmap images} {
+    list [catch {image create bitmap i1 -data bogus} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-1.5 {options for bitmap images} {
+    image create bitmap i1 -file foo.bm
+    lindex [i1 configure -file] 4
+} foo.bm
+test imageBmap-1.6 {options for bitmap images} {
+    list [catch {image create bitmap i1 -file bogus} msg] [string tolower $msg]
+} {1 {couldn't read bitmap file "bogus": no such file or directory}}
+test imageBmap-1.7 {options for bitmap images} {
+    image create bitmap i1 -foreground #00ff00
+    lindex [i1 configure -foreground] 4
+} {#00ff00}
+test imageBmap-1.8 {options for bitmap images} {
+    set errMsg {}
+    image create bitmap i1 -foreground bad_color
+    update
+    list $errMsg $errorInfo
+} {{unknown color name "bad_color"} {unknown color name "bad_color"
+    (while configuring image "i1")}}
+test imageBmap-1.9 {options for bitmap images} {
+    image create bitmap i1 -data $data1 -maskdata $data2
+    lindex [i1 configure -maskdata] 4
+} $data2
+test imageBmap-1.10 {options for bitmap images} {
+    list [catch {image create bitmap i1 -data $data1 -maskdata bogus} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-1.11 {options for bitmap images} {
+    image create bitmap i1 -file foo.bm -maskfile foo2.bm
+    lindex [i1 configure -maskfile] 4
+} foo2.bm
+test imageBmap-1.12 {options for bitmap images} {
+    list [catch {image create bitmap i1 -data $data1 -maskfile bogus} msg] \
+	    [string tolower $msg]
+} {1 {couldn't read bitmap file "bogus": no such file or directory}}
+rename bgerror {}
+
+test imageBmap-2.1 {ImgBmapCreate procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {image create bitmap -gorp dum} msg] $msg [image names]
+} {1 {unknown option "-gorp"} {}}
+test imageBmap-2.2 {ImgBmapCreate procedure} {
+    eval image delete [image names]
+    .c delete all
+    image create bitmap image1
+    list [info commands image1] [image names] \
+	    [image width image1] [image height image1] \
+	    [lindex [image1 configure -foreground] 4] \
+	    [lindex [image1 configure -background] 4]
+} {image1 image1 0 0 #000000 {}}
+
+test imageBmap-3.1 {ImgBmapConfigureMaster procedure, memory de-allocation} {
+    image create bitmap i1 -data $data1
+    i1 configure -data $data1
+} {}
+test imageBmap-3.2 {ImgBmapConfigureMaster procedure} {
+    image create bitmap i1 -data $data1
+    list [catch {i1 configure -data bogus} msg] $msg [image width i1] \
+	    [image height i1]
+} {1 {format error in bitmap data} 16 16}
+test imageBmap-3.3 {ImgBmapConfigureMaster procedure, memory de-allocation} {
+    image create bitmap i1 -data $data1 -maskdata $data2
+    i1 configure -maskdata $data2
+} {}
+test imageBmap-3.4 {ImgBmapConfigureMaster procedure} {
+    image create bitmap i1
+    list [catch {i1 configure -maskdata $data2} msg] $msg
+} {1 {can't have mask without bitmap}}
+test imageBmap-3.5 {ImgBmapConfigureMaster procedure} {
+    list [catch {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};
+	}
+    } msg] $msg
+} {1 {bitmap and mask have different sizes}}
+test imageBmap-3.6 {ImgBmapConfigureMaster procedure} {
+    list [catch {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};
+	}
+    } msg] $msg
+} {1 {bitmap and mask have different sizes}}
+test imageBmap-3.7 {ImgBmapConfigureMaster procedure} {
+    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]
+} {15 14 {100 100 115 114} {200 100 215 114}}
+
+test imageBmap-4.1 {ImgBmapConfigureInstance procedure: check error handling} {
+    proc bgerror args {}
+    .c delete all
+    image create bitmap i1 -file foo.bm
+    .c create image 100 100 -image i1
+    update
+    i1 configure -foreground bogus
+    update
+} {}
+
+test imageBmap-5.1 {GetBitmapData procedure} {
+    list [catch {image create bitmap -file ~bad_user/a/b} msg] \
+	    [string tolower $msg]
+} {1 {user "bad_user" doesn't exist}}
+test imageBmap-5.2 {GetBitmapData procedure} {
+    list [catch {image create bitmap -file bad_name} msg] [string tolower $msg]
+} {1 {couldn't read bitmap file "bad_name": no such file or directory}}
+test imageBmap-5.3 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {image create bitmap -data { }} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-5.4 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {image create bitmap -data {#define foo2_width}} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-5.5 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {image create bitmap -data {#define foo2_width gorp}} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-5.6 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {image create bitmap -data {#define foo2_width 1.4}} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-5.7 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {image create bitmap -data {#define foo2_height}} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-5.8 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {image create bitmap -data {#define foo2_height gorp}} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-5.9 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {image create bitmap -data {#define foo2_height 1.4}} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-5.10 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    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]
+} {15 14}
+test imageBmap-5.11 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    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]
+} {15 14}
+test imageBmap-5.12 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {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};
+    }} msg] $msg
+} {1 {format error in bitmap data; looks like it's an obsolete X10 bitmap file}}
+test imageBmap-5.13 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {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;
+    }} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-5.14 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {image create bitmap i1 -data {
+	#define foo2_width 16
+	static char foo2_bits[] = {
+	   0xff, 0xff, 0xff, }}} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-5.15 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {image create bitmap i1 -data {
+	#define foo2_height 16
+	static char foo2_bits[] = {
+	   0xff, 0xff, 0xff, }}} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-5.16 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {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};
+    }} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-5.17 {GetBitmapData procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {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
+    "} msg] $msg
+} {1 {format error in bitmap data}}
+
+test imageBmap-6.1 {NextBitmapWord procedure} {
+    eval image delete [image names]
+    .c delete all
+    list [catch {image create bitmap i1 -data {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890}} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-6.2 {NextBitmapWord procedure} {
+    eval image delete [image names]
+    .c delete all
+    makeFile {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890} foo3.bm
+    list [catch {image create bitmap i1 -file foo3.bm} msg] $msg
+} {1 {format error in bitmap data}}
+test imageBmap-6.3 {NextBitmapWord procedure} {
+    eval image delete [image names]
+    .c delete all
+    makeFile {   } foo3.bm
+    list [catch {image create bitmap i1 -file foo3.bm} msg] $msg
+} {1 {format error in bitmap data}}
+removeFile foo3.bm
+
+eval image delete [image names]
+.c delete all
+image create bitmap i1
+test imageBmap-7.1 {ImgBmapCmd procedure} {
+    list [catch {i1} msg] $msg
+} {1 {wrong # args: should be "i1 option ?arg arg ...?"}}
+test imageBmap-7.2 {ImgBmapCmd procedure, "cget" option} {
+    list [catch {i1 cget} msg] $msg
+} {1 {wrong # args: should be "i1 cget option"}}
+test imageBmap-7.3 {ImgBmapCmd procedure, "cget" option} {
+    list [catch {i1 cget a b} msg] $msg
+} {1 {wrong # args: should be "i1 cget option"}}
+test imageBmap-7.4 {ImgBmapCmd procedure, "cget" option} {
+    i1 co -foreground #123456
+    i1 cget -foreground
+} {#123456}
+test imageBmap-7.5 {ImgBmapCmd procedure, "cget" option} {
+    list [catch {i1 cget -stupid} msg] $msg
+} {1 {unknown option "-stupid"}}
+test imageBmap-7.6 {ImgBmapCmd procedure} {
+    llength [i1 configure]
+} {6}
+test imageBmap-7.7 {ImgBmapCmd procedure} {
+    i1 co -foreground #001122
+    i1 configure -foreground
+} {-foreground {} {} #000000 #001122}
+test imageBmap-7.8 {ImgBmapCmd procedure} {
+    list [catch {i1 configure -gorp} msg] $msg
+} {1 {unknown option "-gorp"}}
+test imageBmap-7.9 {ImgBmapCmd procedure} {
+    list [catch {i1 configure -foreground #221100 -background} msg] $msg
+} {1 {value for "-background" missing}}
+test imageBmap-7.10 {ImgBmapCmd procedure} {
+    list [catch {i1 gorp} msg] $msg
+} {1 {bad option "gorp": must be cget or configure}}
+
+test imageBmap-8.1 {ImgBmapGet/Free procedures, shared instances} {
+    eval image delete [image names]
+    .c delete all
+    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
+} {}
+
+test imageBmap-9.1 {ImgBmapDisplay procedure, nothing to display} {
+    proc bgerror args {}
+    eval image delete [image names]
+    .c delete all
+    image create bitmap i1 -data $data1
+    .c create image 50 100 -image i1 -tags i1.1
+    i1 configure -data {}
+    update
+} {}
+test imageBmap-9.2 {ImgBmapDisplay procedure, nothing to display} {
+    proc bgerror args {}
+    eval image delete [image names]
+    .c delete all
+    image create bitmap i1 -data $data1
+    .c create image 50 100 -image i1 -tags i1.1
+    i1 configure -foreground bogus
+    update
+} {}
+if {[info exists bgerror]} {
+    rename bgerror {}
+}
+
+test imageBmap-10.1 {ImgBmapFree procedure, resource freeing} {
+    eval image delete [image names]
+    .c delete all
+    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
+} {}
+test imageBmap-10.2 {ImgBmapFree procedures, unlinking} {
+    eval image delete [image names]
+    .c delete all
+    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
+} {}
+
+test imageBmap-11.1 {ImgBmapDelete procedure} {
+    image create bitmap i2 -file foo.bm -maskfile foo2.bm
+    image delete i2
+    info command i2
+} {}
+test imageBmap-11.2 {ImgBmapDelete procedure} {
+    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*]
+} {{} newi2 foo.bm {}}
+
+test imageBmap-12.1 {ImgBmapCmdDeletedProc procedure} {
+    image create bitmap i2 -file foo.bm -maskfile foo2.bm
+    rename i2 {}
+    list [lsearch -exact [image names] i2] [catch {i2 foo} msg] $msg
+} {-1 1 {invalid command name "i2"}}
+
+removeFile foo.bm
+removeFile foo2.bm
+destroy .c
+eval image delete [image names]
+
+# cleanup
+cleanupTests
+return

tests/imgPPM.test

@@ -0,0 +1,165 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+eval image delete [image names]
+
+# 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} {
+    put test.ppm "P6\n0 256\n255\nabcdef"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {PPM image file "test.ppm" has dimension(s) <= 0}}
+test imgPPM-1.2 {FileReadPPM procedure} {
+    put test.ppm "P6\n-2 256\n255\nabcdef"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {PPM image file "test.ppm" has dimension(s) <= 0}}
+test imgPPM-1.3 {FileReadPPM procedure} {
+    put test.ppm "P6\n10 0\n255\nabcdef"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {PPM image file "test.ppm" has dimension(s) <= 0}}
+test imgPPM-1.4 {FileReadPPM procedure} {
+    put test.ppm "P6\n10 -2\n255\nabcdef"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {PPM image file "test.ppm" has dimension(s) <= 0}}
+test imgPPM-1.5 {FileReadPPM procedure} {
+    put test.ppm "P6\n10 20\n256\nabcdef"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {PPM image file "test.ppm" has bad maximum intensity value 256}}
+test imgPPM-1.6 {FileReadPPM procedure} {
+    put test.ppm "P6\n10 20\n0\nabcdef"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {PPM image file "test.ppm" has bad maximum intensity value 0}}
+test imgPPM-1.7 {FileReadPPM procedure} {
+    put test.ppm "P6\n10 10\n255\nabcdef"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {error reading PPM image file "test.ppm": not enough data}}
+test imgPPM-1.8 {FileReadPPM procedure} {
+    put test.ppm "P6\n5 4\n255\n01234567890123456789012345678901234567890123456789012345678"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {error reading PPM image file "test.ppm": not enough data}}
+test imgPPM-1.9 {FileReadPPM procedure} {
+    put test.ppm "P6\n5 4\n150\n012345678901234567890123456789012345678901234567890123456789"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg \
+	    [image width p1] [image height p1]
+} {0 p1 5 4}
+
+catch {image delete p1}
+put test.ppm "P6\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+image create photo p1 -file test.ppm
+test imgPPM-2.1 {FileWritePPM procedure} {
+    list [catch {p1 write not_a_dir/bar/baz/gorp} msg] [string tolower $msg] \
+	    [string tolower $errorCode]
+} {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} {
+    catch {unset data}
+    p1 write -format ppm test.ppm
+    set fd [open test.ppm]
+    set data [read $fd]
+    close $fd
+    set data
+} {P6
+5 4
+255
+012345678901234567890123456789012345678901234567890123456789}
+
+test imgPPM-3.1 {ReadPPMFileHeader procedure} {
+    catch {image delete p1}
+    put test.ppm "#   \n#\n#\nP6\n#\n##\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {0 p1}
+test imgPPM-3.2 {ReadPPMFileHeader procedure} {
+    catch {image delete p1}
+    put test.ppm "P6\n5\n 4   	                                                                 255\n012345678901234567890123456789012345678901234567890123456789"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {0 p1}
+test imgPPM-3.3 {ReadPPMFileHeader procedure} {
+    catch {image delete p1}
+    put test.ppm "P6\n#                                                                      asdfasdf\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {0 p1}
+test imgPPM-3.4 {ReadPPMFileHeader procedure} {
+    catch {image delete p1}
+    put test.ppm "P6 \n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {0 p1}
+test imgPPM-3.5 {ReadPPMFileHeader procedure} {
+    catch {image delete p1}
+    put test.ppm "P5\n5 4\n255\n01234567890123456789"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {0 p1}
+test imgPPM-3.6 {ReadPPMFileHeader procedure} {
+    catch {image delete p1}
+    put test.ppm "P3\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {couldn't recognize data in image file "test.ppm"}}
+test imgPPM-3.7 {ReadPPMFileHeader procedure} {
+    catch {image delete p1}
+    put test.ppm "P6x\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {couldn't recognize data in image file "test.ppm"}}
+test imgPPM-3.8 {ReadPPMFileHeader procedure} {
+    catch {image delete p1}
+    put test.ppm "P6\nxy5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {couldn't recognize data in image file "test.ppm"}}
+test imgPPM-3.9 {ReadPPMFileHeader procedure} {
+    catch {image delete p1}
+    put test.ppm "P6\n5\n255\n!012345678901234567890123456789012345678901234567890123456789"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {couldn't recognize data in image file "test.ppm"}}
+test imgPPM-3.10 {ReadPPMFileHeader procedure} {
+    catch {image delete p1}
+    put test.ppm "P6\n5 4\nzz255\n012345678901234567890123456789012345678901234567890123456789"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {couldn't recognize data in image file "test.ppm"}}
+test imgPPM-3.11 {ReadPPMFileHeader procedure, empty file} {
+    catch {image delete p1}
+    put test.ppm "     "
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {couldn't recognize data in image file "test.ppm"}}
+test imgPPM-3.12 {ReadPPMFileHeader procedure, file ends too soon} {
+    catch {image delete p1}
+    put test.ppm "P6\n566"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {couldn't recognize data in image file "test.ppm"}}
+test imgPPM-3.13 {ReadPPMFileHeader procedure, file ends too soon} {
+    catch {image delete p1}
+    put test.ppm "P6\n566\n#asdf"
+    list [catch {image create photo p1 -file test.ppm} msg] $msg
+} {1 {couldn't recognize data in image file "test.ppm"}}
+
+test imgPPM-4.1 {StringReadPPM procedure, data too short [Bug 1822391]} \
+    -setup {
+	image create photo I -width 1103 -height 997
+    } \
+    -cleanup {
+	image delete I
+    } \
+    -body {
+	I put "P5\n1103 997\n255\n"
+    } \
+    -returnCodes error \
+    -result {truncated PPM data}
+
+eval image delete [image names]
+
+# cleanup
+catch {file delete test.ppm}
+cleanupTests
+return

tests/imgPhoto.test

@@ -0,0 +1,716 @@
+# 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.
+# All rights reserved.
+#
+# Author: Paul Mackerras (paulus@cs.anu.edu.au)
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+eval image delete [image names]
+
+canvas .c
+pack .c
+update
+
+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} {
+    image create photo p1 -width 79 -height 83
+    list [lindex [p1 configure -width] 4] [lindex [p1 configure -height] 4] \
+	[image width p1] [image height p1]
+} {79 83 79 83}
+test imgPhoto-1.2 {options for photo images} {
+    list [catch {image create photo p1 -file no.such.file} err] \
+	[string tolower $err]
+} {1 {couldn't open "no.such.file": no such file or directory}}
+test imgPhoto-1.3 {options for photo images} hasTeapotPhoto {
+    list [catch {image create photo p1 -file $teapotPhotoFile \
+	    -format no.such.format} err] $err
+} {1 {image file format "no.such.format" is not supported}}
+test imgPhoto-1.4 {options for photo images} hasTeapotPhoto {
+    image create photo p1 -file $teapotPhotoFile
+    list [image width p1] [image height p1]
+} {256 256}
+test imgPhoto-1.5 {options for photo images} hasTeapotPhoto {
+    image create photo p1 -file $teapotPhotoFile \
+	    -format ppm -width 79 -height 83
+    list [image width p1] [image height p1] \
+	[lindex [p1 configure -file] 4] [lindex [p1 configure -format] 4]
+} [list 79 83 $teapotPhotoFile ppm]
+test imgPhoto-1.6 {options for photo images} {
+    image create photo p1 -palette 2/2/2 -gamma 2.2
+    list [format %.1f [lindex [p1 configure -gamma] 4]] \
+	    [lindex [p1 configure -palette] 4]
+} {2.2 2/2/2}
+test imgPhoto-1.7 {options for photo images} {
+    list [catch {image create photo p1 -file $README} err] $err
+} [subst {1 {couldn't recognize data in image file "$README"}}]
+test imgPhoto-1.8 {options for photo images} {
+    list [catch {image create photo -blah blah} err] $err
+} {1 {unknown option "-blah"}}
+test imgPhoto-1.9 {options for photo images - error case} {
+    list [catch {image create photo -format} err] $err
+} {1 {value for "-format" missing}}
+test imgPhoto-1.10 {options for photo images - error case} {
+    list [catch {image create photo -data} err] $err
+} {1 {value for "-data" missing}}
+test imgPhoto-1.11 {options for photo images - error case} {
+    list [catch {image create photo p1 -format} err] $err
+} {1 {value for "-format" missing}}
+
+test imgPhoto-2.1 {ImgPhotoCreate procedure} {
+    eval image delete [image names]
+    catch {image create photo -blah blah}
+    image names
+} {}
+test imgPhoto-2.2 {ImgPhotoCreate procedure} {
+    eval image delete [image names]
+    image create photo image1
+    list [info commands image1] [image names] \
+	    [image width image1] [image height image1]
+} {image1 image1 0 0}
+# test imgPhoto-2.3 {ImgPhotoCreate procedure: creation failure} {
+#     image create photo p1
+#     image create photo p2 -width 10 -height 10
+#     catch {image create photo p2 -file bogus.img} msg
+#     p1 copy p2
+#     set msg
+# } {couldn't open "bogus.img": no such file or directory}
+
+test imgPhoto-3.1 {ImgPhotoConfigureMaster procedure} hasTeapotPhoto {
+    image create photo p1 -file $teapotPhotoFile
+    p1 configure -file $teapotPhotoFile
+} {}
+test imgPhoto-3.2 {ImgPhotoConfigureMaster procedure} hasTeapotPhoto {
+    image create photo p1 -file $teapotPhotoFile
+    list [catch {p1 configure -file bogus} err] [string tolower $err] \
+	[image width p1] [image height p1]
+} {1 {couldn't open "bogus": no such file or directory} 256 256}
+test imgPhoto-3.3 {ImgPhotoConfigureMaster procedure} hasTeapotPhoto {
+    image create photo p1
+    .c create image 10 10 -image p1 -tags p1.1 -anchor nw
+    .c create image 300 10 -image p1 -tags p1.2 -anchor nw
+    update
+    p1 configure -file $teapotPhotoFile
+    update
+    list [image width p1] [image height p1] [.c bbox p1.1] [.c bbox p1.2]
+} {256 256 {10 10 266 266} {300 10 556 266}}
+
+eval image delete [image names]
+image create photo p1
+.c create image 10 10 -image p1
+update
+
+test imgPhoto-4.1 {ImgPhotoCmd procedure} {
+    list [catch {p1} err] $err
+} {1 {wrong # args: should be "p1 option ?arg arg ...?"}}
+test imgPhoto-4.2 {ImgPhotoCmd procedure} {
+    list [catch {p1 blah} err] $err
+} {1 {bad option "blah": must be blank, cget, configure, copy, data, get, put, read, redither, transparency, or write}}
+test imgPhoto-4.3 {ImgPhotoCmd procedure: blank option} {
+    p1 blank
+    list [catch {p1 blank x} err] $err
+} {1 {wrong # args: should be "p1 blank"}}
+test imgPhoto-4.4 {ImgPhotoCmd procedure: cget option} {
+    list [catch {p1 cget} msg] $msg
+} {1 {wrong # args: should be "p1 cget option"}}
+test imgPhoto-4.5 {ImgPhotoCmd procedure: cget option} {
+    image create photo p2 -width 25 -height 30
+    list [p2 cget -width] [p2 cget -height]
+} {25 30}
+test imgPhoto-4.6 {ImgPhotoCmd procedure: configure option} {
+    llength [p1 configure]
+} {7}
+test imgPhoto-4.7 {ImgPhotoCmd procedure: configure option} {
+    p1 conf -palette 3/4/2
+    p1 configure -palette
+} {-palette {} {} {} 3/4/2}
+test imgPhoto-4.8 {ImgPhotoCmd procedure: configure option} {
+    list [catch {p1 configure -blah} msg] $msg
+} {1 {unknown option "-blah"}}
+test imgPhoto-4.9 {ImgPhotoCmd procedure: configure option} {
+    list [catch {p1 configure -palette {} -gamma} msg] $msg
+} {1 {value for "-gamma" missing}}
+test imgPhoto-4.10 {ImgPhotoCmd procedure: copy option} hasTeapotPhoto {
+    image create photo p2 -file $teapotPhotoFile
+    p1 configure -width 0 -height 0 -palette {} -gamma 1
+    p1 copy p2
+    list [image width p1] [image height p1] [p1 get 100 100]
+} {256 256 {169 117 90}}
+test imgPhoto-4.11 {ImgPhotoCmd procedure: copy option} {
+    list [catch {p1 copy} msg] $msg
+} {1 {wrong # args: should be "p1 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} {
+    list [catch {p1 copy blah} msg] $msg
+} {1 {image "blah" doesn't exist or is not a photo image}}
+test imgPhoto-4.13 {ImgPhotoCmd procedure: copy option} {
+    list [catch {p1 copy p2 -blah} msg] $msg
+} {1 {unrecognized option "-blah": must be -compositingrule, -from, -shrink, -subsample, -to, or -zoom}}
+test imgPhoto-4.14 {ImgPhotoCmd procedure: copy option} {
+    list [catch {p1 copy p2 -from -to} msg] $msg
+} {1 {the "-from" option requires one to four integer values}}
+test imgPhoto-4.15 {ImgPhotoCmd procedure: copy option} {
+    p1 copy p2
+    p1 copy p2 -from 0 70 60 120 -shrink
+    list [image width p1] [image height p1] [p1 get 20 10]
+} {60 50 {215 154 120}}
+test imgPhoto-4.16 {ImgPhotoCmd procedure: copy option} {
+    p1 copy p2 -from 60 120 0 70 -to 20 50
+    list [image width p1] [image height p1] [p1 get 40 80]
+} {80 100 {19 92 192}}
+test imgPhoto-4.17 {ImgPhotoCmd procedure: copy option} {
+    p1 copy p2 -from 0 120 60 70 -to 0 0 100 100
+    list [image width p1] [image height p1] [p1 get 80 60]
+} {100 100 {215 154 120}}
+test imgPhoto-4.18 {ImgPhotoCmd procedure: copy option} {
+    p1 copy p2 -from 60 70 0 120 -zoom 2
+    list [image width p1] [image height p1] [p1 get 100 50]
+} {120 100 {169 99 47}}
+test imgPhoto-4.19 {ImgPhotoCmd procedure: copy option} {
+    p1 copy p2 -from 0 70 60 120
+    list [image width p1] [image height p1] [p1 get 100 50]
+} {120 100 {169 99 47}}
+test imgPhoto-4.20 {ImgPhotoCmd procedure: copy option} {
+    p1 copy p2 -from 20 20 200 180 -subsample 2 -shrink
+    list [image width p1] [image height p1] [p1 get 50 30]
+} {90 80 {207 146 112}}
+test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} {
+    p1 copy p2
+    set result [list [image width p1] [image height p1]]
+    p1 conf -width 49 -height 51
+    lappend result [image width p1] [image height p1]
+    p1 copy p2
+    lappend result [image width p1] [image height p1]
+    p1 copy p2 -from 0 0 10 10 -shrink
+    lappend result [image width p1] [image height p1]
+    p1 conf -width 0
+    p1 copy p2 -from 0 0 10 10 -shrink
+    lappend result [image width p1] [image height p1]
+    p1 conf -height 0
+    p1 copy p2 -from 0 0 10 10 -shrink
+    lappend result [image width p1] [image height p1]
+} {256 256 49 51 49 51 49 51 10 51 10 10}
+test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} hasTeapotPhoto {
+    p1 read $teapotPhotoFile
+    list [p1 get 100 100] [p1 get 150 100] [p1 get 100 150]
+} {{169 117 90} {172 115 84} {35 35 35}}
+test imgPhoto-4.23 {ImgPhotoCmd procedure: get option} {
+    list [catch {p1 get 256 0} err] $err
+} {1 {p1 get: coordinates out of range}}
+test imgPhoto-4.24 {ImgPhotoCmd procedure: get option} {
+    list [catch {p1 get 0 -1} err] $err
+} {1 {p1 get: coordinates out of range}}
+test imgPhoto-4.25 {ImgPhotoCmd procedure: get option} {
+    list [catch {p1 get} err] $err
+} {1 {wrong # args: should be "p1 get x y"}}
+test imgPhoto-4.26 {ImgPhotoCmd procedure: put option} {
+    list [catch {p1 put} err] $err
+} {1 {wrong # args: should be "p1 put data ?options?"}}
+test imgPhoto-4.27 {ImgPhotoCmd procedure: put option} {
+    list [catch {p1 put {{white} {white white}}} err] $err
+} {1 {all elements of color list must have the same number of elements}}
+test imgPhoto-4.28 {ImgPhotoCmd procedure: put option} {
+    list [catch {p1 put {{blahgle}}} err] $err
+} {1 {can't parse color "blahgle"}}
+test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} {
+    p1 put -to 10 10 20 20 {{white}}
+    p1 get 19 19
+} {255 255 255}
+test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} {
+    list [catch {p1 read} err] $err
+} {1 {wrong # args: should be "p1 read fileName ?options?"}}
+test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} hasTeapotPhoto {
+    list [catch {p1 read $teapotPhotoFile -zoom 2} err] $err
+} {1 {unrecognized option "-zoom": must be -format, -from, -shrink, or -to}}
+test imgPhoto-4.32 {ImgPhotoCmd procedure: read option} {
+    list [catch {p1 read bogus} err] [string tolower $err]
+} {1 {couldn't open "bogus": no such file or directory}}
+test imgPhoto-4.33 {ImgPhotoCmd procedure: read option} hasTeapotPhoto {
+    list [catch {p1 read $teapotPhotoFile -format bogus} err] $err
+} {1 {image file format "bogus" is not supported}}
+test imgPhoto-4.34 {ImgPhotoCmd procedure: read option} {
+    list [catch {p1 read $README} err] $err
+} [subst {1 {couldn't recognize data in image file "$README"}}]
+test imgPhoto-4.35 {ImgPhotoCmd procedure: read option} hasTeapotPhoto {
+    p1 read $teapotPhotoFile
+    list [image width p1] [image height p1] [p1 get 120 120]
+} {256 256 {161 109 82}}
+test imgPhoto-4.36 {ImgPhotoCmd procedure: read option} hasTeapotPhoto {
+    p1 read $teapotPhotoFile -from 0 70 60 120 -to 10 10 -shrink
+    list [image width p1] [image height p1] [p1 get 29 19]
+} {70 60 {244 180 144}}
+test imgPhoto-4.37 {ImgPhotoCmd procedure: redither option} {
+    p1 redither
+    list [catch {p1 redither x} err] $err
+} {1 {wrong # args: should be "p1 redither"}}
+test imgPhoto-4.38 {ImgPhotoCmd procedure: write option} {
+    list [catch {p1 write} err] $err
+} {1 {wrong # args: should be "p1 write fileName ?options?"}}
+test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} {
+    list [catch {p1 write teapot.tmp -format bogus} err] $err
+} {1 {image file format "bogus" is unknown}}
+eval image delete [image names]
+image create photo p1
+test imgPhoto-4.40 {ImgPhotoCmd procedure: transparency option} {
+    list [catch {p1 transparency} err] $err
+} {1 {wrong # args: should be "p1 transparency option ?arg arg ...?"}}
+test imgPhoto-4.41 {ImgPhotoCmd procedure: transparency get option} {
+    list [catch {p1 transparency get} err] $err
+} {1 {wrong # args: should be "p1 transparency get x y"}}
+test imgPhoto-4.42 {ImgPhotoCmd procedure: transparency get option} {
+    list [catch {p1 transparency get 0} err] $err
+} {1 {wrong # args: should be "p1 transparency get x y"}}
+test imgPhoto-4.43 {ImgPhotoCmd procedure: transparency get option} {
+    list [catch {p1 transparency get 0 0 0} err] $err
+} {1 {wrong # args: should be "p1 transparency get x y"}}
+test imgPhoto-4.44 {ImgPhotoCmd procedure: transparency get option} {
+    list [catch {p1 transparency get bogus 0} err] $err
+} {1 {expected integer but got "bogus"}}
+test imgPhoto-4.45 {ImgPhotoCmd procedure: transparency get option} {
+    list [catch {p1 transparency get 0 bogus} err] $err
+} {1 {expected integer but got "bogus"}}
+test imgPhoto-4.46 {ImgPhotoCmd procedure: transparency get option} {
+    p1 put white
+    p1 transparency get 0 0
+} 0
+test imgPhoto-4.47 {ImgPhotoCmd procedure: transparency get option} {
+    list [catch {p1 transparency get 1 0} err] $err
+} {1 {p1 transparency get: coordinates out of range}}
+test imgPhoto-4.48 {ImgPhotoCmd procedure: transparency get option} {
+    list [catch {p1 transparency get -1 0} err] $err
+} {1 {p1 transparency get: coordinates out of range}}
+test imgPhoto-4.49 {ImgPhotoCmd procedure: transparency get option} {
+    list [catch {p1 transparency get 0 1} err] $err
+} {1 {p1 transparency get: coordinates out of range}}
+test imgPhoto-4.50 {ImgPhotoCmd procedure: transparency get option} {
+    list [catch {p1 transparency get 0 -1} err] $err
+} {1 {p1 transparency get: coordinates out of range}}
+test imgPhoto-4.51 {ImgPhotoCmd procedure: transparency get option} {
+    p1 blank
+    p1 transparency get 0 0
+} 1
+test imgPhoto-4.52 {ImgPhotoCmd procedure: transparency set option} {
+    list [catch {p1 transparency set} err] $err
+} {1 {wrong # args: should be "p1 transparency set x y boolean"}}
+test imgPhoto-4.53 {ImgPhotoCmd procedure: transparency set option} {
+    list [catch {p1 transparency set 0} err] $err
+} {1 {wrong # args: should be "p1 transparency set x y boolean"}}
+test imgPhoto-4.54 {ImgPhotoCmd procedure: transparency set option} {
+    list [catch {p1 transparency set 0 0} err] $err
+} {1 {wrong # args: should be "p1 transparency set x y boolean"}}
+test imgPhoto-4.55 {ImgPhotoCmd procedure: transparency set option} {
+    list [catch {p1 transparency set 0 0 0 0} err] $err
+} {1 {wrong # args: should be "p1 transparency set x y boolean"}}
+test imgPhoto-4.56 {ImgPhotoCmd procedure: transparency set option} {
+    list [catch {p1 transparency set bogus 0 0} err] $err
+} {1 {expected integer but got "bogus"}}
+test imgPhoto-4.57 {ImgPhotoCmd procedure: transparency set option} {
+    list [catch {p1 transparency set 0 bogus 0} err] $err
+} {1 {expected integer but got "bogus"}}
+test imgPhoto-4.58 {ImgPhotoCmd procedure: transparency set option} {
+    list [catch {p1 transparency set 0 0 bogus} err] $err
+} {1 {expected boolean value but got "bogus"}}
+test imgPhoto-4.59 {ImgPhotoCmd procedure: transparency set option} {
+    list [catch {p1 transparency set 1 0 0} err] $err
+} {1 {p1 transparency set: coordinates out of range}}
+test imgPhoto-4.60 {ImgPhotoCmd procedure: transparency set option} {
+    list [catch {p1 transparency set -1 0 0} err] $err
+} {1 {p1 transparency set: coordinates out of range}}
+test imgPhoto-4.61 {ImgPhotoCmd procedure: transparency set option} {
+    list [catch {p1 transparency set 0 1 0} err] $err
+} {1 {p1 transparency set: coordinates out of range}}
+test imgPhoto-4.62 {ImgPhotoCmd procedure: transparency set option} {
+    list [catch {p1 transparency set 0 -1 0} err] $err
+} {1 {p1 transparency set: coordinates out of range}}
+test imgPhoto-4.63 {ImgPhotoCmd procedure: transparency set option} {
+    p1 transparency set 0 0 false
+    p1 transparency get 0 0
+} 0
+test imgPhoto-4.64 {ImgPhotoCmd procedure: transparency set option} {
+    p1 transparency set 0 0 true
+    p1 transparency get 0 0
+} 1
+# Now for some heftier testing, checking that setting and resetting of
+# pixels' transparency status doesn't "leak" with any one-off errors.
+proc checkImgTrans {img width height} {
+    set result {}
+    for {set x 0} {$x<$width} {incr x} {
+	for {set y 0} {$y<$height} {incr y} {
+	    if {[$img transparency get $x $y]} {
+		lappend result $x $y
+	    }
+	}
+    }
+    return $result
+}
+test imgPhoto-4.65 {ImgPhotoCmd procedure: transparency get option} {
+    p1 put white -to 0 0 3 3
+    checkImgTrans p1 3 3
+} {}
+test imgPhoto-4.66 {ImgPhotoCmd procedure: transparency get option} {
+    p1 blank
+    checkImgTrans p1 3 3
+} {0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2}
+proc checkImgTransLoopSetReset {img width height} {
+    set result {}
+    for {set x 0} {$x<$width} {incr x} {
+	for {set y 0} {$y<$height} {incr y} {
+	    $img put white -to 0 0 3 3
+	    $img transparency set $x $y 1
+	    set result [concat $result [checkImgTrans $img $width $height]]
+	    lappend result ,
+	    $img transparency set $x $y 0
+	    set result [concat $result [checkImgTrans $img $width $height]]
+	    lappend result .
+	}
+    }
+    return $result
+}
+test imgPhoto-4.67 {ImgPhotoCmd procedure: transparency set option} {
+    checkImgTransLoopSetReset p1 3 3
+} {0 0 , . 0 1 , . 0 2 , . 1 0 , . 1 1 , . 1 2 , . 2 0 , . 2 1 , . 2 2 , .}
+proc checkImgTransLoopResetSet {img width height} {
+    set result {}
+    for {set x 0} {$x<$width} {incr x} {
+	for {set y 0} {$y<$height} {incr y} {
+	    $img blank
+	    $img transparency set $x $y 0
+	    set result [concat $result [checkImgTrans $img $width $height]]
+	    lappend result ,
+	    $img transparency set $x $y 1
+	    set result [concat $result [checkImgTrans $img $width $height]]
+	    lappend result .
+	}
+    }
+    return $result
+}
+test imgPhoto-4.67a {ImgPhotoCmd procedure: transparency set option} {
+    checkImgTransLoopResetSet p1 3 3
+} {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 .}
+catch {rename checkImgTransLoopSetReset {}}
+catch {rename checkImgTransLoopResetSet {}}
+# Test the compositing rules for copying images
+image create photo p1 -width 3 -height 3
+image create photo p2 -width 2 -height 2
+test imgPhoto-4.68 {ImgPhotoCmd procedure: copy with -compositingrule} {
+    list [catch {p1 copy p2 -to 1 1 -compositingrule} msg] $msg
+} {1 {the "-compositingrule" option requires a value}}
+test imgPhoto-4.69 {ImgPhotoCmd procedure: copy with -compositingrule} {
+    list [catch {p1 copy p2 -to 1 1 -compositingrule BAD} msg] $msg
+} {1 {bad compositing rule "BAD": must be overlay or set}}
+test imgPhoto-4.70 {ImgPhotoCmd procedure: copy with -compositingrule} {
+    # Tests default compositing rule
+    p1 blank
+    p2 blank
+    p1 put white -to 0 0 2 2
+    p2 put white -to 0 0 2 2
+    p2 transparency set 0 0 true
+    p1 copy p2 -to 1 1
+    checkImgTrans p1 3 3
+} {0 2 2 0}
+test imgPhoto-4.71 {ImgPhotoCmd procedure: copy with -compositingrule} {
+    p1 blank
+    p2 blank
+    p1 put white -to 0 0 2 2
+    p2 put white -to 0 0 2 2
+    p2 transparency set 0 0 true
+    p1 copy p2 -to 1 1 -compositingrule overlay
+    checkImgTrans p1 3 3
+} {0 2 2 0}
+test imgPhoto-4.72 {ImgPhotoCmd procedure: copy with -compositingrule} {
+    p1 blank
+    p2 blank
+    p1 put white -to 0 0 2 2
+    p2 put white -to 0 0 2 2
+    p2 transparency set 0 0 true
+    p1 copy p2 -to 1 1 -compositingrule set
+    checkImgTrans p1 3 3
+} {0 2 1 1 2 0}
+catch {rename checkImgTrans {}}
+
+test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} hasTeapotPhoto {
+    eval image delete [image names]
+    .c delete all
+    image create photo p1 -file $teapotPhotoFile
+    .c create image 0 0 -image p1 -tags p1.1
+    .c create image 256 0 -image p1 -tags p1.2
+    .c create image 0 256 -image p1 -tags p1.3
+    update
+    .c delete i1.1
+    p1 configure -width 1
+    update
+    .c delete i1.2
+    p1 configure -height 1
+    update
+    image delete p1
+} {}
+
+test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} {
+    .c delete all
+    image create photo p1 -width 10 -height 10
+    p1 blank
+    .c create image 10 10 -image p1
+    update
+} {}
+
+test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} hasTeapotPhoto {
+    eval image delete [image names]
+    .c delete all
+    image create photo p1 -file $teapotPhotoFile
+    .c create image 0 0 -image p1 -anchor nw
+    update
+    .c delete all
+    image delete p1
+} {}
+test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} hasTeapotPhoto {
+    image create photo p1 -file $teapotPhotoFile
+    .c create image 10 10 -image p1 -anchor nw
+    button .b1 -image p1
+    button .b2 -image p1
+    button .b3 -image p1
+    pack .b1 .b2 .b3
+    update
+    destroy .b2
+    update
+    destroy .b3
+    update
+    destroy .b1
+    update
+    .c delete all
+} {}
+test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} hasTeapotPhoto {
+    image create photo p1 -file $teapotPhotoFile
+    button .b1 -image p1
+    frame .f -visual best
+    button .f.b2 -image p1
+    pack .f.b2
+    pack .b1 .f
+    update
+    destroy .b1
+    update
+    .f.b2 configure -image {}
+    update
+    destroy .f
+    image delete p1
+} {}
+
+test imgPhoto-8.1 {ImgPhotoDelete procedure} hasTeapotPhoto {
+    image create photo p2 -file $teapotPhotoFile
+    image delete p2
+} {}
+test imagePhoto-8.2 {ImgPhotoDelete procedure} hasTeapotPhoto {
+    image create photo p2 -file $teapotPhotoFile
+    rename p2 newp2
+    set x [list [info command p2] [info command new*] [newp2 cget -file]]
+    image delete p2
+    append x [info command new*]
+} [list {} newp2 $teapotPhotoFile]
+test imagePhoto-8.3 {ImgPhotoDelete procedure, name cleanup} {
+    image create photo p1
+    image create photo p2 -width 10 -height 10
+    image delete p2
+    list [catch {p1 copy p2} msg] $msg
+} {1 {image "p2" doesn't exist or is not a photo image}}
+
+test imagePhoto-9.1 {ImgPhotoCmdDeletedProc procedure} hasTeapotPhoto {
+    image create photo p2 -file $teapotPhotoFile
+    rename p2 {}
+    list [lsearch -exact [image names] p2] [catch {p2 foo} msg] $msg
+} {-1 1 {invalid command name "p2"}}
+
+test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} {
+    eval image delete [image names]
+    image create photo p1
+    p1 put {{#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000}} -to 0 0
+    p1 put {{#00ff00 #00ff00}} -to 2 0
+    list [p1 get 2 0] [p1 get 3 0] [p1 get 4 0]
+} {{0 255 0} {0 255 0} {255 0 0}}
+
+test imgPhoto-11.1 {Tk_FindPhoto} {
+    eval image delete [image names]
+    image create bitmap i1
+    image create photo p1
+    list [catch {p1 copy i1} msg] $msg
+} {1 {image "i1" doesn't exist or is not a photo image}}
+
+test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} hasTeapotPhoto {
+    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]
+    image delete p3
+    set result
+} {{19 92 192} {169 117 90} 512 512 {19 92 192}}
+
+test imgPhoto-13.1 {check separation of images in different interpreters} {
+    image delete {*}[image names]
+    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}
+    x1 eval [list image create photo T1_data -data $data]
+    x2 eval [list image create photo T1_data -data $data]
+    unset data
+    interp delete x1
+    interp delete x2
+} {}
+
+test imgPhoto-14.1 {GIF writes work correctly} {
+    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 photo [image create photo -data $data]
+    set filename [makeFile {} imgPhoto-14.1.gif]
+    removeFile imgPhoto-14.1.gif
+    $photo write $filename -format gif
+    set photo2 [image create photo -file $filename]
+    set result [string equal [$photo data] [$photo2 data]]
+    image delete $photo $photo2
+    catch {file delete -force $filename}
+    set result
+} 1
+test imgPhoto-14.2 {GIF -index handler buffer sizing} -setup {
+    set i [image create photo]
+} -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 data {
+	R0lGODlhIAAgAKEAAPkOSQsi7////////yH/C05FVFNDQVBFMi4wAwEAAAAh
+	+QQJMgAAACwGAAYAFAAUAAACEYyPqcvtD6OctNqLs968+68VACH5BAkyAAEA
+	LAMAAwAaABoAAAI0jH+gq+gfmFzQzUsr3gBybn1gIm5kaUaoubbuC8fyTNel
+	Ohv1CSO533u8KrgbUfc5Ci/EAgA7
+    }
+    $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} -setup {
+    set i [image create photo]
+} -body {
+    # Interleaved GIFs used to crash us when a smaller subsequent frame
+    # was accessed.
+    $i configure -format {GIF -index 1} -data {
+	R0lGODdhAQAFAPAAAP8AAAAAACwAAAAAAQAFAEACAoRdACwAAAAAAQAEAEACAoRRADs=
+    }
+} -cleanup {
+    image delete $i
+}
+
+test imgPhoto-14.4 {GIF buffer overflow} -setup {
+    set i [image create photo]
+} -body {
+    # This crashes Tk up to 8.4.17 and 8.5.0
+    $i configure -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=
+    } 
+} -cleanup {
+    image delete $i
+} -returnCodes error -result {malformed image}
+
+test imgPhoto-15.1 {photo images can fail to allocate memory gracefully} \
+	{nonPortable} {
+    # This is not portable to very large machines with more around
+    # 3GB of free memory available...
+    list [catch {image create photo -width 32000 -height 32000} msg] $msg
+} {1 {not enough free memory for image buffer}}
+
+test imgPhoto-16.1 {copying to self doesn't access freed memory} {
+    # Bug 877950 makes this crash when trying to copy out of a deallocated area
+    set i [image create photo]
+    $i put red -to 0 0 1000 1000
+    $i copy $i -from 0 0 1000 1000 -to 500 0
+    image delete $i
+} {}
+
+destroy .c
+eval image delete [image names]
+
+# cleanup
+removeFile README-imgPhoto
+cleanupTests
+return

tests/license.terms

@@ -0,0 +1,39 @@
+This software is copyrighted by the Regents of the University of
+California, Sun Microsystems, Inc., and other parties.  The following
+terms apply to all files associated with the software unless explicitly
+disclaimed in individual files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+GOVERNMENT USE: If you are acquiring this software on behalf of the
+U.S. government, the Government shall have only "Restricted Rights"
+in the software and related documentation as defined in the Federal
+Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2).  If you
+are acquiring the software on behalf of the Department of Defense, the
+software shall be classified as "Commercial Computer Software" and the
+Government shall have only "Restricted Rights" as defined in Clause
+252.227-7013 (b) (3) of DFARs.  Notwithstanding the foregoing, the
+authors grant the U.S. Government and others acting in its behalf
+permission to use and distribute the software in accordance with the
+terms specified in this license.

tests/main.test

@@ -0,0 +1,126 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test main-1.1 {StdinProc} -constraints stdio -setup {
+    set script [makeFile {
+	close stdin; exit
+    } script]
+} -body {
+    list [catch {exec [interpreter] <$script} msg] $msg
+} -cleanup {
+    removeFile script
+} -result {0 {}}
+
+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 [list 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 [list script {} 0]\n0\n
+
+    # Procedure to simulate interactive typing of commands, line by line
+    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
+        }
+        list [catch {gets $f} line] $line
+    } -cleanup {
+        close $f
+        removeFile script
+    } -result {0 {-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
+    list [catch {exec [interpreter] -help} msg] $msg
+} -match glob -result {1 {% Application 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 }
+    list [catch {load {} Tk $maininterp} msg] $msg
+} -cleanup {
+    interp delete $maininterp
+} -match glob -result {1 {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 }
+    list [catch {load {} Tk $maininterp} msg] $msg
+} -cleanup {
+    interp delete $maininterp
+} -match glob -result {1 {Command-specific options:*}}
+
+# cleanup
+cleanupTests
+return

tests/menuDraw.test

@@ -0,0 +1,511 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test menuDraw-1.1 {TkMenuInitializeDrawingFields} {
+    catch {destroy .m1}
+    list [menu .m1] [destroy .m1]
+} {.m1 {}}
+
+test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command] [destroy .m1]
+} {{} {}}
+
+test menuDraw-3.1 {TkMenuFreeDrawOptions} {
+    catch {destroy .m1}
+    menu .m1
+    list [destroy .m1]
+} {{}}
+
+test menuDraw-4.1 {TkMenuEntryFreeDrawOptions} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "This is a test"
+    list [destroy .m1]
+} {{}}
+test menuDraw-4.2 {TkMenuEntryFreeDrawOptions} {
+	catch {destroy .m1}
+	menu .m1
+	.m1 add checkbutton -label "This is a test." -font "Courier 12" -activeforeground red -background green -selectcolor purple
+	list [destroy .m1]
+} {{}}
+
+test menuDraw-5.1 {TkMenuConfigureDrawOptions - new menu} {
+    catch {destroy .m1}
+    list [menu .m1] [destroy .m1]
+} {.m1 {}}
+test menuDraw-5.2 {TkMenuConfigureDrawOptions - old menu} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 configure -fg red] [destroy .m1]
+} {{} {}}
+test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} {
+	catch {destroy .m1}
+	list [menu .m1 -disabledforeground ""] [destroy .m1]
+} {.m1 {}}	
+
+test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.2 {TkMenuConfigureEntryDrawOptions - tkfont specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.3 {TkMenuConfigureEntryDrawOptions - active state - wrong entry} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    list [.m1 entryconfigure 1 -state active] [destroy .m1]
+} {{} {}}
+test menuDraw-6.4 {TkMenuConfigureEntryDrawOptions - active state - correct entry} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    .m1 activate 1
+    list [.m1 entryconfigure 1 -state active] [destroy .m1]
+} {{} {}}
+test menuDraw-6.5 {TkMenuConfigureEntryDrawOptions - deactivate entry} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    .m1 activate 1
+    list [.m1 entryconfigure 1 -state normal] [destroy .m1]
+} {{} {}}
+test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    list [catch {.m1 entryconfigure 1 -state foo} msg] $msg [destroy .m1]
+} {1 {bad state "foo": must be active, normal, or disabled} {}}
+test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.8 {TkMenuConfigureEntryDrawOptions - border specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo" -background "red"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.9 {TkMenuConfigureEntryDrawOptions - foreground specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo" -foreground "red"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.10 {TkMenuConfigureEntryDrawOptions - activeBorder specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo" -activebackground "red"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.11 {TkMenuConfigureEntryDrawOptions - activeforeground specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add command -label "foo" -activeforeground "red"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.12 {TkMenuConfigureEntryDrawOptions - selectcolor specified} {
+    catch {destroy .m1}
+    menu .m1
+    list [.m1 add radiobutton -label "foo" -selectcolor "red"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.13 {TkMenuConfigureEntryDrawOptions - textGC disposal} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo" -font "Helvetica 12"
+    list [.m1 entryconfigure 1 -font "Courier 12"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.14 {TkMenuConfigureEntryDrawOptions - activeGC disposal} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo" -activeforeground "red"
+    list [.m1 entryconfigure 1 -activeforeground "green"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.15 {TkMenuConfigureEntryDrawOptions - disabledGC disposal} {
+    catch {destroy .m1}
+    menu .m1 -disabledforeground "red"
+    .m1 add command -label "foo"
+    list [.m1 configure -disabledforeground "green"] [destroy .m1]
+} {{} {}}
+test menuDraw-6.16 {TkMenuConfigureEntryDrawOptions - indicatorGC disposal} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add radiobutton -label "foo" -selectcolor "red"
+    list [.m1 entryconfigure 1 -selectcolor "green"] [destroy .m1]
+} {{} {}}
+
+test menuDraw-7.1 {TkEventuallyRecomputeMenu} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "This is a long label"
+    set tearoff [tk::TearOffMenu .m1]
+    update idletasks
+    list [.m1 entryconfigure 1 -label "foo"] [destroy .m1]
+} {{} {}}
+test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "This is a long label"
+    set tearoff [tk::TearOffMenu .m1]
+    list [.m1 entryconfigure 1 -label "foo"] [destroy .m1]
+} {{} {}}
+
+
+test menuDraw-8.1 {TkRecomputeMenu} {win userInteraction} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 configure -postcommand [.m1 add command -label foo]
+    .m1 add command -label "Hit ESCAPE to make this menu go away."
+    list [.m1 post 0 0] [destroy .m1]
+} {{} {}}
+
+
+test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} {
+    catch {destroy .m1}
+    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]
+} {test {} {}}
+test menuDraw-9.2 {TkEventuallyRedrawMenu - whole menu} {
+    catch {destroy .m1}
+    menu .m1
+    list [catch {tk::TearOffMenu .m1}] [destroy .m1]
+} {0 {}}
+
+# Don't know how to test when window has been deleted and ComputeMenuGeometry
+# gets called.
+test menuDraw-10.1 {ComputeMenuGeometry - menubar} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label test
+    . configure -menu .m1
+    list [update idletasks] [. configure -menu ""] [destroy .m1]
+} {{} {} {}}
+test menuDraw-10.2 {ComputeMenuGeometry - non-menubar} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label test
+    list [update idletasks] [destroy .m1]
+} {{} {}}
+test menuDraw-10.3 {ComputeMenuGeometry - Resize necessary} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label test
+    list [update idletasks] [destroy .m1]
+} {{} {}}
+test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label test
+    update idletasks
+    .m1 entryconfigure 1 -label test
+    list [update idletasks] [destroy .m1]
+} {{} {}}
+
+test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} testImageType {
+    catch {destroy .m1}
+    catch {eval image delete [image names]}
+    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] [eval image delete [image names]]
+} {{} {} {}}
+test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} testImageType {
+    catch {destroy .m1}
+    catch {eval image delete [image names]}
+    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] [eval image delete [image names]]
+} {{} {} {}}
+test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} testImageType {
+    catch {destroy .m1}
+    catch {eval image delete [image names]}
+    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] [eval image delete [image names]]
+} {{} {} {}}
+
+#Don't know how to test missing tkwin in DisplayMenu
+test menuDraw-12.1 {DisplayMenu - menubar background} unix {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add cascade -label foo -menu .m2
+    . configure -menu .m1
+    list [update] [. configure -menu ""] [destroy .m1]
+} {{} {} {}}
+test menuDraw-12.2 {Display menu - no entries} {
+    catch {destroy .m1}
+    menu .m1
+    set tearoff [tk::TearOffMenu .m1 40 40]
+    list [update] [destroy .m1]
+} {{} {}}
+test menuDraw-12.3 {DisplayMenu - one entry} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label foo
+    set tearoff [tk::TearOffMenu .m1 40 40]
+    list [update] [destroy .m1]
+} {{} {}}
+test menuDraw-12.4 {DisplayMenu - two entries} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "one"
+    .m1 add command -label "two"
+    set tearoff [tk::TearOffMenu .m1 40 40]
+    list [update] [destroy .m1]
+} {{} {}}
+test menuDraw.12.5 {DisplayMenu - two columns - first bigger} {
+    catch {destroy .m1}
+    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]
+    list [update] [destroy .m1]
+} {{} {}}
+test menuDraw-12.5 {DisplayMenu - two column - second  bigger} {
+    catch {destroy .m1}
+    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]
+    list [update] [destroy .m1]
+} {{} {}}
+test menuDraw.12.7 {DisplayMenu - three columns} {
+    catch {destroy .m1}
+    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]
+    list [update] [destroy .m1]
+} {{} {}}
+test menuDraw-12.6 {Display menu - testing for extra space and menubars} unix {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add cascade -label foo
+    . configure -menu .m1
+    list [update] [. configure -menu ""] [destroy .m1]
+} {{} {} {}}
+test menuDraw-12.7 {Display menu - extra space at end of menu} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add cascade -label foo
+    set tearoff [tk::TearOffMenu .m1 40 40]
+    wm geometry $tearoff 200x100
+    list [update] [destroy .m1]
+} {{} {}}
+
+test menuDraw-13.1 {TkMenuEventProc - Expose} {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    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] [destroy .m1] [destroy .m2]
+} {{} {} {} {}}
+test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    set tearoff [tk::TearOffMenu .m1 40 40]
+    list [wm geometry $tearoff 200x100] [update] [destroy .m1]
+} {{} {} {}}
+# 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} {
+    catch {destroy .m1}
+    menu .m1
+    list [destroy .m1]
+} {{}}
+test menuDraw-13.5 {TkMenuEventProc - nothing pending} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label foo
+    update idletasks
+    list [destroy .m1]
+} {{}}
+
+test menuDraw-14.1 {TkMenuImageProc} testImageType {
+    catch {destroy .m1}
+    catch {image delete image1}
+    menu .m1
+    image create test image1
+    .m1 add command -image image1
+    update idletasks
+    list [image delete image1] [destroy .m1]
+} {{} {}}
+test menuDraw-14.2 {TkMenuImageProc} testImageType {
+    catch {destroy .m1}
+    catch {image delete image1}
+    menu .m1
+    image create test image1
+    .m1 add command -image image1
+    list [image delete image1] [destroy .m1]
+} {{} {}}
+
+test menuDraw-15.1 {TkPostTearoffMenu - Basic posting} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
+} {0 {}}
+test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo" -state active
+    set tearoff [tk::TearOffMenu .m1 40 40]
+    list [$tearoff index active] [destroy .m1]
+} {none {}}
+test menuDraw-15.3 {TkPostTearoffMenu - post command} {
+    catch {destroy .m1}
+    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]
+} {0 .m1 {} {}}
+test menuDraw-15.4 {TkPostTearoffMenu - post command deleting the menu} {
+    catch {destroy .m1}
+    menu .m1 -postcommand "destroy .m1"
+    .m1 add command -label "foo"
+    list [catch {tk::TearOffMenu .m1 40 40} msg] $msg [winfo exists .m1]
+} {0 {} 0}
+test menuDraw-15.5 {TkPostTearoffMenu - tearoff at edge of screen} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    set height [winfo screenheight .m1]
+    list [catch {tk::TearOffMenu .m1 40 $height}] [destroy .m1]
+} {0 {}}
+test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add command -label "foo"
+    set width [winfo screenwidth .m1]
+    list [catch {tk::TearOffMenu .m1 $width 40}] [destroy .m1]
+} {0 {}}
+
+
+test menuDraw-16.1 {TkPostSubmenu} nonUnixUserInteraction {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    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
+    list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
+} {{} {} {}}
+test menuDraw-16.2 {TkPostSubMenu} nonUnixUserInteraction {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    catch {destroy .m3}
+    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
+    list [$tearoff postcascade 1] [destroy .m1] [destroy .m2] [destroy .m3]
+} {{} {} {} {}}
+test menuDraw-16.3 {TkPostSubMenu} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add cascade -label test -menu .m2
+    list [.m1 postcascade 1] [destroy .m1]
+} {{} {}}
+test menuDraw-16.4 {TkPostSubMenu} {
+    catch {destroy .m1}
+    menu .m1
+    .m1 add cascade -label test
+    set tearoff [tk::TearOffMenu .m1 40 40]
+    list [$tearoff postcascade 0] [destroy .m1]
+} {{} {}}
+test menuDraw-16.5 {TkPostSubMenu} unix {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    menu .m1
+    .m1 add cascade -label test -menu .m2
+    menu .m2 -postcommand "glorp"
+    set tearoff [tk::TearOffMenu .m1 40 40]
+    list [catch {$tearoff postcascade test} msg] $msg [destroy .m1] [destroy .m2]
+} {1 {invalid command name "glorp"} {} {}}
+test menuDraw-16.6 {TkPostSubMenu} {win userInteraction} {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    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]
+    list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
+} {{} {} {}}
+
+test menuDraw-17.1 {AdjustMenuCoords - menubar} unix {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    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 ""] [destroy .m1] [destroy .m2]
+} {{} {} {} {}}
+test menuDraw-17.2 {AdjustMenuCoords - menu} {win userInteraction} {
+    catch {destroy .m1}
+    catch {destroy .m2}
+    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]
+    list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
+} {{} {} {}}
+
+# cleanup
+deleteWindows
+cleanupTests
+return

tests/menubut.test

@@ -0,0 +1,341 @@
+# 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.1
+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 *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}
+
+eval image delete [image names]
+if {[testConstraint testImageType]} {
+    image create test image1
+}
+menubutton .mb -text "Test"
+pack .mb
+update
+set i 1
+foreach test {
+    {-activebackground #012345 #012345 non-existent
+	    {unknown color name "non-existent"}}
+    {-activeforeground #ff0000 #ff0000 non-existent
+	    {unknown color name "non-existent"}}
+    {-anchor nw nw bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}}
+    {-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"}}
+    {-bitmap questhead questhead badValue {bitmap "badValue" not defined}}
+    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
+    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
+    {-direction below below badValue {bad direction "badValue": must be above, below, flush, left, or right}}
+    {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}}
+    {-fg #110022 #110022 bogus {unknown color name "bogus"}}
+    {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}}
+    {-foreground #110022 #110022 bogus {unknown color name "bogus"}}
+    {-height 18 18 20.0 {expected integer but got "20.0"}}
+    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
+    {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}}
+    {-highlightthickness 18 18 badValue {bad screen distance "badValue"}}
+    {-image image1 image1 bogus {image "bogus" doesn't exist}}
+    {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}}
+    {-justify right right bogus {bad justification "bogus": must be left, right, or center}}
+    {-menu "any old string" "any old string" {} {}}
+    {-padx 12 12 420x {bad screen distance "420x"}}
+    {-pady 12 12 420x {bad screen distance "420x"}}
+    {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
+    {-state normal normal bogus {bad state "bogus": must be active, disabled, or normal}}
+    {-takefocus "any string" "any string" {} {}}
+    {-text "Sample text" {Sample text} {} {}}
+    {-textvariable i i {} {}}
+    {-underline 5 5 3p {expected integer but got "3p"}}
+    {-width 402 402 3p {expected integer but got "3p"}}
+    {-wraplength 100 100 6x {bad screen distance "6x"}}
+} {
+    set name [lindex $test 0]
+    test menubutton-1.$i {configuration options} testImageType {
+	.mb configure $name [lindex $test 1]
+	lindex [.mb configure $name] 4
+    } [lindex $test 2]
+    incr i
+    if {[lindex $test 3] != ""} {
+	test menubutton-1.$i {configuration options} {
+	    list [catch {.mb configure $name [lindex $test 3]} msg] $msg
+	} [list 1 [lindex $test 4]]
+    }
+    .mb configure $name [lindex [.mb configure $name] 3]
+    incr i
+}
+
+test menubutton-2.1 {Tk_MenubuttonCmd procedure} {
+    list [catch {menubutton} msg] $msg
+} {1 {wrong # args: should be "menubutton pathName ?options?"}}
+test menubutton-2.2 {Tk_MenubuttonCmd procedure} {
+    list [catch {menubutton foo} msg] $msg
+} {1 {bad window path name "foo"}}
+test menubutton-2.3 {Tk_MenubuttonCmd procedure} {
+    catch {destroy .mb}
+    menubutton .mb
+    winfo class .mb
+} {Menubutton}
+test menubutton-2.4 {Tk_ButtonCmd procedure} {
+    catch {destroy .mb}
+    list [catch {menubutton .mb -gorp foo} msg] $msg [winfo exists .mb]
+} {1 {unknown option "-gorp"} 0}
+
+catch {destroy .mb}
+menubutton .mb -text "Test Menu"
+pack .mb
+test menubutton-3.1 {MenuButtonWidgetCmd procedure} {
+    list [catch {.mb} msg] $msg
+} {1 {wrong # args: should be ".mb option ?arg arg ...?"}}
+test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} {
+    list [catch {.mb c} msg] $msg
+} {1 {ambiguous option "c": must be cget or configure}}
+test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} {
+    list [catch {.mb cget} msg] $msg
+} {1 {wrong # args: should be ".mb cget option"}}
+test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} {
+    list [catch {.mb cget a b} msg] $msg
+} {1 {wrong # args: should be ".mb cget option"}}
+test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} {
+    list [catch {.mb cget -gorp} msg] $msg
+} {1 {unknown option "-gorp"}}
+test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} {
+    .mb configure -highlightthickness 3
+    .mb cget -highlightthickness
+} {3}
+test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} {
+    llength [.mb configure]
+} {33}
+test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} {
+    list [catch {.mb configure -gorp} msg] $msg
+} {1 {unknown option "-gorp"}}
+test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} {
+    list [catch {.mb co -bg #ffffff -fg} msg] $msg
+} {1 {value for "-fg" missing}}
+test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} {
+    .mb configure -fg #123456
+    .mb configure -bg #654321
+    lindex [.mb configure -fg] 4
+} {#123456}
+test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} {
+    list [catch {.mb foobar} msg] $msg
+} {1 {bad option "foobar": must be cget or configure}}
+
+# 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} {
+    catch {destroy .mb1}
+    button .mb1 -text "Menubutton 1"
+    list [catch {.mb1 configure -width 1i} msg] $msg $errorInfo
+} {1 {expected integer but got "1i"} {expected integer but got "1i"
+    (processing -width option)
+    invoked from within
+".mb1 configure -width 1i"}}
+test menubutton-4.2 {ConfigureMenuButton procedure} {
+    catch {destroy .mb1}
+    button .mb1 -text "Menubutton 1"
+    list [catch {.mb1 configure -height 0.5c} msg] $msg $errorInfo
+} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c"
+    (processing -height option)
+    invoked from within
+".mb1 configure -height 0.5c"}}
+test menubutton-4.3 {ConfigureMenuButton procedure} {
+    catch {destroy .mb1}
+    button .mb1 -bitmap questhead
+    list [catch {.mb1 configure -width abc} msg] $msg $errorInfo
+} {1 {bad screen distance "abc"} {bad screen distance "abc"
+    (processing -width option)
+    invoked from within
+".mb1 configure -width abc"}}
+test menubutton-4.4 {ConfigureMenuButton procedure} testImageType {
+    catch {destroy .mb1}
+    eval image delete [image names]
+    image create test image1
+    button .mb1 -image image1
+    list [catch {.mb1 configure -height 0.5x} msg] $msg $errorInfo
+} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x"
+    (processing -height option)
+    invoked from within
+".mb1 configure -height 0.5x"}}
+test menubutton-4.5 {ConfigureMenuButton procedure} {nonPortable fonts} {
+    catch {destroy .mb1}
+    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]
+} {102 46 20 12}
+test menubutton-4.6 {ConfigureMenuButton procedure - bad direction} {
+    catch {destroy .mb}
+    menubutton .mb -text "Test"
+    list [catch {.mb configure -direction badValue} msg] $msg \
+	[.mb cget -direction] [destroy .mb]
+} {1 {bad direction "badValue": must be above, below, flush, left, or right} below {}}
+
+# XXX Need to add tests for several procedures here. XXX
+
+test menubutton-5.1 {MenuButtonEventProc procedure} {
+    deleteWindows
+    menubutton .mb1 -bg #543210
+    rename .mb1 .mb2
+    set x {}
+    lappend x [winfo children .]
+    lappend x [.mb2 cget -bg]
+    destroy .mb1
+    lappend x [info command .mb*] [winfo children .]
+} {.mb1 #543210 {} {}}
+
+test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} {
+    deleteWindows
+    menubutton .mb1
+    rename .mb1 {}
+    list [info command .mb*] [winfo children .]
+} {{} {}}
+
+test menubutton-7.1 {ComputeMenuButtonGeometry procedure} testImageType {
+    catch {destroy .mb}
+    menubutton .mb -image image1 -bd 4 -highlightthickness 0
+    pack .mb
+    list [winfo reqwidth .mb] [winfo reqheight .mb]
+} {38 23}
+test menubutton-7.2 {ComputeMenuButtonGeometry procedure} testImageType {
+    catch {destroy .mb}
+    menubutton .mb -image image1 -bd 1 -highlightthickness 2
+    pack .mb
+    list [winfo reqwidth .mb] [winfo reqheight .mb]
+} {36 21}
+test menubutton-7.3 {ComputeMenuButtonGeometry procedure} testImageType {
+    catch {destroy .mb}
+    menubutton .mb -image image1 -bd 0 -highlightthickness 2 -padx 5 -pady 5
+    pack .mb
+    list [winfo reqwidth .mb] [winfo reqheight .mb]
+} {34 19}
+test menubutton-7.4 {ComputeMenuButtonGeometry procedure} testImageType {
+    catch {destroy .mb}
+    menubutton .mb -image image1 -bd 2 -relief raised -width 40 \
+	    -highlightthickness 2
+    pack .mb
+    list [winfo reqwidth .mb] [winfo reqheight .mb]
+} {48 23}
+test menubutton-7.5 {ComputeMenuButtonGeometry procedure} testImageType {
+    catch {destroy .mb}
+    menubutton .mb -image image1 -bd 2 -relief raised -height 30 \
+	    -highlightthickness 2
+    pack .mb
+    list [winfo reqwidth .mb] [winfo reqheight .mb]
+} {38 38}
+test menubutton-7.6 {ComputeMenuButtonGeometry procedure} {
+    catch {destroy .mb}
+    menubutton .mb -bitmap question -bd 2 -relief raised \
+	    -highlightthickness 2
+    pack .mb
+    list [winfo reqwidth .mb] [winfo reqheight .mb]
+} {25 35}
+test menubutton-7.7 {ComputeMenuButtonGeometry procedure} {
+    catch {destroy .mb}
+    menubutton .mb -bitmap question -bd 2 -relief raised -width 40 \
+	    -highlightthickness 1
+    pack .mb
+    list [winfo reqwidth .mb] [winfo reqheight .mb]
+} {46 33}
+test menubutton-7.8 {ComputeMenuButtonGeometry procedure} {
+    catch {destroy .mb}
+    menubutton .mb -bitmap question -bd 2 -relief raised -height 50 \
+	    -highlightthickness 1
+    pack .mb
+    list [winfo reqwidth .mb] [winfo reqheight .mb]
+} {23 56}
+test menubutton-7.9 {ComputeMenuButtonGeometry procedure} {fonts} {
+    catch {destroy .mb}
+    menubutton .mb -text String -bd 2 -relief raised -padx 0 -pady 0 \
+	    -highlightthickness 1
+    pack .mb
+    list [winfo reqwidth .mb] [winfo reqheight .mb]
+} {42 20}
+test menubutton-7.10 {ComputeMenuButtonGeometry procedure} {fonts} {
+    catch {destroy .mb}
+    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]
+} {146 20}
+test menubutton-7.11 {ComputeMenuButtonGeometry procedure} {fonts} {
+    catch {destroy .mb}
+    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]
+} {42 34}
+test menubutton-7.12 {ComputeMenuButtonGeometry procedure} {fonts} {
+    catch {destroy .mb}
+    menubutton .mb -text String -bd 2 -relief raised -padx 10 -pady 5 \
+	    -highlightthickness 1
+    pack .mb
+    list [winfo reqwidth .mb] [winfo reqheight .mb]
+} {62 30}
+test menubutton-7.13 {ComputeMenuButtonGeometry procedure} {nonPortable fonts} {
+    catch {destroy .mb}
+    menubutton .mb -text String -bd 2 -relief raised \
+	    -highlightthickness 1 -indicatoron 1
+    pack .mb
+    list [winfo reqwidth .mb] [winfo reqheight .mb]
+} {78 28}
+test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {testImageType unix nonPortable} {
+    # The following test is non-portable because the indicator's pixel
+    # size varies to maintain constant absolute size.
+
+    catch {destroy .mb}
+    menubutton .mb -image image1 -bd 2 -relief raised \
+	    -highlightthickness 2 -indicatoron 1
+    pack .mb
+    list [winfo reqwidth .mb] [winfo reqheight .mb]
+} {64 23}
+test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {testImageType win nonPortable} {
+    # The following test is non-portable because the indicator's pixel
+    # size varies to maintain constant absolute size.
+
+    catch {destroy .mb}
+    menubutton .mb -image image1 -bd 2 -relief raised \
+	    -highlightthickness 2 -indicatoron 1
+    pack .mb
+    list [winfo reqwidth .mb] [winfo reqheight .mb]
+} {65 23}
+
+set l [interp hidden]
+deleteWindows
+
+test menubutton-8.1 {menubutton vs hidden commands} {
+    catch {destroy .mb}
+    menubutton .mb
+    interp hide {} .mb
+    destroy .mb
+    list [winfo children .] [interp hidden]
+} [list {} $l]
+
+eval image delete [image names]
+deleteWindows
+option clear
+
+# cleanup
+cleanupTests
+return

tests/message.test

@@ -0,0 +1,120 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+option add *Message.borderWidth 2
+option add *Message.highlightThickness 2
+option add *Message.font {Helvetica -12 bold}
+
+message .m
+pack .m
+update
+set i 0
+foreach test {
+    {-anchor w w bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}}
+    {-aspect 3 3 bogus {expected integer but got "bogus"}}
+    {-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"}}
+    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
+    {-fg #00ff00 #00ff00 badValue {unknown color name "badValue"}}
+    {-font fixed fixed {} {font "" doesn't exist}}
+    {-foreground green green badValue {unknown color name "badValue"}}
+    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
+    {-highlightcolor #123456 #123456 non-existent
+	    {unknown color name "non-existent"}}
+    {-highlightthickness 2 2 badValue {bad screen distance "badValue"}}
+    {-justify right right bogus {bad justification "bogus": must be left, right, or center}}
+    {-padx 12m 12m 420x {bad screen distance "420x"}}
+    {-pady 12m 12m 420x {bad screen distance "420x"}}
+    {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
+    {-text "Sample text" {Sample text} {} {} {1 1 1 1}}
+    {-textvariable i i {} {} {1 1 1 1}}
+    {-width 32 32 badValue {bad screen distance "badValue"}}
+} {
+    set name [lindex $test 0]
+    test message-1.$i {configuration options} {
+	.m configure $name [lindex $test 1]
+	lindex [.m configure $name] 4
+    } [lindex $test 2]
+    incr i
+    if {[lindex $test 3] != ""} {
+	test message-1.$i {configuration options} {
+	    list [catch {.m configure $name [lindex $test 3]} msg] $msg
+	} [list 1 [lindex $test 4]]
+    }
+    .m configure $name [lindex [.m configure $name] 3]
+    incr i
+}
+destroy .m
+
+test message-2.1 {Tk_MessageObjCmd procedure} {
+    list [catch {message} msg] $msg
+} {1 {wrong # args: should be "message pathName ?options?"}}
+test message-2.2 {Tk_MessageObjCmd procedure} {
+    list [catch {message foo} msg] $msg [winfo child .]
+} {1 {bad window path name "foo"} {}}
+test message-2.3 {Tk_MessageObjCmd procedure} {
+    list [catch {message .s -gorp dumb} msg] $msg [winfo child .]
+} {1 {unknown option "-gorp"} {}}
+
+test message-3.1 {MessageWidgetObjCmd procedure} {
+    message .m
+    set result [list [catch {.m} msg] $msg]
+    destroy .m
+    set result
+} {1 {wrong # args: should be ".m option ?arg arg ...?"}}
+test message-3.2 {MessageWidgetObjCmd procedure, "cget"} {
+    message .m
+    set result [list [catch {.m cget} msg] $msg]
+    destroy .m
+    set result
+} {1 {wrong # args: should be ".m cget option"}}
+test message-3.3 {MessageWidgetObjCmd procedure, "cget"} {
+    message .m
+    set result [list [catch {.m cget -gorp} msg] $msg]
+    destroy .m
+    set result
+} {1 {unknown option "-gorp"}}
+test message-3.4 {MessageWidgetObjCmd procedure, "cget"} {
+    message .m
+    .m configure -text foobar
+    set result [.m cget -text]
+    destroy .m
+    set result
+} "foobar"
+test message-3.5 {MessageWidgetObjCmd procedure, "configure"} {
+    message .m
+    set result [llength [.m configure]]
+    destroy .m
+    set result
+} 21
+test message-3.6 {MessageWidgetObjCmd procedure, "configure"} {
+    message .m
+    set result [list [catch {.m configure -foo} msg] $msg]
+    destroy .m
+    set result
+} {1 {unknown option "-foo"}}
+test message-3.7 {MessageWidgetObjCmd procedure, "configure"} {
+    message .m
+    .m configure -bd 4
+    .m configure -bg #ffffff
+    set result [lindex [.m configure -bd] 4]
+    destroy .m
+    set result
+} {4}
+
+# cleanup
+cleanupTests
+return

tests/msgbox.test

@@ -0,0 +1,175 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test msgbox-1.1 {tk_messageBox command} {
+    list [catch {tk_messageBox -foo} msg] $msg
+} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}}
+test msgbox-1.2 {tk_messageBox command} {
+    list [catch {tk_messageBox -foo bar} msg] $msg
+} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}}
+
+catch {tk_messageBox -foo bar} msg
+regsub -all ,      $msg "" options
+regsub \"-foo\" $options "" options
+
+foreach option $options {
+    if {[string index $option 0] eq "-"} {
+	test msgbox-1.3$option {tk_messageBox command} -body {
+	    tk_messageBox $option
+	} -returnCodes error -result "value for \"$option\" missing"
+    }
+}
+
+test msgbox-1.4 {tk_messageBox command} {
+    list [catch {tk_messageBox -default} msg] $msg
+} {1 {value for "-default" missing}}
+
+test msgbox-1.5 {tk_messageBox command} {
+    list [catch {tk_messageBox -type foo} msg] $msg
+} {1 {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}}
+
+proc createPlatformMsg {val} {
+    global tcl_platform
+    if {$tcl_platform(platform) == "unix"} {
+	return "invalid default button \"$val\""
+    }
+    return "bad -default value \"$val\": must be abort, retry, ignore, ok, cancel, no, or yes"
+}
+
+test msgbox-1.6 {tk_messageBox command} {
+    list [catch {tk_messageBox -default 1.1} msg] $msg
+} [list 1 [createPlatformMsg "1.1"]]
+
+test msgbox-1.7 {tk_messageBox command} {
+    list [catch {tk_messageBox -default foo} msg] $msg
+} [list 1 [createPlatformMsg "foo"]]
+
+test msgbox-1.8 {tk_messageBox command} {
+    list [catch {tk_messageBox -type yesno -default 3} msg] $msg
+} [list 1 [createPlatformMsg "3"]]
+
+test msgbox-1.9 {tk_messageBox command} {
+    list [catch {tk_messageBox -icon foo} msg] $msg
+} {1 {bad -icon value "foo": must be error, info, question, or warning}}
+
+test msgbox-1.10 {tk_messageBox command} {
+    list [catch {tk_messageBox -parent foo.bar} msg] $msg
+} {1 {bad window path name "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
+    }
+}
+
+set parent .
+
+set specs {
+    {"abortretryignore"  MB_ABORTRETRYIGNORE  3  {"abort"  "retry"  "ignore"}} 
+    {"ok"  		 MB_OK  	      1  {"ok"                      }} 
+    {"okcancel" 	 MB_OKCANCEL 	      2  {"ok"     "cancel"         }} 
+    {"retrycancel" 	 MB_RETRYCANCEL       2  {"retry"  "cancel"         }} 
+    {"yesno" 		 MB_YESNO 	      2  {"yes"    "no"             }} 
+    {"yesnocancel" 	 MB_YESNOCANCEL       3  {"yes"    "no"     "cancel"}}
+}
+
+#
+# Try out all combinations of (type) x (default button) and
+# (type) x (icon).
+#
+set count 1
+foreach spec $specs {
+    set type [lindex $spec 0]
+    set buttons [lindex $spec 3]
+
+    set button [lindex $buttons 0]
+    test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction {
+	ChooseMsg $parent $button
+	tk_messageBox -title Hi -message "Please press $button" \
+		-type $type
+    } $button
+    incr count
+
+    foreach icon {warning error info question} {
+	test msgbox-2.$count {tk_messageBox command -icon option} \
+		nonUnixUserInteraction {
+	    ChooseMsg $parent $button
+	    tk_messageBox -title Hi -message "Please press $button" \
+		    -type $type -icon $icon
+	} $button
+        incr count
+    }
+
+    foreach button $buttons {
+	test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction {
+	    ChooseMsg $parent $button
+	    tk_messageBox -title Hi -message "Please press $button" \
+		    -type $type -default $button
+	} "$button"
+        incr count
+    }
+}
+
+# These tests will hang your test suite if they fail.
+test msgbox-3.1 {tk_messageBox handles withdrawn parent} nonUnixUserInteraction {
+    wm withdraw .
+    ChooseMsg . "ok"
+    tk_messageBox -title Hi -message "Please press ok" \
+	    -type ok -default ok
+} "ok"
+wm deiconify .
+
+test msgbox-3.2 {tk_messageBox handles iconified parent} nonUnixUserInteraction {
+    wm iconify .
+    ChooseMsg . "ok"
+    tk_messageBox -title Hi -message "Please press ok" \
+	    -type ok -default ok
+} "ok"
+wm deiconify .
+
+# cleanup
+cleanupTests
+return

tests/obj.test

@@ -0,0 +1,30 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test obj-1.1 {TkGetPixelsFromObj} {
+} {}
+
+test obj-2.1 {FreePixelInternalRep} {
+} {}
+
+test obj-3.1 {DupPixelInternalRep} {
+} {}
+
+test obj-4.1 {SetPixelFromAny} {
+} {}
+
+
+
+deleteWindows
+
+# cleanup
+cleanupTests
+return

tests/oldpack.test

@@ -0,0 +1,509 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# First, test a single window packed in various ways in a parent
+
+catch {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} {
+    pack ap .pack .pack.red top
+    update
+    winfo geometry .pack.red
+} 10x20+45+0
+test oldpack-1.2 {basic positioning} {
+    pack append .pack .pack.red bottom
+    update
+    winfo geometry .pack.red
+} 10x20+45+80
+test oldpack-1.3 {basic positioning} {
+    pack append .pack .pack.red left
+    update
+    winfo geometry .pack.red
+} 10x20+0+40
+test oldpack-1.4 {basic positioning} {
+    pack append .pack .pack.red right
+    update
+    winfo geometry .pack.red
+} 10x20+90+40
+
+# Try adding padding around the window and make sure that the
+# window gets a larger frame.
+
+test oldpack-2.1 {padding} {
+    pack append .pack .pack.red {t padx 20}
+    update
+    winfo geometry .pack.red
+} 10x20+45+0
+test oldpack-2.2 {padding} {
+    pack append .pack .pack.red {top pady 20}
+    update
+    winfo geometry .pack.red
+} 10x20+45+10
+test oldpack-2.3 {padding} {
+    pack append .pack .pack.red {l padx 20}
+    update
+    winfo geometry .pack.red
+} 10x20+10+40
+test oldpack-2.4 {padding} {
+    pack append .pack .pack.red {left pady 20}
+    update
+    winfo geometry .pack.red
+} 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} {
+    pack append .pack .pack.red {b padx 20 pady 30}
+    update
+    winfo geometry .pack.red
+} 10x20+45+65
+test oldpack-3.2 {framing} {
+    pack append .pack .pack.red {bottom padx 20 pady 30 fr n}
+    update
+    winfo geometry .pack.red
+} 10x20+45+50
+test oldpack-3.3 {framing} {
+    pack append .pack .pack.red {bottom padx 20 pady 30 frame ne}
+    update
+    winfo geometry .pack.red
+} 10x20+90+50
+test oldpack-3.4 {framing} {
+    pack append .pack .pack.red {bottom padx 20 pady 30 frame e}
+    update
+    winfo geometry .pack.red
+} 10x20+90+65
+test oldpack-3.5 {framing} {
+    pack append .pack .pack.red {bottom padx 20 pady 30 frame se}
+    update
+    winfo geometry .pack.red
+} 10x20+90+80
+test oldpack-3.6 {framing} {
+    pack append .pack .pack.red {bottom padx 20 pady 30 frame s}
+    update
+    winfo geometry .pack.red
+} 10x20+45+80
+test oldpack-3.7 {framing} {
+    pack append .pack .pack.red {bottom padx 20 pady 30 frame sw}
+    update
+    winfo geometry .pack.red
+} 10x20+0+80
+test oldpack-3.8 {framing} {
+    pack append .pack .pack.red {bottom padx 20 pady 30 frame w}
+    update
+    winfo geometry .pack.red
+} 10x20+0+65
+test oldpack-3.9 {framing} {
+    pack append .pack .pack.red {bottom padx 20 pady 30 frame nw}
+    update
+    winfo geometry .pack.red
+} 10x20+0+50
+test oldpack-3.10 {framing} {
+    pack append .pack .pack.red {bottom padx 20 pady 30 frame c}
+    update
+    winfo geometry .pack.red
+} 10x20+45+65
+test oldpack-3.11 {framing} {
+    pack append .pack .pack.red {r padx 20 pady 30}
+    update
+    winfo geometry .pack.red
+} 10x20+80+40
+test oldpack-3.12 {framing} {
+    pack append .pack .pack.red {right padx 20 pady 30 frame n}
+    update
+    winfo geometry .pack.red
+} 10x20+80+0
+test oldpack-3.13 {framing} {
+    pack append .pack .pack.red {right padx 20 pady 30 frame ne}
+    update
+    winfo geometry .pack.red
+} 10x20+90+0
+test oldpack-3.14 {framing} {
+    pack append .pack .pack.red {right padx 20 pady 30 frame e}
+    update
+    winfo geometry .pack.red
+} 10x20+90+40
+test oldpack-3.15 {framing} {
+    pack append .pack .pack.red {right padx 20 pady 30 frame se}
+    update
+    winfo geometry .pack.red
+} 10x20+90+80
+test oldpack-3.16 {framing} {
+    pack append .pack .pack.red {right padx 20 pady 30 frame s}
+    update
+    winfo geometry .pack.red
+} 10x20+80+80
+test oldpack-3.17 {framing} {
+    pack append .pack .pack.red {right padx 20 pady 30 frame sw}
+    update
+    winfo geometry .pack.red
+} 10x20+70+80
+test oldpack-3.18 {framing} {
+    pack append .pack .pack.red {right padx 20 pady 30 frame w}
+    update
+    winfo geometry .pack.red
+} 10x20+70+40
+test oldpack-3.19 {framing} {
+    pack append .pack .pack.red {right padx 20 pady 30 frame nw}
+    update
+    winfo geometry .pack.red
+} 10x20+70+0
+test oldpack-3.20 {framing} {
+    pack append .pack .pack.red {right padx 20 pady 30 frame center}
+    update
+    winfo geometry .pack.red
+} 10x20+80+40
+
+# Try out various filling combinations in a couple of different
+# frame locations.
+
+test oldpack-4.1 {filling} {
+    pack append .pack .pack.red {bottom padx 20 pady 30 fillx}
+    update
+    winfo geometry .pack.red
+} 100x20+0+65
+test oldpack-4.2 {filling} {
+    pack append .pack .pack.red {bottom padx 20 pady 30 filly}
+    update
+    winfo geometry .pack.red
+} 10x50+45+50
+test oldpack-4.3 {filling} {
+    pack append .pack .pack.red {bottom padx 20 pady 30 fill}
+    update
+    winfo geometry .pack.red
+} 100x50+0+50
+test oldpack-4.4 {filling} {
+    pack append .pack .pack.red {right padx 20 pady 30 fillx}
+    update
+    winfo geometry .pack.red
+} 30x20+70+40
+test oldpack-4.5 {filling} {
+    pack append .pack .pack.red {right padx 20 pady 30 filly}
+    update
+    winfo geometry .pack.red
+} 10x100+80+0
+test oldpack-4.6 {filling} {
+    pack append .pack .pack.red {right padx 20 pady 30 fill}
+    update
+    winfo geometry .pack.red
+} 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} {winfo geometry .pack.red} 10x20+45+0
+test oldpack-5.2 {multiple windows} {winfo geometry .pack.green} 30x40+35+20
+test oldpack-5.3 {multiple windows} {winfo geometry .pack.blue} 40x40+30+60
+test oldpack-5.4 {multiple windows} {winfo ismapped .pack.violet} 0
+pack b .pack.blue .pack.violet top
+update
+test oldpack-5.5 {multiple windows} {winfo ismapped .pack.violet} 1
+test oldpack-5.6 {multiple windows} {winfo geometry .pack.violet} 80x20+10+60
+test oldpack-5.7 {multiple windows} {winfo geometry .pack.blue} 40x20+30+80
+pack after .pack.blue .pack.red top
+update
+test oldpack-5.8 {multiple windows} {winfo geometry .pack.green} 30x40+35+0
+test oldpack-5.9 {multiple windows} {winfo geometry .pack.violet} 80x20+10+40
+test oldpack-5.10 {multiple windows} {winfo geometry .pack.blue} 40x40+30+60
+test oldpack-5.11 {multiple windows} {winfo ismapped .pack.red} 0
+pack before .pack.green .pack.red right .pack.blue left
+update
+test oldpack-5.12 {multiple windows} {winfo ismapped .pack.red} 1
+test oldpack-5.13 {multiple windows} {winfo geometry .pack.red} 10x20+90+40
+test oldpack-5.14 {multiple windows} {winfo geometry .pack.blue} 40x40+0+30
+test oldpack-5.15 {multiple windows} {winfo geometry .pack.green} 30x40+50+0
+test oldpack-5.16 {multiple windows} {winfo geometry .pack.violet} 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} {winfo geometry .pack.violet} 80x20+0+40
+test oldpack-5.18 {multiple windows} {winfo geometry .pack.green} 20x40+80+60
+test oldpack-5.19 {multiple windows} {winfo geometry .pack.red} 10x20+85+40
+test oldpack-5.20 {multiple windows} {winfo geometry .pack.blue} 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} {winfo geometry .pack.blue} 40x40+30+0
+test oldpack-5.22 {multiple windows} {winfo geometry .pack.red} 10x20+90+60
+test oldpack-5.23 {multiple windows} {winfo geometry .pack.green} 30x40+60+50
+test oldpack-5.24 {multiple windows} {winfo geometry .pack.violet} 60x20+0+60
+pack after .pack.blue .pack.red left .pack.green left .pack.violet left
+update
+test oldpack-5.25 {multiple windows} {winfo geometry .pack.blue} 40x40+30+0
+test oldpack-5.26 {multiple windows} {winfo geometry .pack.red} 10x20+0+60
+test oldpack-5.27 {multiple windows} {winfo geometry .pack.green} 30x40+10+50
+test oldpack-5.28 {multiple windows} {winfo geometry .pack.violet} 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} {winfo geometry .pack.violet} 80x20+0+40
+test oldpack-5.30 {multiple windows} {winfo geometry .pack.green} 20x40+80+30
+test oldpack-5.31 {multiple windows} {winfo ismapped .pack.blue} 0
+test oldpack-5.32 {multiple windows} {winfo ismapped .pack.red} 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} {winfo reqwidth .pack} 80
+test oldpack-6.2 {geometry propagation} {winfo reqheight .pack} 120
+destroy .pack.violet
+update
+test oldpack-6.3 {geometry propagation} {winfo reqwidth .pack} 40
+test oldpack-6.4 {geometry propagation} {winfo reqheight .pack} 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} {winfo reqwidth .pack} 120
+test oldpack-6.6 {geometry propagation} {winfo reqheight .pack} 60
+pack append .pack .pack.violet top .pack.green top .pack.blue left \
+	.pack.red left
+update
+test oldpack-6.7 {geometry propagation} {winfo reqwidth .pack} 80
+test oldpack-6.8 {geometry propagation} {winfo reqheight .pack} 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} {
+    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]
+} {30x40+3+40 40x40+39+40 10x20+86+50}
+test oldpack-7.2 {multiple expanded windows} {
+    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]
+} {70x20+30+77 40x40+45+30 10x20+60+3}
+test oldpack-7.3 {multiple expanded windows} {
+    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]
+} {40x100+0+0 20x100+40+0 40x40+60+0}
+test oldpack-7.4 {multiple expanded windows} {
+    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]
+} {10x20+45+5 80x20+10+35 40x40+60+60}
+test oldpack-7.5 {multiple expanded windows} {
+    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]
+} {30x40+70+60 10x20+30+40}
+test oldpack-7.6 {multiple expanded windows} {
+    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]
+} {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} {
+    set msg ""
+    set result [catch {pack} msg]
+    concat $result $msg
+} {1 wrong # args: should be "pack option arg ?arg ...?"}
+test oldpack-8.2 {syntax errors} {
+    set msg ""
+    set result [catch {pack append} msg]
+    concat $result $msg
+} {1 wrong # args: should be "pack option arg ?arg ...?"}
+test oldpack-8.3 {syntax errors} {
+    set msg ""
+    set result [catch {pack gorp foo} msg]
+    concat $result $msg
+} {1 bad option "gorp": must be configure, forget, info, propagate, or slaves}
+test oldpack-8.4 {syntax errors} {
+    set msg ""
+    set result [catch {pack a .pack} msg]
+    concat $result $msg
+} {1 bad option "a": must be configure, forget, info, propagate, or slaves}
+test oldpack-8.5 {syntax errors} {
+    set msg ""
+    set result [catch {pack after foobar} msg]
+    concat $result $msg
+} {1 bad window path name "foobar"}
+test oldpack-8.6 {syntax errors} {
+    frame .pack.yellow -bg yellow
+    set msg ""
+    set result [catch {pack after .pack.yellow} msg]
+    destroy .pack.yellow
+    concat $result $msg
+} {1 window ".pack.yellow" isn't packed}
+test oldpack-8.7 {syntax errors} {
+    set msg ""
+    set result [catch {pack append foobar} msg]
+    concat $result $msg
+} {1 bad window path name "foobar"}
+test oldpack-8.8 {syntax errors} {
+    set msg ""
+    set result [catch {pack before foobar} msg]
+    concat $result $msg
+} {1 bad window path name "foobar"}
+test oldpack-8.9 {syntax errors} {
+    frame .pack.yellow -bg yellow
+    set msg ""
+    set result [catch {pack before .pack.yellow} msg]
+    destroy .pack.yellow
+    concat $result $msg
+} {1 window ".pack.yellow" isn't packed}
+test oldpack-8.10 {syntax errors} {
+    set msg ""
+    set result [catch {pack info .pack help} msg]
+    concat $result $msg
+} {1 wrong # args: should be "pack info window"}
+test oldpack-8.11 {syntax errors} {
+    set msg ""
+    set result [catch {pack info foobar} msg]
+    concat $result $msg
+} {1 bad window path name "foobar"}
+test oldpack-8.12 {syntax errors} {
+    set msg ""
+    set result [catch {pack append .pack .pack.blue} msg]
+    concat $result $msg
+} {1 wrong # args: window ".pack.blue" should be followed by options}
+test oldpack-8.13 {syntax errors} {
+    set msg ""
+    set result [catch {pack append . .pack.blue top} msg]
+    concat $result $msg
+} {1 can't pack .pack.blue inside .}
+test oldpack-8.14 {syntax errors} {
+    set msg ""
+    set result [catch {pack append .pack .pack.blue f} msg]
+    concat $result $msg
+} {1 bad option "f": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame}
+test oldpack-8.15 {syntax errors} {
+    set msg ""
+    set result [catch {pack append .pack .pack.blue pad} msg]
+    concat $result $msg
+} {1 bad option "pad": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame}
+test oldpack-8.16 {syntax errors} {
+    set msg ""
+    set result [catch {pack append .pack .pack.blue {frame south}} msg]
+    concat $result $msg
+} {1 bad anchor "south": must be n, ne, e, se, s, sw, w, nw, or center}
+test oldpack-8.17 {syntax errors} {
+    set msg ""
+    set result [catch {pack append .pack .pack.blue {padx -2}} msg]
+    concat $result $msg
+} {1 bad pad value "-2": must be positive screen distance}
+test oldpack-8.18 {syntax errors} {
+    set msg ""
+    set result [catch {pack append .pack .pack.blue {padx}} msg]
+    concat $result $msg
+} {1 wrong # args: "padx" option must be followed by screen distance}
+test oldpack-8.19 {syntax errors} {
+    set msg ""
+    set result [catch {pack append .pack .pack.blue {pady -2}} msg]
+    concat $result $msg
+} {1 bad pad value "-2": must be positive screen distance}
+test oldpack-8.20 {syntax errors} {
+    set msg ""
+    set result [catch {pack append .pack .pack.blue {pady}} msg]
+    concat $result $msg
+} {1 wrong # args: "pady" option must be followed by screen distance}
+test oldpack-8.21 {syntax errors} {
+    set msg ""
+    set result [catch {pack append .pack .pack.blue "\{abc"} msg]
+    concat $result $msg
+} {1 unmatched open brace in list}
+test oldpack-8.22 {syntax errors} {
+    set msg ""
+    set result [catch {pack append .pack .pack.blue frame} msg]
+    concat $result $msg
+} {1 wrong # args: "frame" option must be followed by anchor point}
+
+# Test "pack info" command output.
+
+test oldpack-9.1 {information output} {
+    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]
+} {{.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} {
+    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]
+} {{.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} {
+    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]
+} {{.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}}
+
+catch {destroy .pack}
+
+# cleanup
+cleanupTests
+return

tests/option.file1

@@ -0,0 +1,17 @@
+! 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:	  
+# comment line as last line of file.

tests/option.file2

@@ -0,0 +1,2 @@
+*foo1: magenta
+foo2 missing colon

tests/option.test

@@ -0,0 +1,227 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+testConstraint appNameIsTktest [expr {[winfo name .] eq "tktest"}]
+
+catch {destroy .op1}
+catch {destroy .op2}
+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
+
+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} {option get . x Color1} blue
+test option-1.2 {basic option retrieval} {option get . y Color1} red
+test option-1.3 {basic option retrieval} {option get . z Color1} red
+test option-1.4 {basic option retrieval} {option get . x Color2} blue
+test option-1.5 {basic option retrieval} {option get . y Color2} {}
+test option-1.6 {basic option retrieval} {option get . z Color2} {}
+
+test option-2.1 {basic option retrieval} {option get .op1 x Color1} green
+test option-2.2 {basic option retrieval} {option get .op1 y Color1} red
+test option-2.3 {basic option retrieval} {option get .op1 z Color1} red
+test option-2.4 {basic option retrieval} {option get .op1 x Color2} green
+test option-2.5 {basic option retrieval} {option get .op1 y Color2} {}
+test option-2.6 {basic option retrieval} {option get .op1 z Color2} {}
+
+test option-3.1 {basic option retrieval} {option get .op1.op3 x Color1} yellow
+test option-3.2 {basic option retrieval} {option get .op1.op3 y Color1} red
+test option-3.3 {basic option retrieval} {option get .op1.op3 z Color1} red
+test option-3.4 {basic option retrieval} {option get .op1.op3 x Color2} yellow
+test option-3.5 {basic option retrieval} {option get .op1.op3 y Color2} {}
+test option-3.6 {basic option retrieval} {option get .op1.op3 z Color2} {}
+
+test option-4.1 {basic option retrieval} {option get .op1.op3.op6 x Color1} blue
+test option-4.2 {basic option retrieval} {option get .op1.op3.op6 y Color1} red
+test option-4.3 {basic option retrieval} {option get .op1.op3.op6 z Color1} red
+test option-4.4 {basic option retrieval} {option get .op1.op3.op6 x Color2} black
+test option-4.5 {basic option retrieval} {option get .op1.op3.op6 y Color2} black
+test option-4.6 {basic option retrieval} {option get .op1.op3.op6 z Color2} black
+
+test option-5.1 {basic option retrieval} {option get .op1.op4 x Color1} blue
+test option-5.2 {basic option retrieval} {option get .op1.op4 y Color1} brown
+test option-5.3 {basic option retrieval} {option get .op1.op4 z Color1} red
+test option-5.4 {basic option retrieval} {option get .op1.op4 x Color2} blue
+test option-5.5 {basic option retrieval} {option get .op1.op4 y Color2} brown
+test option-5.6 {basic option retrieval} {option get .op1.op4 z Color2} {}
+
+test option-6.1 {basic option retrieval} {option get .op2 x Color1} orange
+test option-6.2 {basic option retrieval} {option get .op2 y Color1} orange
+test option-6.3 {basic option retrieval} {option get .op2 z Color1} orange
+test option-6.4 {basic option retrieval} {option get .op2 x Color2} blue
+test option-6.5 {basic option retrieval} {option get .op2 y Color2} {}
+test option-6.6 {basic option retrieval} {option get .op2 z Color2} {}
+
+test option-7.1 {basic option retrieval} {option get .op2.op5 x Color1} orange
+test option-7.2 {basic option retrieval} {option get .op2.op5 y Color1} orange
+test option-7.3 {basic option retrieval} {option get .op2.op5 z Color1} orange
+test option-7.4 {basic option retrieval} {option get .op2.op5 x Color2} purple
+test option-7.5 {basic option retrieval} {option get .op2.op5 y Color2} purple
+test option-7.6 {basic option retrieval} {option get .op2.op5 z Color2} 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} {option get .op2.op5 x Color1} orange
+test option-8.2 {stack pushing/popping} {option get .op2.op5 y Color1} orange
+test option-8.3 {stack pushing/popping} {option get .op2.op5 z Color1} orange
+test option-8.4 {stack pushing/popping} {option get .op2.op5 x Color2} purple
+test option-8.5 {stack pushing/popping} {option get .op2.op5 y Color2} purple
+test option-8.6 {stack pushing/popping} {option get .op2.op5 z Color2} purple
+
+test option-9.1 {stack pushing/popping} {option get . x Color1} blue
+test option-9.2 {stack pushing/popping} {option get . y Color1} red
+test option-9.3 {stack pushing/popping} {option get . z Color1} red
+test option-9.4 {stack pushing/popping} {option get . x Color2} blue
+test option-9.5 {stack pushing/popping} {option get . y Color2} {}
+test option-9.6 {stack pushing/popping} {option get . z Color2} {}
+
+test option-10.1 {stack pushing/popping} {option get .op1.op3.op6 x Color1} blue
+test option-10.2 {stack pushing/popping} {option get .op1.op3.op6 y Color1} red
+test option-10.3 {stack pushing/popping} {option get .op1.op3.op6 z Color1} red
+test option-10.4 {stack pushing/popping} {option get .op1.op3.op6 x Color2} black
+test option-10.5 {stack pushing/popping} {option get .op1.op3.op6 y Color2} black
+test option-10.6 {stack pushing/popping} {option get .op1.op3.op6 z Color2} black
+
+test option-11.1 {stack pushing/popping} {option get .op1.op3 x Color1} yellow
+test option-11.2 {stack pushing/popping} {option get .op1.op3 y Color1} red
+test option-11.3 {stack pushing/popping} {option get .op1.op3 z Color1} red
+test option-11.4 {stack pushing/popping} {option get .op1.op3 x Color2} yellow
+test option-11.5 {stack pushing/popping} {option get .op1.op3 y Color2} {}
+test option-11.6 {stack pushing/popping} {option get .op1.op3 z Color2} {}
+
+test option-12.1 {stack pushing/popping} {option get .op1 x Color1} green
+test option-12.2 {stack pushing/popping} {option get .op1 y Color1} red
+test option-12.3 {stack pushing/popping} {option get .op1 z Color1} red
+test option-12.4 {stack pushing/popping} {option get .op1 x Color2} green
+test option-12.5 {stack pushing/popping} {option get .op1 y Color2} {}
+test option-12.6 {stack pushing/popping} {option get .op1 z Color2} {}
+
+# Test the major priority levels (widgetDefault, etc.)
+
+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} {option get .op1 a A} 100
+test option-13.2 {priority levels} {option get .op1 b A} interactive
+test option-13.3 {priority levels} {option get .op1 b B} userDefault
+test option-13.4 {priority levels} {option get .op1 c B} startupFile
+test option-13.5 {priority levels} {option get .op1 c C} widgetDefault
+option add $appName.op1.B file2 widget
+test option-13.6 {priority levels} {option get .op1 c B} startupFile
+option add $appName.op1.B file2 startupFile
+test option-13.7 {priority levels} {option get .op1 c B} file2
+
+# Test various error conditions
+
+test option-14.1 {error conditions} {
+    list [catch {option} msg] $msg
+} {1 {wrong # args: should be "option cmd arg ?arg ...?"}}
+test option-14.2 {error conditions} {
+    list [catch {option x} msg] $msg
+} {1 {bad option "x": must be add, clear, get, or readfile}}
+test option-14.3 {error conditions} {
+    list [catch {option foo 3} msg] $msg
+} {1 {bad option "foo": must be add, clear, get, or readfile}}
+test option-14.4 {error conditions} {
+    list [catch {option add 3} msg] $msg
+} {1 {wrong # args: should be "option add pattern value ?priority?"}}
+test option-14.5 {error conditions} {
+    list [catch {option add . a b c} msg] $msg
+} {1 {wrong # args: should be "option add pattern value ?priority?"}}
+test option-14.6 {error conditions} {
+    list [catch {option add . a -1} msg] $msg
+} {1 {bad priority level "-1": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}}
+test option-14.7 {error conditions} {
+    list [catch {option add . a 101} msg] $msg
+} {1 {bad priority level "101": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}}
+test option-14.8 {error conditions} {
+    list [catch {option add . a gorp} msg] $msg
+} {1 {bad priority level "gorp": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}}
+test option-14.9 {error conditions} {
+    list [catch {option get 3} msg] $msg
+} {1 {wrong # args: should be "option get window name class"}}
+test option-14.10 {error conditions} {
+    list [catch {option get 3 4} msg] $msg
+} {1 {wrong # args: should be "option get window name class"}}
+test option-14.11 {error conditions} {
+    list [catch {option get 3 4 5 6} msg] $msg
+} {1 {wrong # args: should be "option get window name class"}}
+test option-14.12 {error conditions} {
+    list [catch {option get .gorp.gorp a A} msg] $msg
+} {1 {bad window path name ".gorp.gorp"}}
+
+set option1 [file join [testsDirectory] option.file1]
+set option2 [file join [testsDirectory] option.file2]
+
+test option-15.1 {database files} {
+    list [catch {option read non-existent} msg] $msg
+} {1 {couldn't open "non-existent": no such file or directory}}
+option read $option1
+test option-15.2 {database files} {option get . x1 color} blue
+test option-15.3 {database files} appNameIsTktest {option get . x2 color} green
+test option-15.4 {database files} {option get . x3 color} purple
+test option-15.5 {database files} {option get . {x 4} color} brown
+test option-15.6 {database files} {option get . x6 color} {}
+test option-15.7 {database files} {
+    list [catch {option read $option1 widget foo} msg] $msg
+} {1 {wrong # args: should be "option readfile fileName ?priority?"}}
+option add *x3 burgundy
+catch {option read $option1 userDefault}
+test option-15.8 {database files} {option get . x3 color} burgundy
+test option-15.9 {database files} {
+    list [catch {option read $option2} msg] $msg
+} {1 {missing colon on line 2}}
+
+test option-16.1 {ReadOptionFile} {
+    set option3 [makeFile {} option.file3]
+    set file [open $option3 w]
+    fconfigure $file -translation crlf
+    puts $file "*x7: true\n*x8: false"
+    close $file
+    option read $option3 userDefault
+    set result [list [option get . x7 color] [option get . x8 color]]
+    removeFile $option3
+    set result
+} {true false}
+
+catch {destroy .op1}
+catch {destroy .op2}
+
+# cleanup
+cleanupTests
+return

tests/place.test

@@ -0,0 +1,429 @@
+# 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.1
+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.
+
+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} {
+    place .t.f2 -x 0
+    place info .t.f2
+} {-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} {
+    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
+} {-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} {
+    # 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
+    set res [place info .t.f2]
+    destroy ".t.a b"
+    set res
+} {-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} {
+    list [catch {place .t.f2 -height abcd} msg] $msg
+} {1 {bad screen distance "abcd"}}
+test place-2.2 {ConfigureSlave procedure, -height option} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -height 40
+    update
+    winfo height .t.f2
+} {40}
+test place-2.3 {ConfigureSlave procedure, -height option} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -height 120
+    update
+    place .t.f2 -height {}
+    update
+    winfo height .t.f2
+} {60}
+
+test place-3.1 {ConfigureSlave procedure, -relheight option} {
+    list [catch {place .t.f2 -relheight abcd} msg] $msg
+} {1 {expected floating-point number but got "abcd"}}
+test place-3.2 {ConfigureSlave procedure, -relheight option} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -relheight .5
+    update
+    winfo height .t.f2
+} {40}
+test place-3.3 {ConfigureSlave procedure, -relheight option} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -relheight .8
+    update
+    place .t.f2 -relheight {}
+    update
+    winfo height .t.f2
+} {60}
+
+test place-4.1 {ConfigureSlave procedure, bad -in options} {
+    place forget .t.f2
+    list [catch {place .t.f2 -in .t.f2} msg] $msg
+} [list 1 "can't place .t.f2 relative to itself"]
+test place-4.2 {ConfigureSlave procedure, bad -in option} {
+    place forget .t.f2
+    list [winfo manager .t.f2] \
+        [catch {place .t.f2 -in .t.f2} err] $err \
+        [winfo manager .t.f2]
+} {{} 1 {can't place .t.f2 relative to itself} {}}
+test place-4.3 {ConfigureSlave procedure, bad -in option} {
+    place forget .t.f2
+    list [catch {place .t.f2 -in .} msg] $msg
+} [list 1 "can't place .t.f2 relative to ."]
+
+test place-5.1 {ConfigureSlave procedure, -relwidth option} {
+    list [catch {place .t.f2 -relwidth abcd} msg] $msg
+} {1 {expected floating-point number but got "abcd"}}
+test place-5.2 {ConfigureSlave procedure, -relwidth option} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -relwidth .5
+    update
+    winfo width .t.f2
+} {75}
+test place-5.3 {ConfigureSlave procedure, -relwidth option} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -relwidth .8
+    update
+    place .t.f2 -relwidth {}
+    update
+    winfo width .t.f2
+} {30}
+
+test place-6.1 {ConfigureSlave procedure, -width option} {
+    list [catch {place .t.f2 -width abcd} msg] $msg
+} {1 {bad screen distance "abcd"}}
+test place-6.2 {ConfigureSlave procedure, -width option} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -width 100
+    update
+    winfo width .t.f2
+} {100}
+test place-6.3 {ConfigureSlave procedure, -width option} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -width 120
+    update
+    place .t.f2 -width {}
+    update
+    winfo width .t.f2
+} {30}
+
+test place-7.1 {ReconfigurePlacement procedure, computing position} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -x -2 -relx .5 -y 3 -rely .4
+    update
+    winfo geometry .t.f2
+} {30x60+123+75}
+test place-7.2 {ReconfigurePlacement procedure, position rounding} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -x -1.4 -y -2.3
+    update
+    winfo geometry .t.f2
+} {30x60+49+38}
+test place-7.3 {ReconfigurePlacement procedure, position rounding} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -x 1.4 -y 2.3
+    update
+    winfo geometry .t.f2
+} {30x60+51+42}
+test place-7.4 {ReconfigurePlacement procedure, position rounding} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -x -1.6 -y -2.7
+    update
+    winfo geometry .t.f2
+} {30x60+48+37}
+test place-7.5 {ReconfigurePlacement procedure, position rounding} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -x 1.6 -y 2.7
+    update
+    winfo geometry .t.f2
+} {30x60+52+43}
+test place-7.6 {ReconfigurePlacement procedure, position rounding} {
+    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
+} {31x20+30+41}
+catch {destroy .t.f3}
+test place-7.7 {ReconfigurePlacement procedure, computing size} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -width 120 -height 89
+    update
+    list [winfo width .t.f2] [winfo height .t.f2]
+} {120 89}
+test place-7.8 {ReconfigurePlacement procedure, computing size} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -relwidth .4 -relheight .5
+    update
+    list [winfo width .t.f2] [winfo height .t.f2]
+} {60 40}
+test place-7.9 {ReconfigurePlacement procedure, computing size} {
+    place forget .t.f2
+    place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5
+    update
+    list [winfo width .t.f2] [winfo height .t.f2]
+} {70 36}
+test place-7.10 {ReconfigurePlacement procedure, computing size} {
+    place forget .t.f2
+    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]
+} {30 60}
+
+
+test place-8.1 {MasterStructureProc, mapping and unmapping slaves} {
+    place forget .t.f2
+    place forget .t.f
+    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]
+} {1 0 40 30 0 1}
+test place-8.2 {MasterStructureProc, mapping and unmapping slaves} {
+    place forget .t.f2
+    place forget .t.f
+    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]
+} {1 0 42 32 0 1}
+
+test place-9.1 {PlaceObjCmd} {
+    list [catch {place} msg] $msg
+} [list 1 "wrong # args: should be \"place option|pathName args\""]
+test place-9.2 {PlaceObjCmd} {
+    list [catch {place foo} msg] $msg
+} [list 1 "wrong # args: should be \"place option|pathName args\""]
+test place-9.3 {PlaceObjCmd} {
+    catch {destroy .foo}
+    list [catch {place .foo bar} msg] $msg
+} [list 1 "bad window path name \".foo\""]
+test place-9.4 {PlaceObjCmd} {
+    catch {destroy .foo}
+    list [catch {place bar .foo} msg] $msg
+} [list 1 "bad window path name \".foo\""]
+test place-9.5 {PlaceObjCmd} {
+    catch {destroy .foo}
+    frame .foo
+    set res [list [catch {place badopt .foo} msg] $msg]
+    destroy .foo
+    set res
+} [list 1 "bad option \"badopt\": must be configure, forget, info, or slaves"]
+test place-9.6 {PlaceObjCmd, configure errors} {
+    catch {destroy .foo}
+    frame .foo
+    set res [list [catch {place configure .foo} msg] $msg]
+    destroy .foo
+    set res
+} [list 0 ""]
+test place-9.7 {PlaceObjCmd, configure errors} {
+    catch {destroy .foo}
+    frame .foo
+    set res [list [catch {place configure .foo bar} msg] $msg]
+    destroy .foo
+    set res
+} [list 0 ""]
+test place-9.8 {PlaceObjCmd, configure} {
+    catch {destroy .foo}
+    frame .foo
+    place .foo -x 0 -y 0
+    set res [place configure .foo]
+    destroy .foo
+    set res
+} [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} {
+    catch {destroy .foo}
+    frame .foo
+    place .foo -x 0 -y 0
+    set res [place configure .foo -x]
+    destroy .foo
+    set res
+} [list -x {} {} 0 0]
+test place-9.10 {PlaceObjCmd, forget errors} {
+    catch {destroy .foo}
+    frame .foo
+    set res [list [catch {place forget .foo bar} msg] $msg]
+    destroy .foo
+    set res
+} [list 1 "wrong # args: should be \"place forget pathName\""]
+test place-9.11 {PlaceObjCmd, info errors} {
+    catch {destroy .foo}
+    frame .foo
+    set res [list [catch {place info .foo bar} msg] $msg]
+    destroy .foo
+    set res
+} [list 1 "wrong # args: should be \"place info pathName\""]
+test place-9.12 {PlaceObjCmd, slaves errors} {
+    catch {destroy .foo}
+    frame .foo
+    set res [list [catch {place slaves .foo bar} msg] $msg]
+    destroy .foo
+    set res
+} [list 1 "wrong # args: should be \"place slaves pathName\""]
+    
+test place-10.1 {ConfigureSlave} {
+    catch {destroy .foo}
+    frame .foo
+    set res [list [catch {place .foo -badopt} msg] $msg]
+    destroy .foo
+    set res
+} [list 1 "unknown option \"-badopt\""]
+test place-10.2 {ConfigureSlave} {
+    catch {destroy .foo}
+    frame .foo
+    set res [list [catch {place .foo -anchor} msg] $msg]
+    destroy .foo
+    set res
+} [list 1 "value for \"-anchor\" missing"]
+test place-10.3 {ConfigureSlave} {
+    catch {destroy .foo}
+    frame .foo
+    set res [list [catch {place .foo -bordermode j} msg] $msg]
+    destroy .foo
+    set res
+} [list 1 "bad bordermode \"j\": must be inside, outside, or ignore"]
+test place-10.4 {ConfigureSlave} {
+    catch {destroy .foo}
+    frame .foo
+    set res [list [catch {place configure .foo -x 0 -y} msg] $msg]
+    destroy .foo
+    set res
+} [list 1 "value for \"-y\" missing"]
+	
+test place-11.1 {PlaceObjCmd, slaves command} {
+    catch {destroy .foo}
+    frame .foo
+    set res [place slaves .foo]
+    destroy .foo
+    set res
+} {}
+test place-11.2 {PlaceObjCmd, slaves command} {
+    catch {destroy .foo .bar}
+    frame .foo
+    frame .bar
+    place .bar -in .foo
+    set res [place slaves .foo]
+    destroy .foo
+    destroy .bar
+    set res
+} [list .bar]
+
+test place-12.1 {PlaceObjCmd, forget command} {
+    catch {destroy .foo}
+    frame .foo
+    place .foo -width 50 -height 50
+    update
+    set res [winfo ismapped .foo]
+    place forget .foo
+    update
+    lappend res [winfo ismapped .foo]
+    destroy .foo
+    set res
+} [list 1 0]
+
+test place-13.1 {test respect for internalborder} {
+    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]
+    destroy .pack
+    set res
+} {196x188+2+10 177x186+5+7}
+
+test place-14.1 {memory leak testing} -setup {
+    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
+    }
+} -constraints memory -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
+    }
+} -result {0 0 0} -cleanup {
+    destroy .f
+    rename getbytes {}
+    rename stress {}
+}
+
+catch {destroy .t}
+
+# cleanup
+cleanupTests
+return

tests/raise.test

@@ -0,0 +1,287 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# 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} {
+    raise_setup
+    tkwait visibility .raise.e
+    raise_getOrder
+} {d d d b c e e e}
+test raise-1.2 {preserve creation order} testmakeexist {
+    raise_setup
+    testmakeexist .raise.a
+    update
+    raise_getOrder
+} {d d d b c e e e}
+test raise-1.3 {preserve creation order} testmakeexist {
+    raise_setup
+    testmakeexist .raise.c
+    update
+    raise_getOrder
+} {d d d b c e e e}
+test raise-1.4 {preserve creation order} testmakeexist {
+    raise_setup
+    testmakeexist .raise.e
+    update
+    raise_getOrder
+} {d d d b c e e e}
+test raise-1.5 {preserve creation order} testmakeexist {
+    raise_setup
+    testmakeexist .raise.d .raise.c .raise.b
+    update
+    raise_getOrder
+} {d d d b c e e e}
+
+test raise-2.1 {raise internal windows before creation} {
+    raise_setup
+    raise .raise.a
+    update
+    raise_getOrder
+} {a d d a c a e e}
+test raise-2.2 {raise internal windows before creation} {
+    raise_setup
+    raise .raise.c
+    update
+    raise_getOrder
+} {d d c b c e e c}
+test raise-2.3 {raise internal windows before creation} {
+    raise_setup
+    raise .raise.e
+    update
+    raise_getOrder
+} {d d d b c e e e}
+test raise-2.4 {raise internal windows before creation} {
+    raise_setup
+    raise .raise.e .raise.a
+    update
+    raise_getOrder
+} {d d d b c e b c}
+test raise-2.5 {raise internal windows before creation} {
+    raise_setup
+    raise .raise.a .raise.d
+    update
+    raise_getOrder
+} {a d d a c e e e}
+
+test raise-3.1 {raise internal windows after creation} {
+    raise_setup
+    update
+    raise .raise.a .raise.d
+    raise_getOrder
+} {a d d a c e e e}
+test raise-3.2 {raise internal windows after creation} testmakeexist {
+    raise_setup
+    testmakeexist .raise.a .raise.b
+    raise .raise.a .raise.b
+    update
+    raise_getOrder
+} {d d d a c e e e}
+test raise-3.3 {raise internal windows after creation} testmakeexist {
+    raise_setup
+    testmakeexist .raise.a .raise.d
+    raise .raise.a .raise.b
+    update
+    raise_getOrder
+} {d d d a c e e e}
+test raise-3.4 {raise internal windows after creation} testmakeexist {
+    raise_setup
+    testmakeexist .raise.a .raise.c .raise.d
+    raise .raise.a .raise.b
+    update
+    raise_getOrder
+} {d d d a c e e e}
+
+test raise-4.1 {raise relative to nephews} {
+    raise_setup
+    update
+    frame .raise.d.child
+    raise .raise.a .raise.d.child
+    raise_getOrder
+} {a d d a c e e e}
+test raise-4.2 {raise relative to nephews} {
+    raise_setup
+    update
+    frame .raise2
+    list [catch {raise .raise.a .raise2} msg] $msg
+} {1 {can't raise ".raise.a" above ".raise2"}}
+catch {destroy .raise2}
+
+test raise-5.1 {lower internal windows} {
+    raise_setup
+    update
+    lower .raise.d
+    raise_getOrder
+} {a b c b c e e e}
+test raise-5.2 {lower internal windows} {
+    raise_setup
+    update
+    lower .raise.d .raise.b
+    raise_getOrder
+} {d b c b c e e e}
+test raise-5.3 {lower internal windows} {
+    raise_setup
+    update
+    lower .raise.a .raise.e
+    raise_getOrder
+} {a d d a c e e e}
+test raise-5.4 {lower internal windows} {
+    raise_setup
+    update
+    frame .raise2
+    list [catch {lower .raise.a .raise2} msg] $msg
+} {1 {can't lower ".raise.a" below ".raise2"}}
+catch {destroy .raise2}
+
+test raise-6.1 {raise/lower toplevel windows} {nonPortable} {
+    raise_makeToplevels
+    update
+    raise .raise1
+    winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
+} .raise1
+test raise-6.2 {raise/lower toplevel windows} {nonPortable} {
+    raise_makeToplevels
+    update
+    raise .raise2
+    winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
+} .raise2
+test raise-6.3 {raise/lower toplevel windows} {nonPortable} {
+    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]]
+} {.raise2 .raise1}
+test raise-6.4 {raise/lower toplevel windows} {nonPortable} {
+    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]]
+} {.raise1 .raise3}
+test raise-6.5 {raise/lower toplevel windows} {nonPortable} {
+    raise_makeToplevels
+    raise .raise1
+    set time [lindex [time {raise .raise1}] 0]
+    expr {$time < 2000000}
+} 1
+test raise-6.6 {raise/lower toplevel windows} {nonPortable} {
+    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]]
+} {.raise1 .raise3}
+
+test raise-7.1 {errors in raise/lower commands} {
+    list [catch {raise} msg] $msg
+} {1 {wrong # args: should be "raise window ?aboveThis?"}}
+test raise-7.2 {errors in raise/lower commands} {
+    list [catch {raise a b c} msg] $msg
+} {1 {wrong # args: should be "raise window ?aboveThis?"}}
+test raise-7.3 {errors in raise/lower commands} {
+    list [catch {raise badName} msg] $msg
+} {1 {bad window path name "badName"}}
+test raise-7.4 {errors in raise/lower commands} {
+    list [catch {raise . badName2} msg] $msg
+} {1 {bad window path name "badName2"}}
+test raise-7.5 {errors in raise/lower commands} {
+    list [catch {lower} msg] $msg
+} {1 {wrong # args: should be "lower window ?belowThis?"}}
+test raise-7.6 {errors in raise/lower commands} {
+    list [catch {lower a b c} msg] $msg
+} {1 {wrong # args: should be "lower window ?belowThis?"}}
+test raise-7.7 {errors in raise/lower commands} {
+    list [catch {lower badName3} msg] $msg
+} {1 {bad window path name "badName3"}}
+test raise-7.8 {errors in raise/lower commands} {
+    list [catch {lower . badName4} msg] $msg
+} {1 {bad window path name "badName4"}}
+
+deleteWindows
+
+# cleanup
+cleanupTests
+return

tests/safe.test

@@ -0,0 +1,216 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+## 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:
+
+if {[string equal $tcl_platform(platform) "windows"]} {
+    set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection socket source tk_chooseColor tk_chooseDirectory tk_getOpenFile tk_getSaveFile tk_messageBox toplevel unload wm}
+} else {
+    set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection send socket source toplevel unload wm}
+}
+
+set saveAutoPath $::auto_path
+set auto_path [list [info library] $::tk_library]
+
+test safe-1.1 {Safe Tk loading into an interpreter} {
+    catch {safe::interpDelete a}
+    safe::loadTk [safe::interpCreate a]
+    safe::interpDelete a
+    set x {}
+    set x
+} ""
+test safe-1.2 {Safe Tk loading into an interpreter} {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set l [lsort [interp hidden a]]
+    safe::interpDelete a
+    set l
+} $hidden_cmds
+test safe-1.3 {Safe Tk loading into an interpreter} -body {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set l [lsort [interp aliases a]]
+    safe::interpDelete a
+    set l
+} -match glob -result {*encoding*exit*file*load*source*}
+
+test safe-2.1 {Unsafe commands not available} {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set status broken
+    if {[catch {interp eval a {toplevel .t}} msg]} {
+	set status ok
+    }
+    safe::interpDelete a
+    set status
+} ok
+test safe-2.2 {Unsafe commands not available} {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set status broken
+    if {[catch {interp eval a {menu .m}} msg]} {
+	set status ok
+    }
+    safe::interpDelete a
+    set status
+} ok
+test safe-2.3 {Unsafe subcommands not available} {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set status broken
+    if {[catch {interp eval a {tk appname}} msg]} {
+	set status ok
+    }
+    safe::interpDelete a
+    list $status $msg
+} {ok {appname not accessible in a safe interpreter}}
+test safe-2.4 {Unsafe subcommands not available} {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set status broken
+    if {[catch {interp eval a {tk scaling}} msg]} {
+	set status ok
+    }
+    safe::interpDelete a
+    list $status $msg
+} {ok {scaling not accessible in a safe interpreter}}
+
+test safe-3.1 {Unsafe commands are available hidden} {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set status ok
+    if {[catch {interp invokehidden a toplevel .t} msg]} {
+	set status broken
+    }
+    safe::interpDelete a
+    set status
+} ok
+test safe-3.2 {Unsafe commands are available hidden} {
+    catch {safe::interpDelete a}
+    safe::interpCreate a
+    safe::loadTk a
+    set status ok
+    if {[catch {interp invokehidden a menu .m} msg]} {
+	set status broken
+    }
+    safe::interpDelete a
+    set status
+} ok
+
+test safe-4.1 {testing loadTk} {
+    # 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
+} {}
+
+test safe-4.2 {testing loadTk -use} {
+    set w .safeTkFrame
+    catch {destroy $w}
+    frame $w -container 1;
+    pack .safeTkFrame
+    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
+} {}
+
+test safe-5.1 {loading Tk in safe interps without master's clearance} {
+    set i [safe::interpCreate]
+    catch {interp eval $i {load {} Tk}} msg
+    safe::interpDelete $i
+    set msg
+} {not allowed to start Tk by master's safe::TkInit}
+
+test safe-5.2 {multi-level Tk loading with clearance} {
+    # No error shall occur in that test and no window
+    # shall remain at the end.
+    set i [safe::interpCreate]
+    set j [list $i x]
+    set j [safe::interpCreate $j]
+    safe::loadTk $j
+    interp eval $j {
+	button .b -text Ok -command {destroy .}
+	pack .b
+#	tkwait window . ; # for interactive testing/debugging
+    }
+    safe::interpDelete $j
+    safe::interpDelete $i
+} {}
+
+test safe-6.1 {loadTk -use windowPath} {
+    set w .safeTkFrame
+    catch {destroy $w}
+    frame $w -container 1;
+    pack .safeTkFrame
+    set i [safe::loadTk [safe::interpCreate] -use $w]
+    interp eval $i {button .b -text "hello world!"; pack .b}
+    safe::interpDelete $i
+    destroy $w
+} {}
+
+test safe-6.2 {loadTk -use windowPath, conflicting -display} {
+    set w .safeTkFrame
+    catch {destroy $w}
+    frame $w -container 1;
+    pack .safeTkFrame
+    set i     [safe::interpCreate]
+    catch {safe::loadTk $i -use $w -display :23.56} msg
+    safe::interpDelete $i
+    destroy $w
+    string range $msg 0 36
+} {conflicting -display :23.56 and -use }
+
+
+test safe-7.1 {canvas printing} {
+    set i [safe::loadTk [safe::interpCreate]]
+    set r [catch {interp eval $i {canvas .c; .c postscript}}]
+    safe::interpDelete $i
+    set r
+} 0
+
+# cleanup
+set ::auto_path $saveAutoPath
+unset hidden_cmds
+cleanupTests
+return

tests/scale.test

@@ -0,0 +1,870 @@
+# 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.1
+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}
+
+scale .s -from 100 -to 300
+pack .s
+update
+set i 1
+foreach test {
+    {-activebackground #ff0000 #ff0000 non-existent
+	    {unknown color name "non-existent"}}
+    {-background #ff0000 #ff0000 non-existent
+	    {unknown color name "non-existent"}}
+    {-bd 4 4 badValue {bad screen distance "badValue"}}
+    {-bigincrement 12.5 12.5 badValue
+	    {expected floating-point number but got "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} {} {}}
+    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
+    {-digits 5 5 badValue {expected integer but got "badValue"}}
+    {-fg #00ff00 #00ff00 badValue {unknown color name "badValue"}}
+    {-font fixed fixed {} {font "" doesn't exist}}
+    {-foreground green green badValue {unknown color name "badValue"}}
+    {-from -15.0 -15.0 badValue
+	    {expected floating-point number but got "badValue"}}
+    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
+    {-highlightcolor #123456 #123456 non-existent
+	    {unknown color name "non-existent"}}
+    {-highlightthickness 2 2 badValue {bad screen distance "badValue"}}
+    {-label "Some text" {Some text} {} {}}
+    {-length 130 130 badValue {bad screen distance "badValue"}}
+    {-orient horizontal horizontal badValue
+	    {bad orient "badValue": must be horizontal or vertical}}
+    {-orient horizontal horizontal {} {}}
+    {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
+    {-repeatdelay 14 14 bogus {expected integer but got "bogus"}}
+    {-repeatinterval 14 14 bogus {expected integer but got "bogus"}}
+    {-resolution 2.0 2.0 badValue
+	    {expected floating-point number but got "badValue"}}
+    {-showvalue 0 0 badValue {expected boolean value but got "badValue"}}
+    {-sliderlength 86 86 badValue {bad screen distance "badValue"}}
+    {-sliderrelief raised raised badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
+    {-state d disabled badValue
+	    {bad state "badValue": must be active, disabled, or normal}}
+    {-state n normal {} {}}
+    {-takefocus "any string" "any string" {} {}}
+    {-tickinterval 4.3 4.0 badValue
+	    {expected floating-point number but got "badValue"}}
+    {-to 14.9 15.0 badValue
+	    {expected floating-point number but got "badValue"}}
+    {-troughcolor #ff0000 #ff0000 non-existent
+	    {unknown color name "non-existent"}}
+    {-variable x x {} {}}
+    {-width 32 32 badValue {bad screen distance "badValue"}}
+} {
+    set name [lindex $test 0]
+    test scale-1.$i {configuration options} {
+	.s configure $name [lindex $test 1]
+	lindex [.s configure $name] 4
+    } [lindex $test 2]
+    incr i
+    if {[lindex $test 3] ne ""} {
+	test scale-1.$i {configuration options} {
+	    list [catch {.s configure $name [lindex $test 3]} msg] $msg
+	} [list 1 [lindex $test 4]]
+    }
+    .s configure $name [lindex [.s configure $name] 3]
+    incr i
+}
+destroy .s
+
+test scale-2.1 {Tk_ScaleCmd procedure} {
+    list [catch {scale} msg] $msg
+} {1 {wrong # args: should be "scale pathName ?options?"}}
+test scale-2.2 {Tk_ScaleCmd procedure} {
+    list [catch {scale foo} msg] $msg [winfo child .]
+} {1 {bad window path name "foo"} {}}
+test scale-2.3 {Tk_ScaleCmd procedure} {
+    list [catch {scale .s -gorp dumb} msg] $msg [winfo child .]
+} {1 {unknown option "-gorp"} {}}
+
+scale .s -from 100 -to 200
+pack .s
+update idletasks
+test scale-3.1 {ScaleWidgetCmd procedure} {
+    list [catch {.s} msg] $msg
+} {1 {wrong # args: should be ".s option ?arg arg ...?"}}
+test scale-3.2 {ScaleWidgetCmd procedure, cget option} {
+    list [catch {.s cget} msg] $msg
+} {1 {wrong # args: should be ".s cget option"}}
+test scale-3.3 {ScaleWidgetCmd procedure, cget option} {
+    list [catch {.s cget a b} msg] $msg
+} {1 {wrong # args: should be ".s cget option"}}
+test scale-3.4 {ScaleWidgetCmd procedure, cget option} {
+    list [catch {.s cget -gorp} msg] $msg
+} {1 {unknown option "-gorp"}}
+test scale-3.5 {ScaleWidgetCmd procedure, cget option} {
+    .s cget -highlightthickness
+} {2}
+test scale-3.6 {ScaleWidgetCmd procedure, configure option} {
+    list [llength [.s configure]] [lindex [.s configure] 6]
+} {33 {-command command Command {} {}}}
+test scale-3.7 {ScaleWidgetCmd procedure, configure option} {
+    list [catch {.s configure -foo} msg] $msg
+} {1 {unknown option "-foo"}}
+test scale-3.8 {ScaleWidgetCmd procedure, configure option} {
+    list [catch {.s configure -borderwidth 2 -bg} msg] $msg
+} {1 {value for "-bg" missing}}
+test scale-3.9 {ScaleWidgetCmd procedure, coords option} {
+    list [catch {.s coords a b} msg] $msg
+} {1 {wrong # args: should be ".s coords ?value?"}}
+test scale-3.10 {ScaleWidgetCmd procedure, coords option} {
+    list [catch {.s coords bad} msg] $msg
+} {1 {expected floating-point number but got "bad"}}
+test scale-3.11 {ScaleWidgetCmd procedure} {fonts} {
+    .s set 120
+    .s coords
+} {38 34}
+test scale-3.12 {ScaleWidgetCmd procedure, coords option} {fonts} {
+    .s configure -orient horizontal
+    update
+    .s set 120
+    .s coords
+} {34 31}
+.s configure -orient vertical
+update
+test scale-3.13 {ScaleWidgetCmd procedure, get option} {
+    list [catch {.s get a} msg] $msg
+} {1 {wrong # args: should be ".s get ?x y?"}}
+test scale-3.14 {ScaleWidgetCmd procedure, get option} {
+    list [catch {.s get a b c} msg] $msg
+} {1 {wrong # args: should be ".s get ?x y?"}}
+test scale-3.15 {ScaleWidgetCmd procedure, get option} {
+    list [catch {.s get a 11} msg] $msg
+} {1 {expected integer but got "a"}}
+test scale-3.16 {ScaleWidgetCmd procedure, get option} {
+    list [catch {.s get 12 b} msg] $msg
+} {1 {expected integer but got "b"}}
+test scale-3.17 {ScaleWidgetCmd procedure, get option} {
+    .s set 133
+    .s get
+} 133
+test scale-3.18 {ScaleWidgetCmd procedure, get option} {
+    .s configure -resolution 0.5
+    .s set 150
+    .s get 37 34
+} 119.5
+.s configure -resolution 1
+test scale-3.19 {ScaleWidgetCmd procedure, identify option} {
+    list [catch {.s identify} msg] $msg
+} {1 {wrong # args: should be ".s identify x y"}}
+test scale-3.20 {ScaleWidgetCmd procedure, identify option} {
+    list [catch {.s identify 1 2 3} msg] $msg
+} {1 {wrong # args: should be ".s identify x y"}}
+test scale-3.21 {ScaleWidgetCmd procedure, identify option} {
+    list [catch {.s identify boo 16} msg] $msg
+} {1 {expected integer but got "boo"}}
+test scale-3.22 {ScaleWidgetCmd procedure, identify option} {
+    list [catch {.s identify 17 bad} msg] $msg
+} {1 {expected integer but got "bad"}}
+test scale-3.23 {ScaleWidgetCmd procedure, identify option} {fonts} {
+    .s set 120
+    list [.s identify 35 10] [.s identify 35 30] [.s identify 35 80] [.s identify 5 80]
+} {trough1 slider trough2 {}}
+test scale-3.24 {ScaleWidgetCmd procedure, set option} {
+    list [catch {.s set} msg] $msg
+} {1 {wrong # args: should be ".s set value"}}
+test scale-3.25 {ScaleWidgetCmd procedure, set option} {
+    list [catch {.s set a b} msg] $msg
+} {1 {wrong # args: should be ".s set value"}}
+test scale-3.26 {ScaleWidgetCmd procedure, set option} {
+    list [catch {.s set bad} msg] $msg
+} {1 {expected floating-point number but got "bad"}}
+test scale-3.27 {ScaleWidgetCmd procedure, set option} {
+    .s set 142
+} {}
+test scale-3.28 {ScaleWidgetCmd procedure, set option} {
+    .s set 118
+    .s configure -state disabled
+    .s set 181
+    .s configure -state normal
+    .s get
+} {118}
+test scale-3.29 {ScaleWidgetCmd procedure} {
+    list [catch {.s dumb} msg] $msg
+} {1 {bad option "dumb": must be cget, configure, coords, get, identify, or set}}
+test scale-3.30 {ScaleWidgetCmd procedure} {
+    list [catch {.s c} msg] $msg
+} {1 {ambiguous option "c": must be cget, configure, coords, get, identify, or set}}
+test scale-3.31 {ScaleWidgetCmd procedure} {
+    list [catch {.s co} msg] $msg
+} {1 {ambiguous option "co": must be cget, configure, coords, get, identify, or set}}
+test scale-3.32 {ScaleWidgetCmd procedure, Tk_Preserve} {
+    proc kill args {
+	destroy .s
+    }
+    catch {destroy .s}
+    scale .s -variable x -from 0 -to 100 -orient horizontal
+    pack .s
+    update
+    .s configure -command kill
+    .s set 55
+} {}
+
+test scale-4.1 {DestroyScale procedure} {
+    catch {destroy .s}
+    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
+} {0 foo foo}
+
+test scale-5.1 {ConfigureScale procedure} {
+    catch {destroy .s}
+    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]
+} {0 foo foo 77}
+test scale-5.2 {ConfigureScale procedure} {
+    catch {destroy .s}
+    scale .s -from 0 -to 100
+    list [catch {.s configure -foo bar} msg] $msg
+} {1 {unknown option "-foo"}}
+test scale-5.3 {ConfigureScale procedure} {
+    catch {destroy .s}
+    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 [catch {set x} msg] $msg
+} {0 0 92 3 0 3}
+test scale-5.4 {ConfigureScale procedure} {
+    catch {destroy .s}
+    scale .s -from 0 -to 100
+    list [catch {.s configure -orient dumb} msg] $msg
+} {1 {bad orient "dumb": must be horizontal or vertical}}
+test scale-5.5 {ConfigureScale procedure} {
+    catch {destroy .s}
+    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]]
+} {1.1 1.9 0.8}
+test scale-5.6 {ConfigureScale procedure} {
+    catch {destroy .s}
+    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]
+} {2.0 -2.0}
+test scale-5.7 {ConfigureScale procedure} {
+    catch {destroy .s}
+    list [catch {scale .s -from 0 -to 100 -state bogus} msg] $msg
+} {1 {bad state "bogus": must be active, disabled, or normal}}
+
+catch {destroy .s}
+scale .s -orient horizontal -length 200
+pack .s
+test scale-6.1 {ComputeFormat procedure} {
+    .s configure -from 10 -to 100 -resolution 10
+    .s set 49.3
+    .s get
+} {50}
+test scale-6.2 {ComputeFormat procedure} {
+    .s configure -from 100 -to 1000 -resolution 100
+    .s set 493
+    .s get
+} {500}
+test scale-6.3 {ComputeFormat procedure} {
+    .s configure -from 1000 -to 10000 -resolution 1000
+    .s set 4930
+    .s get
+} {5000}
+test scale-6.4 {ComputeFormat procedure} {
+    .s configure -from 10000 -to 100000 -resolution 10000
+    .s set 49000
+    .s get
+} {50000}
+test scale-6.5 {ComputeFormat procedure} {
+    .s configure -from 100000 -to 1000000 -resolution 100000
+    .s set 493000
+    .s get
+} {500000}
+test scale-6.6 {ComputeFormat procedure} {nonPortable} {
+    # 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
+} {5000000}
+test scale-6.7 {ComputeFormat procedure} {
+    .s configure -from 1000000000 -to 10000000000 -resolution 1000000000
+    .s set 4930000000
+    expr {[.s get] == 5.0e+09}
+} 1
+test scale-6.8 {ComputeFormat procedure} {
+    .s configure -from .1 -to 1 -resolution .1
+    .s set .6
+    .s get
+} {0.6}
+test scale-6.9 {ComputeFormat procedure} {
+    .s configure -from .01 -to .1 -resolution .01
+    .s set .06
+    .s get
+} {0.06}
+test scale-6.10 {ComputeFormat procedure} {
+    .s configure -from .001 -to .01 -resolution .001
+    .s set .006
+    .s get
+} {0.006}
+test scale-6.11 {ComputeFormat procedure} {
+    .s configure -from .0001 -to .001 -resolution .0001
+    .s set .0006
+    .s get
+} {0.0006}
+test scale-6.12 {ComputeFormat procedure} {
+    .s configure -from .00001 -to .0001 -resolution .00001
+    .s set .00006
+    .s get
+} {0.00006}
+test scale-6.13 {ComputeFormat procedure} {
+    .s configure -from .000001 -to .00001 -resolution .000001
+    .s set .000006
+    expr {[.s get] == 6.0e-06}
+} {1}
+test scale-6.14 {ComputeFormat procedure} {
+    .s configure -to .00001 -from .0001 -resolution .00001
+    .s set .00006
+    .s get
+} {0.00006}
+test scale-6.15 {ComputeFormat procedure} {
+    .s configure -to .000001 -from .00001 -resolution .000001
+    .s set .000006
+    expr {[.s get] == 6.0e-06}
+} {1}
+test scale-6.16 {ComputeFormat procedure} {
+    .s configure -from .00001 -to .0001 -resolution .00001 -digits 1
+    .s set .00006
+    expr {[.s get] == 6e-05}
+} {1}
+test scale-6.17 {ComputeFormat procedure} {
+    .s configure -from 10000000 -to 100000000 -resolution 10000000 -digits 3
+    .s set 49300000
+    .s get
+} {50000000}
+test scale-6.18 {ComputeFormat procedure} {
+    .s configure -length 200 -from 0 -to 10 -resolution 0 -digits 0
+    .s set .111111111
+    .s get
+} {0.11}
+test scale-6.19 {ComputeFormat procedure} {
+    .s configure -length 200 -from 1000 -to 1002 -resolution 0 -digits 0
+    .s set 1001.23456789
+    .s get
+} {1001.23}
+test scale-6.20 {ComputeFormat procedure} {
+    .s configure -length 200 -from 1000 -to 1001.8 -resolution 0 -digits 0
+    .s set 1001.23456789
+    .s get
+} {1001.235}
+
+test scale-7.1 {ComputeScaleGeometry procedure} {nonPortable fonts} {
+    catch {destroy .s}
+    scale .s -from 0 -to 10 -label "Short" -orient vertical -length 5i
+    pack .s
+    update
+    list [winfo reqwidth .s] [winfo reqheight .s]
+} {88 458}
+test scale-7.2 {ComputeScaleGeometry procedure} {fonts} {
+    catch {destroy .s}
+    scale .s -from 0 -to 1000 -label "Long string" -orient vertical -tick 200
+    pack .s
+    update
+    list [winfo reqwidth .s] [winfo reqheight .s]
+} {168 108}
+test scale-7.3 {ComputeScaleGeometry procedure} {fonts} {
+    catch {destroy .s}
+    scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -width 10 \
+	    -sliderlength 10
+    pack .s
+    update
+    list [winfo reqwidth .s] [winfo reqheight .s]
+} {22 108}
+test scale-7.4 {ComputeScaleGeometry procedure} {fonts} {
+    catch {destroy .s}
+    scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -bd 5 \
+	    -relief sunken
+    pack .s
+    update
+    list [winfo reqwidth .s] [winfo reqheight .s]
+} {39 114}
+test scale-7.5 {ComputeScaleGeometry procedure} {nonPortable fonts} {
+    catch {destroy .s}
+    scale .s -from 0 -to 10 -label "Short" -orient horizontal -length 5i
+    pack .s
+    update
+    list [winfo reqwidth .s] [winfo reqheight .s]
+} {458 61}
+test scale-7.6 {ComputeScaleGeometry procedure} {fonts} {
+    catch {destroy .s}
+    scale .s -from 0 -to 1000 -label "Long string" -orient horizontal \
+	    -tick 500
+    pack .s
+    update
+    list [winfo reqwidth .s] [winfo reqheight .s]
+} {108 79}
+test scale-7.7 {ComputeScaleGeometry procedure} {fonts} {
+    catch {destroy .s}
+    scale .s -from 0 -to 1000 -orient horizontal -showvalue 0
+    pack .s
+    update
+    list [winfo reqwidth .s] [winfo reqheight .s]
+} {108 27}
+test scale-7.8 {ComputeScaleGeometry procedure} {
+    catch {destroy .s}
+    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]
+} {114 39}
+
+test scale-8.1 {ScaleElement procedure} {fonts} {
+    catch {destroy .s}
+    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]
+} {{} trough1 trough1 {}}
+test scale-8.2 {ScaleElement procedure} {fonts} {
+    catch {destroy .s}
+    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]
+} {{} trough1 trough2 {}}
+test scale-8.3 {ScaleElement procedure} {fonts} {
+    catch {destroy .s}
+    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] \
+} {trough1 slider slider trough2}
+test scale-8.4 {ScaleElement procedure} {
+    catch {destroy .s}
+    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] \
+} {{} trough1 trough1 {}}
+test scale-8.5 {ScaleElement procedure} {fonts} {
+    catch {destroy .s}
+    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]
+} {{} trough2 trough2 {}}
+test scale-8.6 {ScaleElement procedure} {fonts} {
+    catch {destroy .s}
+    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]
+} {{} trough2 trough2 {}}
+test scale-8.7 {ScaleElement procedure} {
+    catch {destroy .s}
+    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]
+} {{} trough1 trough1 {}}
+test scale-8.8 {ScaleElement procedure} {
+    catch {destroy .s}
+    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]
+} {{} trough1 trough2 {}}
+test scale-8.9 {ScaleElement procedure} {
+    catch {destroy .s}
+    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]
+} {trough1 slider slider trough2}
+
+catch {destroy .s}
+scale .s -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+pack .s
+update
+test scale-9.1 {PixelToValue procedure} {
+    .s get 46 0
+} 0
+test scale-9.2 {PixelToValue procedure} {
+    .s get -10 9
+} 0
+test scale-9.3 {PixelToValue procedure} {
+    .s get -10 12
+} 1
+test scale-9.4 {PixelToValue procedure} {
+    .s get -10 46
+} 35
+test scale-9.5 {PixelToValue procedure} {
+    .s get -10 110
+} 99
+test scale-9.6 {PixelToValue procedure} {
+    .s get -10 111
+} 100
+test scale-9.7 {PixelToValue procedure} {
+    .s get -10 112
+} 100
+test scale-9.8 {PixelToValue procedure} {
+    .s get -10 154
+} 100
+.s configure -orient horizontal
+update
+test scale-9.9 {PixelToValue procedure} {
+    .s get 76 152
+} 65
+
+test scale-10.1 {ValueToPixel procedure} {fonts} {
+    catch {destroy .s}
+    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]
+} {{16 47} {56 47} {116 47}}
+test scale-10.2 {ValueToPixel procedure} {fonts} {
+    catch {destroy .s}
+    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]
+} {{62 114} {62 74} {62 14}}
+
+test scale-11.1 {ScaleEventProc procedure} {
+    proc killScale value {
+	global x
+	if {$value > 30} {
+	    destroy .s1
+	    lappend x [winfo exists .s1] [info commands .s1]
+	}
+    }
+    catch {destroy .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
+    rename killScale {}
+    set x
+} {initial 1 0 {}}
+test scale-11.2 {ScaleEventProc procedure} {
+    deleteWindows
+    scale .s1 -bg #543210
+    rename .s1 .s2
+    set x {}
+    lappend x [winfo children .]
+    lappend x [.s2 cget -bg]
+    destroy .s1
+    lappend x [info command .s*] [winfo children .]
+} {.s1 #543210 {} {}}
+
+test scale-12.1 {ScaleCmdDeletedProc procedure} {
+    deleteWindows
+    scale .s1
+    rename .s1 {}
+    list [info command .s*] [winfo children .]
+} {{} {}}
+
+catch {destroy .s}
+scale .s -from 0 -to 100 -command {set x} -variable y
+pack .s
+update
+proc varTrace args {
+    global traceInfo
+    set traceInfo $args
+}
+test scale-13.1 {SetScaleValue procedure} {
+    set x xyzzy
+    .s set 44
+    set result [list $x $y]
+    update
+    lappend result $x $y
+} {xyzzy 44 44 44}
+test scale-13.2 {SetScaleValue procedure} {
+    .s set -3
+    .s get
+} 0
+test scale-13.3 {SetScaleValue procedure} {
+    .s set 105
+    .s get
+} 100
+.s configure -from 100 -to 0
+test scale-13.4 {SetScaleValue procedure} {
+    .s set -3
+    .s get
+} 0
+test scale-13.5 {SetScaleValue procedure} {
+    .s set 105
+    .s get
+} 100
+test scale-13.6 {SetScaleValue procedure} {
+    .s set 50
+    update
+    trace variable y w varTrace
+    set traceInfo empty
+    set x untouched
+    .s set 50
+    update
+    list $x $traceInfo
+} {untouched empty}
+
+catch {destroy .s}
+scale .s -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 -orient horizontal
+pack .s
+update
+.s configure -resolution 4.0
+update
+test scale-14.1 {RoundToResolution procedure} {
+    .s get 84 152
+} 72
+test scale-14.2 {RoundToResolution procedure} {
+    .s get 86 152
+} 76
+.s configure -from 100 -to 0
+update
+test scale-14.3 {RoundToResolution procedure} {
+    .s get 84 152
+} 28
+test scale-14.4 {RoundToResolution procedure} {
+    .s get 86 152
+} 24
+.s configure -from -100 -to 0
+update
+test scale-14.5 {RoundToResolution procedure} {
+    .s get 84 152
+} -28
+test scale-14.6 {RoundToResolution procedure} {
+    .s get 86 152
+} -24
+.s configure -from 0 -to -100
+update
+test scale-14.7 {RoundToResolution procedure} {
+    .s get 84 152
+} -72
+test scale-14.8 {RoundToResolution procedure} {
+    .s get 86 152
+} -76
+.s configure -from 0 -to 2.25 -resolution 0
+update
+test scale-14.9 {RoundToResolution procedure} {
+    .s get 84 152
+} 1.64
+test scale-14.10 {RoundToResolution procedure} {
+    .s get 86 152
+} 1.69
+.s configure -from 0 -to 225 -resolution 0  -digits 5
+update
+test scale-14.11 {RoundToResolution procedure} {
+    .s get 84 152
+} 164.25
+test scale-14.12 {RoundToResolution procedure} {
+    .s get 86 152
+} 168.75
+
+test scale-15.1 {ScaleVarProc procedure} {
+    catch {destroy .s}
+    set y -130
+    scale .s -from 0 -to -200 -variable y -orient horizontal -length 150
+    pack .s
+    set y
+} -130
+test scale-15.2 {ScaleVarProc procedure} {
+    catch {destroy .s}
+    set y -130
+    scale .s -from -200 -to 0 -variable y -orient horizontal -length 150
+    pack .s
+    set y -87
+    .s get
+} -87
+test scale-15.3 {ScaleVarProc procedure} {
+    catch {destroy .s}
+    set y -130
+    scale .s -from -200 -to 0 -variable y -orient horizontal -length 150
+    pack .s
+    list [catch {set y 40q} msg] $msg [.s get]
+} {1 {can't set "y": can't assign non-numeric value to scale variable} -130}
+test scale-15.4 {ScaleVarProc procedure} {
+    catch {destroy .s}
+    set y 1
+    scale .s -from 1 -to 0 -variable y -orient horizontal -length 150
+    pack .s
+    list [catch {set y x} msg] $msg [.s get]
+} {1 {can't set "y": can't assign non-numeric value to scale variable} 1}
+test scale-15.5 {ScaleVarProc procedure, variable deleted} {
+    catch {destroy .s}
+    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
+} {0 6 6 untouched}
+test scale-15.6 {ScaleVarProc procedure, don't call -command} {
+    catch {destroy .s}
+    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]
+} {untouched 60}
+
+set l [interp hidden]
+deleteWindows
+
+test scale-16.1 {scale widget vs hidden commands} {
+    catch {destroy .s}
+    scale .s
+    interp hide {} .s
+    destroy .s
+    list [winfo children .] [interp hidden]
+} [list {} $l]
+
+test scale-17.1 {bug fix 1786} {
+    # 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)
+    set x
+} {100}
+
+test scale-18.1 {DestroyScale, -cursor option [Bug: 3897]} {
+    catch {destroy .s}
+    scale .s -cursor trek
+    destroy .s
+} {}
+
+test scale-18.2 {Scale button 1 events [Bug 787065]} \
+    -setup {
+        catch {destroy .s}
+        set y 5
+        scale .s -from 0 -to 10 -variable y -orient horizontal -length 150
+        pack .s
+        tkwait visibility .s
+        set ::error {}
+        proc bgerror {args} {set ::error $args}
+    } \
+    -body {
+        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 {}
+        catch {destroy .s}
+    } \
+    -result {0 {}}
+
+test scale-18.3 {Scale button 2 events [Bug 787065]} \
+    -setup {
+        catch {destroy .s}
+        set y 5
+        scale .s -from 0 -to 10 -variable y -orient horizontal -length 150
+        pack .s
+        tkwait visibility .s
+        set ::error {}
+        proc bgerror {args} {set ::error $args}
+    } \
+    -body {
+        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 {}
+        catch {destroy .s}
+    } \
+    -result {0 {}}
+
+catch {destroy .s}
+option clear
+
+# cleanup
+cleanupTests
+return

tests/scrollbar.test

@@ -0,0 +1,640 @@
+# 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 type "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 type "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 ?options?"}
+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 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 {bad 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]
+
+catch {destroy .s}
+catch {destroy .t}
+
+# cleanup
+cleanupTests
+return

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 {bad option "-gorp": must be -async, -displayof, or --}}
+test send-8.5 {Tk_SendCmd procedure, options} {secureserver} {
+    list [catch {send -async foo} msg] $msg
+} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}}
+test send-8.6 {Tk_SendCmd procedure, options} {secureserver} {
+    list [catch {send foo} msg] $msg
+} {1 {wrong # args: should be "send ?options? 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

tests/textBTree.test

@@ -0,0 +1,898 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+catch {destroy .t}
+text .t
+.t debug on
+
+test btree-1.1 {basic insertions} {
+    .t delete 1.0 100000.0
+    .t insert 1.0 "Line 1\nLine 2\nLine 3"
+    .t get 1.0 1000000.0
+} "Line 1\nLine 2\nLine 3\n"
+test btree-1.2 {basic insertions} {
+    .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
+} "LinXXXe 1\nLine 2\nLine 3\n"
+test btree-1.3 {basic insertions} {
+    .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
+} "Line 1\nLine 2\nYYYLine 3\n"
+test btree-1.4 {basic insertions} {
+    .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
+} "Line 1\nLX\nYYine 2\nLine 3\n"
+test btree-1.5 {basic insertions} {
+    .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
+} "Line 1\nX\n\n\nLine 2\nLine 3\n"
+test btree-1.6 {basic insertions} {
+    .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
+} "Line 1\nLine 2X\n\nLine 3\n"
+test btree-1.7 {insertion before start of text} {
+    .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
+} "XXXLine 1\nLine 2\nLine 3\n"
+test btree-1.8 {insertion past end of text} {
+    .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
+} "Line 1\nLine 2\nLine 3ZZ\n"
+test btree-1.9 {insertion before start of line} {
+    .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
+} "Line 1\nQLine 2\nLine 3\n"
+test btree-1.10 {insertion past end of line} {
+    .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
+} "Line 1\nLine 2XYZZY\nLine 3\n"
+test btree-1.11 {insertion past end of last line} {
+    .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
+} "Line 1\nLine 2\nLine 3ABC\n"
+
+test btree-2.1 {basic deletions} {
+    .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
+} "e 1\nLine 2\nLine 3\n"
+test btree-2.2 {basic deletions} {
+    .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
+} "Line 1\nLie 2\nLine 3\n"
+test btree-2.3 {basic deletions} {
+    .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
+} "Line 1\ne 2\nLine 3\n"
+test btree-2.4 {deleting whole lines} {
+    .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
+} "LiLine 3\n"
+test btree-2.5 {deleting whole lines} {
+    .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
+} "ne 5\n"
+test btree-2.6 {deleting before start of file} {
+    .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
+} "ne 1\nLine 2\nLine 3\n"
+test btree-2.7 {deleting after end of file} {
+    .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
+} "Line 1\nLine 2\nLine 3\n"
+test btree-2.8 {deleting before start of line} {
+    .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
+} "Line 1\nLine 2\ne 3\n"
+test btree-2.9 {deleting before start of line} {
+    .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
+} "Line 1\nLine 2\nLine 3\n"
+test btree-2.10 {deleting after end of line} {
+    .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
+} "Line 1ine 2\nLine 3\n"
+test btree-2.11 {deleting after end of last line} {
+    .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
+} "Line 1\nLine 2\nLine 3\n"
+test btree-2.12 {deleting before start of file} {
+    .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
+} "Line 1\nLine 2\nLine 3\n"
+test btree-2.13 {deleting past end of file} {
+    .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
+} "Line 1\n"
+test btree-2.14 {deleting with end before start of line} {
+    .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
+} "LinLine 2\nLine 3\n"
+test btree-2.15 {deleting past end of line} {
+    .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
+} "Lin\nLine 2\nLine 3\n"
+test btree-2.16 {deleting past end of line} {
+    .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
+} "Line 1\nLine 2\nLi\n"
+test btree-2.17 {deleting past end of line} {
+    .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
+} "Line 1\nLine 2\n\n"
+test btree-2.18 {deleting past end of line} {
+    .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
+} "\n"
+test btree-2.19 {deleting with negative range} {
+    .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
+} "Line 1\nLine 2\nLine 3\n"
+test btree-2.20 {deleting with negative range} {
+    .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
+} "Line 1\nLine 2\nLine 3\n"
+test btree-2.21 {deleting with negative range} {
+    .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
+} "Line 1\nLine 2\nLine 3\n"
+
+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
+}
+
+test btree-3.1 {inserting with tags} {
+    setup
+    .t insert 1.0 XXX
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.4 1.5 1.8 1.16 2.2 2.6} {1.8 1.9}}
+test btree-3.2 {inserting with tags} {
+    setup
+    .t insert 1.15 YYY
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.1 1.2 1.5 1.13 2.2 2.6} {1.5 1.6}}
+test btree-3.3 {inserting with tags} {
+    setup
+    .t insert 1.7 ZZZZ
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.1 1.2 1.5 1.17 2.2 2.6} {1.5 1.6}}
+test btree-3.4 {inserting with tags} {
+    setup
+    .t insert 1.7 \n\n
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.1 1.2 1.5 3.6 4.2 4.6} {1.5 1.6}}
+test btree-3.5 {inserting with tags} {
+    setup
+    .t insert 1.5 A\n
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.1 1.2 2.0 2.8 3.2 3.6} {2.0 2.1}}
+test btree-3.6 {inserting with tags} {
+    setup
+    .t insert 1.13 A\n
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.1 1.2 1.5 1.13 3.2 3.6} {1.5 1.6}}
+
+test btree-4.1 {deleting with tags} {
+    setup
+    .t delete 1.6 1.9
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}}
+test btree-4.2 {deleting with tags} {
+    setup
+    .t delete 1.1 2.3
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.1 1.4} {}}
+test btree-4.3 {deleting with tags} {
+    setup
+    .t delete 1.4 2.1
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.1 1.2 1.5 1.9} {}}
+test btree-4.4 {deleting with tags} {
+    setup
+    .t delete 1.14 2.1
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.1 1.2 1.5 1.13 1.15 1.19} {1.5 1.6}}
+test btree-4.5 {deleting with tags} {
+    setup
+    .t delete 1.0 2.10
+    list [.t tag ranges x] [.t tag ranges y]
+} {{} {}}
+test btree-4.6 {deleting with tags} {
+    setup
+    .t delete 1.0 1.5
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.0 1.8 2.2 2.6} {1.0 1.1}}
+test btree-4.7 {deleting with tags} {
+    setup
+    .t delete 1.6 1.9
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}}
+test btree-4.8 {deleting with tags} {
+    setup
+    .t delete 1.5 1.13
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.1 1.2 2.2 2.6} {}}
+
+set bigText1 {}
+for {set i 0} {$i < 10} {incr i} {
+    append bigText1 "Line $i\n"
+}
+set bigText2 {}
+for {set i 0} {$i < 200} {incr i} {
+    append bigText2 "Line $i\n"
+}
+test btree-5.1 {very large inserts, with tags} {
+    setup
+    .t insert 1.0 $bigText1
+    list [.t tag ranges x] [.t tag ranges y]
+} {{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
+    .t insert 1.2 $bigText2
+    list [.t tag ranges x] [.t tag ranges y]
+} {{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} {
+    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]
+} {{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
+    .t insert 1.1 $bigText2
+    .t delete 1.2 201.2
+    list [.t tag ranges x] [.t tag ranges y]
+} {{1.4 1.12 2.2 2.6} {1.4 1.5}}
+test btree-6.2 {very large deletes, with tags} {
+    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]
+} {{1.4 1.12 2.2 2.6} {1.4 1.5}}
+test btree-6.3 {very large deletes, with tags} {
+    setup
+    .t insert 1.1 $bigText2
+    .t delete 2.3 10000.0
+    .t get 1.0 1000.0
+} {TLine 0
+Lin
+}
+test btree-6.4 {very large deletes, with tags} {
+    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]
+} {{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
+    .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]
+} {{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
+    .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]
+} {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}}
+
+.t delete 1.0 end
+.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+set i 1
+foreach check {
+    {1.3 1.6 1.7 2.0 {1.3 1.6 1.7 2.0}}
+    {1.3 1.6 1.6 2.0 {1.3 2.0}}
+    {1.3 1.6 1.4 2.0 {1.3 2.0}}
+    {2.0 4.3 1.4 1.10 {1.4 1.10 2.0 4.3}}
+    {2.0 4.3 1.4 1.end {1.4 1.19 2.0 4.3}}
+    {2.0 4.3 1.4 2.0 {1.4 4.3}}
+    {2.0 4.3 1.4 3.0 {1.4 4.3}}
+    {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 4.2 {1.1 4.2}}
+    {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.3 4.2 {1.2 4.2}}
+    {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 3.0 {1.1 4.0}}
+    {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.2 3.0 {1.2 4.0}}
+} {
+    test btree-7.$i {tag addition and removal} {
+	.t tag remove x 1.0 end
+	while {[llength $check] > 2} {
+	    .t tag add x [lindex $check 0] [lindex $check 1]
+	    set check [lrange $check 2 end]
+	}
+	.t tag ranges x
+    } [lindex $check [expr [llength $check]-1]]
+    incr i
+}
+
+test btree-8.1 {tag addition and removal, weird ranges} {
+    .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
+} {1.0 1.3}
+test btree-8.2 {tag addition and removal, weird ranges} {
+    .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
+} {1.19 2.4}
+test btree-8.3 {tag addition and removal, weird ranges} {
+    .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
+} {}
+test btree-8.4 {tag addition and removal, weird ranges} {
+    .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
+} {}
+test btree-8.5 {tag addition and removal, weird ranges} {
+    .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
+} {1.1 5.0}
+test btree-8.6 {tag addition and removal, weird ranges} {
+    .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
+} {1.1 1.19}
+test btree-8.7 {tag addition and removal, weird ranges} {
+    .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
+} {1.1 4.17}
+test btree-8.8 {tag addition and removal, weird ranges} {
+    .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
+} {}
+
+test btree-9.1 {tag names} {
+    setup
+    .t tag names
+} {sel x y}
+test btree-9.2 {tag names} {
+    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
+} {x tag1 tag2 tag3}
+test btree-9.3 {lots of tag names} {
+    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
+} {tag1 foo ThisOne {x space} q r s t u tagA tagB tagC and more {$} \{}
+test btree-9.4 {lots of tag names} {
+    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
+} {foo ThisOne {x space} s t}
+
+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
+}
+test btree-10.1 {basic mark facilities} {
+    msetup
+    list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3]
+} {{current insert l1 m1 m2 m3 next x} 1.2 2.0 2.11}
+test btree-10.2 {basic mark facilities} {
+    msetup
+    .t mark unset m2
+    lsort [.t mark names]
+} {current insert l1 m1 m3 next x}
+test btree-10.3 {basic mark facilities} {
+    msetup
+    .t mark set m2 1.8
+    list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3]
+} {{current insert l1 m1 m2 m3 next x} 1.2 1.8 2.11}
+
+test btree-11.1 {marks and inserts} {
+    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]
+} {1.7 1.7 1.11 1.11 2.0 2.11}
+test btree-11.2 {marks and inserts} {
+    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]
+} {1.2 1.7 1.11 1.11 2.0 2.11}
+test btree-11.3 {marks and inserts} {
+    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]
+} {1.2 1.2 1.11 1.11 2.0 2.11}
+test btree-11.4 {marks and inserts} {
+    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]
+} {3.4 3.4 3.8 3.8 4.0 4.11}
+test btree-11.5 {marks and inserts} {
+    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]
+} {1.2 1.2 3.5 3.5 4.0 4.11}
+test btree-11.6 {marks and inserts} {
+    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]
+} {1.2 1.2 1.6 1.6 4.0 4.11}
+
+test btree-12.1 {marks and deletes} {
+    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]
+} {1.2 1.2 1.4 1.4 2.0 2.11}
+test btree-12.2 {marks and deletes} {
+    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]
+} {1.2 1.2 1.3 1.3 2.0 2.11}
+test btree-12.3 {marks and deletes} {
+    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]
+} {1.2 1.2 1.2 1.2 2.0 2.11}
+test btree-12.4 {marks and deletes} {
+    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]
+} {1.1 1.1 1.1 1.1 2.0 2.11}
+test btree-12.5 {marks and deletes} {
+    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]
+} {1.2 1.2 1.5 1.5 1.5 1.5}
+test btree-12.6 {marks and deletes} {
+    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]
+} {1.2 1.2 1.5 1.5 1.9 1.5}
+test btree-12.7 {marks and deletes} {
+    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]
+} {1.2 1.11 1.5 1.5 1.9 1.9}
+
+destroy .t
+text .t
+test btree-13.1 {tag searching} {
+    .t delete 1.0 100000.0
+    .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+    .t tag next x 2.2 2.1
+} {}
+test btree-13.2 {tag searching} {
+    .t delete 1.0 100000.0
+    .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
+} {2.2 2.4}
+test btree-13.3 {tag searching} {
+    .t delete 1.0 100000.0
+    .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
+} {}
+test btree-13.4 {tag searching} {
+    .t delete 1.0 100000.0
+    .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
+} {2.5 2.8}
+test btree-13.5 {tag searching} {
+    .t delete 1.0 100000.0
+    .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
+} {}
+test btree-13.6 {tag searching} {
+    .t delete 1.0 100000.0
+    .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
+} {}
+test btree-13.7 {tag searching} {
+    .t delete 1.0 100000.0
+    .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
+} {}
+test btree-13.8 {tag searching} {
+    setup
+    .t insert 1.2 $bigText2
+    .t tag add x 190.3 191.2
+    .t tag next x 3.5
+} {190.3 191.2}
+
+test btree-14.1 {check tag presence} {
+    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
+} {x y z}
+
+test btree-15.1 {rebalance with empty node} {
+    catch {destroy .t}
+    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
+} "1\n2\n3\n4\n5\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23\n"
+
+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
+}
+
+test btree-16.1 {add tag does not push root above level 0} {
+    catch {destroy .t}
+    text .t
+    setupBig
+    .t tag add x 1.1 1.10
+    .t tag add x 5.1 5.10
+    .t tag ranges x
+} {1.1 1.10 5.1 5.10}
+test btree-16.2 {add tag pushes root up to level 1 node} {
+    catch {destroy .t}
+    text .t
+    .t debug 1
+    setupBig
+    .t tag add x 1.1 1.10
+    .t tag add x 8.1 8.10
+    .t tag ranges x
+} {1.1 1.10 8.1 8.10}
+test btree-16.3 {add tag pushes root up to level 2 node} {
+    .t tag remove x 1.0 end
+    .t tag add x 8.1 9.10
+    .t tag add x 180.1 180.end
+    .t tag ranges x
+} {8.1 9.10 180.1 180.23}
+test btree-16.4 {add tag pushes root up to level 3 node} {
+    .t tag remove x 1.0 end
+    .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]
+} {{1.1 8.10 180.23 217.0} {1.1 2000.0}}
+test btree-16.5 {add tag doesn't push root up} {
+    .t tag remove x 1.0 end
+    .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
+} {1.1 8.10 180.23 217.0 2000.0 2000.3}
+test btree-16.6 {two node splits at once pushes root up} {
+    .t delete 1.0 end
+    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]
+} {{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} {
+    .t tag remove x 1.0 end
+    .t tag add x 2.0 2.6
+    .t tag remove x 1.0 2.0
+    .t tag ranges x
+} {2.0 2.6}
+test btree-16.8 {Partial tag remove from before first range} {
+    .t tag remove x 1.0 end
+    .t tag add x 2.0 2.6
+    .t tag remove x 1.0 2.1
+    .t tag ranges x
+} {2.1 2.6}
+test btree-16.9 {Partial tag remove from before first range} {
+    .t tag remove x 1.0 end
+    .t tag add x 2.0 2.6
+    .t tag remove x 1.0 2.3
+    .t tag ranges x
+} {2.3 2.6}
+test btree-16.10 {Partial tag remove from before first range} {
+    .t tag remove x 1.0 end
+    .t tag add x 1.0 2.6
+    .t tag remove x 1.0 2.5
+    .t tag ranges x
+} {2.5 2.6}
+test btree-16.11 {StartSearchBack boundary case} {
+    .t tag remove x 1.0 end
+    .t tag add x 1.3 1.4
+    .t tag prevr x 2.0 1.4
+} {}
+test btree-16.12 {StartSearchBack boundary case} {
+    .t tag remove x 1.0 end
+    .t tag add x 1.3 1.4
+    .t tag prevr x 2.0 1.3
+} {1.3 1.4}
+test btree-16.13 {StartSearchBack boundary case} {
+    .t tag remove x 1.0 end
+    .t tag add x 1.0 1.4
+    .t tag prevr x 1.3
+} {1.0 1.4}
+
+
+test btree-17.1 {remove tag does not push root down} {
+    catch {destroy .t}
+    text .t
+    .t debug 0
+    setupBig
+    .t tag add x 1.1 5.10
+    .t tag remove x 3.1 5.end
+    .t tag ranges x
+} {1.1 3.1}
+test btree-17.2 {remove tag pushes root from level 1 to level 0} {
+    .t tag remove x 1.0 end
+    .t tag add x 1.1 8.10
+    .t tag remove x 3.1 end
+    .t tag ranges x
+} {1.1 3.1}
+test btree-17.3 {remove tag pushes root from level 2 to level 1} {
+    .t tag remove x 1.0 end
+    .t tag add x 1.1 180.10
+    .t tag remove x 35.1 end
+    .t tag ranges x
+} {1.1 35.1}
+test btree-17.4 {remove tag doesn't change level 2} {
+    .t tag remove x 1.0 end
+    .t tag add x 1.1 180.10
+    .t tag remove x 35.1 180.0
+    .t tag ranges x
+} {1.1 35.1 180.0 180.10}
+test btree-17.5 {remove tag pushes root from level 3 to level 0} {
+    .t tag remove x 1.0 end
+    .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
+} {2000.1 2000.10}
+test btree-17.6 {text deletion pushes root from level 3 to level 0} {
+    .t tag remove x 1.0 end
+    .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
+} {1000.1 1000.10}
+
+catch {destroy .t}
+text .t
+test btree-18.1 {tag search back, no tag} {
+    .t insert 1.0 "Line 1 abcd efgh ijkl\n"
+    .t tag prev x 1.1 1.1
+} {}
+test btree-18.2 {tag search back, start at existing range} {
+    .t tag remove x 1.0 end
+    .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
+} {}
+test btree-18.3 {tag search back, end at existing range} {
+    .t tag remove x 1.0 end
+    .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
+} {1.1 1.4}
+test btree-18.4 {tag search back, start within range} {
+    .t tag remove x 1.0 end
+    .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
+} {1.8 1.11}
+test btree-18.5 {tag search back, start at end of range} {
+    .t tag remove x 1.0 end
+    .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]
+} {{1.1 1.4} {1.8 1.11}}
+test btree-18.6 {tag search back, start beyond range, same level 0 node} {
+    .t tag remove x 1.0 end
+    .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
+} {1.16 1.17}
+test btree-18.7 {tag search back, outside any range} {
+    .t tag remove x 1.0 end
+    .t tag add x 1.1 1.4
+    .t tag add x 1.16
+    .t tag prev x 1.8 1.5
+} {}
+test btree-18.8 {tag search back, start at start of node boundary} {
+    setupBig
+    .t tag remove x 1.0 end
+    .t tag add x 2.5 2.8
+    .t tag prev x 19.0
+} {2.5 2.8}
+test btree-18.9 {tag search back, large complex btree spans} {
+    .t tag remove x 1.0 end
+    .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]
+} {{500.0 520.0} {200.0 220.0}}
+
+destroy .t
+
+# cleanup
+cleanupTests
+return

tests/textImage.test

@@ -0,0 +1,370 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# One time setup.  Create a font to insure the tests are font metric invariant.
+
+catch {destroy .t}
+font create test_font -family courier -size 14
+text .t -font test_font
+destroy .t
+
+test textImage-1.1 {basic argument checking} {
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image} msg] $msg
+} {1 {wrong # args: should be ".t image option ?arg arg ...?"}}
+
+test textImage-1.2 {basic argument checking} {
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image c} msg] $msg
+} {1 {ambiguous option "c": must be cget, configure, create, or names}}
+
+test textImage-1.3 {cget argument checking} {
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image cget} msg] $msg
+} {1 {wrong # args: should be ".t image cget index option"}}
+
+test textImage-1.4 {cget argument checking} {
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image cget blurf -flurp} msg] $msg
+} {1 {bad text index "blurf"}}
+
+test textImage-1.5 {cget argument checking} {
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image cget 1.1 -flurp} msg] $msg
+} {1 {no embedded image at index "1.1"}}
+
+test textImage-1.6 {configure argument checking} {
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image configure } msg] $msg
+} {1 {wrong # args: should be ".t image configure index ?option value ...?"}}
+
+test textImage-1.7 {configure argument checking} {
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image configure blurf } msg] $msg
+} {1 {bad text index "blurf"}}
+
+test textImage-1.8 {configure argument checking} {
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image configure 1.1 } msg] $msg
+} {1 {no embedded image at index "1.1"}}
+
+test textImage-1.9 {create argument checking} {
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image create} msg] $msg
+} {1 {wrong # args: should be ".t image create index ?option value ...?"}}
+
+test textImage-1.10 {create argument checking} {
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image create blurf } msg] $msg
+} {1 {bad text index "blurf"}}
+
+test textImage-1.11 {basic argument checking} {
+	catch {
+	    image create photo small -width 5 -height 5
+	    small put red -to 0 0 4 4
+	}
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image create 1000.1000 -image small} msg] $msg
+} {0 small}
+
+test textImage-1.12 {names argument checking} {
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image names dates places} msg] $msg
+} {1 {wrong # args: should be ".t image names"}}
+
+
+test textImage-1.13 {names argument checking} {
+	catch {
+	    image create photo small -width 5 -height 5
+	    small put red -to 0 0 4 4
+	}
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	set result ""
+	lappend result [.t image names]
+	.t image create insert -image small
+	lappend result [.t image names]
+	.t image create insert -image small
+	lappend result [.t image names]
+	.t image create insert -image small -name little
+	lappend result [.t image names]
+} {{} small {small#1 small} {small#1 small little}}
+
+test textImage-1.14 {basic argument checking} {
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image huh} msg] $msg
+} {1 {bad option "huh": must be cget, configure, create, or names}}
+
+test textImage-1.15 {align argument checking} {
+	catch {
+	    image create photo small -width 5 -height 5
+	    small put red -to 0 0 4 4
+	}
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	list [catch {.t image create end -image small -align wrong} msg] $msg
+} {1 {bad align "wrong": must be baseline, bottom, center, or top}}
+
+test textImage-1.16 {configure} {
+	catch {
+	    image create photo small -width 5 -height 5
+	    small put red -to 0 0 4 4
+	}
+	catch {destroy .t}
+	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
+} {{-align {} {} center center} {-padx {} {} 0 0} {-pady {} {} 0 0} {-image {} {} {} small} {-name {} {} {} {}}}
+
+test textImage-1.17 {basic cget options} {
+	catch {
+	    image create photo small -width 5 -height 5
+	    small put red -to 0 0 4 4
+	}
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	.t image create end -image small
+	set result ""
+	foreach i {align padx pady image name} {
+	    lappend result $i:[.t image cget small -$i]
+	} 
+	set result
+} {align:center padx:0 pady:0 image:small name:}
+
+test textImage-1.18 {basic configure options} {
+	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
+	}
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	.t image create end -image small
+	set result ""
+	foreach {option value}  {align top padx 5 pady 7 image large name none} {
+	    .t image configure small -$option $value
+	} 
+	update
+	.t image configure small
+} {{-align {} {} center top} {-padx {} {} 0 5} {-pady {} {} 0 7} {-image {} {} {} large} {-name {} {} {} none}}
+
+test textImage-1.19 {basic image naming} {
+	catch {
+	    image create photo small -width 5 -height 5
+	    small put red -to 0 0 4 4
+	}
+	catch {destroy .t}
+	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]
+} {small small#1 small#6342 small#6343}
+
+test textImage-2.1 {debug} {
+	catch {
+	    image create photo small -width 5 -height 5
+	    small put red -to 0 0 4 4
+	}
+	catch {destroy .t}
+	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
+} {}
+
+test textImage-3.1 {image change propagation} {
+	catch {
+	    image create photo vary -width 5 -height 5
+	    small put red -to 0 0 4 4
+	}
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	.t image create end -image vary -align top
+	update
+	set result ""
+	lappend result base:[.t bbox vary]
+	foreach i {10 20 40} {
+	    vary configure -width $i -height $i
+	    update
+	    lappend result $i:[.t bbox vary]
+	} 
+	set 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} {
+	catch {
+	    image create photo small -width 5 -height 5
+	    small put red -to 0 0 4 4
+	}
+	catch {destroy .t}
+	text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+	pack .t
+	.t image create end -name test
+	update
+	set result ""
+	lappend result [.t bbox test]
+	.t image configure test -image small -align top
+	update
+	lappend result [.t bbox test]
+} {{} {0 0 5 5}}
+
+# some temporary random tests
+
+test textImage-4.1 {alignment checking - except baseline} {
+    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
+    }
+    catch {destroy .t}
+    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
+    set result ""
+    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]
+    }
+    set 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} {
+    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
+    }
+    catch {destroy .t}
+    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
+    set result ""
+    # 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"
+    }
+    font delete test_font2
+    unset Metrics
+    set result
+} {{10 0} {15 0} {20 0} {25 0}}
+
+test textImage-4.3 {alignment and padding checking} {fonts} {
+    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
+    }
+    catch {destroy .t}
+    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
+    set result ""
+    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]
+    }
+    set 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.0 {peer widget images} {
+    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
+    }
+    catch {destroy .t .tt}
+    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
+catch {destroy .t}
+foreach image [image names] {image delete $image}
+font delete test_font
+
+# cleanup
+cleanupTests
+return

tests/textIndex.test

@@ -0,0 +1,935 @@
+# 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 .t
+    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-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}
+
+# cleanup
+rename textimage {}
+catch {destroy .t}
+cleanupTests
+return

tests/textMark.test

@@ -0,0 +1,294 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+catch {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 . {}
+.t peer create .pt
+
+# 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 .
+
+entry .t.e
+.t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+
+test textMark-1.1 {TkTextMarkCmd - missing option} haveCourier12 {
+    list [catch {.t mark} msg] $msg
+} {1 {wrong # args: should be ".t mark option ?arg arg ...?"}}
+test textMark-1.2 {TkTextMarkCmd - bogus option} haveCourier12 {
+    list [catch {.t mark gorp} msg] $msg
+} {1 {bad mark option "gorp": must be gravity, names, next, previous, set, or unset}}
+test textMark-1.3 {TkTextMarkCmd - "gravity" option} haveCourier12 {
+    list [catch {.t mark gravity foo} msg] $msg
+} {1 {there is no mark named "foo"}}
+test textMark-1.4 {TkTextMarkCmd - "gravity" option} haveCourier12 {
+    .t mark unset x
+    .t mark set x 1.3
+    .t insert 1.3 x
+    list [.t mark gravity x] [.t index x]
+} {right 1.4}
+test textMark-1.5 {TkTextMarkCmd - "gravity" option} haveCourier12 {
+    .t mark unset x
+    .t mark set x 1.3
+    .t mark g x left
+    .t insert 1.3 x
+    list [.t mark gravity x] [.t index x]
+} {left 1.3}
+test textMark-1.6 {TkTextMarkCmd - "gravity" option} haveCourier12 {
+    .t mark unset x
+    .t mark set x 1.3
+    .t mark gravity x right
+    .t insert 1.3 x
+    list [.t mark gravity x] [.t index x]
+} {right 1.4}
+test textMark-1.7 {TkTextMarkCmd - "gravity" option} haveCourier12 {
+    list [catch {.t mark gravity x gorp} msg] $msg
+} {1 {bad mark gravity "gorp": must be left or right}}
+test textMark-1.8 {TkTextMarkCmd - "gravity" option} haveCourier12 {
+    list [catch {.t mark gravity} msg] $msg
+} {1 {wrong # args: should be ".t mark gravity markName ?gravity?"}}
+
+test textMark-2.1 {TkTextMarkCmd - "names" option} haveCourier12 {
+    list [catch {.t mark names 2} msg] $msg
+} {1 {wrong # args: should be ".t mark names"}}
+.t mark unset x
+test textMark-2.2 {TkTextMarkCmd - "names" option} haveCourier12 {
+    lsort [.t mark na]
+} {current insert}
+test textMark-2.3 {TkTextMarkCmd - "names" option} haveCourier12 {
+    .t mark set a 1.1
+    .t mark set "b c" 2.3
+    lsort [.t mark names]
+} {a {b c} current insert}
+
+test textMark-3.1 {TkTextMarkCmd - "set" option} haveCourier12 {
+    list [catch {.t mark set a} msg] $msg
+} {1 {wrong # args: should be ".t mark set markName index"}}
+test textMark-3.2 {TkTextMarkCmd - "set" option} haveCourier12 {
+    list [catch {.t mark s a b c} msg] $msg
+} {1 {wrong # args: should be ".t mark set markName index"}}
+test textMark-3.3 {TkTextMarkCmd - "set" option} haveCourier12 {
+    list [catch {.t mark set a @x} msg] $msg
+} {1 {bad text index "@x"}}
+test textMark-3.4 {TkTextMarkCmd - "set" option} haveCourier12 {
+    .t mark set a 1.2
+    .t index a
+} 1.2
+test textMark-3.5 {TkTextMarkCmd - "set" option} haveCourier12 {
+    .t mark set a end
+    .t index a
+} {8.0}
+
+test textMark-4.1 {TkTextMarkCmd - "unset" option} haveCourier12 {
+    list [catch {.t mark unset} msg] $msg
+} {0 {}}
+test textMark-4.2 {TkTextMarkCmd - "unset" option} haveCourier12 {
+    .t mark set a 1.2
+    .t mark set b 2.3
+    .t mark unset a b
+        list [catch {.t index a} msg] $msg [catch {.t index b} msg2] $msg2
+} {1 {bad text index "a"} 1 {bad text index "b"}}
+test textMark-4.3 {TkTextMarkCmd - "unset" option} haveCourier12 {
+    .t mark set a 1.2
+    .t mark set b 2.3
+    .t mark set 49ers 3.1
+    eval .t mark unset [.t mark names]
+    lsort [.t mark names]
+} {current insert}
+
+test textMark-5.1 {TkTextMarkCmd - miscellaneous} haveCourier12 {
+    list [catch {.t mark} msg] $msg
+} {1 {wrong # args: should be ".t mark option ?arg arg ...?"}}
+test textMark-5.2 {TkTextMarkCmd - miscellaneous} haveCourier12 {
+    list [catch {.t mark foo} msg] $msg
+} {1 {bad mark option "foo": must be gravity, names, next, previous, set, or unset}}
+
+test textMark-6.1 {TkTextMarkSegToIndex} haveCourier12 {
+    .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]
+} {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}
+
+catch {eval {.t mark unset} [.t mark names]}
+test textMark-7.1 {MarkFindNext - invalid mark name} haveCourier12 {
+    catch {.t mark next bogus} x
+    set x
+} {bad text index "bogus"}
+test textMark-7.2 {MarkFindNext - marks at same location} haveCourier12 {
+    .t mark set insert 2.0
+    .t mark set current 2.0
+    .t mark next current
+} {insert}
+test textMark-7.3 {MarkFindNext - numerical starting mark} haveCourier12 {
+    .t mark set current 1.0
+    .t mark set insert 1.0
+    .t mark next 1.0
+} {insert}
+test textMark-7.4 {MarkFindNext - mark on the same line} haveCourier12 {
+    .t mark set current 1.0
+    .t mark set insert 1.1
+    .t mark next current
+} {insert}
+test textMark-7.5 {MarkFindNext - mark on the next line} haveCourier12 {
+    .t mark set current 1.end
+    .t mark set insert 2.0
+    .t mark next current
+} {insert}
+test textMark-7.6 {MarkFindNext - mark far away} haveCourier12 {
+    .t mark set current 1.2
+    .t mark set insert 7.0
+    .t mark next current
+} {insert}
+test textMark-7.7 {MarkFindNext - mark on top of end} haveCourier12 {
+    .t mark set current end
+    .t mark next end
+} {current}
+test textMark-7.8 {MarkFindNext - no next mark} haveCourier12 {
+    .t mark set current 1.0
+    .t mark set insert 3.0
+    .t mark next insert
+} {}
+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} -constraints haveCourier12 -setup {
+    .t mark unset {*}[.t mark names]
+} -body {
+    catch {.t mark prev bogus} x
+    set x
+} -result {bad text index "bogus"}
+test textMark-8.2 {MarkFindPrev - marks at same location} -constraints haveCourier12 -setup {
+    .t mark unset {*}[.t mark names]
+} -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} -constraints haveCourier12 -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} -constraints haveCourier12 -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} -constraints haveCourier12 -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} -constraints haveCourier12 -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}
+
+catch {destroy .t}
+catch {destroy .pt}
+
+# cleanup
+cleanupTests
+return

tests/textTag.test

@@ -0,0 +1,815 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+catch {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 .
+
+entry .t.e
+.t.e insert 0 "Text"
+
+.t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+
+
+set i 1
+foreach test {
+    {-background #012345 #012345 non-existent
+	    {unknown color name "non-existent"}}
+    {-bgstipple gray50 gray50 badStipple
+	    {bitmap "badStipple" not defined}}
+    {-borderwidth 2 2 46q
+	    {bad screen distance "46q"}}
+    {-fgstipple gray25 gray25 bogus
+	    {bitmap "bogus" not defined}}
+    {-font fixed fixed {}
+	    {font "" doesn't exist}}
+    {-foreground #001122 #001122 {silly color}
+	    {unknown color name "silly color"}}
+    {-justify left left middle
+	    {bad justification "middle": must be left, right, or center}}
+    {-lmargin1 10 10 bad
+	    {bad screen distance "bad"}}
+    {-lmargin2 10 10 bad
+	    {bad screen distance "bad"}}
+    {-offset 2 2 100xyz
+	    {bad screen distance "100xyz"}}
+    {-overstrike on on stupid
+	    {expected boolean value but got "stupid"}}
+    {-relief raised raised stupid
+	    {bad relief type "stupid": must be flat, groove, raised, ridge, solid, or sunken}}
+    {-rmargin 10 10 bad
+	    {bad screen distance "bad"}}
+    {-spacing1 10 10 bad
+	    {bad screen distance "bad"}}
+    {-spacing2 10 10 bad
+	    {bad screen distance "bad"}}
+    {-spacing3 10 10 bad
+	    {bad screen distance "bad"}}
+    {-tabs {10 20 30} {10 20 30} {10 fork}
+	    {bad tab alignment "fork": must be left, right, center, or numeric}}
+    {-underline no no stupid
+	    {expected boolean value but got "stupid"}}
+} {
+    set name [lindex $test 0]
+    test textTag-1.$i {tag configuration options} haveCourier12 {
+	.t tag configure x $name [lindex $test 1]
+	.t tag cget x $name
+    } [lindex $test 2]
+    incr i
+    if {[lindex $test 3] != ""} {
+	test textTag-1.$i {configuration options} haveCourier12 {
+	    list [catch {.t tag configure x $name [lindex $test 3]} msg] $msg
+	} [list 1 [lindex $test 4]]
+    }
+    .t tag configure x $name [lindex [.t tag configure x $name] 3]
+    incr i
+}
+test textTag-2.1 {TkTextTagCmd - "add" option} haveCourier12 {
+    list [catch {.t tag} msg] $msg
+} {1 {wrong # args: should be ".t tag option ?arg arg ...?"}}
+test textTag-2.2 {TkTextTagCmd - "add" option} haveCourier12 {
+    list [catch {.t tag gorp} msg] $msg
+} {1 {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} haveCourier12 {
+    list [catch {.t tag add foo} msg] $msg
+} {1 {wrong # args: should be ".t tag add tagName index1 ?index2 index1 index2 ...?"}}
+test textTag-2.4 {TkTextTagCmd - "add" option} haveCourier12 {
+    list [catch {.t tag add x gorp} msg] $msg
+} {1 {bad text index "gorp"}}
+test textTag-2.5 {TkTextTagCmd - "add" option} haveCourier12 {
+    list [catch {.t tag add x 1.2 gorp} msg] $msg
+} {1 {bad text index "gorp"}}
+test textTag-2.6 {TkTextTagCmd - "add" option} haveCourier12 {
+    .t tag add sel 3.2 3.4
+    .t tag add sel 3.2 3.0
+    .t tag ranges sel
+} {3.2 3.4}
+test textTag-2.7 {TkTextTagCmd - "add" option} haveCourier12 {
+    .t tag add x 1.0 1.end
+    .t tag ranges x
+} {1.0 1.6}
+test textTag-2.8 {TkTextTagCmd - "add" option} haveCourier12 {
+    .t tag remove x 1.0 end
+    .t tag add x 1.2
+    .t tag ranges x
+} {1.2 1.3}
+test textTag-2.9 {TkTextTagCmd - "add" option} haveCourier12 {
+    .t.e select from 0
+    .t.e select to 4
+    .t tag add sel 3.2 3.4
+    selection get
+} 34
+test textTag-2.11 {TkTextTagCmd - "add" option} haveCourier12 {
+    .t.e select from 0
+    .t.e select to 4
+    .t configure -exportselection 0
+    .t tag add sel 3.2 3.4
+    selection get
+} Text
+test textTag-2.12 {TkTextTagCmd - "add" option} haveCourier12 {
+    .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
+} {1.1 1.5 2.4 3.1 4.2 4.4}
+test textTag-2.13 {TkTextTagCmd - "add" option} haveCourier12 {
+    .t tag remove sel 1.0 end
+    .t tag add sel 1.1 1.5 2.4
+    .t tag ranges sel
+} {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}
+
+catch {.t tag delete x}
+test textTag-3.1 {TkTextTagCmd - "bind" option} haveCourier12 {
+    list [catch {.t tag bind} msg] $msg
+} {1 {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}}
+test textTag-3.2 {TkTextTagCmd - "bind" option} haveCourier12 {
+    list [catch {.t tag bind 1 2 3 4} msg] $msg
+} {1 {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}}
+test textTag-3.3 {TkTextTagCmd - "bind" option} haveCourier12 {
+    .t tag bind x <Enter> script1
+    .t tag bind x <Enter>
+} script1
+test textTag-3.4 {TkTextTagCmd - "bind" option} haveCourier12 {
+    list [catch {.t tag bind x <Gorp> script2} msg] $msg
+} {1 {bad event type or keysym "Gorp"}}
+test textTag-3.5 {TkTextTagCmd - "bind" option} haveCourier12 {
+    .t tag delete x
+    .t tag bind x <Enter> script1
+    list [catch {.t tag bind x <FocusIn> script2} msg] $msg [.t tag bind x]
+} {1 {requested illegal events; only key, button, motion, enter, leave, and virtual events may be used} <Enter>}
+test textTag-3.6 {TkTextTagCmd - "bind" option} haveCourier12 {
+    .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]
+} {{<Enter> <Leave> a} script1 xyzzy}
+test textTag-3.7 {TkTextTagCmd - "bind" option} haveCourier12 {
+    .t tag delete x
+    .t tag bind x <Enter> script1
+    .t tag bind x <Enter> +script2
+    .t tag bind x <Enter>
+} {script1
+script2}
+test textTag-3.7a {TkTextTagCmd - "bind" option} haveCourier12 {
+    .t tag delete x
+    list [catch {.t tag bind x <Enter>} msg] $msg
+} {0 {}}
+test textTag-3.8 {TkTextTagCmd - "bind" option} haveCourier12 {
+    .t tag delete x
+    list [catch {.t tag bind x <} msg] $msg
+} {1 {no event type or button # or keysym}}
+
+test textTag-4.1 {TkTextTagCmd - "cget" option} haveCourier12 {
+    list [catch {.t tag cget a} msg] $msg
+} {1 {wrong # args: should be ".t tag cget tagName option"}}
+test textTag-4.2 {TkTextTagCmd - "cget" option} haveCourier12 {
+    list [catch {.t tag cget a b c} msg] $msg
+} {1 {wrong # args: should be ".t tag cget tagName option"}}
+test textTag-4.3 {TkTextTagCmd - "cget" option} haveCourier12 {
+    .t tag delete foo
+    list [catch {.t tag cget foo bar} msg] $msg
+} {1 {tag "foo" isn't defined in text widget}}
+test textTag-4.4 {TkTextTagCmd - "cget" option} haveCourier12 {
+    list [catch {.t tag cget sel bogus} msg] $msg
+} {1 {unknown option "bogus"}}
+test textTag-4.5 {TkTextTagCmd - "cget" option} haveCourier12 {
+    .t tag delete x
+    .t tag configure x -background red
+    list [catch {.t tag cget x -background} msg] $msg
+} {0 red}
+
+test textTag-5.1 {TkTextTagCmd - "configure" option} haveCourier12 {
+    list [catch {.t tag configure} msg] $msg
+} {1 {wrong # args: should be ".t tag configure tagName ?option? ?value? ?option value ...?"}}
+test textTag-5.2 {TkTextTagCmd - "configure" option} haveCourier12 {
+    list [catch {.t tag configure x -foo} msg] $msg
+} {1 {unknown option "-foo"}}
+test textTag-5.3 {TkTextTagCmd - "configure" option} haveCourier12 {
+    list [catch {.t tag configure x -background red -underline} msg] $msg
+} {1 {value for "-underline" missing}}
+test textTag-5.4 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    .t tag configure x -underline yes
+    .t tag configure x -underline
+} {-underline {} {} {} yes}
+test textTag-5.5 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    .t tag configure x -overstrike on
+    .t tag cget x -overstrike
+} {on}
+test textTag-5.6 {TkTextTagCmd - "configure" option} haveCourier12 {
+    list [catch {.t tag configure x -overstrike foo} msg] $msg
+} {1 {expected boolean value but got "foo"}}
+test textTag-5.7 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    list [catch {.t tag configure x -underline stupid} msg] $msg
+} {1 {expected boolean value but got "stupid"}}
+test textTag-5.8 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    .t tag configure x -justify left
+    .t tag configure x -justify
+} {-justify {} {} {} left}
+test textTag-5.9 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    list [catch {.t tag configure x -justify bogus} msg] $msg
+} {1 {bad justification "bogus": must be left, right, or center}}
+test textTag-5.10 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    list [catch {.t tag configure x -justify fill} msg] $msg
+} {1 {bad justification "fill": must be left, right, or center}}
+test textTag-5.11 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    .t tag configure x -offset 2
+    .t tag configure x -offset
+} {-offset {} {} {} 2}
+test textTag-5.12 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    list [catch {.t tag configure x -offset 1.0q} msg] $msg
+} {1 {bad screen distance "1.0q"}}
+test textTag-5.13 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    .t tag configure x -lmargin1 2 -lmargin2 4 -rmargin 5
+    list [.t tag configure x -lmargin1] [.t tag configure x -lmargin2] \
+	    [.t tag configure x -rmargin]
+} {{-lmargin1 {} {} {} 2} {-lmargin2 {} {} {} 4} {-rmargin {} {} {} 5}}
+test textTag-5.14 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    list [catch {.t tag configure x -lmargin1 2.0x} msg] $msg
+} {1 {bad screen distance "2.0x"}}
+test textTag-5.15 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    list [catch {.t tag configure x -lmargin2 gorp} msg] $msg
+} {1 {bad screen distance "gorp"}}
+test textTag-5.16 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    list [catch {.t tag configure x -rmargin 140.1.1} msg] $msg
+} {1 {bad screen distance "140.1.1"}}
+.t tag delete x
+test textTag-5.17 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .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]
+} {{-spacing1 {} {} {} 2} {-spacing2 {} {} {} 4} {-spacing3 {} {} {} 6}}
+test textTag-5.18 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    list [catch {.t tag configure x -spacing1 2.0x} msg] $msg
+} {1 {bad screen distance "2.0x"}}
+test textTag-5.19 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    list [catch {.t tag configure x -spacing1 lousy} msg] $msg
+} {1 {bad screen distance "lousy"}}
+test textTag-5.20 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t tag delete x
+    list [catch {.t tag configure x -spacing1 4.2.3} msg] $msg
+} {1 {bad screen distance "4.2.3"}}
+test textTag-5.21 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .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]
+    }
+    set x
+} {4 green yellow}
+test textTag-5.22 {TkTextTagCmd - "configure" option} haveCourier12 {
+    .t configure -selectborderwidth 20
+    .t tag configure sel -borderwidth {}
+    .t cget -selectborderwidth
+} {}
+
+test textTag-6.1 {TkTextTagCmd - "delete" option} haveCourier12 {
+    list [catch {.t tag delete} msg] $msg
+} {1 {wrong # args: should be ".t tag delete tagName ?tagName ...?"}}
+test textTag-6.2 {TkTextTagCmd - "delete" option} haveCourier12 {
+    list [catch {.t tag delete zork} msg] $msg
+} {0 {}}
+test textTag-6.3 {TkTextTagCmd - "delete" option} haveCourier12 {
+    .t tag delete x
+    .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]
+} {sel x}
+test textTag-6.4 {TkTextTagCmd - "delete" option} haveCourier12 {
+    .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
+} {sel}
+test textTag-6.5 {TkTextTagCmd - "delete" option} haveCourier12 {
+    .t tag bind x <Enter> foo
+    .t tag delete x
+    .t tag configure x -background black
+    .t tag bind x
+} {}
+
+proc tagsetup {} {
+    .t tag delete x y z a b c d
+    .t tag remove sel 1.0 end
+    foreach i {a b c d} {
+	.t tag configure $i -background black
+    }
+}
+test textTag-7.1 {TkTextTagCmd - "lower" option} haveCourier12 {
+    list [catch {.t tag lower} msg] $msg
+} {1 {wrong # args: should be ".t tag lower tagName ?belowThis?"}}
+test textTag-7.2 {TkTextTagCmd - "lower" option} haveCourier12 {
+    list [catch {.t tag lower foo} msg] $msg
+} {1 {tag "foo" isn't defined in text widget}}
+test textTag-7.3 {TkTextTagCmd - "lower" option} haveCourier12 {
+    list [catch {.t tag lower sel bar} msg] $msg
+} {1 {tag "bar" isn't defined in text widget}}
+test textTag-7.4 {TkTextTagCmd - "lower" option} haveCourier12 {
+    tagsetup
+    .t tag lower c
+    .t tag names
+} {c sel a b d}
+test textTag-7.5 {TkTextTagCmd - "lower" option} haveCourier12 {
+    tagsetup
+    .t tag lower d b
+    .t tag names
+} {sel a d b c}
+test textTag-7.6 {TkTextTagCmd - "lower" option} haveCourier12 {
+    tagsetup
+    .t tag lower a c
+    .t tag names
+} {sel b a c d}
+
+test textTag-8.1 {TkTextTagCmd - "names" option} haveCourier12 {
+    list [catch {.t tag names a b} msg] $msg
+} {1 {wrong # args: should be ".t tag names ?index?"}}
+test textTag-8.2 {TkTextTagCmd - "names" option} haveCourier12 {
+    tagsetup
+    .t tag names
+} {sel a b c d}
+test textTag-8.3 {TkTextTagCmd - "names" option} haveCourier12 {
+    tagsetup
+    .t tag add "a b" 2.1 2.6
+    .t tag add c 2.4 2.7
+    .t tag names 2.5
+} {c {a b}}
+
+.t tag delete x y z a b c d {a b}
+.t tag add x 2.3 2.5
+.t tag add x 2.9 3.1
+.t tag add x 7.2
+test textTag-9.1 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    list [catch {.t tag nextrange x} msg] $msg
+} {1 {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}}
+test textTag-9.2 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    list [catch {.t tag nextrange x 1 2 3} msg] $msg
+} {1 {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}}
+test textTag-9.3 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    list [catch {.t tag nextrange foo 1.0} msg] $msg
+} {0 {}}
+test textTag-9.4 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    list [catch {.t tag nextrange x foo} msg] $msg
+} {1 {bad text index "foo"}}
+test textTag-9.5 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    list [catch {.t tag nextrange x 1.0 bar} msg] $msg
+} {1 {bad text index "bar"}}
+test textTag-9.6 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    .t tag nextrange x 1.0
+} {2.3 2.5}
+test textTag-9.7 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    .t tag nextrange x 2.2
+} {2.3 2.5}
+test textTag-9.8 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    .t tag nextrange x 2.3
+} {2.3 2.5}
+test textTag-9.9 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    .t tag nextrange x 2.4
+} {2.9 3.1}
+test textTag-9.10 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    .t tag nextrange x 2.4 2.9
+} {}
+test textTag-9.11 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    .t tag nextrange x 2.4 2.10
+} {2.9 3.1}
+test textTag-9.12 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    .t tag nextrange x 2.4 2.11
+} {2.9 3.1}
+test textTag-9.13 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    .t tag nextrange x 7.0
+} {7.2 7.3}
+test textTag-9.14 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+    .t tag nextrange x 7.3
+} {}
+
+test textTag-10.1 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    list [catch {.t tag prevrange x} msg] $msg
+} {1 {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"}}
+test textTag-10.2 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    list [catch {.t tag prevrange x 1 2 3} msg] $msg
+} {1 {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"}}
+test textTag-10.3 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    list [catch {.t tag prevrange foo end} msg] $msg
+} {0 {}}
+test textTag-10.4 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    list [catch {.t tag prevrange x foo} msg] $msg
+} {1 {bad text index "foo"}}
+test textTag-10.5 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    list [catch {.t tag prevrange x end bar} msg] $msg
+} {1 {bad text index "bar"}}
+test textTag-10.6 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    .t tag prevrange x end
+} {7.2 7.3}
+test textTag-10.7 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    .t tag prevrange x 2.4
+} {2.3 2.5}
+test textTag-10.8 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    .t tag prevrange x 2.5
+} {2.3 2.5}
+test textTag-10.9 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    .t tag prevrange x 2.9
+} {2.3 2.5}
+test textTag-10.10 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    .t tag prevrange x 2.9 2.6
+} {}
+test textTag-10.11 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    .t tag prevrange x 2.9 2.5
+} {}
+test textTag-10.12 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    .t tag prevrange x 2.9 2.3
+} {2.3 2.5}
+test textTag-10.13 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    .t tag prevrange x 7.0
+} {2.9 3.1}
+test textTag-10.14 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+    .t tag prevrange x 2.3
+} {}
+
+test textTag-11.1 {TkTextTagCmd - "raise" option} haveCourier12 {
+    list [catch {.t tag raise} msg] $msg
+} {1 {wrong # args: should be ".t tag raise tagName ?aboveThis?"}}
+test textTag-11.2 {TkTextTagCmd - "raise" option} haveCourier12 {
+    list [catch {.t tag raise foo} msg] $msg
+} {1 {tag "foo" isn't defined in text widget}}
+test textTag-11.3 {TkTextTagCmd - "raise" option} haveCourier12 {
+    list [catch {.t tag raise sel bar} msg] $msg
+} {1 {tag "bar" isn't defined in text widget}}
+test textTag-11.4 {TkTextTagCmd - "raise" option} haveCourier12 {
+    tagsetup
+    .t tag raise c
+    .t tag names
+} {sel a b d c}
+test textTag-11.5 {TkTextTagCmd - "raise" option} haveCourier12 {
+    tagsetup
+    .t tag raise d b
+    .t tag names
+} {sel a b d c}
+test textTag-11.6 {TkTextTagCmd - "raise" option} haveCourier12 {
+    tagsetup
+    .t tag raise a c
+    .t tag names
+} {sel b c a d}
+
+test textTag-12.1 {TkTextTagCmd - "ranges" option} haveCourier12 {
+    list [catch {.t tag ranges} msg] $msg
+} {1 {wrong # args: should be ".t tag ranges tagName"}}
+test textTag-12.2 {TkTextTagCmd - "ranges" option} haveCourier12 {
+    .t tag delete x
+    .t tag ranges x
+} {}
+test textTag-12.3 {TkTextTagCmd - "ranges" option} haveCourier12 {
+    .t tag delete x
+    .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
+} {2.2 2.3 2.7 4.6 5.2 5.5}
+test textTag-12.4 {TkTextTagCmd - "ranges" option} haveCourier12 {
+    .t tag delete x
+    .t tag add x 1.0 3.0
+    .t tag add x 4.0 end
+    .t tag ranges x
+} {1.0 3.0 4.0 8.0}
+
+test textTag-13.1 {TkTextTagCmd - "remove" option} haveCourier12 {
+    list [catch {.t tag remove} msg] $msg
+} {1 {wrong # args: should be ".t tag remove tagName index1 ?index2 index1 index2 ...?"}}
+test textTag-13.2 {TkTextTagCmd - "remove" option} haveCourier12 {
+    .t tag delete x
+    .t tag add x 2.2 2.11
+    .t tag remove x 2.3 2.7
+    .t tag ranges x
+} {2.2 2.3 2.7 2.11}
+test textTag-13.3 {TkTextTagCmd - "remove" option} haveCourier12 {
+    .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
+} Text
+
+.t tag delete x a b c d
+test textTag-14.1 {SortTags} haveCourier12 {
+    foreach i {a b c d} {
+	.t tag add $i 2.0 2.2
+    }
+    .t tag names 2.1
+} {a b c d}
+.t tag delete a b c d
+test textTag-14.2 {SortTags} haveCourier12 {
+    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
+} {a b c d}
+.t tag delete x a b c d
+test textTag-14.3 {SortTags} haveCourier12 {
+    for {set i 0} {$i < 30} {incr i} {
+	.t tag add x$i 2.0 2.2
+    }
+    .t tag names 2.1
+} {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} haveCourier12 {
+    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
+} {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}
+
+foreach tag [.t tag names] {
+    catch {.t tag delete $tag}
+}
+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} haveCourier12 {
+    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
+    bind .t <ButtonRelease> {}
+    set x
+} {x-up up up y-up up}
+test textTag-15.2 {TkTextBindProc} haveCourier12 {
+    catch {.t tag delete x}
+    catch {.t tag delete y}
+    .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
+    set x
+} {x-enter | x-down | | x-up x-leave y-enter}
+test textTag-15.3 {TkTextBindProc} haveCourier12 {
+    catch {.t tag delete x}
+    catch {.t tag delete y}
+    .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
+    set x
+} {x-enter | x-down | | | x-up | x-leave y-enter}
+
+foreach tag [.t tag names] {
+    catch {.t tag delete $tag}
+}
+.t tag configure big -font $bigFont
+test textTag-16.1 {TkTextPickCurrent procedure} haveCourier12 {
+    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]
+} {2.1 3.2 3.2 3.2 3.2 3.2 4.3}
+test textTag-16.2 {TkTextPickCurrent procedure} haveCourier12 {
+    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]
+} {3.2 3.1}
+.t tag remove big 1.0 end
+foreach i {a b c d} {
+    .t tag bind $i <Enter> "lappend x enter-$i"
+    .t tag bind $i <Leave> "lappend x leave-$i"
+}
+test textTag-16.3 {TkTextPickCurrent procedure} haveCourier12 {
+    foreach i {a b c d} {
+	.t tag remove $i 1.0 end
+    }
+    .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
+    set x
+} {enter-a enter-b | leave-b enter-c | leave-a leave-c}
+test textTag-16.4 {TkTextPickCurrent procedure} haveCourier12 {
+    foreach i {a b c d} {
+	.t tag remove $i 1.0 end
+    }
+    .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
+    set x
+} {enter-a enter-b enter-c | leave-c leave-b}
+foreach i {a b c d} {
+    .t tag delete $i
+}
+test textTag-16.5 {TkTextPickCurrent procedure} haveCourier12 {
+    foreach i {a b c d} {
+	.t tag remove $i 1.0 end
+    }
+    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
+} {3.2}
+test textTag-16.6 {TkTextPickCurrent procedure} haveCourier12 {
+    foreach i {a b c d} {
+	.t tag remove $i 1.0 end
+    }
+    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
+} {3.1}
+test textTag-16.7 {TkTextPickCurrent procedure} haveCourier12 {
+    foreach i {a b c d} {
+	.t tag remove $i 1.0 end
+    }
+    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
+    .t index current
+} {3.1}
+
+test textTag-17.1 {insert procedure inserts tags} {
+    .t delete 1.0 end
+    # 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
+} {tagon x 1.0 tagoff x 1.4 tagon y 2.0 tagoff y 2.4}
+
+catch {destroy .t}
+
+test textTag-18.1 {TkTextPickCurrent tag bindings} {
+    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
+    set res
+} {Enter {25 25 tag-Enter} {20 20 tag-Leave} {25 25 tag-Enter}}
+
+catch {destroy .t}
+
+# cleanup
+cleanupTests
+return

tests/tk.test

@@ -0,0 +1,164 @@
+# 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.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test tk-1.1 {tk command: general} \
+    -body {tk} -returnCodes 1 \
+    -result {wrong # args: should be "tk option ?arg?"}
+test tk-1.2 {tk command: general} \
+    -body {tk xyz} -returnCodes 1 \
+    -result {bad option "xyz": must be appname, caret, scaling, useinputmethods, windowingsystem, or inactive}
+
+set appname [tk appname]
+test tk-2.1 {tk command: appname} {
+    list [catch {tk appname xyz abc} msg] $msg
+} {1 {wrong # args: should be "tk appname ?newName?"}}
+test tk-2.2 {tk command: appname} {
+    tk appname foobazgarply
+} {foobazgarply}
+test tk-2.3 {tk command: appname} unix {
+    tk appname bazfoogarply
+    expr {[lsearch -exact [winfo interps] [tk appname]] >= 0}
+} {1}
+test tk-2.4 {tk command: appname} {
+    tk appname $appname
+} $appname
+tk appname $appname
+
+set scaling [tk scaling]
+test tk-3.1 {tk command: scaling} {
+    list [catch {tk scaling -displayof} msg] $msg
+} {1 {value for "-displayof" missing}}
+test tk-3.2 {tk command: scaling: get current} {
+    tk scaling 1
+    format %.2g [tk scaling]
+} 1
+test tk-3.3 {tk command: scaling: get current} {
+    tk scaling -displayof . 1.25
+    format %.3g [tk scaling]
+} 1.25
+test tk-3.4 {tk command: scaling: set new} {
+    list [catch {tk scaling xyz} msg] $msg
+} {1 {expected floating-point number but got "xyz"}}
+test tk-3.5 {tk command: scaling: set new} {
+    list [catch {tk scaling -displayof . xyz} msg] $msg
+} {1 {expected floating-point number but got "xyz"}}
+test tk-3.6 {tk command: scaling: set new} {
+    tk scaling 1
+    format %.2g [tk scaling]
+} 1
+test tk-3.7 {tk command: scaling: set new} {
+    tk scaling -displayof . 1.25
+    format %.3g [tk scaling]
+} 1.25
+test tk-3.8 {tk command: scaling: negative} {
+    tk scaling -1
+    expr {[tk scaling] > 0}
+} {1}
+test tk-3.9 {tk command: scaling: too big} {
+    tk scaling 1000000
+    expr {[tk scaling] < 10000}
+} {1}    
+test tk-3.10 {tk command: scaling: widthmm} {
+    tk scaling 1.25
+    expr {int((25.4*[winfo screenwidth .])/(72*1.25)+0.5)-[winfo screenmmwidth .]}
+} {0}
+test tk-3.11 {tk command: scaling: heightmm} {
+    tk scaling 1.25
+    expr {int((25.4*[winfo screenheight .])/(72*1.25)+0.5)-[winfo screenmmheight .]}
+} {0}
+tk scaling $scaling
+
+set useim [tk useinputmethods]
+test tk-4.1 {tk command: useinputmethods} {
+    list [catch {tk useinputmethods -displayof} msg] $msg
+} {1 {value for "-displayof" missing}}
+test tk-4.2 {tk command: useinputmethods: get current} {
+    tk useinputmethods no
+} 0
+test tk-4.3 {tk command: useinputmethods: get current} {
+    tk useinputmethods -displayof .
+} 0
+test tk-4.4 {tk command: useinputmethods: set new} {
+    list [catch {tk useinputmethods xyz} msg] $msg
+} {1 {expected boolean value but got "xyz"}}
+test tk-4.5 {tk command: useinputmethods: set new} {
+    list [catch {tk useinputmethods -displayof . xyz} msg] $msg
+} {1 {expected boolean value but got "xyz"}}
+test tk-4.6 {tk command: useinputmethods: set new} unix {
+    # 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"
+    }
+    set useim
+} $useim
+test tk-4.7 {tk command: useinputmethods: set new} win {
+    # Mac and Windows don't have X Input Methods, so this should
+    # always return 0
+    tk useinputmethods 1
+} 0
+tk useinputmethods $useim
+
+test tk-5.1 {tk caret} {
+    list [catch {tk caret} msg] $msg
+} {1 {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}}
+test tk-5.2 {tk caret} {
+    list [catch {tk caret bogus} msg] $msg
+} {1 {bad window path name "bogus"}}
+test tk-5.3 {tk caret} {
+    list [catch {tk caret . -foo} msg] $msg
+} {1 {bad caret option "-foo": must be -x, -y, or -height}}
+test tk-5.4 {tk caret} {
+    list [catch {tk caret . -x 0 -y} msg] $msg
+} {1 {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}}
+test tk-5.5 {tk caret} {
+    list [catch {tk caret . -x 10 -y 11 -h 12; tk caret .} msg] $msg
+} {0 {-height 12 -x 10 -y 11}}
+test tk-5.6 {tk caret} {
+    list [catch {tk caret . -x 20 -y 25 -h 30; tk caret . -hei} msg] $msg
+} {0 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 {
+    catch {tk inactive reset}
+} -result 0
+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
+
+# tk inactive in safe interpreters
+safe::interpCreate foo
+safe::loadTk foo
+test tk-7.1 {tk inactive in a safe interpreter} -body {
+    foo eval {tk inactive}
+} -result -1
+test tk-7.2 {tk inactive reset in a safe interpreter} -body {
+    foo eval {tk inactive reset}
+} -returnCodes 1 -result {resetting the user inactivity timer is not allowed in a safe interpreter}
+::safe::interpDelete foo
+
+# cleanup
+cleanupTests
+return

tests/ttk/all.tcl

@@ -0,0 +1,21 @@
+# 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 Tcl 8.5
+package require tcltest 2.2
+package require Tk ;# This is the Tk test suite; fail early if no Tk!
+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
+

tests/ttk/checkbutton.test

@@ -0,0 +1,48 @@
+#
+# 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 {}]
+
+tcltest::cleanupTests

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

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

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

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

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

tests/ttk/notebook.test

@@ -0,0 +1,493 @@
+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 }
+
+
+# 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

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

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

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