1# This file is a Tcl script to test out Tk's "tk_messageBox" command. 2# It is organized in the standard fashion for Tcl tests. 3# 4# Copyright (c) 1996 Sun Microsystems, Inc. 5# Copyright (c) 1998-1999 by Scriptics Corporation. 6# All rights reserved. 7# 8# RCS: @(#) $Id$ 9# 10 11package require tcltest 2.1 12eval tcltest::configure $argv 13tcltest::loadTestedCommands 14 15test msgbox-1.1 {tk_messageBox command} { 16 list [catch {tk_messageBox -foo} msg] $msg 17} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}} 18test msgbox-1.2 {tk_messageBox command} { 19 list [catch {tk_messageBox -foo bar} msg] $msg 20} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}} 21 22catch {tk_messageBox -foo bar} msg 23regsub -all , $msg "" options 24regsub \"-foo\" $options "" options 25 26foreach option $options { 27 if {[string index $option 0] eq "-"} { 28 test msgbox-1.3$option {tk_messageBox command} -body { 29 tk_messageBox $option 30 } -returnCodes error -result "value for \"$option\" missing" 31 } 32} 33 34test msgbox-1.4 {tk_messageBox command} { 35 list [catch {tk_messageBox -default} msg] $msg 36} {1 {value for "-default" missing}} 37 38test msgbox-1.5 {tk_messageBox command} { 39 list [catch {tk_messageBox -type foo} msg] $msg 40} {1 {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}} 41 42proc createPlatformMsg {val} { 43 global tcl_platform 44 if {$tcl_platform(platform) == "unix"} { 45 return "invalid default button \"$val\"" 46 } 47 return "bad -default value \"$val\": must be abort, retry, ignore, ok, cancel, no, or yes" 48} 49 50test msgbox-1.6 {tk_messageBox command} { 51 list [catch {tk_messageBox -default 1.1} msg] $msg 52} [list 1 [createPlatformMsg "1.1"]] 53 54test msgbox-1.7 {tk_messageBox command} { 55 list [catch {tk_messageBox -default foo} msg] $msg 56} [list 1 [createPlatformMsg "foo"]] 57 58test msgbox-1.8 {tk_messageBox command} { 59 list [catch {tk_messageBox -type yesno -default 3} msg] $msg 60} [list 1 [createPlatformMsg "3"]] 61 62test msgbox-1.9 {tk_messageBox command} { 63 list [catch {tk_messageBox -icon foo} msg] $msg 64} {1 {bad -icon value "foo": must be error, info, question, or warning}} 65 66test msgbox-1.10 {tk_messageBox command} { 67 list [catch {tk_messageBox -parent foo.bar} msg] $msg 68} {1 {bad window path name "foo.bar"}} 69 70set isNative [expr {[info commands tk::MessageBox] == ""}] 71 72proc ChooseMsg {parent btn} { 73 global isNative 74 if {!$isNative} { 75 after 100 SendEventToMsg $parent $btn mouse 76 } 77} 78 79proc ChooseMsgByKey {parent btn} { 80 global isNative 81 if {!$isNative} { 82 after 100 SendEventToMsg $parent $btn key 83 } 84} 85 86proc PressButton {btn} { 87 event generate $btn <Enter> 88 event generate $btn <ButtonPress-1> -x 5 -y 5 89 event generate $btn <ButtonRelease-1> -x 5 -y 5 90} 91 92proc SendEventToMsg {parent btn type} { 93 if {$parent != "."} { 94 set w $parent.__tk__messagebox 95 } else { 96 set w .__tk__messagebox 97 } 98 if ![winfo ismapped $w.$btn] { 99 update 100 } 101 if {$type == "mouse"} { 102 PressButton $w.$btn 103 } else { 104 event generate $w <Enter> 105 focus $w 106 event generate $w.$btn <Enter> 107 event generate $w <KeyPress> -keysym Return 108 } 109} 110 111set parent . 112 113set specs { 114 {"abortretryignore" MB_ABORTRETRYIGNORE 3 {"abort" "retry" "ignore"}} 115 {"ok" MB_OK 1 {"ok" }} 116 {"okcancel" MB_OKCANCEL 2 {"ok" "cancel" }} 117 {"retrycancel" MB_RETRYCANCEL 2 {"retry" "cancel" }} 118 {"yesno" MB_YESNO 2 {"yes" "no" }} 119 {"yesnocancel" MB_YESNOCANCEL 3 {"yes" "no" "cancel"}} 120} 121 122# 123# Try out all combinations of (type) x (default button) and 124# (type) x (icon). 125# 126set count 1 127foreach spec $specs { 128 set type [lindex $spec 0] 129 set buttons [lindex $spec 3] 130 131 set button [lindex $buttons 0] 132 test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction { 133 ChooseMsg $parent $button 134 tk_messageBox -title Hi -message "Please press $button" \ 135 -type $type 136 } $button 137 incr count 138 139 foreach icon {warning error info question} { 140 test msgbox-2.$count {tk_messageBox command -icon option} \ 141 nonUnixUserInteraction { 142 ChooseMsg $parent $button 143 tk_messageBox -title Hi -message "Please press $button" \ 144 -type $type -icon $icon 145 } $button 146 incr count 147 } 148 149 foreach button $buttons { 150 test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction { 151 ChooseMsg $parent $button 152 tk_messageBox -title Hi -message "Please press $button" \ 153 -type $type -default $button 154 } "$button" 155 incr count 156 } 157} 158 159# These tests will hang your test suite if they fail. 160test msgbox-3.1 {tk_messageBox handles withdrawn parent} nonUnixUserInteraction { 161 wm withdraw . 162 ChooseMsg . "ok" 163 tk_messageBox -title Hi -message "Please press ok" \ 164 -type ok -default ok 165} "ok" 166wm deiconify . 167 168test msgbox-3.2 {tk_messageBox handles iconified parent} nonUnixUserInteraction { 169 wm iconify . 170 ChooseMsg . "ok" 171 tk_messageBox -title Hi -message "Please press ok" \ 172 -type ok -default ok 173} "ok" 174wm deiconify . 175 176# cleanup 177cleanupTests 178return 179