* Merged 8.1 branch into the main trunk

1 files changed, 50 insertions, 24 deletions

diff --git a/tests/msgbox.test b/tests/msgbox.test
index 0511c87..e9a16d4 100644
--- a/tests/msgbox.test
+++ b/tests/msgbox.test
@@ -2,23 +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: msgbox.test,v 1.2 1998/09/14 18:23:49 stanton Exp $
+# RCS: @(#) $Id: msgbox.test,v 1.3 1999/04/16 01:51:39 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 msgbox-1.1 {tk_messageBox command} {
     list [catch {tk_messageBox -foo} msg] $msg
-} {1 {unknown option "-foo", must be -default, -icon, -message, -parent, -title or -type}}
+} {1 {bad option "-foo": must be -default, -icon, -message, -parent, -title, or -type}}
 test msgbox-1.2 {tk_messageBox command} {
     list [catch {tk_messageBox -foo bar} msg] $msg
-} {1 {unknown option "-foo", must be -default, -icon, -message, -parent, -title or -type}}
+} {1 {bad option "-foo": must be -default, -icon, -message, -parent, -title, or -type}}
 
 catch {tk_messageBox -foo bar} msg
 regsub -all ,      $msg "" options
@@ -38,23 +42,31 @@ test msgbox-1.4 {tk_messageBox command} {
 
 test msgbox-1.5 {tk_messageBox command} {
     list [catch {tk_messageBox -type foo} msg] $msg
-} {1 {invalid message box type "foo", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel}}
+} {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
-} {1 {invalid default button "1.1"}}
+} [list 1 [createPlatformMsg "1.1"]]
 
 test msgbox-1.7 {tk_messageBox command} {
     list [catch {tk_messageBox -default foo} msg] $msg
-} {1 {invalid default button "foo"}}
+} [list 1 [createPlatformMsg "foo"]]
 
 test msgbox-1.8 {tk_messageBox command} {
     list [catch {tk_messageBox -type yesno -default 3} msg] $msg
-} {1 {invalid default button "3"}}
+} [list 1 [createPlatformMsg "3"]]
 
 test msgbox-1.9 {tk_messageBox command} {
     list [catch {tk_messageBox -icon foo} msg] $msg
-} {1 {invalid icon "foo", must be error, info, question or warning}}
+} {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
@@ -66,14 +78,6 @@ if {[info commands tkMessageBox] == ""} {
     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 ChooseMsg {parent btn} {
     global isNative
     if {!$isNative} {
@@ -128,30 +132,52 @@ set specs {
 # 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.1 {tk_messageBox command} {
+    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.2 {tk_messageBox command -icon option} {
+	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.3 {tk_messageBox command} {
+	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
     }
 }
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+