* Merged 8.1 branch into the main trunk

1 files changed, 60 insertions, 47 deletions

diff --git a/tests/clrpick.test b/tests/clrpick.test
index a56b6b3..db101b8 100644
--- a/tests/clrpick.test
+++ b/tests/clrpick.test
@@ -2,22 +2,27 @@
 # 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.
 #
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: clrpick.test,v 1.2 1998/09/14 18:23:45 stanton Exp $
+# RCS: @(#) $Id: clrpick.test,v 1.3 1999/04/16 01:51:35 stanton Exp $
 #
 
-if {[string compare test [info procs test]] == 1} {
-    source defs
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    source [file join [pwd] [file dirname [info script]] defs.tcl]
 }
 
+# Some tests require user interaction on non-unix platform
+
+set ::tcltest::testConfig(nonUnixUserInteraction) \
+    [expr {$::tcltest::testConfig(userInteraction) || \
+	$::tcltest::testConfig(unixOnly)}]
+
 test clrpick-1.1 {tk_chooseColor command} {
     list [catch {tk_chooseColor -foo} msg] $msg
-} {1 {unknown option "-foo", must be -initialcolor, -parent or -title}}
+} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}}
 
-catch {tk_chooseColor -foo} msg
+catch {tk_chooseColor -foo 1} msg
 regsub -all ,      $msg "" options
 regsub \"-foo\" $options "" options
 
@@ -31,7 +36,7 @@ foreach option $options {
 
 test clrpick-1.3 {tk_chooseColor command} {
     list [catch {tk_chooseColor -foo bar} msg] $msg
-} {1 {unknown option "-foo", must be -initialcolor, -parent or -title}}
+} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}}
 
 test clrpick-1.4 {tk_chooseColor command} {
     list [catch {tk_chooseColor -initialcolor} msg] $msg
@@ -55,14 +60,6 @@ if {[info commands tkColorDialog] == ""} {
     set isNative 0
 }
 
-if {$isNative && ![info exists INTERACTIVE]} {
-    puts " Some tests were skipped because they could not be performed"
-    puts " automatically on this platform. If you wish to execute them"
-    puts " interactively, set the TCL variable INTERACTIVE and re-run"
-    puts " the test."
-    return
-}
-
 proc ToPressButton {parent btn} {
     global isNative
     if {!$isNative} {
@@ -141,8 +138,9 @@ set verylongstring $verylongstring$verylongstring
 
 # 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
-set nomorecolors 0
+set ::tcltest::testConfig(colorsLeftover) 1
 set i 0
 canvas .c
 pack .c -expand 1 -fill both
@@ -160,7 +158,7 @@ while {$i<$numcolors} {
 	set g [expr $g/256]
 	set b [expr $b/256]
 	if {"$color" != "#[format %02x%02x%02x $r $g $b]"} {
-	    set nomorecolors 1
+	    set ::tcltest::testConfig(colorsLeftover) 0
 	}
     }
     .c delete $i
@@ -169,47 +167,62 @@ while {$i<$numcolors} {
 
 destroy .c
 
-if {!$nomorecolors} {
-    set color #404040
-    test clrpick-2.1 {tk_chooseColor command} {
-	ToPressButton $parent ok
-	tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color -parent $parent
-    } "$color"
+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} {
-	if {$tcl_platform(platform) == "macintosh"} {
-	    set colors "32768 32768 16384"
-	} else {
-	    set colors "128 128 64"
-	}
-	ToChooseColorByKey $parent 128 128 64
-	tk_chooseColor -parent $parent -title "choose $colors"
-    } "$color"
+set color #808040
+test clrpick-2.2 {tk_chooseColor command} \
+	{nonUnixUserInteraction colorsLeftover} {
+    if {$tcl_platform(platform) == "macintosh"} {
+	set colors "32768 32768 16384"
+    } else {
+	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} {
-	ToPressButton $parent ok
-	tk_chooseColor -parent $parent -title "Press OK"
-    } "$color"
-} else {
-    puts "Skipped tests clrpick2.1, clrpick2.2 and clrpick2.3 because"
-    puts "you ran out of colors in your color palette, and this would"
-    puts "have caused the tests to generate errors."
-}
+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} {
+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} {
+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} {
+test clrpick-3.2 {tk_chooseColor: background events} {nonUnixUserInteraction} {
     after 1 {set x 53}
     ToPressButton $parent cancel
     tk_chooseColor -parent $parent -title "Press Cancel"
 } ""
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+