Subversion Repositories or1k

# This file is a Tcl script to test out Tk's "tk_messageBox" command.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# 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.1.1.1 2002-01-16 10:25:59 markom Exp $
#

if {[string compare test [info procs test]] == 1} {
    source defs
}

test msgbox-1.1 {tk_messageBox command} {
    list [catch {tk_messageBox -foo} msg] $msg
} {1 {unknown option "-foo", must be -default, -icon, -message, -modal, -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, -modal, -parent, -title or -type}}

catch {tk_messageBox -foo bar} msg
regsub -all ,      $msg "" options
regsub \"-foo\" $options "" options

foreach option $options {
    if {[string index $option 0] == "-"} {
        test msgbox-1.3 {tk_messageBox command} {
            list [catch {tk_messageBox $option} msg] $msg
        } [list 1 "value for \"$option\" missing"]
    }
}

test msgbox-1.4 {tk_messageBox command} {
    list [catch {tk_messageBox -default} msg] $msg
} {1 {value for "-default" missing}}

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}}

test msgbox-1.6 {tk_messageBox command} {
    list [catch {tk_messageBox -default 1.1} msg] $msg
} {1 {invalid default button "1.1"}}

test msgbox-1.7 {tk_messageBox command} {
    list [catch {tk_messageBox -default foo} msg] $msg
} {1 {invalid default button "foo"}}

test msgbox-1.8 {tk_messageBox command} {
    list [catch {tk_messageBox -type yesno -default 3} msg] $msg
} {1 {invalid default button "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}}

test msgbox-1.10 {tk_messageBox command} {
    list [catch {tk_messageBox -parent foo.bar} msg] $msg
} {1 {bad window path name "foo.bar"}}

if {[info commands tkMessageBox] == ""} {
    set isNative 1
} else {
    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} {
        after 100 SendEventToMsg $parent $btn mouse
    }
}

proc ChooseMsgByKey {parent btn} {
    global isNative
    if {!$isNative} {
        after 100 SendEventToMsg $parent $btn key
    }
}

proc PressButton {btn} {
    event generate $btn <Enter>
    event generate $btn <ButtonPress-1> -x 5 -y 5
    event generate $btn <ButtonRelease-1> -x 5 -y 5
}

proc SendEventToMsg {parent btn type} {
    if {$parent != "."} {
        set w $parent.__tk__messagebox
    } else {
        set w .__tk__messagebox
    }
    if ![winfo ismapped $w.$btn] {
        update
    }
    if {$type == "mouse"} {
        PressButton $w.$btn
    } else {
        event generate $w <Enter>
        focus $w
        event generate $w.$btn <Enter>
        event generate $w <KeyPress> -keysym Return
    }
}

set parent .

set specs {
    {"abortretryignore"  MB_ABORTRETRYIGNORE  3  {"abort"  "retry"  "ignore"}} 
    {"ok"                MB_OK                1  {"ok"                      }} 
    {"okcancel"          MB_OKCANCEL          2  {"ok"     "cancel"         }} 
    {"retrycancel"       MB_RETRYCANCEL       2  {"retry"  "cancel"         }} 
    {"yesno"             MB_YESNO             2  {"yes"    "no"             }} 
    {"yesnocancel"       MB_YESNOCANCEL       3  {"yes"    "no"     "cancel"}}
}

#
# Try out all combinations of (type) x (default button) and
# (type) x (icon).
#
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} {
        ChooseMsg $parent $button
        tk_messageBox -title Hi -message "Please press $button" \
            -type $type
    } $button

    foreach icon {warning error info question} {
        test msgbox-2.2 {tk_messageBox command -icon option} {
            ChooseMsg $parent $button
            tk_messageBox -title Hi -message "Please press $button" \
                -type $type -icon $icon
        } $button
    }

    foreach button $buttons {
        test msgbox-2.3 {tk_messageBox command} {
            ChooseMsg $parent $button
            tk_messageBox -title Hi -message "Please press $button" \
                -type $type -default $button
        } "$button"
    }
}