Fix [66db98f30d]: choosedir, filebox, msgbox tests fails on macOS + undocumented options -message and -command

8 files changed, 75 insertions, 36 deletions

diff --git a/doc/chooseDirectory.n b/doc/chooseDirectory.n
index 8528ddb..e441d78 100644
--- a/doc/chooseDirectory.n
+++ b/doc/chooseDirectory.n
@@ -17,6 +17,13 @@ The procedure \fBtk_chooseDirectory\fR pops up a dialog box for the
 user to select a directory. The following \fIoption\-value\fR pairs are
 possible as command line arguments:
 .TP
+\fB\-command\fR \fIstring\fR
+Specifies the prefix of a Tcl command to invoke when the user closes the
+dialog after having selected an item. This callback is not called if the
+user cancelled the dialog. The actual command consists of \fIstring\fR
+followed by a space and the value selected by the user in the dialog. This
+is only available on Mac OS X.
+.TP
 \fB\-initialdir\fR \fIdirname\fR
 Specifies that the directories in \fIdirectory\fR should be displayed
 when the dialog pops up. If this parameter is not specified,
@@ -27,6 +34,10 @@ user-selected directory for the application. If the
 parameter specifies a relative path, the return value will convert the
 relative path to an absolute path.
 .TP
+\fB\-message\fR \fIstring\fR
+Specifies a message to include in the client area of the dialog.
+This is only available on Mac OS X.
+.TP
 \fB\-mustexist\fR \fIboolean\fR
 Specifies whether the user may specify non-existent directories.  If
 this parameter is true, then the user may only select directories that
diff --git a/doc/getOpenFile.n b/doc/getOpenFile.n
index 39bce41..d2323de 100644
--- a/doc/getOpenFile.n
+++ b/doc/getOpenFile.n
@@ -35,6 +35,13 @@ whether the existing file should be overwritten or not.
 The following \fIoption\-value\fR pairs are possible as command line
 arguments to these two commands:
 .TP
+\fB\-command\fR \fIstring\fR
+Specifies the prefix of a Tcl command to invoke when the user closes the
+dialog after having selected an item. This callback is not called if the
+user cancelled the dialog. The actual command consists of \fIstring\fR
+followed by a space and the value selected by the user in the dialog. This
+is only available on Mac OS X.
+.TP
 \fB\-confirmoverwrite\fR \fIboolean\fR
 Configures how the Save dialog reacts when the selected file already
 exists, and saving would overwrite it.  A true value requests a
diff --git a/doc/messageBox.n b/doc/messageBox.n
index 5ce1745..6bcbc09 100644
--- a/doc/messageBox.n
+++ b/doc/messageBox.n
@@ -24,6 +24,12 @@ buttons. Then it returns the symbolic name of the selected button.
 .PP
 The following option-value pairs are supported:
 .TP
+\fB\-command\fR \fIstring\fR
+Specifies the prefix of a Tcl command to invoke when the user closes the
+dialog. The actual command consists of \fIstring\fR followed by a space
+and the name of the button clicked by the user to close the dialog. This
+is only available on Mac OS X.
+.TP
 \fB\-default\fR \fIname\fR
 .
 \fIName\fR gives the symbolic name of the default button for
diff --git a/library/msgbox.tcl b/library/msgbox.tcl
index 6d329c2..98603af 100644
--- a/library/msgbox.tcl
+++ b/library/msgbox.tcl
@@ -234,7 +234,8 @@ proc ::tk::MessageBox {args} {
     }
     if {!$valid} {
 	return -code error -errorcode {TK MSGBOX DEFAULT} \
-	    "invalid default button \"$data(-default)\""
+	    "bad -default value \"$data(-default)\": must be\
+	    abort, retry, ignore, ok, cancel, no, or yes"
     }
 
     # 2. Set the dialog to be a child window of $parent
