see ChangeLog for specific file details

17 files changed, 610 insertions, 110 deletions

diff --git a/tests/bind.test b/tests/bind.test
index 25ac2c3..f32b346 100644
--- a/tests/bind.test
+++ b/tests/bind.test
@@ -7,7 +7,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: bind.test,v 1.7 1999/12/14 06:53:11 hobbs Exp $
+# RCS: @(#) $Id: bind.test,v 1.7.2.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -1945,7 +1945,7 @@ test bind-22.2 {HandleEventGenerate} {
 } {1 {bad window name/identifier "zzz"}}
 test bind-22.3 {HandleEventGenerate} {
     list [catch {event gen 47 <Control-v>} msg] $msg
-} {1 {window id "47" doesn't exist in this application}}
+} {1 {bad window name/identifier "47"}}
 test bind-22.4 {HandleEventGenerate} {
     setup
     bind .b.f <Button> {set x "%s %b"}
@@ -2046,7 +2046,11 @@ test bind-22.16 {HandleEventGenerate} {
 test bind-22.17 {HandleEventGenerate} {
     list [catch {event gen . <Button> -when xyz} msg] $msg
 } {1 {bad -when value "xyz": must be now, head, mark, or tail}}
-set i 18
+test bind-22.18 {HandleEventGenerate} {
+    # Bug 411307
+    list [catch {event gen . <a> -root 98765} msg] $msg
+} {1 {bad window name/identifier "98765"}}
+set i 19
 foreach check {
     {<Configure> %a {-above .xyz} {{1 {bad window path name ".xyz"}}}}
     {<Configure> %a {-above .b} {[winfo id .b]}}
@@ -2673,22 +2677,8 @@ test bind-31.2 {MouseWheel events} {
     set x
 } {240 10 30}
 
-
 destroy .b
 
 # cleanup
 ::tcltest::cleanupTests
 return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/canvas.test b/tests/canvas.test
index df4d524..4150381 100644
--- a/tests/canvas.test
+++ b/tests/canvas.test
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-2000 Ajuba Solutions.
 # All rights reserved.
 #
-# RCS: @(#) $Id: canvas.test,v 1.8.2.1 2000/08/05 23:53:14 hobbs Exp $
+# RCS: @(#) $Id: canvas.test,v 1.8.2.2 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -367,6 +367,50 @@ test canvas-11.1 {canvas poly fill check, bug 5783} {
 	    -fill {} -stipple gray50 -outline black
 } 1
 
+test canvas-12.1 {canvas mm obj, patch SF-403327, 102471} {
+    destroy .c
+    pack [canvas .c]
+    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]
+} {2.0 3}
+test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} {
+    destroy .c
+    pack [canvas .c]
+    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
+} {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
+
 # cleanup
 ::tcltest::cleanupTests
 return
diff --git a/tests/color.test b/tests/color.test
index 9dbc85a..d2ed785 100644
--- a/tests/color.test
+++ b/tests/color.test
@@ -5,7 +5,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: color.test,v 1.4 2000/03/02 23:52:55 hobbs Exp $
+# RCS: @(#) $Id: color.test,v 1.4.2.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -192,9 +192,13 @@ test color-2.4 {Tk_GetColor procedure} {
 test color-2.5 {Tk_GetColor procedure} {
     winfo rgb .t #00FF00
 } {0 65535 0}
-test color-2.6 {Tk_GetColor procedure} {
+test color-2.6 {Tk_GetColor procedure} {nonPortable} {
+    # Red doesn't always map to *pure* red
     winfo rgb .t red
 } {65535 0 0}
+test color-2.7 {Tk_GetColor procedure} {
+    winfo rgb .t #ff0000
+} {65535 0 0}
 
 test color-3.1 {Tk_FreeColor procedure, reference counting} {
     eval destroy [winfo child .t]
diff --git a/tests/cursor.test b/tests/cursor.test
index bb01561..9591e4a 100644
--- a/tests/cursor.test
+++ b/tests/cursor.test
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: cursor.test,v 1.2 1999/04/16 01:51:36 stanton Exp $
+# RCS: @(#) $Id: cursor.test,v 1.2.12.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -61,37 +61,37 @@ test cursor-2.2 {Tk_GetCursor procedure} {
 } {1 {bad cursor spec "@xyzzy"}}
 
 test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} {
-    set x arrow
+    set x heart
     destroy .b1 .b2 .b3
     button .b1 -cursor $x
     button .b3 -cursor $x
     button .b2 -cursor $x
     set result {}
-    lappend result [testcursor arrow]
+    lappend result [testcursor heart]
     destroy .b1
-    lappend result [testcursor arrow]
+    lappend result [testcursor heart]
     destroy .b2
-    lappend result [testcursor arrow]
+    lappend result [testcursor heart]
     destroy .b3
-    lappend result [testcursor arrow]
+    lappend result [testcursor heart]
 } {{{3 1}} {{2 1}} {{1 1}} {}}
 
 test cursor-4.1 {FreeCursorObjProc} {
     destroy .b
-    set x [format arrow]
+    set x [format heart]
     button .b -cursor $x
-    set y [format arrow]
+    set y [format heart]
     .b configure -cursor $y
-    set z [format arrow]
+    set z [format heart]
     .b configure -cursor $z
     set result {}
-    lappend result [testcursor arrow]
+    lappend result [testcursor heart]
     set x red
-    lappend result [testcursor arrow]
+    lappend result [testcursor heart]
     set z 32
-    lappend result [testcursor arrow]
+    lappend result [testcursor heart]
     destroy .b
-    lappend result [testcursor arrow]
+    lappend result [testcursor heart]
     set y bogus
     set result
 } {{{1 3}} {{1 2}} {{1 1}} {}}
diff --git a/tests/entry.test b/tests/entry.test
index f8fd7ef..b78c958 100644
--- a/tests/entry.test
+++ b/tests/entry.test
@@ -6,20 +6,12 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: entry.test,v 1.7 2000/03/07 22:27:50 hobbs Exp $
+# RCS: @(#) $Id: entry.test,v 1.7.2.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
 }
 
-if {[lsearch [image types] test] < 0} {
-    puts "This application hasn't been compiled with the \"test\""
-    puts "image, so I can't run this test.  Are you sure you're using"
-    puts "tktest instead of wish?"
-    ::tcltest::cleanupTests
-    return
-}
-
 foreach i [winfo children .] {
     destroy $i
 }
@@ -74,6 +66,8 @@ foreach test {
     {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}}
     {-insertofftime 100 100 3.2 {expected integer but got "3.2"}}
     {-insertontime 100 100 3.2 {expected integer but got "3.2"}}
+    {-invalidcommand "any string" "any string" {} {}}
+    {-invcmd "any string" "any string" {} {}}
     {-justify right right bogus {bad justification "bogus": must be left, right, or center}}
     {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
     {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}}
@@ -1511,6 +1505,53 @@ catch {unset ::e ::vVals}
 ## End validation tests
 ##
 
+test entry-20.1 {widget deletion while active} {
+    destroy .e
+    entry .e -validate all \
+	    -validatecommand { destroy %W ; return 1 } \
+	    -invalidcommand bell
+    update
+    .e insert 0 abc
+    winfo exists .e
+} 0
+test entry-20.2 {widget deletion while active} {
+    destroy .e
+    entry .e -validate all \
+	    -validatecommand { return 0 } \
+	    -invalidcommand { destroy %W }
+    .e insert 0 abc
+    winfo exists .e
+} 0
+test entry-20.3 {widget deletion while active} {
+    destroy .e
+    entry .e -validate all \
+	    -validatecommand { rename .e {} ; return 1 }
+    .e insert 0 abc
+    winfo exists .e
+} 0
+test entry-20.4 {widget deletion while active} {
+    destroy .e
+    entry .e -validate all \
+	    -validatecommand { return 0 } \
+	    -invalidcommand { rename .e {} }
+    .e insert 0 abc
+    winfo exists .e
+} 0
+test entry-20.5 {widget deletion while active} {
+    destroy .e
+    entry .e -validatecommand { destroy .e ; return 0 }
+    .e validate
+    winfo exists .e
+} 0
+test entry-20.6 {widget deletion while active} {
+    destroy .e
+    pack [entry .e]
+    update
+    .e config -xscrollcommand { destroy .e }
+    update idle
+    winfo exists .e
+} 0
+
 # XXX Still need to write tests for EntryBlinkProc, EntryFocusProc,
 # and EntryTextVarProc.
 
diff --git a/tests/event.test b/tests/event.test
index f1d0450..adc5328 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: event.test,v 1.5 2000/04/10 22:43:13 ericm Exp $
+# RCS: @(#) $Id: event.test,v 1.5.2.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -22,6 +22,144 @@ raise .
 # 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
+    }
+
+    array set keypress_lookup [list \
+        " " space \
+        ! exclam \
+        \" quotedbl \
+        \# numbersign \
+        \$ dollar \
+        % percent \
+        & ampersand \
+        ( parenleft \
+        ) parenright \
+        * asterisk \
+        + plus \
+        , comma \
+        - minus \
+        . period \
+        / slash \
+        : colon \
+        \; semicolon \
+        < less \
+        = equal \
+        > greater \
+        ? question \
+        @ at \
+        \[ bracketleft \
+        \\ backslash \
+        \] bracketright \
+        ^ asciicircum \
+        _ underscore \
+        \{ braceleft \
+        | bar \
+        \} braceright \
+        ~ asciitilde \
+        ' apostrophe \
+        "\n" Return]
+}
+
+# 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]
+
+    event generate $win <KeyPress-$keysym>
+    _pause 50
+    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 } {
+    foreach {x1 y1 x2 y2} [$text bbox $ind] break
+    set middle_y [expr {$y1 + (($y2 - $y1) / 2)}]
+    return [list $x1 $middle_y]
+}
+
+
+# Begining of the actual tests
+
 test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} {
     button .b -text Test
     pack .b
@@ -51,19 +189,249 @@ test event-1.2 {event generate <Alt-z>} {
 	destroy .e
 	set ::event12result
 } 1
-# cleanup
-::tcltest::cleanupTests
-return
 
+test event-keypress-1.1 { 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
+    focus -force $e
+    _keypress_string $e HELLO\n
+    list [$e get] $return_binding
+} {HELLO 1}
 
+test event-keypress-1.2 { 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
+    focus -force $e
+    _keypress_string $e MELLO
+    _keypress $e BackSpace
+    _keypress $e BackSpace
+    $e get
+} MEL
 
+test event-keypress-1.3 { 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
+    focus -force $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-keypress-1.4 { 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
+    focus -force $e
+    _keypress_string $e HELLO\n
+    list [$e get 1.0 end] $return_binding
+} [list "HELLO\n\n" 1]
+
+test event-keypress-1.5 { 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
+    focus -force $e
+    _keypress_string $e MELLO
+    _keypress $e BackSpace
+    _keypress $e BackSpace
+    $e get 1.0 1.end
+} MEL
+
+test event-keypress-1.6 { 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
+    focus -force $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-click-drag-1.1 { 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
+    focus -force $e
+    _keypress_string $e "A Tcl/Tk selection test!"
+    set anchor 1.6
+    set selend 1.18
+
+    set result [list [$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 [$e get sel.first sel.last]
+
+    # 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 [$e get sel.first sel.last]
+
+} {{A Tcl/Tk selection test!} 1.6 1.18 {Tk selection} 1.2 {Tcl/Tk selection}}
+
+test event-click-drag-1.2 { 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
+    focus -force $e
+    _keypress_string $e "A Tcl/Tk selection test!"
+    set anchor 6
+    set selend 18
+
+    set result [list [$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 [selection get]
 
+    # 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 [selection get]
 
+} {{A Tcl/Tk selection test!} 6 18 {Tk selection} 2 {Tcl/Tk selection}}
 
+# cleanup
+
+destroy .t
+
+unset keypress_lookup
+rename _init_keypress_lookup {}
+rename _keypress_lookup {}
+rename _keypress {}
+rename _pause {}
+rename _text_ind_to_x_y {}
+
+::tcltest::cleanupTests
+return
diff --git a/tests/focus.test b/tests/focus.test
index de6eda3..d8febb8 100644
--- a/tests/focus.test
+++ b/tests/focus.test
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: focus.test,v 1.5.12.1 2000/08/05 23:53:14 hobbs Exp $
+# RCS: @(#) $Id: focus.test,v 1.5.12.2 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -572,7 +572,7 @@ test focus-6.1 {miscellaneous - embedded application in same process} \
     bind all <FocusOut> {lappend x "focus out %W %d"}
     interp create child
     child eval "set argv {-use [winfo id .t.f1]}"
-    load {} tk child
+    load {} Tk child
     child eval {
 	entry .e1 -bg lightBlue
 	pack .e1
diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test
index 99d3832..28704da 100644
--- a/tests/imgPhoto.test
+++ b/tests/imgPhoto.test
@@ -9,7 +9,7 @@
 #
 # Author: Paul Mackerras (paulus@cs.anu.edu.au)
 #
-# RCS: @(#) $Id: imgPhoto.test,v 1.7 1999/12/14 06:53:13 hobbs Exp $
+# RCS: @(#) $Id: imgPhoto.test,v 1.7.2.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -436,6 +436,46 @@ test imgPhoto-13.1 {check separation of images in different interpreters} {
     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 [file join $::tcltest::workingDir imgPhoto-14.1.gif]
+    if {[file exists $filename]} {
+	catch {file delete -force $filename}
+    }
+    $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
+
 destroy .c
 eval image delete [image names]
 
@@ -445,16 +485,3 @@ if {[info exists removeREADME]} {
 }
 ::tcltest::cleanupTests
 return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/listbox.test b/tests/listbox.test
index f1546d7..b45589a 100644
--- a/tests/listbox.test
+++ b/tests/listbox.test
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: listbox.test,v 1.12 2000/02/01 11:41:22 hobbs Exp $
+# RCS: @(#) $Id: listbox.test,v 1.12.2.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -2050,16 +2050,22 @@ test listbox-25.2 {listbox item configurations and widget based inserts} {
     .l insert 0 1 2 3 4
     list [.l itemcget 0 -fg] [.l itemcget 4 -fg]
 } [list {} red]
-    
-
 
 resetGridInfo
-catch {destroy .l2}
-catch {destroy .t}
-catch {destroy .e}
-catch {destroy .partial}
+eval destroy [winfo children .]
 option clear
 
+test listbox-27.1 {widget deletion while active} {
+    destroy .l
+    pack [listbox .l]
+    update
+    .l configure -cursor xterm -xscrollcommand { destroy .l }
+    update idle
+    winfo exists .l
+} 0
+
+eval destroy [winfo children .]
+
 # cleanup
 ::tcltest::cleanupTests
 return
diff --git a/tests/macEmbed.test b/tests/macEmbed.test
index 67a77a0..5882378 100644
--- a/tests/macEmbed.test
+++ b/tests/macEmbed.test
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: macEmbed.test,v 1.4 1999/04/16 01:51:38 stanton Exp $
+# RCS: @(#) $Id: macEmbed.test,v 1.4.12.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -216,7 +216,7 @@ test unixEmbed-5.1 {TkpClaimFocus procedure} {macOnly tempNotMac} {
     pack .f1 .f2
     interp create child
     child eval "set argv {-use [winfo id .f1]}"
-    load {} tk child
+    load {} Tk child
     child eval {
 	. configure -bd 2 -highlightthickness 2 -relief sunken
     }
diff --git a/tests/macMenu.test b/tests/macMenu.test
index b76b7e6..e91f3d5 100644
--- a/tests/macMenu.test
+++ b/tests/macMenu.test
@@ -7,7 +7,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: macMenu.test,v 1.3 1999/04/16 01:51:39 stanton Exp $
+# RCS: @(#) $Id: macMenu.test,v 1.3.12.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -852,7 +852,7 @@ test macMenu-21.3 {TkpSetMainMenubar - different interps} {
     catch {destroy .m1}
     catch {interp delete testinterp}
     interp create testinterp
-    load {} tk testinterp
+    load {} Tk testinterp
     menu .m1
     . configure -menu .m1
     raise .
diff --git a/tests/menu.test b/tests/menu.test
index e04ef3e..5bd20d1 100644
--- a/tests/menu.test
+++ b/tests/menu.test
@@ -5,7 +5,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: menu.test,v 1.3.12.1 2000/08/05 23:53:14 hobbs Exp $
+# RCS: @(#) $Id: menu.test,v 1.3.12.2 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -2300,7 +2300,7 @@ test menu-26.1 {DestroyMenuHashTable} {
 test menu-27.1 {GetMenuHashTable} {
     catch {interp destroy testinterp}
     interp create testinterp
-    load {} tk testinterp
+    load {} Tk testinterp
     list [catch {interp eval testinterp {menu .m1}} msg] $msg [interp delete testinterp]
 } {0 .m1 {}}
 
@@ -2449,6 +2449,8 @@ test menu-35.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} {
 	menu .two.m
 	destroy .one
 	destroy .two
+    } else {
+	puts "skipping: Multi-screen tests requiring TK_ALT_DISPLAY..."
     }
 } {}
 
diff --git a/tests/safe.test b/tests/safe.test
index b791811..b2ebf67 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -6,12 +6,32 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: safe.test,v 1.6 1999/12/14 06:53:13 hobbs Exp $
+# RCS: @(#) $Id: safe.test,v 1.6.2.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
 }
 
+## 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
+
 foreach i [winfo children .] {
     destroy $i
 }
@@ -176,16 +196,3 @@ test safe-7.1 {canvas printing} {
 unset hidden_cmds
 ::tcltest::cleanupTests
 return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/tk.test b/tests/tk.test
index bfd0cf8..1251631 100644
--- a/tests/tk.test
+++ b/tests/tk.test
@@ -5,7 +5,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: tk.test,v 1.4 1999/12/16 21:58:29 hobbs Exp $
+# RCS: @(#) $Id: tk.test,v 1.4.2.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -101,9 +101,8 @@ test tk-4.6 {tk command: useinputmethods: set new} {unixOnly} {
     if {[tk useinputmethods 1] == 0} {
 	puts "this wish doesn't have XIM (X Input Methods) support"
     }
-    # We should always start with XIM support off
     set useim
-} 0
+} $useim
 test tk-4.7 {tk command: useinputmethods: set new} {macOrPc} {
     # Mac and Windows don't have X Input Methods, so this should
     # always return 0
diff --git a/tests/unixWm.test b/tests/unixWm.test
index 61c8a5a..eb4a94b 100644
--- a/tests/unixWm.test
+++ b/tests/unixWm.test
@@ -7,7 +7,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: unixWm.test,v 1.12 2000/03/29 00:09:07 ericm Exp $
+# RCS: @(#) $Id: unixWm.test,v 1.12.2.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -1832,7 +1832,7 @@ test unixWm-50.4 {Tk_CoordsToWindow procedure, window in other application} {
     wm geometry .t +0+0
     tkwait visibility .t
     interp create slave
-    load {} tk slave
+    load {} Tk slave
     slave eval {wm geometry . 200x200+0+0; tkwait visibility .}
     set result [list [winfo containing 100 100] \
 	    [slave eval {winfo containing 100 100}]]
diff --git a/tests/winClipboard.test b/tests/winClipboard.test
index fca13eb..f382f06 100644
--- a/tests/winClipboard.test
+++ b/tests/winClipboard.test
@@ -10,7 +10,7 @@
 # Copyright (c) 1998-2000 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: winClipboard.test,v 1.7 2000/04/12 18:52:14 hobbs Exp $
+# RCS: @(#) $Id: winClipboard.test,v 1.7.2.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -33,23 +33,31 @@ test winClipboard-1.1 {TkSelGetSelection} {pcOnly} {
 test winClipboard-1.2 {TkSelGetSelection} {pcOnly} {
     clipboard clear
     clipboard append {}
-    list [selection get -selection CLIPBOARD] [testclipboard]
+    catch {selection get -selection CLIPBOARD} r1
+    catch {testclipboard} r2
+    list $r1 $r2
 } {{} {}}
 test winClipboard-1.3 {TkSelGetSelection & TkWinClipboardRender} {pcOnly} {
     clipboard clear
     clipboard append abcd
     update
-    list [selection get -selection CLIPBOARD] [testclipboard]
+    catch {selection get -selection CLIPBOARD} r1
+    catch {testclipboard} r2
+    list $r1 $r2
 } {abcd abcd}
 test winClipboard-1.4 {TkSelGetSelection & TkWinClipboardRender} {pcOnly} {
     clipboard clear
     clipboard append "line 1\nline 2"
-    list [selection get -selection CLIPBOARD] [testclipboard]
+    catch {selection get -selection CLIPBOARD} r1
+    catch {testclipboard} r2
+    list $r1 $r2
 } [list "line 1\nline 2" "line 1\r\nline 2"]
 test winClipboard-1.5 {TkSelGetSelection & TkWinClipboardRender} {pcOnly} {
     clipboard clear
     clipboard append "line 1\u00c7\nline 2"
-    list [selection get -selection CLIPBOARD] [testclipboard]
+    catch {selection get -selection CLIPBOARD} r1
+    catch {testclipboard} r2
+    list $r1 $r2
 } [list "line 1\u00c7\nline 2" [bytestring "line 1\u00c7\r\nline 2"]]
 
 test winClipboard-2.1 {TkSelUpdateClipboard reentrancy problem} {pcOnly} {
@@ -57,14 +65,18 @@ test winClipboard-2.1 {TkSelUpdateClipboard reentrancy problem} {pcOnly} {
     clipboard append -type OUR_ACTION "action data"
     clipboard append "string data"
     update
-    list [selection get -selection CLIPBOARD -type OUR_ACTION] [testclipboard]
+    catch {selection get -selection CLIPBOARD -type OUR_ACTION} r1
+    catch {testclipboard} r2
+    list $r1 $r2
 } [list "action data" "string data"]
 test winClipboard-2.2 {TkSelUpdateClipboard reentrancy problem} {pcOnly} {
     clipboard clear
     clipboard append -type OUR_ACTION "new data"
     clipboard append "more data in string"
     update
-    list [testclipboard] [selection get -selection CLIPBOARD -type OUR_ACTION]
+    catch {testclipboard} r1
+    catch {selection get -selection CLIPBOARD -type OUR_ACTION} r2
+    list $r1 $r2
 } [list "more data in string" "new data"]
 
 # cleanup
diff --git a/tests/winDialog.test b/tests/winDialog.test
index 15b491f..81670c4 100644
--- a/tests/winDialog.test
+++ b/tests/winDialog.test
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: winDialog.test,v 1.4 2000/04/14 08:34:28 hobbs Exp $
+# RCS: @(#) $Id: winDialog.test,v 1.4.2.1 2001/04/04 07:57:17 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -126,16 +126,16 @@ test winDialog-5.8 {GetFileName: extension begins with .} {nt} {
 	SetText 0x480 bar
 	Click 1
     }
-    set x
-} [file join [pwd] bar.foo]
+    string totitle $x
+} [string totitle [file join [pwd] bar.foo]]
 test winDialog-5.9 {GetFileName: extension doesn't begin with .} {nt} {
     start {set x [tk_getSaveFile -defaultextension foo -title Save]}
     then {
 	SetText 0x480 bar
 	Click 1
     }
-    set x
-} [file join [pwd] bar.foo]
+    string totitle $x
+} [string totitle [file join [pwd] bar.foo]]
 test winDialog-5.10 {GetFileName: file types} {nt} {
 #	    case FILE_TYPES: 
 
@@ -173,8 +173,8 @@ test winDialog-5.14 {GetFileName: initial file} {nt} {
     then {
 	Click 1
     }
-    set x
-} [file join [pwd] "12x 456"]
+    string totitle $x
+} [string totitle [file join [pwd] "12x 456"]]
 test winDialog-5.15 {GetFileName: initial file: Tcl_TranslateFileName()} {nt} {
 #		if (Tcl_TranslateFileName(interp, string, &ds) == NULL) 
     list [catch {tk_getOpenFile -initialfile ~12x/455} msg] $msg
@@ -189,8 +189,8 @@ test winDialog-5.16 {GetFileName: initial file: long name} {nt} {
     then {
 	Click 1
     }
-    set x
-} [string range [file join [pwd] $a] 0 257]
+    string totitle $x
+} [string totitle [string range [file join [pwd] $a] 0 257]]
 test winDialog-5.17 {GetFileName: parent} {nt} {
 #	    case FILE_PARENT: