1# This file is a Tcl script to test out the "message" command 2# of Tk. It is organized in the standard fashion for Tcl tests. 3# 4# Copyright (c) 1994 The Regents of the University of California. 5# Copyright (c) 1994-1996 Sun Microsystems, Inc. 6# Copyright (c) 1998-2000 by Ajuba Solutions. 7# All rights reserved. 8# 9# RCS: @(#) $Id: message.test,v 1.2 2002/07/13 20:28:35 dgp Exp $ 10 11package require tcltest 2.1 12namespace import -force tcltest::configure 13namespace import -force tcltest::testsDirectory 14configure -testdir [file join [pwd] [file dirname [info script]]] 15configure -loadfile [file join [testsDirectory] constraints.tcl] 16tcltest::loadTestedCommands 17 18option add *Message.borderWidth 2 19option add *Message.highlightThickness 2 20option add *Message.font {Helvetica -12 bold} 21 22message .m 23pack .m 24update 25set i 0 26foreach test { 27 {-anchor w w bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}} 28 {-aspect 3 3 bogus {expected integer but got "bogus"}} 29 {-background #ff0000 #ff0000 non-existent 30 {unknown color name "non-existent"}} 31 {-bd 4 4 badValue {bad screen distance "badValue"}} 32 {-bg #ff0000 #ff0000 non-existent 33 {unknown color name "non-existent"}} 34 {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} 35 {-cursor arrow arrow badValue {bad cursor spec "badValue"}} 36 {-fg #00ff00 #00ff00 badValue {unknown color name "badValue"}} 37 {-font fixed fixed {} {font "" doesn't exist}} 38 {-foreground green green badValue {unknown color name "badValue"}} 39 {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} 40 {-highlightcolor #123456 #123456 non-existent 41 {unknown color name "non-existent"}} 42 {-highlightthickness 2 2 badValue {bad screen distance "badValue"}} 43 {-justify right right bogus {bad justification "bogus": must be left, right, or center}} 44 {-padx 12m 12m 420x {bad screen distance "420x"}} 45 {-pady 12m 12m 420x {bad screen distance "420x"}} 46 {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} 47 {-text "Sample text" {Sample text} {} {} {1 1 1 1}} 48 {-textvariable i i {} {} {1 1 1 1}} 49 {-width 32 32 badValue {bad screen distance "badValue"}} 50} { 51 set name [lindex $test 0] 52 test message-1.$i {configuration options} { 53 .m configure $name [lindex $test 1] 54 lindex [.m configure $name] 4 55 } [lindex $test 2] 56 incr i 57 if {[lindex $test 3] != ""} { 58 test message-1.$i {configuration options} { 59 list [catch {.m configure $name [lindex $test 3]} msg] $msg 60 } [list 1 [lindex $test 4]] 61 } 62 .m configure $name [lindex [.m configure $name] 3] 63 incr i 64} 65destroy .m 66 67test message-2.1 {Tk_MessageObjCmd procedure} { 68 list [catch {message} msg] $msg 69} {1 {wrong # args: should be "message pathName ?options?"}} 70test message-2.2 {Tk_MessageObjCmd procedure} { 71 list [catch {message foo} msg] $msg [winfo child .] 72} {1 {bad window path name "foo"} {}} 73test message-2.3 {Tk_MessageObjCmd procedure} { 74 list [catch {message .s -gorp dumb} msg] $msg [winfo child .] 75} {1 {unknown option "-gorp"} {}} 76 77test message-3.1 {MessageWidgetObjCmd procedure} { 78 message .m 79 set result [list [catch {.m} msg] $msg] 80 destroy .m 81 set result 82} {1 {wrong # args: should be ".m option ?arg arg ...?"}} 83test message-3.2 {MessageWidgetObjCmd procedure, "cget"} { 84 message .m 85 set result [list [catch {.m cget} msg] $msg] 86 destroy .m 87 set result 88} {1 {wrong # args: should be ".m cget option"}} 89test message-3.3 {MessageWidgetObjCmd procedure, "cget"} { 90 message .m 91 set result [list [catch {.m cget -gorp} msg] $msg] 92 destroy .m 93 set result 94} {1 {unknown option "-gorp"}} 95test message-3.4 {MessageWidgetObjCmd procedure, "cget"} { 96 message .m 97 .m configure -text foobar 98 set result [.m cget -text] 99 destroy .m 100 set result 101} "foobar" 102test message-3.5 {MessageWidgetObjCmd procedure, "configure"} { 103 message .m 104 set result [llength [.m configure]] 105 destroy .m 106 set result 107} 21 108test message-3.6 {MessageWidgetObjCmd procedure, "configure"} { 109 message .m 110 set result [list [catch {.m configure -foo} msg] $msg] 111 destroy .m 112 set result 113} {1 {unknown option "-foo"}} 114test message-3.7 {MessageWidgetObjCmd procedure, "configure"} { 115 message .m 116 .m configure -bd 4 117 .m configure -bg #ffffff 118 set result [lindex [.m configure -bd] 4] 119 destroy .m 120 set result 121} {4} 122 123# cleanup 124::tcltest::cleanupTests 125return 126