diff --git a/macosx/tkMacOSXDialog.c b/macosx/tkMacOSXDialog.c
index b98d6d8..1effe48 100644
--- a/macosx/tkMacOSXDialog.c
+++ b/macosx/tkMacOSXDialog.c
@@ -117,7 +117,7 @@ enum alertIconOptions {
     ICON_ERROR, ICON_INFO, ICON_QUESTION, ICON_WARNING
 };
 static const char *const alertButtonStrings[] = {
-    "abort", "retry", "ignore", "ok", "cancel", "yes", "no", NULL
+    "abort", "retry", "ignore", "ok", "cancel", "no", "yes", NULL
 };
 
 static const NSString *const alertButtonNames[][3] = {
@@ -1330,7 +1330,7 @@ Tk_MessageBoxObjCmd(
 
 	case ALERT_ICON:
 	    if (Tcl_GetIndexFromObjStruct(interp, objv[i + 1], alertIconStrings,
-		    sizeof(char *), "value", TCL_EXACT, &iconIndex) != TCL_OK) {
+		    sizeof(char *), "-icon value", TCL_EXACT, &iconIndex) != TCL_OK) {
 		goto end;
 	    }
 	    break;
@@ -1360,7 +1360,7 @@ Tk_MessageBoxObjCmd(
 
 	case ALERT_TYPE:
 	    if (Tcl_GetIndexFromObjStruct(interp, objv[i + 1], alertTypeStrings,
-		    sizeof(char *), "value", TCL_EXACT, &typeIndex) != TCL_OK) {
+		    sizeof(char *), "-type value", TCL_EXACT, &typeIndex) != TCL_OK) {
 		goto end;
 	    }
 	    break;
@@ -1376,7 +1376,7 @@ Tk_MessageBoxObjCmd(
 	 */
 
 	if (Tcl_GetIndexFromObjStruct(interp, objv[indexDefaultOption + 1],
-		alertButtonStrings, sizeof(char *), "value", TCL_EXACT, &index) != TCL_OK) {
+		alertButtonStrings, sizeof(char *), "-default value", TCL_EXACT, &index) != TCL_OK) {
 	    goto end;
 	}
 
diff --git a/tests/choosedir.test b/tests/choosedir.test
index fb6e62d..f67a721 100644
--- a/tests/choosedir.test
+++ b/tests/choosedir.test
@@ -85,23 +85,25 @@ set fake [file join $dir non-existant]
 
 set parent .
 
-test choosedir-1.1 {tk_chooseDirectory command} -constraints unix -body {
+test choosedir-1.1 {tk_chooseDirectory command} -body {
     tk_chooseDirectory -initialdir
 } -returnCodes error -result {value for "-initialdir" missing}
-test choosedir-1.2 {tk_chooseDirectory command} -constraints unix -body {
+test choosedir-1.2 {tk_chooseDirectory command} -body {
     tk_chooseDirectory -mustexist
 } -returnCodes error -result {value for "-mustexist" missing}
-test choosedir-1.3 {tk_chooseDirectory command} -constraints unix -body {
+test choosedir-1.3 {tk_chooseDirectory command} -body {
     tk_chooseDirectory -parent
 } -returnCodes error -result {value for "-parent" missing}
-test choosedir-1.4 {tk_chooseDirectory command} -constraints unix -body {
+test choosedir-1.4 {tk_chooseDirectory command} -body {
     tk_chooseDirectory -title
 } -returnCodes error -result {value for "-title" missing}
-
-test choosedir-1.5 {tk_chooseDirectory command} -constraints unix -body {
+test choosedir-1.5.1 {tk_chooseDirectory command} -constraints notAqua -body {
     tk_chooseDirectory -foo bar
 } -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}
-test choosedir-1.6 {tk_chooseDirectory command} -constraints unix -body {
+test choosedir-1.5.2 {tk_chooseDirectory command} -constraints aqua -body {
+    tk_chooseDirectory -foo bar
+} -returnCodes error -result {bad option "-foo": must be -initialdir, -message, -mustexist, -parent, -title, or -command}
+test choosedir-1.6 {tk_chooseDirectory command} -body {
     tk_chooseDirectory -parent foo.bar
 } -returnCodes error -result {bad window path name "foo.bar"}
 
diff --git a/tests/filebox.test b/tests/filebox.test
index 2f87c3e..0114a07 100644
--- a/tests/filebox.test
+++ b/tests/filebox.test
@@ -110,8 +110,10 @@ if {$tcl_platform(platform) == "unix"} {
     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 unknownOptionsMsg(tk_getOpenFile,notAqua) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
+set unknownOptionsMsg(tk_getOpenFile,aqua) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -message, -multiple, -parent, -title, -typevariable, or -command}
+set unknownOptionsMsg(tk_getSaveFile,notAqua) {bad option "-foo": must be -confirmoverwrite, -defaultextension, -filetypes, -initialdir, -initialfile, -parent, -title, or -typevariable}
+set unknownOptionsMsg(tk_getSaveFile,aqua) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -message, -parent, -title, -typevariable, -command, or -confirmoverwrite}
 
 set tmpFile "filebox.tmp"
 makeFile {
@@ -155,9 +157,12 @@ foreach mode $modes {
 	}
     }
 
-    test filebox-1.1-$mode "tk_getOpenFile command" -body {
+    test filebox-1.1.1-$mode "tk_getOpenFile command" -constraints notAqua -body {
 	tk_getOpenFile -foo
-    } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile)
+    } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile,notAqua)
+    test filebox-1.1.2-$mode "tk_getOpenFile command" -constraints aqua -body {
+	tk_getOpenFile -foo
+    } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile,aqua)
 
     catch {tk_getOpenFile -foo 1} msg
     regsub -all ,      $msg "" options
@@ -171,9 +176,12 @@ foreach mode $modes {
         }
     }
 
-    test filebox-1.3-$mode "tk_getOpenFile command" -body {
+    test filebox-1.3.1-$mode "tk_getOpenFile command" -constraints notAqua -body {
+        tk_getOpenFile -foo bar
+    } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile,notAqua)
+    test filebox-1.3.2-$mode "tk_getOpenFile command" -constraints aqua -body {
         tk_getOpenFile -foo bar
-    } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile)
+    } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile,aqua)
     test filebox-1.4-$mode "tk_getOpenFile command" -body {
         tk_getOpenFile -initialdir
     } -returnCodes error -result {value for "-initialdir" missing}
@@ -289,9 +297,12 @@ foreach mode $modes {
         } $res
     }
 
-    test filebox-4.1-$mode "tk_getSaveFile command" -body {
+    test filebox-4.1.1-$mode "tk_getSaveFile command" -constraints notAqua -body {
 	tk_getSaveFile -foo
-    } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile)
+    } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,notAqua)
+    test filebox-4.1.2-$mode "tk_getSaveFile command" -constraints aqua -body {
+	tk_getSaveFile -foo
+    } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,aqua)
 
     catch {tk_getSaveFile -foo 1} msg
     regsub -all ,      $msg "" options
@@ -305,9 +316,12 @@ foreach mode $modes {
 	}
     }
 
-    test filebox-4.3-$mode "tk_getSaveFile command" -body {
+    test filebox-4.3.1-$mode "tk_getSaveFile command" -constraints notAqua -body {
+	tk_getSaveFile -foo bar
+    } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,notAqua)
+    test filebox-4.3.2-$mode "tk_getSaveFile command" -constraints aqua -body {
 	tk_getSaveFile -foo bar
-    } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile)
+    } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,aqua)
     test filebox-4.4-$mode "tk_getSaveFile command" -body {
 	tk_getSaveFile -initialdir
     } -returnCodes error -result {value for "-initialdir" missing}
diff --git a/tests/msgbox.test b/tests/msgbox.test
index 643ae2c..1b84463 100644
--- a/tests/msgbox.test
+++ b/tests/msgbox.test
@@ -11,12 +11,18 @@ tcltest::loadTestedCommands
 namespace import -force tcltest::test
 
 
-test msgbox-1.1 {tk_messageBox command} -body {
+test msgbox-1.1.1 {tk_messageBox command} -constraints notAqua -body {
     tk_messageBox -foo
 } -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
-test msgbox-1.2 {tk_messageBox command} -body {
+test msgbox-1.1.2 {tk_messageBox command} -constraints aqua -body {
+    tk_messageBox -foo
+} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, -type, or -command}
+test msgbox-1.2.1 {tk_messageBox command} -constraints notAqua -body {
     tk_messageBox -foo bar
 } -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
+test msgbox-1.2.2 {tk_messageBox command} -constraints aqua -body {
+    tk_messageBox -foo bar
+} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, -type, or -command}
 
 test msgbox-1.3 {tk_messageBox command} -body {
     tk_messageBox -default
@@ -48,30 +54,22 @@ test msgbox-1.11 {tk_messageBox command} -body {
     tk_messageBox -type foo
 } -returnCodes error -result {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}
 
-test msgbox-1.12 {tk_messageBox command} -constraints unix -body {
-    tk_messageBox -default 1.1
-} -returnCodes error -result {invalid default button "1.1"}
-test msgbox-1.13 {tk_messageBox command} -constraints macOrWin -body {
+test msgbox-1.13 {tk_messageBox command} -body {
     tk_messageBox -default 1.1
 } -returnCodes error -result {bad -default value "1.1": must be abort, retry, ignore, ok, cancel, no, or yes}
 
-test msgbox-1.14 {tk_messageBox command} -constraints unix -body {
-    tk_messageBox -default foo
-} -returnCodes error -result {invalid default button "foo"}
-test msgbox-1.15 {tk_messageBox command} -constraints macOrWin -body {
+test msgbox-1.14 {tk_messageBox command} -body {
     tk_messageBox -default foo
 } -returnCodes error -result {bad -default value "foo": must be abort, retry, ignore, ok, cancel, no, or yes}
 
-test msgbox-1.16 {tk_messageBox command} -constraints unix -body {
-    tk_messageBox -type yesno -default 3
-} -returnCodes error -result {invalid default button "3"}
-test msgbox-1.17 {tk_messageBox command} -constraints macOrWin -body {
+test msgbox-1.16 {tk_messageBox command} -body {
     tk_messageBox -type yesno -default 3
 } -returnCodes error -result {bad -default value "3": must be abort, retry, ignore, ok, cancel, no, or yes}
 
 test msgbox-1.18 {tk_messageBox command} -body {
     tk_messageBox -icon foo
 } -returnCodes error -result {bad -icon value "foo": must be error, info, question, or warning}
+
 test msgbox-1.19 {tk_messageBox command} -body {
     tk_messageBox -parent foo.bar
 } -returnCodes error -result {bad window path name "foo.bar"}