fixed tests for bug ids: 1521 1578 1570 1580 and 1608

7 files changed, 87 insertions, 78 deletions

diff --git a/tests/defs.tcl b/tests/defs.tcl
index 5986d03..bbeadfb 100644
--- a/tests/defs.tcl
+++ b/tests/defs.tcl
@@ -11,7 +11,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 # 
-# RCS: @(#) $Id: defs.tcl,v 1.1.2.8 1999/03/26 00:07:54 hershey Exp $
+# RCS: @(#) $Id: defs.tcl,v 1.1.2.9 1999/04/02 18:06:43 hershey Exp $
 
 # Initialize wish shell
 if {[info exists tk_version]} {
@@ -458,9 +458,10 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
 
 	# if any tests were skipped, print the constraints that kept them
 	# from running.
-	if {$::tcltest::numTests(Skipped) > 0} {
+	set constraintList [array names ::tcltest::skippedBecause]
+	if {[llength $constraintList] > 0} {
 	    puts stdout "Number of tests skipped for each constraint:"
-	    foreach constraint [lsort [array names ::tcltest::skippedBecause]] {
+	    foreach constraint [lsort $constraintList] {
 		puts stdout \
 			"\t$::tcltest::skippedBecause($constraint)\t$constraint"
 		unset ::tcltest::skippedBecause($constraint)
diff --git a/tests/grid.test b/tests/grid.test
index 030367b..18f5f4b 100644
--- a/tests/grid.test
+++ b/tests/grid.test
@@ -5,7 +5,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: grid.test,v 1.1.4.6 1999/03/26 19:14:48 hershey Exp $
+# RCS: @(#) $Id: grid.test,v 1.1.4.7 1999/04/02 18:06:43 hershey Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -988,23 +988,26 @@ test grid-14.2 {structure notify} {
 } {{0 0 200 100,0 0 200 100} {0 0 240 140,20 20 200 100}}
 grid_reset 14.2
 
-test grid-14.3 {map notify} {
-	global A
-	catch {unset A}
-	bind . <Configure> {incr A(%W)}
-	set A(.) 0
-	foreach i {0 1 2} {
-		frame .$i -width 100 -height 75
-		set A(.$i) 0
-	}
-	grid .0 .1 .2
-	update
-	bind <Configure> .1 {destroy .0}
-	.2 configure -bd 10
-	update
-	bind . <Configure> {}
-	array get A
-} {.2 2 .0 1 . 1 .1 1}
+test grid-14.3 {map notify: bug 1648} {nonPortable} {
+    # This test is nonPortable because the number of times
+    # A(.) will be incremented is unspecified--the behavior
+    # is different accross window managers.
+    global A
+    catch {unset A}
+    bind . <Configure> {incr A(%W)}
+    set A(.) 0
+    foreach i {0 1 2} {
+	frame .$i -width 100 -height 75
+	set A(.$i) 0
+    }
+    grid .0 .1 .2
+    update
+    bind <Configure> .1 {destroy .0}
+    .2 configure -bd 10
+    update
+    bind . <Configure> {}
+    array get A
+} {.2 2 .0 1 . 2 .1 1}
 grid_reset 14.3
 
 test grid-15.1 {lost slave} {
diff --git a/tests/safe.test b/tests/safe.test
index 1bbe81c..9b0c069 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: safe.test,v 1.1.4.5 1999/03/24 02:54:57 hershey Exp $
+# RCS: @(#) $Id: safe.test,v 1.1.4.6 1999/04/02 18:06:44 hershey Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -101,9 +101,9 @@ test safe-4.1 {testing loadTk} {
     # 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 impy 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
+    # 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
 } {}
 
diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test
index 64e7d08..7344d40 100644
--- a/tests/unixEmbed.test
+++ b/tests/unixEmbed.test
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: unixEmbed.test,v 1.1.4.6 1999/03/26 00:08:07 hershey Exp $
+# RCS: @(#) $Id: unixEmbed.test,v 1.1.4.7 1999/04/02 18:06:44 hershey Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -73,7 +73,7 @@ test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} {
     catch {destroy .t}
     list [catch {toplevel .t -use 47} msg] $msg
 } {1 {couldn't create child of window "47"}}
-test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {
+test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {nonPortable} {
     catch {destroy .t}
     catch {destroy .x}
     toplevel .t -colormap new
@@ -85,7 +85,7 @@ test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {
     destroy .t
     set result
 } {0}
-test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {
+test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {nonPortable} {
     catch {destroy .t}
     catch {destroy .t2}
     catch {destroy .x}
diff --git a/tests/unixFont.test b/tests/unixFont.test
index 5de7d6d..e64e422 100644
--- a/tests/unixFont.test
+++ b/tests/unixFont.test
@@ -12,7 +12,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: unixFont.test,v 1.1.4.6 1999/03/26 00:08:08 hershey Exp $
+# RCS: @(#) $Id: unixFont.test,v 1.1.4.7 1999/04/02 18:06:45 hershey Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -223,15 +223,17 @@ test unixfont-8.1 {AllocFont procedure: use old font} {
     font delete xyz
 } {}
 test unixfont-8.2 {AllocFont procedure: parse information from XLFD} {
-    expr [lindex [font actual {-family times -size 0}] 3]==0
+    expr {[lindex [font actual {-family times -size 0}] 3] == 0}
 } {0}
 test unixfont-8.3 {AllocFont procedure: can't parse info from name} {
-    if [catch {set a [font actual a12biluc]}]==0 {
-	string compare $a "-family a12biluc -size 0 -weight normal -slant roman -underline 0 -overstrike 0"
-    } else {
-	set a 0
-    }
-} {0}
+    catch {unset fontArray}
+    # check that font actual returns the correct attributes.
+    # the values of those attributes are system dependent.
+    array set fontArray [font actual a12biluc]
+    set result [lsort [array get fontArray]]
+    catch {unset fontArray}
+    set result
+} {-family -overstrike -size -slant -underline -weight}
 test unixfont-8.4 {AllocFont procedure: classify characters} {
     set x 0
     incr x [font measure $courier "\u4000"]   ;# 6
diff --git a/tests/unixWm.test b/tests/unixWm.test
index f905b9d..a70b640 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.1.4.8 1999/03/26 00:08:10 hershey Exp $
+# RCS: @(#) $Id: unixWm.test,v 1.1.4.9 1999/04/02 18:06:45 hershey Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -1475,22 +1475,26 @@ test unixWm-44.6 {UpdateGeometryInfo procedure, negative height} {
     update
     list [winfo width .t] [winfo height .t]
 } {100 1}
+
+catch {destroy .t}
+toplevel .t -width 80 -height 60
 test unixWm-44.7 {UpdateGeometryInfo procedure, computing position} {
-    catch {destroy .t}
-    toplevel .t -width 80 -height 60
     wm geometry .t +5-10
     wm overrideredirect .t 1
     tkwait visibility .t
     list [winfo x .t] [winfo y .t]
-} "5 [expr [winfo screenheight .t] - 70]"
+} [list 5 [expr [winfo screenheight .t] - 70]]
+
+catch {destroy .t}
+toplevel .t -width 80 -height 60
 test unixWm-44.8 {UpdateGeometryInfo procedure, computing position} {
-    catch {destroy .t}
-    toplevel .t -width 80 -height 60
     wm geometry .t -30+2
     wm overrideredirect .t 1
     tkwait visibility .t
     list [winfo x .t] [winfo y .t]
-} "[expr [winfo screenwidth .t] - 110] 2"
+} [list [expr [winfo screenwidth .t] - 110] 2]
+catch {destroy .t}
+
 test unixWm-44.9 {UpdateGeometryInfo procedure, updating fixed dimensions} {unixOnly} {
     catch {destroy .t}
     toplevel .t -width 80 -height 60
diff --git a/tests/winfo.test b/tests/winfo.test
index a64e896..8c85ca5 100644
--- a/tests/winfo.test
+++ b/tests/winfo.test
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: winfo.test,v 1.1.4.5 1999/03/24 02:55:16 hershey Exp $
+# RCS: @(#) $Id: winfo.test,v 1.1.4.6 1999/04/02 18:06:46 hershey Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -18,6 +18,10 @@ foreach i [winfo children .] {
 wm geometry . {}
 raise .
 
+# Some tests require the testwrapper command
+set ::tcltest::testConfig(testwrapper) \
+	[expr {[info commands testwrapper] != {}}]
+
 # eatColors --
 # Creates a toplevel window and allocates enough colors in it to
 # use up all the slots in the colormap.
@@ -87,32 +91,33 @@ test winfo-2.7 {"winfo atom" command} {
     winfo atomname -displayof . 2
 } SECONDARY
 
-if {([winfo depth .] == 8) && ([winfo visual .] == "pseudocolor")} {
-    test winfo-3.1 {"winfo colormapfull" command} {
-	list [catch {winfo colormapfull} msg] $msg
-    } {1 {wrong # args: should be "winfo colormapfull window"}}
-    test winfo-3.2 {"winfo colormapfull" command} {
-	list [catch {winfo colormapfull a b} msg] $msg
-    } {1 {wrong # args: should be "winfo colormapfull window"}}
-    test winfo-3.3 {"winfo colormapfull" command} {
-	list [catch {winfo colormapfull foo} msg] $msg
-    } {1 {bad window path name "foo"}}
-    test winfo-3.4 {"winfo colormapfull" command} {macOrUnix} {
-	eatColors .t {-colormap new}
-	set result [list [winfo colormapfull .] [winfo colormapfull .t]]
-	.t.c delete 34
-	lappend result [winfo colormapfull .t]
-	.t.c create rectangle 30 30 80 80 -fill #441739
-	lappend result [winfo colormapfull .t]
-	.t.c create rectangle 40 40 90 90 -fill #ffeedd
-	lappend result [winfo colormapfull .t]
-	destroy .t.c
-	lappend result [winfo colormapfull .t]
-    } {0 1 0 0 1 0}
-    catch {destroy .t}
-}
-
+# Some tests require the "pseudocolor" visual class.
+set ::tcltest::testConfig(pseudocolor) \
+	[expr {([winfo depth .] == 8) && ([winfo visual .] == "pseudocolor")}]
+
+test winfo-3.1 {"winfo colormapfull" command} {pseudocolor} {
+    list [catch {winfo colormapfull} msg] $msg
+} {1 {wrong # args: should be "winfo colormapfull window"}}
+test winfo-3.2 {"winfo colormapfull" command} {pseudocolor} {
+    list [catch {winfo colormapfull a b} msg] $msg
+} {1 {wrong # args: should be "winfo colormapfull window"}}
+test winfo-3.3 {"winfo colormapfull" command} {pseudocolor} {
+    list [catch {winfo colormapfull foo} msg] $msg
+} {1 {bad window path name "foo"}}
+test winfo-3.4 {"winfo colormapfull" command} {macOrUnix pseudocolor} {
+    eatColors .t {-colormap new}
+    set result [list [winfo colormapfull .] [winfo colormapfull .t]]
+    .t.c delete 34
+    lappend result [winfo colormapfull .t]
+    .t.c create rectangle 30 30 80 80 -fill #441739
+    lappend result [winfo colormapfull .t]
+    .t.c create rectangle 40 40 90 90 -fill #ffeedd
+    lappend result [winfo colormapfull .t]
+    destroy .t.c
+    lappend result [winfo colormapfull .t]
+} {0 1 0 0 1 0}
 catch {destroy .t}
+
 toplevel .t -width 550 -height 400
 frame .t.f -width 80 -height 60 -bd 2 -relief raised
 place .t.f -x 50 -y 50
@@ -205,15 +210,9 @@ test winfo-7.6 {"winfo pathname" command} {
 test winfo-7.7 {"winfo pathname" command} {
     winfo pathname -displayof .b [winfo id .]
 } {.}
-
-if {[string compare testwrapper [info commands testwrapper]] == 0} {
-    puts "This application hasn't been compiled with the testwrapper command,"
-    puts "therefore I am skipping all of these tests."
-
-    test winfo-7.8 {"winfo pathname" command} {unixOnly} {
-        winfo pathname [testwrapper .]
-    } {}
-}
+test winfo-7.8 {"winfo pathname" command} {unixOnly testwrapper} {
+    winfo pathname [testwrapper .]
+} {}
 
 test winfo-8.1 {"winfo pointerx" command} {
     catch [winfo pointerx .b]