summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog3
-rw-r--r--tests/bell.test15
-rw-r--r--tests/bgerror.test15
-rw-r--r--tests/bind.test577
-rw-r--r--tests/bitmap.test15
-rw-r--r--tests/border.test15
-rw-r--r--tests/button.test52
-rw-r--r--tests/canvImg.test62
-rw-r--r--tests/canvPs.test15
-rw-r--r--tests/canvRect.test46
-rw-r--r--tests/canvText.test31
-rw-r--r--tests/canvWind.test15
-rw-r--r--tests/canvas.test45
-rw-r--r--tests/choosedir.test4
-rw-r--r--tests/clipboard.test15
-rw-r--r--tests/clrpick.test16
-rw-r--r--tests/cmds.test15
-rw-r--r--tests/cursor.test228
-rw-r--r--tests/entry.test16
-rw-r--r--tests/filebox.test227
-rw-r--r--tests/focus.test15
-rw-r--r--tests/focusTcl.test15
-rw-r--r--tests/font.test155
-rw-r--r--tests/frame.test349
-rw-r--r--tests/geometry.test15
-rw-r--r--tests/get.test15
-rw-r--r--tests/id.test15
-rw-r--r--tests/imgBmap.test15
-rw-r--r--tests/imgPPM.test15
-rw-r--r--tests/imgPhoto.test4
-rw-r--r--tests/main.test15
-rw-r--r--tests/menu.test16
-rw-r--r--tests/menuDraw.test15
-rw-r--r--tests/menubut.test15
-rw-r--r--tests/msgbox.test34
-rw-r--r--tests/obj.test16
-rw-r--r--tests/oldpack.test15
-rw-r--r--tests/option.test21
-rw-r--r--tests/panedwindow.test6
-rw-r--r--tests/raise.test15
-rw-r--r--tests/scale.test4
-rw-r--r--tests/scrollbar.test17
-rw-r--r--tests/select.test64
-rw-r--r--tests/textBTree.test15
-rw-r--r--tests/textDisp.test14
-rw-r--r--tests/textImage.test15
-rw-r--r--tests/textIndex.test15
-rw-r--r--tests/textMark.test15
-rw-r--r--tests/textTag.test15
-rw-r--r--tests/textWind.test27
-rw-r--r--tests/unixEmbed.test15
-rw-r--r--tests/unixFont.test15
-rw-r--r--tests/util.test15
-rw-r--r--tests/visual.test258
-rw-r--r--tests/winMenu.test14
-rw-r--r--tests/winSend.test48
-rw-r--r--tests/window.test14
-rw-r--r--tests/wm.test5
-rw-r--r--tests/xmfbox.test14
59 files changed, 1150 insertions, 1657 deletions
diff --git a/ChangeLog b/ChangeLog
index ebeefb2..08693fd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
2004-05-23 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+ * tests/*.test: Many minor fixes aiming towards making the Tk test
+ suite have better style.
+
* generic/tkVisual.c (Tk_GetVisual): Minor fix for error message.
2004-05-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
diff --git a/tests/bell.test b/tests/bell.test
index 59bfca6..455eb76 100644
--- a/tests/bell.test
+++ b/tests/bell.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-2000 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: bell.test,v 1.7 2003/04/01 21:06:15 dgp Exp $
+# RCS: @(#) $Id: bell.test,v 1.8 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -46,16 +46,3 @@ test bell-1.8 {bell command} {
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/bgerror.test b/tests/bgerror.test
index e104980..7d35862 100644
--- a/tests/bgerror.test
+++ b/tests/bgerror.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: bgerror.test,v 1.5 2003/04/01 21:06:15 dgp Exp $
+# RCS: @(#) $Id: bgerror.test,v 1.6 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -58,16 +58,3 @@ catch {rename tkerror {}}
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/bind.test b/tests/bind.test
index 9ecee81..9117204 100644
--- a/tests/bind.test
+++ b/tests/bind.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: bind.test,v 1.12 2003/04/01 21:06:16 dgp Exp $
+# RCS: @(#) $Id: bind.test,v 1.13 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -2051,189 +2051,187 @@ test bind-22.18 {HandleEventGenerate} {
# Bug 411307
list [catch {event gen . <a> -root 98765} msg] $msg
} {1 {bad window name/identifier "98765"}}
-set i 19
foreach check {
- {<Configure> %a {-above .xyz} {{1 {bad window path name ".xyz"}}}}
- {<Configure> %a {-above .b} {[winfo id .b]}}
- {<Configure> %a {-above xyz} {{1 {bad window name/identifier "xyz"}}}}
- {<Configure> %a {-above [winfo id .b]} {[winfo id .b]}}
- {<Key> %b {-above .} {{1 {<Key> event doesn't accept "-above" option}}}}
-
- {<Configure> %B {-borderwidth xyz} {{1 {bad screen distance "xyz"}}}}
- {<Configure> %B {-borderwidth 2i} {[winfo pixels .b.f 2i]}}
- {<Key> %k {-borderwidth 2i} {{1 {<Key> event doesn't accept "-borderwidth" option}}}}
-
- {<Button> %b {-button xyz} {{1 {expected integer but got "xyz"}}}}
- {<Button> %b {-button 1} 1}
- {<ButtonRelease> %b {-button 1} 1}
- {<Key> %k {-button 1} {{1 {<Key> event doesn't accept "-button" option}}}}
-
- {<Expose> %c {-count xyz} {{1 {expected integer but got "xyz"}}}}
- {<Expose> %c {-count 20} 20}
- {<Key> %b {-count 20} {{1 {<Key> event doesn't accept "-count" option}}}}
-
- {<Enter> %d {-detail xyz} {{1 {bad -detail value "xyz": must be NotifyAncestor, NotifyVirtual, NotifyInferior, NotifyNonlinear, NotifyNonlinearVirtual, NotifyPointer, NotifyPointerRoot, or NotifyDetailNone}}}}
- {<FocusIn> %d {-detail NotifyVirtual} {{}}}
- {<Enter> %d {-detail NotifyVirtual} NotifyVirtual}
- {<Key> %k {-detail NotifyVirtual} {{1 {<Key> event doesn't accept "-detail" option}}}}
-
- {<Enter> %f {-focus xyz} {{1 {expected boolean value but got "xyz"}}}}
- {<Enter> %f {-focus 1} 1}
- {<Key> %k {-focus 1} {{1 {<Key> event doesn't accept "-focus" option}}}}
-
- {<Expose> %h {-height xyz} {{1 {bad screen distance "xyz"}}}}
- {<Expose> %h {-height 2i} {[winfo pixels .b.f 2i]}}
- {<Configure> %h {-height 2i} {[winfo pixels .b.f 2i]}}
- {<Key> %k {-height 2i} {{1 {<Key> event doesn't accept "-height" option}}}}
-
- {<Key> %k {-keycode xyz} {{1 {expected integer but got "xyz"}}}}
- {<Key> %k {-keycode 20} 20}
- {<Button> %b {-keycode 20} {{1 {<Button> event doesn't accept "-keycode" option}}}}
-
- {<Key> %K {-keysym xyz} {{1 {unknown keysym "xyz"}}}}
- {<Key> %K {-keysym a} a}
- {<Button> %b {-keysym a} {{1 {<Button> event doesn't accept "-keysym" option}}}}
-
- {<Enter> %m {-mode xyz} {{1 {bad -mode value "xyz": must be NotifyNormal, NotifyGrab, NotifyUngrab, or NotifyWhileGrabbed}}}}
- {<Enter> %m {-mode NotifyNormal} NotifyNormal}
- {<FocusIn> %m {-mode NotifyNormal} {{}}}
- {<Key> %k {-mode NotifyNormal} {{1 {<Key> event doesn't accept "-mode" option}}}}
-
- {<Map> %o {-override xyz} {{1 {expected boolean value but got "xyz"}}}}
- {<Map> %o {-override 1} 1}
- {<Reparent> %o {-override 1} 1}
- {<Configure> %o {-override 1} 1}
- {<Key> %k {-override 1} {{1 {<Key> event doesn't accept "-override" option}}}}
-
- {<Circulate> %p {-place xyz} {{1 {bad -place value "xyz": must be PlaceOnTop, or PlaceOnBottom}}}}
- {<Circulate> %p {-place PlaceOnTop} PlaceOnTop}
- {<Key> %k {-place PlaceOnTop} {{1 {<Key> event doesn't accept "-place" option}}}}
-
- {<Key> %R {-root .xyz} {{1 {bad window path name ".xyz"}}}}
- {<Key> %R {-root .b} {[winfo id .b]}}
- {<Key> %R {-root xyz} {{1 {bad window name/identifier "xyz"}}}}
- {<Key> %R {-root [winfo id .b]} {[winfo id .b]}}
- {<Button> %R {-root .b} {[winfo id .b]}}
- {<ButtonRelease> %R {-root .b} {[winfo id .b]}}
- {<Motion> %R {-root .b} {[winfo id .b]}}
- {<<Paste>> %R {-root .b} {[winfo id .b]}}
- {<Enter> %R {-root .b} {[winfo id .b]}}
- {<Configure> %R {-root .b} {{1 {<Configure> event doesn't accept "-root" option}}}}
-
- {<Key> %X {-rootx xyz} {{1 {bad screen distance "xyz"}}}}
- {<Key> %X {-rootx 2i} {[winfo pixels .b.f 2i]}}
- {<Button> %X {-rootx 2i} {[winfo pixels .b.f 2i]}}
- {<ButtonRelease> %X {-rootx 2i} {[winfo pixels .b.f 2i]}}
- {<Motion> %X {-rootx 2i} {[winfo pixels .b.f 2i]}}
- {<<Paste>> %X {-rootx 2i} {[winfo pixels .b.f 2i]}}
- {<Enter> %X {-rootx 2i} {[winfo pixels .b.f 2i]}}
- {<Configure> %X {-rootx 2i} {{1 {<Configure> event doesn't accept "-rootx" option}}}}
-
- {<Key> %Y {-rooty xyz} {{1 {bad screen distance "xyz"}}}}
- {<Key> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}}
- {<Button> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}}
- {<ButtonRelease> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}}
- {<Motion> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}}
- {<<Paste>> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}}
- {<Enter> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}}
- {<Configure> %Y {-rooty 2i} {{1 {<Configure> event doesn't accept "-rooty" option}}}}
-
- {<Key> %E {-sendevent xyz} {{1 {expected boolean value but got "xyz"}}}}
- {<Key> %E {-sendevent 1} 1}
- {<Key> %E {-sendevent yes} 1}
- {<Key> %E {-sendevent 43} 43}
-
- {<Key> %# {-serial xyz} {{1 {expected integer but got "xyz"}}}}
- {<Key> %# {-serial 100} 100}
-
- {<Key> %s {-state xyz} {{1 {expected integer but got "xyz"}}}}
- {<Key> %s {-state 1} 1}
- {<Button> %s {-state 1025} 1025}
- {<ButtonRelease> %s {-state 1025} 1025}
- {<Motion> %s {-state 1} 1}
- {<<Paste>> %s {-state 1} 1}
- {<Enter> %s {-state 1} 1}
- {<Visibility> %s {-state xyz} {{1 {bad -state value "xyz": must be VisibilityUnobscured, VisibilityPartiallyObscured, or VisibilityFullyObscured}}}}
- {<Visibility> %s {-state VisibilityUnobscured} VisibilityUnobscured}
- {<Configure> %s {-state xyz} {{1 {<Configure> event doesn't accept "-state" option}}}}
-
- {<Key> %S {-subwindow .xyz} {{1 {bad window path name ".xyz"}}}}
- {<Key> %S {-subwindow .b} {[winfo id .b]}}
- {<Key> %S {-subwindow xyz} {{1 {bad window name/identifier "xyz"}}}}
- {<Key> %S {-subwindow [winfo id .b]} {[winfo id .b]}}
- {<Button> %S {-subwindow .b} {[winfo id .b]}}
- {<ButtonRelease> %S {-subwindow .b} {[winfo id .b]}}
- {<Motion> %S {-subwindow .b} {[winfo id .b]}}
- {<<Paste>> %S {-subwindow .b} {[winfo id .b]}}
- {<Enter> %S {-subwindow .b} {[winfo id .b]}}
- {<Configure> %S {-subwindow .b} {{1 {<Configure> event doesn't accept "-subwindow" option}}}}
-
- {<Key> %t {-time xyz} {{1 {expected integer but got "xyz"}}}}
- {<Key> %t {-time 100} 100}
- {<Button> %t {-time 100} 100}
- {<ButtonRelease> %t {-time 100} 100}
- {<Motion> %t {-time 100} 100}
- {<<Paste>> %t {-time 100} 100}
- {<Enter> %t {-time 100} 100}
- {<Property> %t {-time 100} 100}
- {<Configure> %t {-time 100} {{1 {<Configure> event doesn't accept "-time" option}}}}
-
- {<Expose> %w {-width xyz} {{1 {bad screen distance "xyz"}}}}
- {<Expose> %w {-width 2i} {[winfo pixels .b.f 2i]}}
- {<Configure> %w {-width 2i} {[winfo pixels .b.f 2i]}}
- {<Key> %k {-width 2i} {{1 {<Key> event doesn't accept "-width" option}}}}
-
- {<Unmap> %W {-window .xyz} {{1 {bad window path name ".xyz"}}}}
- {<Unmap> %W {-window .b.f} .b.f}
- {<Unmap> %W {-window xyz} {{1 {bad window name/identifier "xyz"}}}}
- {<Unmap> %W {-window [winfo id .b.f]} .b.f}
- {<Unmap> %W {-window .b.f} .b.f}
- {<Map> %W {-window .b.f} .b.f}
- {<Reparent> %W {-window .b.f} .b.f}
- {<Configure> %W {-window .b.f} .b.f}
- {<Gravity> %W {-window .b.f} .b.f}
- {<Circulate> %W {-window .b.f} .b.f}
- {<Key> %W {-window .b.f} {{1 {<Key> event doesn't accept "-window" option}}}}
-
- {<Key> %x {-x xyz} {{1 {bad screen distance "xyz"}}}}
- {<Key> %x {-x 2i} {[winfo pixels .b.f 2i]}}
- {<Button> %x {-x 2i} {[winfo pixels .b.f 2i]}}
- {<ButtonRelease> %x {-x 2i} {[winfo pixels .b.f 2i]}}
- {<Motion> %x {-x 2i} {[winfo pixels .b.f 2i]}}
- {<<Paste>> %x {-x 2i} {[winfo pixels .b.f 2i]}}
- {<Enter> %x {-x 2i} {[winfo pixels .b.f 2i]}}
- {<Expose> %x {-x 2i} {[winfo pixels .b.f 2i]}}
- {<Configure> %x {-x 2i} {[winfo pixels .b.f 2i]}}
- {<Gravity> %x {-x 2i} {[winfo pixels .b.f 2i]}}
- {<Reparent> %x {-x 2i} {[winfo pixels .b.f 2i]}}
- {<Map> %x {-x 2i} {{1 {<Map> event doesn't accept "-x" option}}}}
-
- {<Key> %y {-y xyz} {{1 {bad screen distance "xyz"}}}}
- {<Key> %y {-y 2i} {[winfo pixels .b.f 2i]}}
- {<Button> %y {-y 2i} {[winfo pixels .b.f 2i]}}
- {<ButtonRelease> %y {-y 2i} {[winfo pixels .b.f 2i]}}
- {<Motion> %y {-y 2i} {[winfo pixels .b.f 2i]}}
- {<<Paste>> %y {-y 2i} {[winfo pixels .b.f 2i]}}
- {<Enter> %y {-y 2i} {[winfo pixels .b.f 2i]}}
- {<Expose> %y {-y 2i} {[winfo pixels .b.f 2i]}}
- {<Configure> %y {-y 2i} {[winfo pixels .b.f 2i]}}
- {<Gravity> %y {-y 2i} {[winfo pixels .b.f 2i]}}
- {<Reparent> %y {-y 2i} {[winfo pixels .b.f 2i]}}
- {<Map> %y {-y 2i} {{1 {<Map> event doesn't accept "-y" option}}}}
-
- {<Key> %k {-xyz 1} {{1 {bad option "-xyz": must be -when, -above, -borderwidth, -button, -count, -delta, -detail, -focus, -height, -keycode, -keysym, -mode, -override, -place, -root, -rootx, -rooty, -sendevent, -serial, -state, -subwindow, -time, -warp, -width, -window, -x, or -y}}}}
+ {bind-22.19 <Configure> %a {-above .xyz} {{1 {bad window path name ".xyz"}}}}
+ {bind-22.20 <Configure> %a {-above .b} {[winfo id .b]}}
+ {bind-22.21 <Configure> %a {-above xyz} {{1 {bad window name/identifier "xyz"}}}}
+ {bind-22.22 <Configure> %a {-above [winfo id .b]} {[winfo id .b]}}
+ {bind-22.23 <Key> %b {-above .} {{1 {<Key> event doesn't accept "-above" option}}}}
+
+ {bind-22.24 <Configure> %B {-borderwidth xyz} {{1 {bad screen distance "xyz"}}}}
+ {bind-22.25 <Configure> %B {-borderwidth 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.26 <Key> %k {-borderwidth 2i} {{1 {<Key> event doesn't accept "-borderwidth" option}}}}
+
+ {bind-22.27 <Button> %b {-button xyz} {{1 {expected integer but got "xyz"}}}}
+ {bind-22.28 <Button> %b {-button 1} 1}
+ {bind-22.29 <ButtonRelease> %b {-button 1} 1}
+ {bind-22.30 <Key> %k {-button 1} {{1 {<Key> event doesn't accept "-button" option}}}}
+
+ {bind-22.31 <Expose> %c {-count xyz} {{1 {expected integer but got "xyz"}}}}
+ {bind-22.32 <Expose> %c {-count 20} 20}
+ {bind-22.33 <Key> %b {-count 20} {{1 {<Key> event doesn't accept "-count" option}}}}
+
+ {bind-22.34 <Enter> %d {-detail xyz} {{1 {bad -detail value "xyz": must be NotifyAncestor, NotifyVirtual, NotifyInferior, NotifyNonlinear, NotifyNonlinearVirtual, NotifyPointer, NotifyPointerRoot, or NotifyDetailNone}}}}
+ {bind-22.35 <FocusIn> %d {-detail NotifyVirtual} {{}}}
+ {bind-22.36 <Enter> %d {-detail NotifyVirtual} NotifyVirtual}
+ {bind-22.37 <Key> %k {-detail NotifyVirtual} {{1 {<Key> event doesn't accept "-detail" option}}}}
+
+ {bind-22.38 <Enter> %f {-focus xyz} {{1 {expected boolean value but got "xyz"}}}}
+ {bind-22.39 <Enter> %f {-focus 1} 1}
+ {bind-22.40 <Key> %k {-focus 1} {{1 {<Key> event doesn't accept "-focus" option}}}}
+
+ {bind-22.41 <Expose> %h {-height xyz} {{1 {bad screen distance "xyz"}}}}
+ {bind-22.42 <Expose> %h {-height 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.43 <Configure> %h {-height 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.44 <Key> %k {-height 2i} {{1 {<Key> event doesn't accept "-height" option}}}}
+
+ {bind-22.45 <Key> %k {-keycode xyz} {{1 {expected integer but got "xyz"}}}}
+ {bind-22.46 <Key> %k {-keycode 20} 20}
+ {bind-22.47 <Button> %b {-keycode 20} {{1 {<Button> event doesn't accept "-keycode" option}}}}
+
+ {bind-22.48 <Key> %K {-keysym xyz} {{1 {unknown keysym "xyz"}}}}
+ {bind-22.49 <Key> %K {-keysym a} a}
+ {bind-22.50 <Button> %b {-keysym a} {{1 {<Button> event doesn't accept "-keysym" option}}}}
+
+ {bind-22.51 <Enter> %m {-mode xyz} {{1 {bad -mode value "xyz": must be NotifyNormal, NotifyGrab, NotifyUngrab, or NotifyWhileGrabbed}}}}
+ {bind-22.52 <Enter> %m {-mode NotifyNormal} NotifyNormal}
+ {bind-22.53 <FocusIn> %m {-mode NotifyNormal} {{}}}
+ {bind-22.54 <Key> %k {-mode NotifyNormal} {{1 {<Key> event doesn't accept "-mode" option}}}}
+
+ {bind-22.55 <Map> %o {-override xyz} {{1 {expected boolean value but got "xyz"}}}}
+ {bind-22.56 <Map> %o {-override 1} 1}
+ {bind-22.57 <Reparent> %o {-override 1} 1}
+ {bind-22.58 <Configure> %o {-override 1} 1}
+ {bind-22.59 <Key> %k {-override 1} {{1 {<Key> event doesn't accept "-override" option}}}}
+
+ {bind-22.60 <Circulate> %p {-place xyz} {{1 {bad -place value "xyz": must be PlaceOnTop, or PlaceOnBottom}}}}
+ {bind-22.61 <Circulate> %p {-place PlaceOnTop} PlaceOnTop}
+ {bind-22.62 <Key> %k {-place PlaceOnTop} {{1 {<Key> event doesn't accept "-place" option}}}}
+
+ {bind-22.63 <Key> %R {-root .xyz} {{1 {bad window path name ".xyz"}}}}
+ {bind-22.64 <Key> %R {-root .b} {[winfo id .b]}}
+ {bind-22.65 <Key> %R {-root xyz} {{1 {bad window name/identifier "xyz"}}}}
+ {bind-22.66 <Key> %R {-root [winfo id .b]} {[winfo id .b]}}
+ {bind-22.67 <Button> %R {-root .b} {[winfo id .b]}}
+ {bind-22.68 <ButtonRelease> %R {-root .b} {[winfo id .b]}}
+ {bind-22.69 <Motion> %R {-root .b} {[winfo id .b]}}
+ {bind-22.70 <<Paste>> %R {-root .b} {[winfo id .b]}}
+ {bind-22.71 <Enter> %R {-root .b} {[winfo id .b]}}
+ {bind-22.72 <Configure> %R {-root .b} {{1 {<Configure> event doesn't accept "-root" option}}}}
+
+ {bind-22.73 <Key> %X {-rootx xyz} {{1 {bad screen distance "xyz"}}}}
+ {bind-22.74 <Key> %X {-rootx 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.75 <Button> %X {-rootx 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.76 <ButtonRelease> %X {-rootx 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.77 <Motion> %X {-rootx 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.78 <<Paste>> %X {-rootx 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.79 <Enter> %X {-rootx 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.80 <Configure> %X {-rootx 2i} {{1 {<Configure> event doesn't accept "-rootx" option}}}}
+
+ {bind-22.81 <Key> %Y {-rooty xyz} {{1 {bad screen distance "xyz"}}}}
+ {bind-22.82 <Key> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.83 <Button> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.84 <ButtonRelease> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.85 <Motion> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.86 <<Paste>> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.87 <Enter> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.88 <Configure> %Y {-rooty 2i} {{1 {<Configure> event doesn't accept "-rooty" option}}}}
+
+ {bind-22.89 <Key> %E {-sendevent xyz} {{1 {expected boolean value but got "xyz"}}}}
+ {bind-22.90 <Key> %E {-sendevent 1} 1}
+ {bind-22.91 <Key> %E {-sendevent yes} 1}
+ {bind-22.92 <Key> %E {-sendevent 43} 43}
+
+ {bind-22.93 <Key> %# {-serial xyz} {{1 {expected integer but got "xyz"}}}}
+ {bind-22.94 <Key> %# {-serial 100} 100}
+
+ {bind-22.95 <Key> %s {-state xyz} {{1 {expected integer but got "xyz"}}}}
+ {bind-22.96 <Key> %s {-state 1} 1}
+ {bind-22.97 <Button> %s {-state 1025} 1025}
+ {bind-22.98 <ButtonRelease> %s {-state 1025} 1025}
+ {bind-22.99 <Motion> %s {-state 1} 1}
+ {bind-22.100 <<Paste>> %s {-state 1} 1}
+ {bind-22.101 <Enter> %s {-state 1} 1}
+ {bind-22.102 <Visibility> %s {-state xyz} {{1 {bad -state value "xyz": must be VisibilityUnobscured, VisibilityPartiallyObscured, or VisibilityFullyObscured}}}}
+ {bind-22.103 <Visibility> %s {-state VisibilityUnobscured} VisibilityUnobscured}
+ {bind-22.104 <Configure> %s {-state xyz} {{1 {<Configure> event doesn't accept "-state" option}}}}
+
+ {bind-22.105 <Key> %S {-subwindow .xyz} {{1 {bad window path name ".xyz"}}}}
+ {bind-22.106 <Key> %S {-subwindow .b} {[winfo id .b]}}
+ {bind-22.107 <Key> %S {-subwindow xyz} {{1 {bad window name/identifier "xyz"}}}}
+ {bind-22.108 <Key> %S {-subwindow [winfo id .b]} {[winfo id .b]}}
+ {bind-22.109 <Button> %S {-subwindow .b} {[winfo id .b]}}
+ {bind-22.110 <ButtonRelease> %S {-subwindow .b} {[winfo id .b]}}
+ {bind-22.111 <Motion> %S {-subwindow .b} {[winfo id .b]}}
+ {bind-22.112 <<Paste>> %S {-subwindow .b} {[winfo id .b]}}
+ {bind-22.113 <Enter> %S {-subwindow .b} {[winfo id .b]}}
+ {bind-22.114 <Configure> %S {-subwindow .b} {{1 {<Configure> event doesn't accept "-subwindow" option}}}}
+
+ {bind-22.115 <Key> %t {-time xyz} {{1 {expected integer but got "xyz"}}}}
+ {bind-22.116 <Key> %t {-time 100} 100}
+ {bind-22.117 <Button> %t {-time 100} 100}
+ {bind-22.118 <ButtonRelease> %t {-time 100} 100}
+ {bind-22.119 <Motion> %t {-time 100} 100}
+ {bind-22.120 <<Paste>> %t {-time 100} 100}
+ {bind-22.121 <Enter> %t {-time 100} 100}
+ {bind-22.122 <Property> %t {-time 100} 100}
+ {bind-22.123 <Configure> %t {-time 100} {{1 {<Configure> event doesn't accept "-time" option}}}}
+
+ {bind-22.124 <Expose> %w {-width xyz} {{1 {bad screen distance "xyz"}}}}
+ {bind-22.125 <Expose> %w {-width 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.126 <Configure> %w {-width 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.127 <Key> %k {-width 2i} {{1 {<Key> event doesn't accept "-width" option}}}}
+
+ {bind-22.128 <Unmap> %W {-window .xyz} {{1 {bad window path name ".xyz"}}}}
+ {bind-22.129 <Unmap> %W {-window .b.f} .b.f}
+ {bind-22.130 <Unmap> %W {-window xyz} {{1 {bad window name/identifier "xyz"}}}}
+ {bind-22.131 <Unmap> %W {-window [winfo id .b.f]} .b.f}
+ {bind-22.132 <Unmap> %W {-window .b.f} .b.f}
+ {bind-22.133 <Map> %W {-window .b.f} .b.f}
+ {bind-22.134 <Reparent> %W {-window .b.f} .b.f}
+ {bind-22.135 <Configure> %W {-window .b.f} .b.f}
+ {bind-22.136 <Gravity> %W {-window .b.f} .b.f}
+ {bind-22.137 <Circulate> %W {-window .b.f} .b.f}
+ {bind-22.138 <Key> %W {-window .b.f} {{1 {<Key> event doesn't accept "-window" option}}}}
+
+ {bind-22.139 <Key> %x {-x xyz} {{1 {bad screen distance "xyz"}}}}
+ {bind-22.140 <Key> %x {-x 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.141 <Button> %x {-x 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.142 <ButtonRelease> %x {-x 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.143 <Motion> %x {-x 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.144 <<Paste>> %x {-x 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.145 <Enter> %x {-x 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.146 <Expose> %x {-x 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.147 <Configure> %x {-x 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.148 <Gravity> %x {-x 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.149 <Reparent> %x {-x 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.150 <Map> %x {-x 2i} {{1 {<Map> event doesn't accept "-x" option}}}}
+
+ {bind-22.151 <Key> %y {-y xyz} {{1 {bad screen distance "xyz"}}}}
+ {bind-22.152 <Key> %y {-y 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.153 <Button> %y {-y 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.154 <ButtonRelease> %y {-y 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.155 <Motion> %y {-y 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.156 <<Paste>> %y {-y 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.157 <Enter> %y {-y 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.158 <Expose> %y {-y 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.159 <Configure> %y {-y 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.160 <Gravity> %y {-y 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.161 <Reparent> %y {-y 2i} {[winfo pixels .b.f 2i]}}
+ {bind-22.162 <Map> %y {-y 2i} {{1 {<Map> event doesn't accept "-y" option}}}}
+
+ {bind-22.163 <Key> %k {-xyz 1} {{1 {bad option "-xyz": must be -when, -above, -borderwidth, -button, -count, -delta, -detail, -focus, -height, -keycode, -keysym, -mode, -override, -place, -root, -rootx, -rooty, -sendevent, -serial, -state, -subwindow, -time, -warp, -width, -window, -x, or -y}}}}
} {
- set event [lindex $check 0]
- test bind-22.$i "HandleEventGenerate: options $event [lindex $check 2]" {
+ lassign $check name event substitution generator result
+ test $name "HandleEventGenerate: options $event $generator" {
setup
- bind .b.f $event "lappend x [lindex $check 1]"
+ bind .b.f $event "lappend x $substitution"
set x {}
- if [catch {eval event gen .b.f $event [lindex $check 2]} msg] {
+ if [catch {eval event gen .b.f $event $generator} msg] {
set x [list 1 $msg]
}
set x
- } [eval set x [lindex $check 3]]
- incr i
+ } [eval set x $result]
}
test bind-23.1 {GetVirtualEventUid procedure} {
list [catch {event info <<asd} msg] $msg
@@ -2432,48 +2430,49 @@ test bind-25.17 {ParseEventDescription} {
setup
list [catch {event add <<xyz>> <<abc>>} msg] $msg
} {1 {virtual event not allowed in definition of another virtual event}}
-set i 1
foreach check {
- {{<Control- a>} <Control-Key-a>}
- {<Shift-a> <Shift-Key-a>}
- {<Lock-a> <Lock-Key-a>}
- {<Meta---a> <Meta-Key-a>}
- {<M-a> <Meta-Key-a>}
- {<Alt-a> <Alt-Key-a>}
- {<B1-a> <B1-Key-a>}
- {<B2-a> <B2-Key-a>}
- {<B3-a> <B3-Key-a>}
- {<B4-a> <B4-Key-a>}
- {<B5-a> <B5-Key-a>}
- {<Button1-a> <B1-Key-a>}
- {<Button2-a> <B2-Key-a>}
- {<Button3-a> <B3-Key-a>}
- {<Button4-a> <B4-Key-a>}
- {<Button5-a> <B5-Key-a>}
- {<M1-a> <Mod1-Key-a>}
- {<M2-a> <Mod2-Key-a>}
- {<M3-a> <Mod3-Key-a>}
- {<M4-a> <Mod4-Key-a>}
- {<M5-a> <Mod5-Key-a>}
- {<Mod1-a> <Mod1-Key-a>}
- {<Mod2-a> <Mod2-Key-a>}
- {<Mod3-a> <Mod3-Key-a>}
- {<Mod4-a> <Mod4-Key-a>}
- {<Mod5-a> <Mod5-Key-a>}
- {<Double-a> <Double-Key-a>}
- {<Triple-a> <Triple-Key-a>}
- {{<Double 1>} <Double-Button-1>}
- {<Triple-1> <Triple-Button-1>}
- {{<M1-M2 M3-M4 B1-Control-a>} <Control-B1-Mod1-Mod2-Mod3-Mod4-Key-a>}
+ {bind-25.1 {<Control- a>} <Control-Key-a>}
+ {bind-25.2 <Shift-a> <Shift-Key-a>}
+ {bind-25.3 <Lock-a> <Lock-Key-a>}
+ {bind-25.4 <Meta---a> <Meta-Key-a>}
+ {bind-25.5 <M-a> <Meta-Key-a>}
+ {bind-25.6 <Alt-a> <Alt-Key-a>}
+ {bind-25.7 <B1-a> <B1-Key-a>}
+ {bind-25.8 <B2-a> <B2-Key-a>}
+ {bind-25.9 <B3-a> <B3-Key-a>}
+ {bind-25.10 <B4-a> <B4-Key-a>}
+ {bind-25.11 <B5-a> <B5-Key-a>}
+ {bind-25.12 <Button1-a> <B1-Key-a>}
+ {bind-25.13 <Button2-a> <B2-Key-a>}
+ {bind-25.14 <Button3-a> <B3-Key-a>}
+ {bind-25.15 <Button4-a> <B4-Key-a>}
+ {bind-25.16 <Button5-a> <B5-Key-a>}
+ {bind-25.17 <M1-a> <Mod1-Key-a>}
+ {bind-25.18 <M2-a> <Mod2-Key-a>}
+ {bind-25.19 <M3-a> <Mod3-Key-a>}
+ {bind-25.20 <M4-a> <Mod4-Key-a>}
+ {bind-25.21 <M5-a> <Mod5-Key-a>}
+ {bind-25.22 <Mod1-a> <Mod1-Key-a>}
+ {bind-25.23 <Mod2-a> <Mod2-Key-a>}
+ {bind-25.24 <Mod3-a> <Mod3-Key-a>}
+ {bind-25.25 <Mod4-a> <Mod4-Key-a>}
+ {bind-25.26 <Mod5-a> <Mod5-Key-a>}
+ {bind-25.27 <Double-a> <Double-Key-a>}
+ {bind-25.28 <Triple-a> <Triple-Key-a>}
+ {bind-25.29 {<Double 1>} <Double-Button-1>}
+ {bind-25.30 <Triple-1> <Triple-Button-1>}
+ {bind-25.31 {<M1-M2 M3-M4 B1-Control-a>} <Control-B1-Mod1-Mod2-Mod3-Mod4-Key-a>}
} {
- test bind-25.$i {modifier names} {
+ lassign $check name shortBind longBind
+ test $name {modifier names} -setup {
catch {destroy .b.f}
frame .b.f -class Test -width 150 -height 100
- bind .b.f [lindex $check 0] foo
+ } -body {
+ bind .b.f $shortBind foo
bind .b.f
- } [lindex $check 1]
- bind .b.f [lindex $check 1] {}
- incr i
+ } -result $longBind -cleanup {
+ bind .b.f [lindex $check 1] {}
+ }
}
foreach event [bind Test] {
@@ -2501,72 +2500,97 @@ test bind-26.3 {event names} {
destroy .b.f
set x
} {<Destroy> destroyed}
-set i 4
foreach check {
- {Motion Motion}
- {Button Button}
- {ButtonPress Button}
- {ButtonRelease ButtonRelease}
- {Colormap Colormap}
- {Enter Enter}
- {Leave Leave}
- {Expose Expose}
- {Key Key}
- {KeyPress Key}
- {KeyRelease KeyRelease}
- {Property Property}
- {Visibility Visibility}
- {Activate Activate}
- {Deactivate Deactivate}
+ {bind-26.4 Motion Motion}
+ {bind-26.5 Button Button}
+ {bind-26.6 ButtonPress Button}
+ {bind-26.7 ButtonRelease ButtonRelease}
+ {bind-26.8 Colormap Colormap}
+ {bind-26.9 Enter Enter}
+ {bind-26.10 Leave Leave}
+ {bind-26.11 Expose Expose}
+ {bind-26.12 Key Key}
+ {bind-26.13 KeyPress Key}
+ {bind-26.14 KeyRelease KeyRelease}
+ {bind-26.15 Property Property}
+ {bind-26.16 Visibility Visibility}
+ {bind-26.17 Activate Activate}
+ {bind-26.18 Deactivate Deactivate}
} {
- set event [lindex $check 0]
- test bind-26.$i {event names} {
+ lassign $check name event canonicalEvent
+ test $name "event names: $event" {
setup
bind .b.f <$event> "set x {event $event}"
set x xyzzy
event gen .b.f <$event>
list $x [bind .b.f]
- } [list "event $event" <[lindex $check 1]>]
- incr i
+ } [list "event $event" <$canonicalEvent>]
}
+# These events require an extra argument to [event generate]
foreach check {
- {Circulate Circulate}
- {Configure Configure}
- {Gravity Gravity}
- {Map Map}
- {Reparent Reparent}
- {Unmap Unmap}
+ {bind-26.19 Circulate Circulate}
+ {bind-26.20 Configure Configure}
+ {bind-26.21 Gravity Gravity}
+ {bind-26.22 Map Map}
+ {bind-26.23 Reparent Reparent}
+ {bind-26.24 Unmap Unmap}
} {
- set event [lindex $check 0]
- test bind-26.$i {event names} {
+ lassign $check name event canonicalEvent
+ test $name "event names: $event" {
setup
bind .b.f <$event> "set x {event $event}"
set x xyzzy
event gen .b.f <$event> -window .b.f
list $x [bind .b.f]
- } [list "event $event" <[lindex $check 1]>]
- incr i
+ } [list "event $event" <$canonicalEvent>]
}
-
test bind-27.1 {button names} {
list [catch {bind .b <Expose-1> foo} msg] $msg
} {1 {specified button "1" for non-button event}}
test bind-27.2 {button names} {
list [catch {bind .b <Button-6> foo} msg] $msg
} {1 {specified keysym "6" for non-key event}}
-set i 3
-foreach button {1 2 3 4 5} {
- test bind-27.$i {button names} {
- setup
- bind .b.f <Button-$button> "lappend x \"button $button\""
- set x [bind .b.f]
- event gen .b.f <Button-$button>
- event gen .b.f <ButtonRelease-$button>
- set x
- } [list <Button-$button> "button $button"]
- incr i
-}
+test bind-27.3 {button names} {
+ setup
+ bind .b.f <Button-1> {lappend x "button 1"}
+ set x [bind .b.f]
+ event gen .b.f <Button-1>
+ event gen .b.f <ButtonRelease-1>
+ set x
+} {<Button-1> {button 1}}
+test bind-27.4 {button names} {
+ setup
+ bind .b.f <Button-2> {lappend x "button 2"}
+ set x [bind .b.f]
+ event gen .b.f <Button-2>
+ event gen .b.f <ButtonRelease-2>
+ set x
+} {<Button-2> {button 2}}
+test bind-27.5 {button names} {
+ setup
+ bind .b.f <Button-3> {lappend x "button 3"}
+ set x [bind .b.f]
+ event gen .b.f <Button-3>
+ event gen .b.f <ButtonRelease-3>
+ set x
+} {<Button-3> {button 3}}
+test bind-27.6 {button names} {
+ setup
+ bind .b.f <Button-4> {lappend x "button 4"}
+ set x [bind .b.f]
+ event gen .b.f <Button-4>
+ event gen .b.f <ButtonRelease-4>
+ set x
+} {<Button-4> {button 4}}
+test bind-27.7 {button names} {
+ setup
+ bind .b.f <Button-5> {lappend x "button 5"}
+ set x [bind .b.f]
+ event gen .b.f <Button-5>
+ event gen .b.f <ButtonRelease-5>
+ set x
+} {<Button-5> {button 5}}
test bind-28.1 {keysym names} {
list [catch {bind .b <Expose-a> foo} msg] $msg
@@ -2583,46 +2607,41 @@ test bind-28.4 {keysym names} {
bind .b.f <a> foo
bind .b.f
} a
-set i 5
foreach check {
- {a 0 a}
- {space 0 <Key-space>}
- {Return 0 <Key-Return>}
- {X 1 X}
+ {bind-28.5 a 0 a}
+ {bind-28.6 space 0 <Key-space>}
+ {bind-28.7 Return 0 <Key-Return>}
+ {bind-28.8 X 1 X}
} {
- set keysym [lindex $check 0]
- test bind-28.$i {keysym names} {
+ lassign $check name keysym state result
+ test $name {keysym names} {
setup
bind .b.f <Key-$keysym> "lappend x \"keysym $keysym\""
bind .b.f <Key-x> "lappend x {bad binding match}"
set x [lsort [bind .b.f]]
- event gen .b.f <Key-$keysym> -state [lindex $check 1]
+ event gen .b.f <Key-$keysym> -state $state
set x
- } [concat [lsort "x [lindex $check 2]"] "{keysym $keysym}"]
- incr i
+ } [concat [lsort "x $result"] "{keysym $keysym}"]
}
test bind-29.1 {dummy test to help ensure proper numbering} {} {}
setup
bind .b.f <KeyPress> {set x %K}
-set i 2
foreach check {
- {a 0 a}
- {x 1 X}
- {x 2 X}
- {space 0 space}
- {F1 1 F1}
+ {bind-29.2 a 0 a}
+ {bind-29.3 x 1 X}
+ {bind-29.4 x 2 X}
+ {bind-29.5 space 0 space}
+ {bind-29.6 F1 1 F1}
} {
- test bind-29.$i {GetKeySym procedure} {nonPortable} {
+ lassign $check name keysym state result
+ test $name {GetKeySym procedure} nonPortable {
set x nothing
- event gen .b.f <KeyPress> -keysym [lindex $check 0] \
- -state [lindex $check 1]
+ event gen .b.f <KeyPress> -keysym $keysym -state $state
set x
- } [lindex $check 2]
- incr i
+ } $result
}
-
proc bgerror msg {
global x errorInfo
set x [list $msg $errorInfo]
diff --git a/tests/bitmap.test b/tests/bitmap.test
index f81613d..95d04a9 100644
--- a/tests/bitmap.test
+++ b/tests/bitmap.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: bitmap.test,v 1.4 2003/04/01 21:06:17 dgp Exp $
+# RCS: @(#) $Id: bitmap.test,v 1.5 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -93,16 +93,3 @@ destroy .t
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/border.test b/tests/border.test
index 0bf08b8..81cea0b 100644
--- a/tests/border.test
+++ b/tests/border.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: border.test,v 1.4 2003/04/01 21:06:17 dgp Exp $
+# RCS: @(#) $Id: border.test,v 1.5 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -163,16 +163,3 @@ if {[testConstraint pseudocolor8]} {
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/button.test b/tests/button.test
index bc81d9a..b536078 100644
--- a/tests/button.test
+++ b/tests/button.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: button.test,v 1.15 2004/02/18 00:40:24 hobbs Exp $
+# RCS: @(#) $Id: button.test,v 1.16 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -42,7 +42,9 @@ foreach test {
{unknown color name "non-existent"} {1 1 1 1}}
{-activeforeground #ff0000 #ff0000 non-existent
{unknown color name "non-existent"} {1 1 1 1}}
- {-anchor nw nw bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} {1 1 1 1}}
+ {-anchor nw nw bogus
+ {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+ {1 1 1 1}}
{-background #ff0000 #ff0000 non-existent
{unknown color name "non-existent"} {1 1 1 1}}
{-bd 4 4 badValue {bad screen distance "badValue"} {1 1 1 1}}
@@ -52,7 +54,9 @@ foreach test {
{1 1 1 1}}
{-borderwidth 1.3 1.3 badValue {bad screen distance "badValue"} {1 1 1 1}}
{-command "set x" {set x} {} {} {0 1 1 1}}
- {-compound left left bogus {bad compound "bogus": must be bottom, center, left, none, right, or top} {1 1 1 1}}
+ {-compound left left bogus
+ {bad compound "bogus": must be bottom, center, left, none, right, or top}
+ {1 1 1 1}}
{-cursor arrow arrow badValue {bad cursor spec "badValue"} {1 1 1 1}}
{-default active active huh?
{bad default "huh?": must be active, disabled, or normal}
@@ -72,47 +76,57 @@ foreach test {
{-image image1 image1 bogus {image "bogus" doesn't exist} {1 1 1 1}}
{-indicatoron yes 1 no_way {expected boolean value but got "no_way"}
{0 0 1 1}}
- {-justify right right bogus {bad justification "bogus": must be left, right, or center} {1 1 1 1}}
- {-offrelief flat flat 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} {0 0 1 1}}
+ {-justify right right bogus
+ {bad justification "bogus": must be left, right, or center}
+ {1 1 1 1}}
+ {-offrelief flat flat 1.5
+ {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+ {0 0 1 1}}
{-offvalue lousy lousy {} {} {0 0 1 0}}
{-onvalue fantastic fantastic {} {} {0 0 1 0}}
- {-overrelief "" "" 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} {0 1 1 1}}
+ {-overrelief "" "" 1.5
+ {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+ {0 1 1 1}}
{-padx 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}}
{-pady 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}}
{-repeatdelay 100 100 foo {expected integer but got "foo"} {0 1 0 0}}
{-repeatinterval 100 100 foo {expected integer but got "foo"} {0 1 0 0}}
- {-relief flat flat 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} {1 1 1 1}}
+ {-relief flat flat 1.5
+ {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+ {1 1 1 1}}
{-selectcolor #110022 #110022 bogus {unknown color name "bogus"} {0 0 1 1}}
{-selectimage image1 image1 bogus {image "bogus" doesn't exist} {0 0 1 1}}
- {-state normal normal bogus {bad state "bogus": must be active, disabled, or normal} {1 1 1 1}}
+ {-state normal normal bogus
+ {bad state "bogus": must be active, disabled, or normal}
+ {1 1 1 1}}
{-takefocus "any string" "any string" {} {} {1 1 1 1}}
{-text "Sample text" {Sample text} {} {} {1 1 1 1}}
{-textvariable i i {} {} {1 1 1 1}}
- {-tristateimage image1 image1 bogus {image "bogus" doesn't exist} {0 0 1 1}}
+ {-tristateimage image1 image1 bogus {image "bogus" doesn't exist}
+ {0 0 1 1}}
{-tristatevalue unknowable unknowable {} {} {0 0 1 1}}
{-underline 5 5 3p {expected integer but got "3p"} {1 1 1 1}}
{-value anyString anyString {} {} {0 0 0 1}}
{-width 402 402 3p {expected integer but got "3p"} {1 1 1 1}}
{-wraplength 100 100 6x {bad screen distance "6x"} {1 1 1 1}}
} {
- set name [lindex $test 0]
- set classes [lindex $test 5]
- foreach w {.l .b .c .r} hasOption [lindex $test 5] {
- if $hasOption {
+ lassign $test name value okResult badValue badResult classes
+ foreach w {.l .b .c .r} hasOption $classes {
+ if {$hasOption} {
test button-1.$i {configuration options} testImageType {
- $w configure $name [lindex $test 1]
+ $w configure $name $value
lindex [$w configure $name] 4
- } [lindex $test 2]
+ } $okResult
incr i
- if {[lindex $test 3] != ""} {
+ if {$badValue ne ""} {
test button-1.$i {configuration options} testImageType {
- list [catch {$w configure $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
+ list [catch {$w configure $name $badValue} msg] $msg
+ } [list 1 $badResult]
}
$w configure $name [lindex [$w configure $name] 3]
} else {
test button-1.$i {configuration options} testImageType {
- list [catch {$w configure $name [lindex $test 1]} msg] $msg
+ list [catch {$w configure $name $value} msg] $msg
} "1 {unknown option \"$name\"}"
}
}
diff --git a/tests/canvImg.test b/tests/canvImg.test
index ec6fb6b..5a7cd71 100644
--- a/tests/canvImg.test
+++ b/tests/canvImg.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: canvImg.test,v 1.7 2003/05/08 09:35:41 dkf Exp $
+# RCS: @(#) $Id: canvImg.test,v 1.8 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -225,37 +225,36 @@ test canvImg-7.2 {DisplayImage procedure, no image} {
update
} {}
-set i 1
.c delete all
if {[testConstraint testImageType]} {
.c create image 50 100 -image foo -tags image -anchor nw
}
.c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
foreach check {
- {{50 70 80 81} {70 90} {rect}}
- {{50 70 80 79} {70 90} {image}}
- {{99 70 110 81} {90 90} {rect}}
- {{101 70 110 79} {90 90} {image}}
- {{99 100 110 115} {90 110} {rect}}
- {{101 100 110 115} {90 110} {image}}
- {{99 134 110 145} {90 125} {rect}}
- {{101 136 110 145} {90 125} {image}}
- {{50 134 80 145} {70 125} {rect}}
- {{50 136 80 145} {70 125} {image}}
- {{20 134 31 145} {40 125} {rect}}
- {{20 136 29 145} {40 125} {image}}
- {{20 100 31 115} {40 110} {rect}}
- {{20 100 29 115} {40 110} {image}}
- {{20 70 31 80} {40 90} {rect}}
- {{20 70 29 79} {40 90} {image}}
- {{60 70 69 109} {70 110} {image}}
- {{60 70 71 111} {70 110} {rect}}
+ {canvImg-8.1 {50 70 80 81} {70 90} rect}
+ {canvImg-8.2 {50 70 80 79} {70 90} image}
+ {canvImg-8.3 {99 70 110 81} {90 90} rect}
+ {canvImg-8.4 {101 70 110 79} {90 90} image}
+ {canvImg-8.5 {99 100 110 115} {90 110} rect}
+ {canvImg-8.6 {101 100 110 115} {90 110} image}
+ {canvImg-8.7 {99 134 110 145} {90 125} rect}
+ {canvImg-8.8 {101 136 110 145} {90 125} image}
+ {canvImg-8.9 {50 134 80 145} {70 125} rect}
+ {canvImg-8.10 {50 136 80 145} {70 125} image}
+ {canvImg-8.11 {20 134 31 145} {40 125} rect}
+ {canvImg-8.12 {20 136 29 145} {40 125} image}
+ {canvImg-8.13 {20 100 31 115} {40 110} rect}
+ {canvImg-8.14 {20 100 29 115} {40 110} image}
+ {canvImg-8.15 {20 70 31 80} {40 90} rect}
+ {canvImg-8.16 {20 70 29 79} {40 90} image}
+ {canvImg-8.17 {60 70 69 109} {70 110} image}
+ {canvImg-8.18 {60 70 71 111} {70 110} rect}
} {
- test canvImg-8.$i {ImageToPoint procedure} testImageType {
- eval .c coords rect [lindex $check 0]
- .c gettags [eval .c find closest [lindex $check 1]]
- } [lindex $check 2]
- incr i
+ lassign $check name rectCoords testPoint result
+ test $name {ImageToPoint procedure} testImageType {
+ .c coords rect {expand}$rectCoords
+ .c gettags [.c find closest {expand}$testPoint]
+ } $result
}
.c delete all
@@ -392,16 +391,3 @@ test canvImg-11.3 {ImageChangedProc procedure} testImageType {
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/canvPs.test b/tests/canvPs.test
index d065d53..e57b9b9 100644
--- a/tests/canvPs.test
+++ b/tests/canvPs.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: canvPs.test,v 1.7 2003/05/11 00:52:41 hobbs Exp $
+# RCS: @(#) $Id: canvPs.test,v 1.8 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -131,16 +131,3 @@ removeFile bar.ps
deleteWindows
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/canvRect.test b/tests/canvRect.test
index a9918e1..07f3e91 100644
--- a/tests/canvRect.test
+++ b/tests/canvRect.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: canvRect.test,v 1.7 2003/04/01 21:06:18 dgp Exp $
+# RCS: @(#) $Id: canvRect.test,v 1.8 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -22,22 +22,27 @@ update
set i 1
.c create rectangle 20 20 80 80 -tag test
foreach test {
- {-fill #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
- {-outline #123456 #123456 bad_color {unknown color name "bad_color"}}
- {-stipple gray50 gray50 bogus {bitmap "bogus" not defined}}
- {-tags {test a b c} {test a b c} {} {}}
- {-width 6.0 6.0 abc {bad screen distance "abc"}}
+ {-fill #ff0000 #ff0000
+ non-existent {unknown color name "non-existent"}}
+ {-outline #123456 #123456
+ bad_color {unknown color name "bad_color"}}
+ {-stipple gray50 gray50
+ bogus {bitmap "bogus" not defined}}
+ {-tags {test a b c} {test a b c}
+ {} {}}
+ {-width 6.0 6.0
+ abc {bad screen distance "abc"}}
} {
- set name [lindex $test 0]
- test canvRect-1.$i {configuration options} {
- .c itemconfigure test $name [lindex $test 1]
+ lassign $test name goodValue goodResult badValue badResult
+ test canvRect-1.$i "configuration options: good value for $name" {
+ .c itemconfigure test $name $goodValue
list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name]
- } [list [lindex $test 2] [lindex $test 2]]
+ } [list $goodResult $goodResult]
incr i
- if {[lindex $test 3] != ""} {
- test canvRect-1.$i {configuration options} {
- list [catch {.c itemconfigure test $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
+ if {$badValue ne ""} {
+ test canvRect-1.$i "configuration options: bad value for $name" -body {
+ .c itemconfigure test $name $badValue
+ } -returnCodes error -result $badResult
}
incr i
}
@@ -323,16 +328,3 @@ end
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/canvText.test b/tests/canvText.test
index 5d5acb9..4578ff0 100644
--- a/tests/canvText.test
+++ b/tests/canvText.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: canvText.test,v 1.13 2003/04/01 21:06:19 dgp Exp $
+# RCS: @(#) $Id: canvText.test,v 1.14 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -35,16 +35,16 @@ foreach test {
{-text xyz xyz {} {}}
{-width 6 6 xyz {bad screen distance "xyz"}}
} {
- set name [lindex $test 0]
- test canvText-1.$i {configuration options} {
- .c itemconfigure test $name [lindex $test 1]
+ lassign $test name goodValue goodResult badValue badResult
+ test canvText-1.$i "configuration options: good value for $name" {
+ .c itemconfigure test $name $goodValue
list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name]
- } [list [lindex $test 2] [lindex $test 2]]
+ } [list $goodResult $goodResult]
incr i
- if {[lindex $test 3] != ""} {
- test canvText-1.$i {configuration options} {
- list [catch {.c itemconfigure test $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
+ if {$badValue ne ""} {
+ test canvText-1.$i "configuration options: bad value for $name" -body {
+ .c itemconfigure test $name $badValue
+ } -returnCodes error -result $badResult
}
incr i
}
@@ -516,16 +516,3 @@ test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} {
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/canvWind.test b/tests/canvWind.test
index 37e6e34..1b07e3f 100644
--- a/tests/canvWind.test
+++ b/tests/canvWind.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: canvWind.test,v 1.5 2003/04/01 21:06:19 dgp Exp $
+# RCS: @(#) $Id: canvWind.test,v 1.6 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -129,16 +129,3 @@ catch {destroy .t}
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/canvas.test b/tests/canvas.test
index 5a2b5d3..3a7daff 100644
--- a/tests/canvas.test
+++ b/tests/canvas.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-2000 Ajuba Solutions.
# All rights reserved.
#
-# RCS: @(#) $Id: canvas.test,v 1.17 2003/04/01 21:06:19 dgp Exp $
+# RCS: @(#) $Id: canvas.test,v 1.18 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -20,12 +20,13 @@ pack .c
update
set i 1
foreach test {
- {-background #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
+ {-background #ff0000 #ff0000
+ non-existent {unknown color name "non-existent"}}
{-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
{-bd 4 4 badValue {bad screen distance "badValue"}}
{-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
- {-closeenough 24 24.0 bogus {expected floating-point number but got "bogus"}}
+ {-closeenough 24 24.0
+ bogus {expected floating-point number but got "bogus"}}
{-confine true 1 silly {expected boolean value but got "silly"}}
{-cursor arrow arrow badValue {bad cursor spec "badValue"}}
{-height 2.1 2 x42 {bad screen distance "x42"}}
@@ -37,7 +38,8 @@ foreach test {
{-insertofftime 100 100 3.2 {expected integer but got "3.2"}}
{-insertontime 100 100 3.2 {expected integer but got "3.2"}}
{-insertwidth 1.3 1 6x {bad screen distance "6x"}}
- {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
+ {-relief groove groove
+ 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
{-selectbackground #110022 #110022 bogus {unknown color name "bogus"}}
{-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}}
{-selectforeground #654321 #654321 bogus {unknown color name "bogus"}}
@@ -46,16 +48,16 @@ foreach test {
{-xscrollcommand {Some command} {Some command} {} {}}
{-yscrollcommand {Another command} {Another command} {} {}}
} {
- set name [lindex $test 0]
- test canvas-1.$i {configuration options} {
- .c configure $name [lindex $test 1]
+ lassign $test name goodValue goodResult badValue badResult
+ test canvas-1.$i "configuration options: good value for $name" {
+ .c configure $name $goodValue
lindex [.c configure $name] 4
- } [lindex $test 2]
+ } $goodResult
incr i
- if {[lindex $test 3] != ""} {
- test canvas-1.$i {configuration options} {
- list [catch {.c configure $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
+ if {$badValue ne ""} {
+ test canvas-1.$i "configuration options: bad value for $name" -body {
+ .c configure $name $badValue
+ } -returnCodes error -result $badResult
}
.c configure $name [lindex [.c configure $name] 3]
incr i
@@ -454,15 +456,18 @@ proc create {w type args} {
eval [list $w create $type] $args
}
foreach type {arc bitmap image line oval polygon rect text window} {
- test canvas-15.[incr i] "basic types check: $type" {
+ incr i
+ test canvas-15.$i "basic types check: $type requires coords" -setup {
destroy .c; canvas .c
- list [catch {.c create $type} msg] $msg
- } [format {1 {wrong # args: should be ".c create %s coords ?arg arg ...?"}} $type]
- test canvas-15.[incr i] "basic coords check: $type" {
+ } -body {
+ .c create $type
+ } -returnCodes error -result [format {wrong # args: should be ".c create %s coords ?arg arg ...?"} $type]
+ incr i
+ test canvas-15.$i "basic coords check: $type coords are paired" -setup {
destroy .c; canvas .c
- list [catch {.c create $type 0} msg] \
- [string match "wrong # coordinates: expected*" $msg]
- } {1 1}
+ } -match glob -body {
+ .c create $type 0
+ } -returnCodes error -result "wrong # coordinates: expected*"
}
test canvas-16.1 {arc coords check} {
diff --git a/tests/choosedir.test b/tests/choosedir.test
index 98831df..d72dbcd 100644
--- a/tests/choosedir.test
+++ b/tests/choosedir.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: choosedir.test,v 1.11 2003/04/01 21:06:19 dgp Exp $
+# RCS: @(#) $Id: choosedir.test,v 1.12 2004/05/23 17:34:48 dkf Exp $
#
package require tcltest 2.1
@@ -89,7 +89,7 @@ set real [file join $dir choosedirTest]
set parent .
foreach opt {-initialdir -mustexist -parent -title} {
- test choosedir-1.1 "tk_chooseDirectory command" unixOnly {
+ test choosedir-1.1$opt "tk_chooseDirectory command" unixOnly {
list [catch {tk_chooseDirectory $opt} msg] $msg
} [list 1 "value for \"$opt\" missing"]
}
diff --git a/tests/clipboard.test b/tests/clipboard.test
index 2793aaf..b8530a6 100644
--- a/tests/clipboard.test
+++ b/tests/clipboard.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: clipboard.test,v 1.7 2003/04/01 21:06:20 dgp Exp $
+# RCS: @(#) $Id: clipboard.test,v 1.8 2004/05/23 17:34:48 dkf Exp $
#
# Note: Multiple display clipboard handling will only be tested if the
@@ -244,16 +244,3 @@ test clipboard-7.16 {Tk_ClipboardCmd procedure} {
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/clrpick.test b/tests/clrpick.test
index 5e19770..70f1a52 100644
--- a/tests/clrpick.test
+++ b/tests/clrpick.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: clrpick.test,v 1.9 2004/03/17 18:15:49 das Exp $
+# RCS: @(#) $Id: clrpick.test,v 1.10 2004/05/23 17:34:48 dkf Exp $
#
package require tcltest 2.1
@@ -21,10 +21,10 @@ regsub -all , $msg "" options
regsub \"-foo\" $options "" options
foreach option $options {
- if {[string index $option 0] == "-"} {
- test clrpick-1.2 {tk_chooseColor command} {
- list [catch {tk_chooseColor $option} msg] $msg
- } [list 1 "value for \"$option\" missing"]
+ if {[string index $option 0] eq "-"} {
+ test clrpick-1.2$option {tk_chooseColor command} -body {
+ tk_chooseColor $option
+ } -returnCodes error -result "value for \"$option\" missing"
}
}
@@ -48,11 +48,7 @@ test clrpick-1.7 {tk_chooseColor command} {
list [catch {tk_chooseColor -initialcolor ##badbadbaadcolor} msg] $msg
} {1 {invalid color name "##badbadbaadcolor"}}
-if {[info commands tk::dialog::color::] == ""} {
- set isNative 1
-} else {
- set isNative 0
-}
+set isNative [expr {[info commands tk::dialog::color::] eq ""}]
proc ToPressButton {parent btn} {
global isNative
diff --git a/tests/cmds.test b/tests/cmds.test
index 7e1680c..0d989a1 100644
--- a/tests/cmds.test
+++ b/tests/cmds.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: cmds.test,v 1.5 2003/04/01 21:06:20 dgp Exp $
+# RCS: @(#) $Id: cmds.test,v 1.6 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -42,16 +42,3 @@ test cmds-1.5 {tkwait visibility, window gets deleted} {
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/cursor.test b/tests/cursor.test
index 9da3539..b5ce675 100644
--- a/tests/cursor.test
+++ b/tests/cursor.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: cursor.test,v 1.11 2004/03/17 18:15:49 das Exp $
+# RCS: @(#) $Id: cursor.test,v 1.12 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -131,133 +131,127 @@ test cursor-4.1 {FreeCursorObjProc} {testcursor} {
# -------------------------------------------------------------------------
-test cursor-5.1 {assert consistent cursor configuration command} \
- -setup { button .b } \
- -body {
- list [catch {.b configure -cursor {watch red black}} msg] $msg
- } \
- -cleanup {destroy .b} \
- -result {0 {}}
+test cursor-5.1 {assert consistent cursor configuration command} -setup {
+ button .b
+} -body {
+ .b configure -cursor {watch red black}
+} -cleanup {
+ destroy .b
+} -result {}
# -------------------------------------------------------------------------
# Check for the standard set of cursors.
-set n 0
-foreach cursor {
- X_cursor
- arrow
- based_arrow_down
- based_arrow_up
- boat
- bogosity
- bottom_left_corner
- bottom_right_corner
- bottom_side
- bottom_tee
- box_spiral
- center_ptr
- circle
- clock
- coffee_mug
- cross
- cross_reverse
- crosshair
- diamond_cross
- dot
- dotbox
- double_arrow
- draft_large
- draft_small
- draped_box
- exchange
- fleur
- gobbler
- gumby
- hand1
- hand2
- heart
- icon
- iron_cross
- left_ptr
- left_side
- left_tee
- leftbutton
- ll_angle
- lr_angle
- man
- middlebutton
- mouse
- pencil
- pirate
- plus
- question_arrow
- right_ptr
- right_side
- right_tee
- rightbutton
- rtl_logo
- sailboat
- sb_down_arrow
- sb_h_double_arrow
- sb_left_arrow
- sb_right_arrow
- sb_up_arrow
- sb_v_double_arrow
- shuttle
- sizing
- spider
- spraycan
- star
- target
- tcross
- top_left_arrow
- top_left_corner
- top_right_corner
- top_side
- top_tee
- trek
- ul_angle
- umbrella
- ur_angle
- watch
- xterm
+foreach {testName cursor} {
+ cursor-6.1 X_cursor
+ cursor-6.2 arrow
+ cursor-6.3 based_arrow_down
+ cursor-6.4 based_arrow_up
+ cursor-6.5 boat
+ cursor-6.6 bogosity
+ cursor-6.7 bottom_left_corner
+ cursor-6.8 bottom_right_corner
+ cursor-6.9 bottom_side
+ cursor-6.10 bottom_tee
+ cursor-6.11 box_spiral
+ cursor-6.12 center_ptr
+ cursor-6.13 circle
+ cursor-6.14 clock
+ cursor-6.15 coffee_mug
+ cursor-6.16 cross
+ cursor-6.17 cross_reverse
+ cursor-6.18 crosshair
+ cursor-6.19 diamond_cross
+ cursor-6.20 dot
+ cursor-6.21 dotbox
+ cursor-6.22 double_arrow
+ cursor-6.23 draft_large
+ cursor-6.24 draft_small
+ cursor-6.25 draped_box
+ cursor-6.26 exchange
+ cursor-6.27 fleur
+ cursor-6.28 gobbler
+ cursor-6.29 gumby
+ cursor-6.30 hand1
+ cursor-6.31 hand2
+ cursor-6.32 heart
+ cursor-6.33 icon
+ cursor-6.34 iron_cross
+ cursor-6.35 left_ptr
+ cursor-6.36 left_side
+ cursor-6.37 left_tee
+ cursor-6.38 leftbutton
+ cursor-6.39 ll_angle
+ cursor-6.40 lr_angle
+ cursor-6.41 man
+ cursor-6.42 middlebutton
+ cursor-6.43 mouse
+ cursor-6.44 pencil
+ cursor-6.45 pirate
+ cursor-6.46 plus
+ cursor-6.47 question_arrow
+ cursor-6.48 right_ptr
+ cursor-6.49 right_side
+ cursor-6.50 right_tee
+ cursor-6.51 rightbutton
+ cursor-6.52 rtl_logo
+ cursor-6.53 sailboat
+ cursor-6.54 sb_down_arrow
+ cursor-6.55 sb_h_double_arrow
+ cursor-6.56 sb_left_arrow
+ cursor-6.57 sb_right_arrow
+ cursor-6.58 sb_up_arrow
+ cursor-6.59 sb_v_double_arrow
+ cursor-6.60 shuttle
+ cursor-6.61 sizing
+ cursor-6.62 spider
+ cursor-6.63 spraycan
+ cursor-6.64 star
+ cursor-6.65 target
+ cursor-6.66 tcross
+ cursor-6.67 top_left_arrow
+ cursor-6.68 top_left_corner
+ cursor-6.68 top_right_corner
+ cursor-6.69 top_side
+ cursor-6.70 top_tee
+ cursor-6.71 trek
+ cursor-6.72 ul_angle
+ cursor-6.73 umbrella
+ cursor-6.74 ur_angle
+ cursor-6.75 watch
+ cursor-6.76 xterm
} {
- test cursor-6.$n {check cursor $cursor} \
- -setup {button .b -text $cursor} \
- -body {
- list [catch {.b configure -cursor $cursor} msg] $msg
- } \
- -cleanup {destroy .b} \
- -result {0 {}}
- incr n
+ test $testName "check cursor-font cursor $cursor" -setup {
+ button .b -text $cursor
+ } -body {
+ .b configure -cursor $cursor
+ } -cleanup {
+ destroy .b
+ } -result {}
}
-unset n
# -------------------------------------------------------------------------
# Check the Windows specific cursors
-set n 0
-foreach cursor {
- no
- starting
- size
- size_ne_sw
- size_ns
- size_nw_se
- size_we
- uparrow
- wait
+
+foreach {testName cursor} {
+ cursor-7.1 no
+ cursor-7.2 starting
+ cursor-7.3 size
+ cursor-7.4 size_ne_sw
+ cursor-7.5 size_ns
+ cursor-7.6 size_nw_se
+ cursor-7.7 size_we
+ cursor-7.8 uparrow
+ cursor-7.9 wait
} {
- test cursor-7.$n {check cursor $cursor} \
- -constraints {pcOnly} \
- -setup {button .b -text $cursor} \
- -body {
- list [catch {.b configure -cursor $cursor} msg] $msg
- } \
- -cleanup {destroy .b} \
- -result {0 {}}
- incr n
+ test testName "check Windows cursor $cursor" -constraints pcOnly -setup {
+ button .b -text $cursor
+ } -body {
+ .b configure -cursor $cursor
+ } -cleanup {
+ destroy .b
+ } -result {}
}
-unset n
# -------------------------------------------------------------------------
diff --git a/tests/entry.test b/tests/entry.test
index a8742b6..8a5713e 100644
--- a/tests/entry.test
+++ b/tests/entry.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: entry.test,v 1.16 2004/03/17 18:15:49 das Exp $
+# RCS: @(#) $Id: entry.test,v 1.17 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -81,16 +81,16 @@ foreach test {
{-width 402 402 3p {expected integer but got "3p"}}
{-xscrollcommand {Some command} {Some command} {} {}}
} {
- set name [lindex $test 0]
+ lassign $test name goodValue goodResult badValue badResult
test entry-1.$i {configuration options} {
- .e configure $name [lindex $test 1]
+ .e configure $name $goodValue
list [lindex [.e configure $name] 4] [.e cget $name]
- } [list [lindex $test 2] [lindex $test 2]]
+ } [list $goodResult $goodResult]
incr i
- if {[lindex $test 3] != ""} {
- test entry-1.$i {configuration options} {
- list [catch {.e configure $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
+ if {$badValue ne ""} {
+ test entry-1.$i {configuration options} -body {
+ .e configure $name $badValue
+ } -returnCodes error -result $badResult
}
.e configure $name [lindex [.e configure $name] 3]
incr i
diff --git a/tests/filebox.test b/tests/filebox.test
index e386022..e7e386f 100644
--- a/tests/filebox.test
+++ b/tests/filebox.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: filebox.test,v 1.14 2003/04/01 21:06:23 dgp Exp $
+# RCS: @(#) $Id: filebox.test,v 1.15 2004/05/23 17:34:48 dkf Exp $
#
package require tcltest 2.1
@@ -99,8 +99,8 @@ if {$tcl_platform(platform) == "unix"} {
set modes 1
}
-set unknownOptionsMsg(tk_getOpenFile) {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, or -title}}
-set unknownOptionsMsg(tk_getSaveFile) {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent, or -title}}
+set unknownOptionsMsg(tk_getOpenFile) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, or -title}
+set unknownOptionsMsg(tk_getSaveFile) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent, or -title}
set tmpFile "filebox.tmp"
makeFile {
@@ -127,12 +127,11 @@ array set filters {
}
foreach mode $modes {
-
#
# Test both the motif version and the "tk" version of the file dialog
# box on Unix.
#
- # Note that this can use the same test number twice!
+ # Note that this means that test names are unusually complex.
#
set addedExtensions {}
@@ -145,46 +144,42 @@ foreach mode $modes {
}
}
- test filebox-1.1 "tk_getOpenFile command" {
- list [catch {tk_getOpenFile -foo} msg] $msg
- } $unknownOptionsMsg(tk_getOpenFile)
+ test filebox-1.1-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -foo
+ } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile)
catch {tk_getOpenFile -foo 1} msg
regsub -all , $msg "" options
regsub \"-foo\" $options "" options
foreach option $options {
- if {[string index $option 0] == "-"} {
- test filebox-1.2 "tk_getOpenFile command" {
- list [catch {tk_getOpenFile $option} msg] $msg
- } [list 1 "value for \"$option\" missing"]
+ if {[string index $option 0] eq "-"} {
+ test filebox-1.2-$mode$option "tk_getOpenFile command" -body {
+ tk_getOpenFile $option
+ } -returnCode error -result "value for \"$option\" missing"
}
}
-
- test filebox-1.3 "tk_getOpenFile command" {
- list [catch {tk_getOpenFile -foo bar} msg] $msg
- } $unknownOptionsMsg(tk_getOpenFile)
-
- test filebox-1.4 "tk_getOpenFile command" {
- list [catch {tk_getOpenFile -initialdir} msg] $msg
- } {1 {value for "-initialdir" missing}}
-
- test filebox-1.5 "tk_getOpenFile command" {
- list [catch {tk_getOpenFile -parent foo.bar} msg] $msg
- } {1 {bad window path name "foo.bar"}}
-
- test filebox-1.6 "tk_getOpenFile command" {
- list [catch {tk_getOpenFile -filetypes {Foo}} msg] $msg
- } {1 {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}}
-
- if {[info commands tk::MotifFDialog] == "" && [info commands ::tk::dialog::file::] == ""} {
- set isNative 1
- } else {
- set isNative 0
- }
-
+
+ test filebox-1.3-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -foo bar
+ } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile)
+ test filebox-1.4-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -initialdir
+ } -returnCodes error -result {value for "-initialdir" missing}
+ test filebox-1.5-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -parent foo.bar
+ } -returnCodes error -result {bad window path name "foo.bar"}
+ test filebox-1.6-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -filetypes {Foo}
+ } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}
+
+ set isNative [expr {
+ [info commands ::tk::MotifFDialog] eq "" &&
+ [info commands ::tk::dialog::file::] eq ""
+ }]
+
set parent .
-
+
set verylongstring longstring:
set verylongstring $verylongstring$verylongstring
set verylongstring $verylongstring$verylongstring
@@ -197,111 +192,103 @@ foreach mode $modes {
# set verylongstring $verylongstring$verylongstring
set color #404040
- test filebox-2.1 "tk_getOpenFile command" {nonUnixUserInteraction} {
+ test filebox-2.1-$mode "tk_getOpenFile command" nonUnixUserInteraction {
ToPressButton $parent cancel
tk_getOpenFile -title "Press Cancel ($verylongstring)" -parent $parent
} ""
-
+
set fileName $tmpFile
set fileDir [pwd]
set pathName [file join $fileDir $fileName]
-
- test filebox-2.2 "tk_getOpenFile command" {nonUnixUserInteraction} {
+
+ test filebox-2.2-$mode "tk_getOpenFile command" nonUnixUserInteraction {
ToPressButton $parent ok
set choice [tk_getOpenFile -title "Press Ok" \
- -parent $parent -initialfile $fileName -initialdir $fileDir]
+ -parent $parent -initialfile $fileName -initialdir $fileDir]
} $pathName
-
- test filebox-2.3 "tk_getOpenFile command" {nonUnixUserInteraction} {
+ test filebox-2.3-$mode "tk_getOpenFile command" nonUnixUserInteraction {
ToEnterFileByKey $parent $fileName $fileDir
set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \
- -parent $parent -initialdir $fileDir]
+ -parent $parent -initialdir $fileDir]
} $pathName
-
- test filebox-2.4 "tk_getOpenFile command" {nonUnixUserInteraction} {
+ test filebox-2.4-$mode "tk_getOpenFile command" nonUnixUserInteraction {
ToPressButton $parent ok
set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \
- -parent $parent -initialdir . \
- -initialfile $fileName]
+ -parent $parent -initialdir . -initialfile $fileName]
} $pathName
-
- test filebox-2.5 "tk_getOpenFile command" {nonUnixUserInteraction} {
+ test filebox-2.5-$mode "tk_getOpenFile command" nonUnixUserInteraction {
ToPressButton $parent ok
set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \
- -parent $parent -initialdir /badpath \
- -initialfile $fileName]
+ -parent $parent -initialdir /badpath -initialfile $fileName]
} $pathName
-
- test filebox-2.6 "tk_getOpenFile command" {nonUnixUserInteraction} {
+ test filebox-2.6-$mode "tk_getOpenFile command" -setup {
toplevel .t1; toplevel .t2
wm geometry .t1 +0+0
wm geometry .t2 +0+0
- ToPressButton .t1 ok
+ } -constraints nonUnixUserInteraction -body {
set choice {}
+ ToPressButton .t1 ok
lappend choice [tk_getOpenFile \
- -title "Enter \"$fileName\" and press Ok" \
- -parent .t1 -initialdir $fileDir \
- -initialfile $fileName]
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t1 -initialdir $fileDir \
+ -initialfile $fileName]
ToPressButton .t2 ok
lappend choice [tk_getOpenFile \
- -title "Enter \"$fileName\" and press Ok" \
- -parent .t2 -initialdir $fileDir \
- -initialfile $fileName]
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t2 -initialdir $fileDir \
+ -initialfile $fileName]
ToPressButton .t1 ok
lappend choice [tk_getOpenFile \
- -title "Enter \"$fileName\" and press Ok" \
- -parent .t1 -initialdir $fileDir \
- -initialfile $fileName]
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t1 -initialdir $fileDir \
+ -initialfile $fileName]
+ } -result [list $pathName $pathName $pathName] -cleanup {
destroy .t1
destroy .t2
- set choice
- } [list $pathName $pathName $pathName]
+ }
foreach x [lsort -integer [array names filters]] {
- test filebox-3.$x "tk_getOpenFile command" {nonUnixUserInteraction} {
- ToPressButton $parent ok
- set choice [tk_getOpenFile -title "Press Ok" -filetypes $filters($x)\
- -parent $parent -initialfile $fileName -initialdir $fileDir]
+ test filebox-3.$x-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getOpenFile -title "Press Ok" \
+ -filetypes $filters($x) -parent $parent \
+ -initialfile $fileName -initialdir $fileDir]
} $pathName
}
- test filebox-4.1 "tk_getSaveFile command" {
- list [catch {tk_getSaveFile -foo} msg] $msg
- } $unknownOptionsMsg(tk_getSaveFile)
+ test filebox-4.1-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -foo
+ } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile)
catch {tk_getSaveFile -foo 1} msg
regsub -all , $msg "" options
regsub \"-foo\" $options "" options
foreach option $options {
- if {[string index $option 0] == "-"} {
- test filebox-4.2 "tk_getSaveFile command" {
- list [catch {tk_getSaveFile $option} msg] $msg
- } [list 1 "value for \"$option\" missing"]
+ if {[string index $option 0] eq "-"} {
+ test filebox-4.2-$mode$option "tk_getSaveFile command" -body {
+ tk_getSaveFile $option
+ } -returnCodes error -result "value for \"$option\" missing"
}
}
- test filebox-4.3 "tk_getSaveFile command" {
- list [catch {tk_getSaveFile -foo bar} msg] $msg
- } $unknownOptionsMsg(tk_getSaveFile)
-
- test filebox-4.4 "tk_getSaveFile command" {
- list [catch {tk_getSaveFile -initialdir} msg] $msg
- } {1 {value for "-initialdir" missing}}
-
- test filebox-4.5 "tk_getSaveFile command" {
- list [catch {tk_getSaveFile -parent foo.bar} msg] $msg
- } {1 {bad window path name "foo.bar"}}
-
- test filebox-4.6 "tk_getSaveFile command" {
- list [catch {tk_getSaveFile -filetypes {Foo}} msg] $msg
- } {1 {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}}
-
- if {[info commands tk::MotifFDialog] == "" && [info commands ::tk::dialog::file::] == ""} {
- set isNative 1
- } else {
- set isNative 0
- }
+ test filebox-4.3-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -foo bar
+ } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile)
+ test filebox-4.4-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -initialdir
+ } -returnCodes error -result {value for "-initialdir" missing}
+ test filebox-4.5-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -parent foo.bar
+ } -returnCodes error -result {bad window path name "foo.bar"}
+ test filebox-4.6-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -filetypes {Foo}
+ } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}
+
+ set isNative [expr {
+ [info commands ::tk::MotifFDialog] eq "" &&
+ [info commands ::tk::dialog::file::] eq ""
+ }]
set parent .
@@ -317,7 +304,7 @@ foreach mode $modes {
# set verylongstring $verylongstring$verylongstring
set color #404040
- test filebox-5.1 "tk_getSaveFile command" {nonUnixUserInteraction} {
+ test filebox-5.1-$mode "tk_getSaveFile command" nonUnixUserInteraction {
ToPressButton $parent cancel
tk_getSaveFile -title "Press Cancel ($verylongstring)" -parent $parent
} ""
@@ -326,62 +313,56 @@ foreach mode $modes {
set fileDir [pwd]
set pathName [file join [pwd] $fileName]
- test filebox-5.2 "tk_getSaveFile command" {nonUnixUserInteraction} {
+ test filebox-5.2-$mode "tk_getSaveFile command" nonUnixUserInteraction {
ToPressButton $parent ok
set choice [tk_getSaveFile -title "Press Ok" \
-parent $parent -initialfile $fileName -initialdir $fileDir]
} $pathName
-
- test filebox-5.3 "tk_getSaveFile command" {nonUnixUserInteraction} {
+ test filebox-5.3-$mode "tk_getSaveFile command" nonUnixUserInteraction {
ToEnterFileByKey $parent $fileName $fileDir
set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \
-parent $parent -initialdir $fileDir]
} $pathName
-
- test filebox-5.4 "tk_getSaveFile command" {nonUnixUserInteraction} {
+ test filebox-5.4-$mode "tk_getSaveFile command" nonUnixUserInteraction {
ToPressButton $parent ok
set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \
- -parent $parent -initialdir . \
- -initialfile $fileName]
+ -parent $parent -initialdir . -initialfile $fileName]
} $pathName
-
- test filebox-5.5 "tk_getSaveFile command" {nonUnixUserInteraction} {
+ test filebox-5.5-$mode "tk_getSaveFile command" nonUnixUserInteraction {
ToPressButton $parent ok
set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \
- -parent $parent -initialdir /badpath \
- -initialfile $fileName]
+ -parent $parent -initialdir /badpath -initialfile $fileName]
} $pathName
- test filebox-5.6 "tk_getSaveFile command" {nonUnixUserInteraction} {
+ test filebox-5.6-$mode "tk_getSaveFile command" -setup {
toplevel .t1; toplevel .t2
wm geometry .t1 +0+0
wm geometry .t2 +0+0
- ToPressButton .t1 ok
+ } -constraints nonUnixUserInteraction -body {
set choice {}
+ ToPressButton .t1 ok
lappend choice [tk_getSaveFile \
-title "Enter \"$fileName\" and press Ok" \
- -parent .t1 -initialdir $fileDir \
- -initialfile $fileName]
+ -parent .t1 -initialdir $fileDir -initialfile $fileName]
ToPressButton .t2 ok
lappend choice [tk_getSaveFile \
-title "Enter \"$fileName\" and press Ok" \
- -parent .t2 -initialdir $fileDir \
- -initialfile $fileName]
+ -parent .t2 -initialdir $fileDir -initialfile $fileName]
ToPressButton .t1 ok
lappend choice [tk_getSaveFile \
-title "Enter \"$fileName\" and press Ok" \
- -parent .t1 -initialdir $fileDir \
- -initialfile $fileName]
+ -parent .t1 -initialdir $fileDir -initialfile $fileName]
+ } -result [list $pathName $pathName $pathName] -cleanup {
destroy .t1
destroy .t2
- set choice
- } [list $pathName $pathName $pathName]
+ }
foreach x [lsort -integer [array names filters]] {
- test filebox-6.$x "tk_getSaveFile command" {nonUnixUserInteraction} {
+ test filebox-6.$x-$mode "tk_getSaveFile command" nonUnixUserInteraction {
ToPressButton $parent ok
- set choice [tk_getSaveFile -title "Press Ok" -filetypes $filters($x)\
- -parent $parent -initialfile $fileName -initialdir $fileDir]
+ set choice [tk_getSaveFile -title "Press Ok" \
+ -filetypes $filters($x) -parent $parent \
+ -initialfile $fileName -initialdir $fileDir]
} $pathName[lindex $addedExtensions $x]
}
diff --git a/tests/focus.test b/tests/focus.test
index 37a0263..312c4d4 100644
--- a/tests/focus.test
+++ b/tests/focus.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: focus.test,v 1.9 2003/04/01 21:06:25 dgp Exp $
+# RCS: @(#) $Id: focus.test,v 1.10 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -642,16 +642,3 @@ bind all <FocusOut> {}
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/focusTcl.test b/tests/focusTcl.test
index 1570c36..4a891b5 100644
--- a/tests/focusTcl.test
+++ b/tests/focusTcl.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: focusTcl.test,v 1.7 2003/10/28 22:52:16 hobbs Exp $
+# RCS: @(#) $Id: focusTcl.test,v 1.8 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -278,16 +278,3 @@ option clear
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/font.test b/tests/font.test
index ed6a64a..cc0aa45 100644
--- a/tests/font.test
+++ b/tests/font.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: font.test,v 1.10 2004/03/17 18:15:49 das Exp $
+# RCS: @(#) $Id: font.test,v 1.11 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -672,54 +672,70 @@ test font-21.9 {Tk_PostscriptFontName procedure: spaces} {unixOnly} {
} {NewCenturySchlbk-Roman}
set i 10
foreach p {
- {"avantgarde" AvantGarde-Book AvantGarde-Demi AvantGarde-BookOblique AvantGarde-DemiOblique}
- {"bookman" Bookman-Light Bookman-Demi Bookman-LightItalic Bookman-DemiItalic}
- {"courier" Courier Courier-Bold Courier-Oblique Courier-BoldOblique}
- {"helvetica" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique}
- {"new century schoolbook" NewCenturySchlbk-Roman NewCenturySchlbk-Bold NewCenturySchlbk-Italic NewCenturySchlbk-BoldItalic}
- {"palatino" Palatino-Roman Palatino-Bold Palatino-Italic Palatino-BoldItalic}
- {"symbol" Symbol Symbol Symbol Symbol}
- {"times" Times-Roman Times-Bold Times-Italic Times-BoldItalic}
- {"zapfchancery" ZapfChancery-MediumItalic ZapfChancery-MediumItalic ZapfChancery-MediumItalic ZapfChancery-MediumItalic}
- {"zapfdingbats" ZapfDingbats ZapfDingbats ZapfDingbats ZapfDingbats}
+ {font-21.10 "avantgarde"
+ AvantGarde-Book AvantGarde-Demi
+ AvantGarde-BookOblique AvantGarde-DemiOblique}
+ {font-21.11 "bookman"
+ Bookman-Light Bookman-Demi Bookman-LightItalic Bookman-DemiItalic}
+ {font-21.12 "courier"
+ Courier Courier-Bold Courier-Oblique Courier-BoldOblique}
+ {font-21.13 "helvetica"
+ Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique}
+ {font-21.14 "new century schoolbook"
+ NewCenturySchlbk-Roman NewCenturySchlbk-Bold
+ NewCenturySchlbk-Italic NewCenturySchlbk-BoldItalic}
+ {font-21.15 "palatino"
+ Palatino-Roman Palatino-Bold Palatino-Italic Palatino-BoldItalic}
+ {font-21.16 "symbol"
+ Symbol Symbol Symbol Symbol}
+ {font-21.17 "times"
+ Times-Roman Times-Bold Times-Italic Times-BoldItalic}
+ {font-21.18 "zapfchancery"
+ ZapfChancery-MediumItalic ZapfChancery-MediumItalic
+ ZapfChancery-MediumItalic ZapfChancery-MediumItalic}
+ {font-21.19 "zapfdingbats"
+ ZapfDingbats ZapfDingbats ZapfDingbats ZapfDingbats}
} {
- test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {unixOnly} {
- set family [lindex $p 0]
+ set values [lassign $p testName family]
+ test $testName {Tk_PostscriptFontName procedure: exhaustive} unixOnly {
set x {}
- set i 1
+ set j 0
foreach slant {roman italic} {
foreach weight {normal bold} {
set name [list $family 12 $slant $weight]
if {[font actual $name -family] == $family} {
lappend x [psfontname $name]
} else {
- lappend x [lindex $p $i]
+ lappend x [lindex $values $j]
}
- incr i
+ incr j
}
}
- incr i
set x
- } [lrange $p 1 end]
+ } $values
}
foreach p {
- {"arial" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique}
- {"courier new" Courier Courier-Bold Courier-Oblique Courier-BoldOblique}
- {"helvetica" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique}
- {"symbol" Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic}
- {"times new roman" Times-Roman Times-Bold Times-Italic Times-BoldItalic}
+ {font-21.20 "arial"
+ Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique}
+ {font-21.21 "courier new"
+ Courier Courier-Bold Courier-Oblique Courier-BoldOblique}
+ {font-21.22 "helvetica"
+ Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique}
+ {font-21.23 "symbol"
+ Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic}
+ {font-21.24 "times new roman"
+ Times-Roman Times-Bold Times-Italic Times-BoldItalic}
} {
- test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {pcOnly} {
- set family [lindex $p 0]
+ set values [lassign $p testName family]
+ test $testName {Tk_PostscriptFontName procedure: exhaustive} pcOnly {
set x {}
foreach slant {roman italic} {
foreach weight {normal bold} {
lappend x [psfontname [list $family 12 "$slant $weight"]]
}
}
- incr i
set x
- } [lrange $p 1 end]
+ } $values
}
test font-22.1 {Tk_TextWidth procedure} {
@@ -1115,48 +1131,47 @@ test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} {
test font-33.1 {Tk_TextWidth procedure} {
} {}
-test font-33.2 {ConfigAttributesObj procedure: arguments} {
+test font-34.1 {ConfigAttributesObj procedure: arguments} {
# (Tcl_GetIndexFromObj() != TCL_OK)
setup
list [catch {font create xyz -xyz} msg] $msg
} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}}
-test font-34.1 {ConfigAttributesObj procedure: arguments} {
+test font-34.2 {ConfigAttributesObj procedure: arguments} {
# (objc & 1)
setup
list [catch {font create xyz -family} msg] $msg
} {1 {value for "-family" option missing}}
-set i 3
foreach p {
- {family xyz times}
- {size 20 40}
- {weight normal bold}
- {slant roman italic}
- {underline 0 1}
- {overstrike 0 1}
+ {font-34.3 family xyz times}
+ {font-34.4 size 20 40}
+ {font-34.5 weight normal bold}
+ {font-34.6 slant roman italic}
+ {font-34.7 underline 0 1}
+ {font-34.8 overstrike 0 1}
} {
- set opt [lindex $p 0]
- test font-34.$i "ConfigAttributesObj procedure: $opt" {
+ lassign $p testName opt val1 val2
+ test $testName "ConfigAttributesObj procedure: $opt" {
setup
set x {}
- font create xyz -$opt [lindex $p 1]
+ font create xyz -$opt $val1
lappend x [font config xyz -$opt]
- font config xyz -$opt [lindex $p 2]
+ font config xyz -$opt $val2
lappend x [font config xyz -$opt]
- } [lrange $p 1 2]
- incr i
+ } [list $val1 $val2]
}
foreach p {
- {size xyz {1 {expected integer but got "xyz"}}}
- {weight xyz {1 {bad -weight value "xyz": must be normal, or bold}}}
- {slant xyz {1 {bad -slant value "xyz": must be roman, or italic}}}
- {underline xyz {1 {expected boolean value but got "xyz"}}}
- {overstrike xyz {1 {expected boolean value but got "xyz"}}}
+ {font-34.9 size xyz {expected integer but got "xyz"}}
+ {font-34.10 weight xyz {bad -weight value "xyz": must be normal, or bold}}
+ {font-34.11 slant xyz {bad -slant value "xyz": must be roman, or italic}}
+ {font-34.12 underline xyz {expected boolean value but got "xyz"}}
+ {font-34.13 overstrike xyz {expected boolean value but got "xyz"}}
} {
- test font-34.$i "ConfigAttributesObj procedure: [lindex $p 0]" {
+ lassign $p testName opt val result
+ test $testName "ConfigAttributesObj procedure: $opt" -setup {
setup
- list [catch {font create xyz -[lindex $p 0] [lindex $p 1]} msg] $msg
- } [lindex $p 2]
- incr i
+ } -body {
+ font create xyz -$opt $val
+ } -returnCodes error -result $result
}
test font-35.1 {GetAttributeInfoObj procedure: one attribute} {
@@ -1165,12 +1180,14 @@ test font-35.1 {GetAttributeInfoObj procedure: one attribute} {
font create xyz -family xyz
font config xyz -family
} {xyz}
+
test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} {
# (Tcl_GetIndexFromObj() != TCL_OK)
setup
font create xyz
list [catch {font config xyz -xyz} msg] $msg
} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}}
+
test font-37.1 {GetAttributeInfoObj procedure: all attributes} {
# not (objPtr != NULL)
setup
@@ -1179,19 +1196,20 @@ test font-37.1 {GetAttributeInfoObj procedure: all attributes} {
} {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0}
set i 4
foreach p {
- {family xyz xyz}
- {size 20 20}
- {weight normal normal}
- {slant italic italic}
- {underline yes 1}
- {overstrike false 0}
+ {font-37.2 family xyz xyz}
+ {font-37.3 size 20 20}
+ {font-37.4 weight normal normal}
+ {font-37.5 slant italic italic}
+ {font-37.6 underline yes 1}
+ {font-37.7 overstrike false 0}
} {
- test font-31.$i "GetAttributeInfo procedure: [lindex $p 0]" {
+ lassign $p testName opt val expected
+ test $testName "GetAttributeInfo procedure: $opt" -setup {
setup
- font create xyz -[lindex $p 0] [lindex $p 1]
- font config xyz -[lindex $p 0]
- } [lindex $p 2]
- incr i
+ } -body {
+ font create xyz -$opt $val
+ font config xyz -$opt
+ } -result $expected
}
# In tests below, one field is set to "xyz" so that font name doesn't
@@ -1319,16 +1337,3 @@ destroy .b
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/frame.test b/tests/frame.test
index 22f4091..41307fe 100644
--- a/tests/frame.test
+++ b/tests/frame.test
@@ -7,12 +7,20 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: frame.test,v 1.9 2003/07/16 23:16:52 pspjuth Exp $
+# RCS: @(#) $Id: frame.test,v 1.10 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
+testConstraint haveDISPLAY [info exists env(DISPLAY)]
+testConstraint edibleColors [expr {
+ ([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)
+}]
+testConstraint haveGrayscale8 [expr {
+ [lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0
+}]
+
# eatColors --
# Creates a toplevel window and allocates enough colors in it to
# use up all the slots in the colormap.
@@ -120,23 +128,22 @@ foreach test {
{-takefocus "any string" "any string" {} {}}
{-width 32 32 badValue {bad screen distance "badValue"}}
} {
- set name [lindex $test 0]
+ lassign $test opt goodValue goodResult badValue badResult
test frame-1.$i {frame configuration options} {
- .f configure $name [lindex $test 1]
- lindex [.f configure $name] 4
- } [lindex $test 2]
+ .f configure $opt $goodValue
+ lindex [.f configure $opt] 4
+ } $goodResult
incr i
- if {[lindex $test 3] != ""} {
- test frame-1.$i {frame configuration options} {
- list [catch {.f configure $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
+ if {$badValue ne ""} {
+ test frame-1.$i {frame configuration options} -body {
+ .f configure $opt $badValue
+ } -returnCodes error -result $badResult
}
- .f configure $name [lindex [.f configure $name] 3]
+ .f configure $opt [lindex [.f configure $opt] 3]
incr i
}
destroy .f
-set i 1
test frame-2.1 {toplevel configuration options} {
catch {destroy .t}
toplevel .t -width 200 -height 100 -class NewClass
@@ -176,15 +183,13 @@ test frame-2.7 {toplevel configuration options} {
catch {destroy .t}
list [catch {toplevel .t -width 200 -height 100 -visual who_knows?} msg] $msg
} {1 {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
-if [info exists env(DISPLAY)] {
- test frame-2.8 {toplevel configuration options} {
- catch {destroy .t}
- toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
- wm geometry .t +0+0
- list [.t configure -screen] \
- [catch {.t configure -screen another} msg] $msg
- } [list [list -screen screen Screen {} $env(DISPLAY)] 1 {can't modify -screen option after widget is created}]
-}
+test frame-2.8 {toplevel configuration options} haveDISPLAY {
+ catch {destroy .t}
+ toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
+ wm geometry .t +0+0
+ list [.t configure -screen] \
+ [catch {.t configure -screen another} msg] $msg
+} [list [list -screen screen Screen {} $env(DISPLAY)] 1 {can't modify -screen option after widget is created}]
test frame-2.9 {toplevel configuration options} {
catch {destroy .t}
list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg
@@ -234,38 +239,40 @@ foreach test {
{-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
{-width 32 32 badValue {bad screen distance "badValue"}}
} {
- set name [lindex $test 0]
+ lassign $test opt goodValue goodResult badValue badResult
test frame-2.$i {toplevel configuration options} {
- .t configure $name [lindex $test 1]
- lindex [.t configure $name] 4
- } [lindex $test 2]
+ .t configure $opt $goodValue
+ lindex [.t configure $opt] 4
+ } $goodResult
incr i
- if {[lindex $test 3] != ""} {
- test frame-2.$i {toplevel configuration options} {
- list [catch {.t configure $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
+ if {$badValue ne ""} {
+ test frame-2.$i {toplevel configuration options} -body {
+ .t configure $opt $badValue
+ } -returnCodes error -result $badResult
}
- .t configure $name [lindex [.t configure $name] 3]
+ .t configure $opt [lindex [.t configure $opt] 3]
incr i
}
-test frame-3.1 {TkCreateFrame procedure} {
- list [catch frame msg] $msg
-} {1 {wrong # args: should be "frame pathName ?options?"}}
-test frame-3.2 {TkCreateFrame procedure} {
+test frame-3.1 {TkCreateFrame procedure} -body {
+ frame
+} -returnCodes error -result {wrong # args: should be "frame pathName ?options?"}
+test frame-3.2 {TkCreateFrame procedure} -setup {
catch {destroy .f}
frame .f
- set result [.f configure -class]
+} -body {
+ .f configure -class
+} -cleanup {
destroy .f
- set result
-} {-class class Class Frame Frame}
-test frame-3.3 {TkCreateFrame procedure} {
+} -result {-class class Class Frame Frame}
+test frame-3.3 {TkCreateFrame procedure} -setup {
catch {destroy .t}
toplevel .t
wm geometry .t +0+0
- set result [.t configure -class]
+} -body {
+ .t configure -class
+} -cleanup {
destroy .t
- set result
} {-class class Class Toplevel Toplevel}
test frame-3.4 {TkCreateFrame procedure} {
catch {destroy .t}
@@ -310,141 +317,147 @@ test frame-3.8 {TkCreateFrame procedure} {
option clear
list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]
} {Silly #122334}
-test frame-3.9 {TkCreateFrame procedure, -use option} unixOnly {
+test frame-3.9 {TkCreateFrame procedure, -use option} -setup {
catch {destroy .t}
catch {destroy .x}
+} -constraints unixOnly -body {
toplevel .t -container 1 -width 300 -height 120
wm geometry .t +0+0
toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green
tkwait visibility .x
- set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]"
+ list [expr {[winfo rootx .x] - [winfo rootx .t]}] \
+ [expr {[winfo rooty .x] - [winfo rooty .t]}] \
+ [winfo width .t] [winfo height .t]
+} -cleanup {
destroy .t
- set result
-} {0 0 140 300}
-test frame-3.10 {TkCreateFrame procedure, -use option} unixOnly {
+} -result {0 0 140 300}
+test frame-3.10 {TkCreateFrame procedure, -use option} -setup {
catch {destroy .t}
catch {destroy .x}
+} -constraints unixOnly -body {
toplevel .t -container 1 -width 300 -height 120
wm geometry .t +0+0
option add *x.use [winfo id .t]
toplevel .x -width 140 -height 300 -bg green
tkwait visibility .x
- set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]"
- destroy .t
+ list [expr {[winfo rootx .x] - [winfo rootx .t]}] \
+ [expr {[winfo rooty .x] - [winfo rooty .t]}] \
+ [winfo width .t] [winfo height .t]
+} -cleanup {
+ destroy .t
option clear
- set result
-} {0 0 140 300}
+} -result {0 0 140 300}
# The tests below require specific display characteristics. Even so,
# they are non-portable: some machines don't seem to ever run out of
# colors.
-if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} {
+if {[testConstraint edibleColors]} {
eatColors .t1
- test frame-3.11 {TkCreateFrame procedure} {nonPortable} {
- catch {destroy .t}
- toplevel .t -width 300 -height 200 -bg #475601
- wm geometry .t +0+0
- update
- colorsFree .t
- } {0}
- test frame-3.12 {TkCreateFrame procedure} {nonPortable} {
- catch {destroy .t}
- toplevel .t -width 300 -height 200 -bg #475601 -colormap new
- wm geometry .t +0+0
- update
- colorsFree .t
- } {1}
- test frame-3.13 {TkCreateFrame procedure} {nonPortable} {
- catch {destroy .t}
- option add *t.class Toplevel2
- option add *Toplevel2.colormap new
- toplevel .t -width 300 -height 200 -bg #475601
- wm geometry .t +0+0
- update
- option clear
- colorsFree .t
- } {1}
- test frame-3.14 {TkCreateFrame procedure} {nonPortable} {
- catch {destroy .t}
- option add *t.class Toplevel3
- option add *Toplevel3.Colormap new
- toplevel .t -width 300 -height 200 -bg #475601 -colormap new
- wm geometry .t +0+0
- update
- option clear
- colorsFree .t
- } {1}
- test frame-3.15 {TkCreateFrame procedure, -use and -colormap} {unixOnly nonPortable} {
- catch {destroy .t}
- catch {destroy .x}
- toplevel .t -container 1 -width 300 -height 120
- wm geometry .t +0+0
- toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new
- tkwait visibility .x
- set result "[colorsFree .t] [colorsFree .x]"
- destroy .t
- set result
- } {0 1}
- test frame-3.16 {TkCreateFrame procedure} {nonPortable} {
- catch {destroy .t}
- toplevel .t -width 300 -height 200 -bg #475601 -visual default
- wm geometry .t +0+0
- update
- colorsFree .t
- } {0}
- test frame-3.17 {TkCreateFrame procedure} {nonPortable} {
- catch {destroy .t}
- toplevel .t -width 300 -height 200 -bg #475601 -visual default \
- -colormap new
- wm geometry .t +0+0
- update
- colorsFree .t
- } {1}
- if {[lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0} {
- test frame-3.18 {TkCreateFrame procedure} {nonPortable} {
- catch {destroy .t}
- toplevel .t -visual {grayscale 8} -width 300 -height 200 \
- -bg #434343
- wm geometry .t +0+0
- update
- colorsFree .t 131 131 131
- } {1}
- test frame-3.19 {TkCreateFrame procedure} {nonPortable} {
- catch {destroy .t}
- option add *t.class T4
- option add *T4.visual {grayscale 8}
- toplevel .t -width 300 -height 200 -bg #434343
- wm geometry .t +0+0
- update
- option clear
- list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
- } {1 {grayscale 8}}
- test frame-3.20 {TkCreateFrame procedure} {nonPortable} {
- catch {destroy .t}
- set x ok
- option add *t.class T5
- option add *T5.Visual {grayscale 8}
- toplevel .t -width 300 -height 200 -bg #434343
- wm geometry .t +0+0
- update
- option clear
- list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
- } {1 {grayscale 8}}
- test frame-3.21 {TkCreateFrame procedure} {nonPortable} {
- catch {destroy .t}
- set x ok
- toplevel .t -visual {grayscale 8} -width 300 -height 200 \
- -bg #434343
- wm geometry .t +0+0
- update
- colorsFree .t 131 131 131
- } {1}
- }
+}
+test frame-3.11 {TkCreateFrame procedure} {edibleColors nonPortable} {
+ catch {destroy .t}
+ toplevel .t -width 300 -height 200 -bg #475601
+ wm geometry .t +0+0
+ update
+ colorsFree .t
+} {0}
+test frame-3.12 {TkCreateFrame procedure} {edibleColors nonPortable} {
+ catch {destroy .t}
+ toplevel .t -width 300 -height 200 -bg #475601 -colormap new
+ wm geometry .t +0+0
+ update
+ colorsFree .t
+} {1}
+test frame-3.13 {TkCreateFrame procedure} {edibleColors nonPortable} {
+ catch {destroy .t}
+ option add *t.class Toplevel2
+ option add *Toplevel2.colormap new
+ toplevel .t -width 300 -height 200 -bg #475601
+ wm geometry .t +0+0
+ update
+ option clear
+ colorsFree .t
+} {1}
+test frame-3.14 {TkCreateFrame procedure} {edibleColors nonPortable} {
+ catch {destroy .t}
+ option add *t.class Toplevel3
+ option add *Toplevel3.Colormap new
+ toplevel .t -width 300 -height 200 -bg #475601 -colormap new
+ wm geometry .t +0+0
+ update
+ option clear
+ colorsFree .t
+} {1}
+test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -setup {
+ catch {destroy .t}
+ catch {destroy .x}
+} -constraints {edibleColors unixOnly nonPortable} -body {
+ toplevel .t -container 1 -width 300 -height 120
+ wm geometry .t +0+0
+ toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new
+ tkwait visibility .x
+ list [colorsFree .t] [colorsFree .x]
+} -cleanup {
+ destroy .t
+} -result {0 1}
+test frame-3.16 {TkCreateFrame procedure} {edibleColors nonPortable} {
+ catch {destroy .t}
+ toplevel .t -width 300 -height 200 -bg #475601 -visual default
+ wm geometry .t +0+0
+ update
+ colorsFree .t
+} {0}
+test frame-3.17 {TkCreateFrame procedure} {edibleColors nonPortable} {
+ catch {destroy .t}
+ toplevel .t -width 300 -height 200 -bg #475601 -visual default \
+ -colormap new
+ wm geometry .t +0+0
+ update
+ colorsFree .t
+} {1}
+test frame-3.18 {TkCreateFrame procedure} {edibleColors haveGrayscale8 nonPortable} {
+ catch {destroy .t}
+ toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343
+ wm geometry .t +0+0
+ update
+ colorsFree .t 131 131 131
+} {1}
+test frame-3.19 {TkCreateFrame procedure} {edibleColors haveGrayscale8 nonPortable} {
+ catch {destroy .t}
+ option add *t.class T4
+ option add *T4.visual {grayscale 8}
+ toplevel .t -width 300 -height 200 -bg #434343
+ wm geometry .t +0+0
+ update
+ option clear
+ list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
+} {1 {grayscale 8}}
+test frame-3.20 {TkCreateFrame procedure} {edibleColors haveGrayscale8 nonPortable} {
+ catch {destroy .t}
+ set x ok
+ option add *t.class T5
+ option add *T5.Visual {grayscale 8}
+ toplevel .t -width 300 -height 200 -bg #434343
+ wm geometry .t +0+0
+ update
+ option clear
+ list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
+} {1 {grayscale 8}}
+test frame-3.21 {TkCreateFrame procedure} {edibleColors haveGrayscale8 nonPortable} {
+ catch {destroy .t}
+ set x ok
+ toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343
+ wm geometry .t +0+0
+ update
+ colorsFree .t 131 131 131
+} {1}
+if {[testConstraint edibleColors]} {
destroy .t1
}
-test frame-3.22 {TkCreateFrame procedure, default dimensions} {
+test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup {
catch {destroy .t}
+} -body {
toplevel .t
wm geometry .t +0+0
update
@@ -453,20 +466,20 @@ test frame-3.22 {TkCreateFrame procedure, default dimensions} {
pack .t.f
update
lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f]
+} -cleanup {
destroy .t
- set result
-} {200 200 1 1}
-test frame-3.23 {TkCreateFrame procedure} {
+} -result {200 200 1 1}
+test frame-3.23 {TkCreateFrame procedure} -setup {
catch {destroy .f}
- list [catch {frame .f -gorp glob} msg] $msg
-} {1 {unknown option "-gorp"}}
-test frame-3.24 {TkCreateFrame procedure} {
+} -body {
+ frame .f -gorp glob
+} -returnCodes error -result {unknown option "-gorp"}
+test frame-3.24 {TkCreateFrame procedure} -setup {
catch {destroy .t}
- list [catch {
- toplevel .t -width 300 -height 200 -colormap new -bogus option
- wm geometry .t +0+0
- } msg] $msg
-} {1 {unknown option "-bogus"}}
+} -body {
+ toplevel .t -width 300 -height 200 -colormap new -bogus option
+ wm geometry .t +0+0
+} -returnCodes error -result {unknown option "-bogus"}
test frame-4.1 {TkCreateFrame procedure} {
catch {destroy .f}
@@ -776,16 +789,16 @@ foreach test {
{-text "any string" "any string" {} {}}
{-width 32 32 badValue {bad screen distance "badValue"}}
} {
- set name [lindex $test 0]
+ lassign $test name goodValue goodResult badValue badResult
test frame-13.$i {labelframe configuration options} {
- .f configure $name [lindex $test 1]
+ .f configure $name $goodValue
lindex [.f configure $name] 4
- } [lindex $test 2]
+ } $goodResult
incr i
- if {[lindex $test 3] != ""} {
- test frame-13.$i {labelframe configuration options} {
- list [catch {.f configure $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
+ if {$badValue ne ""} {
+ test frame-13.$i {labelframe configuration options} -body {
+ .f configure $name $badValue
+ } -returnCodes error -result $badResult
}
.f configure $name [lindex [.f configure $name] 3]
incr i
diff --git a/tests/geometry.test b/tests/geometry.test
index 77a2a93..d005891 100644
--- a/tests/geometry.test
+++ b/tests/geometry.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: geometry.test,v 1.5 2003/04/01 21:06:34 dgp Exp $
+# RCS: @(#) $Id: geometry.test,v 1.6 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -249,16 +249,3 @@ catch {destroy .t}
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/get.test b/tests/get.test
index c9c2e38..66c5d1e 100644
--- a/tests/get.test
+++ b/tests/get.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: get.test,v 1.4 2003/04/01 21:06:35 dgp Exp $
+# RCS: @(#) $Id: get.test,v 1.5 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -78,16 +78,3 @@ test get-2.4 {Tk_GetJustifyFromObj - error} {
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/id.test b/tests/id.test
index acc0712..b1933db 100644
--- a/tests/id.test
+++ b/tests/id.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: id.test,v 1.7 2003/04/01 21:06:36 dgp Exp $
+# RCS: @(#) $Id: id.test,v 1.8 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -91,16 +91,3 @@ bind all <Destroy> {}
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/imgBmap.test b/tests/imgBmap.test
index ebdaf07..8849f73 100644
--- a/tests/imgBmap.test
+++ b/tests/imgBmap.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: imgBmap.test,v 1.5 2003/04/01 21:06:37 dgp Exp $
+# RCS: @(#) $Id: imgBmap.test,v 1.6 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -469,16 +469,3 @@ eval image delete [image names]
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/imgPPM.test b/tests/imgPPM.test
index 20f224b..1e043bd 100644
--- a/tests/imgPPM.test
+++ b/tests/imgPPM.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: imgPPM.test,v 1.6 2003/04/01 21:06:37 dgp Exp $
+# RCS: @(#) $Id: imgPPM.test,v 1.7 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -151,16 +151,3 @@ eval image delete [image names]
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test
index 9374b0f..05f8297 100644
--- a/tests/imgPhoto.test
+++ b/tests/imgPhoto.test
@@ -9,7 +9,7 @@
#
# Author: Paul Mackerras (paulus@cs.anu.edu.au)
#
-# RCS: @(#) $Id: imgPhoto.test,v 1.18 2004/02/17 20:39:52 dgp Exp $
+# RCS: @(#) $Id: imgPhoto.test,v 1.19 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -34,7 +34,7 @@ if {![file exists $teapotPhotoFile]} {
set newLib [file dirname [testsDirectory]]
set teapotPhotoFile [file join $newLib library demos images teapot.ppm]
if {![file exists $teapotPhotoFile]} {
- testConstraint hasTeapotPhoto
+ testConstraint hasTeapotPhoto 0
}
}
diff --git a/tests/main.test b/tests/main.test
index ff86dc2..ffb098a 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -8,7 +8,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: main.test,v 1.8 2003/09/05 22:44:39 dgp Exp $
+# RCS: @(#) $Id: main.test,v 1.9 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -102,16 +102,3 @@ test main-2.3 {Tk_MainEx: -encoding option} -constraints {
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/menu.test b/tests/menu.test
index d5d93d0..1441eab 100644
--- a/tests/menu.test
+++ b/tests/menu.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: menu.test,v 1.15 2003/05/30 11:03:02 vincentdarley Exp $
+# RCS: @(#) $Id: menu.test,v 1.16 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -2041,23 +2041,23 @@ test menu-20.6 {CloneMenu - hooking up bookeeping ptrs} {
catch {destroy .m2}
menu .m1
list [catch {.m1 clone .m2} msg] $msg [destroy .m1]
- } {0 {} {}}
- test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} {
+} {0 {} {}}
+test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} {
catch {destroy .m1}
catch {destroy .m2}
catch {destroy .m3}
menu .m1
.m1 clone .m2
list [catch {.m1 clone .m3} msg] $msg [destroy .m1]
- } {0 {} {}}
- test menu-20.8 {CloneMenu - cascade entries} {
+} {0 {} {}}
+test menu-20.8 {CloneMenu - cascade entries} {
catch {destroy .m1}
catch {destroy .foo}
menu .m1
.m1 add cascade -menu .m2
list [catch {.m1 clone .foo} msg] $msg [destroy .m1]
- } {0 {} {}}
- test menu-20.9 {CloneMenu - cascades entries} {
+} {0 {} {}}
+test menu-20.9 {CloneMenu - cascades entries} {
catch {destroy .m1}
catch {destroy .m2}
catch {destroy .foo}
@@ -2065,7 +2065,7 @@ test menu-20.6 {CloneMenu - hooking up bookeeping ptrs} {
.m1 add cascade -menu .m2
menu .m2
list [catch {.m1 clone .foo} msg] $msg [destroy .m1 .m2]
- } {0 {} {}}
+} {0 {} {}}
test menu-20.10 {CloneMenu - tearoff fields} {
catch {destroy .m1}
catch {destroy .m2}
diff --git a/tests/menuDraw.test b/tests/menuDraw.test
index 156ee9f..b217948 100644
--- a/tests/menuDraw.test
+++ b/tests/menuDraw.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: menuDraw.test,v 1.7 2004/03/17 18:15:49 das Exp $
+# RCS: @(#) $Id: menuDraw.test,v 1.8 2004/05/23 17:34:48 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -511,16 +511,3 @@ test menuDraw-17.2 {AdjustMenuCoords - menu} {pcOnly userInteraction} {
deleteWindows
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/menubut.test b/tests/menubut.test
index 93153bc..32039d5 100644
--- a/tests/menubut.test
+++ b/tests/menubut.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: menubut.test,v 1.8 2003/04/01 21:06:45 dgp Exp $
+# RCS: @(#) $Id: menubut.test,v 1.9 2004/05/23 17:34:48 dkf Exp $
# XXX This test file is woefully incomplete right now. If any part
# XXX of a procedure has tests then the whole procedure has tests,
@@ -341,16 +341,3 @@ option clear
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/msgbox.test b/tests/msgbox.test
index fb07c80..2959ccd 100644
--- a/tests/msgbox.test
+++ b/tests/msgbox.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: msgbox.test,v 1.7 2003/04/01 21:06:47 dgp Exp $
+# RCS: @(#) $Id: msgbox.test,v 1.8 2004/05/23 17:34:49 dkf Exp $
#
package require tcltest 2.1
@@ -24,10 +24,10 @@ 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"]
+ if {[string index $option 0] eq "-"} {
+ test msgbox-1.3$option {tk_messageBox command} -body {
+ tk_messageBox $option
+ } -returnCodes error -result "value for \"$option\" missing"
}
}
@@ -67,11 +67,7 @@ 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 tk::MessageBox] == ""} {
- set isNative 1
-} else {
- set isNative 0
-}
+set isNative [expr {[info commands tk::MessageBox] == ""}]
proc ChooseMsg {parent btn} {
global isNative
@@ -133,35 +129,35 @@ foreach spec $specs {
set buttons [lindex $spec 3]
set button [lindex $buttons 0]
- test msgbox-2.$count {tk_messageBox command} {nonUnixUserInteraction} {
+ test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction {
ChooseMsg $parent $button
tk_messageBox -title Hi -message "Please press $button" \
- -type $type
+ -type $type
} $button
incr count
foreach icon {warning error info question} {
test msgbox-2.$count {tk_messageBox command -icon option} \
- {nonUnixUserInteraction} {
+ nonUnixUserInteraction {
ChooseMsg $parent $button
tk_messageBox -title Hi -message "Please press $button" \
- -type $type -icon $icon
+ -type $type -icon $icon
} $button
incr count
}
foreach button $buttons {
- test msgbox-2.$count {tk_messageBox command} {nonUnixUserInteraction} {
+ test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction {
ChooseMsg $parent $button
tk_messageBox -title Hi -message "Please press $button" \
- -type $type -default $button
+ -type $type -default $button
} "$button"
incr count
}
}
# These tests will hang your test suite if they fail.
-test msgbox-3.1 {tk_messageBox handles withdrawn parent} {nonUnixUserInteraction} {
+test msgbox-3.1 {tk_messageBox handles withdrawn parent} nonUnixUserInteraction {
wm withdraw .
ChooseMsg . "ok"
tk_messageBox -title Hi -message "Please press ok" \
@@ -169,13 +165,13 @@ test msgbox-3.1 {tk_messageBox handles withdrawn parent} {nonUnixUserInteraction
} "ok"
wm deiconify .
-test msgbox-3.2 {tk_messageBox handles iconified parent} {nonUnixUserInteraction} {
+test msgbox-3.2 {tk_messageBox handles iconified parent} nonUnixUserInteraction {
wm iconify .
ChooseMsg . "ok"
tk_messageBox -title Hi -message "Please press ok" \
-type ok -default ok
} "ok"
-wm deiconify .
+wm deiconify .
# cleanup
cleanupTests
diff --git a/tests/obj.test b/tests/obj.test
index 9778b2e..3112f8b 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: obj.test,v 1.4 2003/04/01 21:06:47 dgp Exp $
+# RCS: @(#) $Id: obj.test,v 1.5 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -30,17 +30,3 @@ deleteWindows
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/oldpack.test b/tests/oldpack.test
index 33a2719..f12b32d 100644
--- a/tests/oldpack.test
+++ b/tests/oldpack.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: oldpack.test,v 1.6 2003/04/01 21:06:48 dgp Exp $
+# RCS: @(#) $Id: oldpack.test,v 1.7 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -509,16 +509,3 @@ catch {destroy .pack}
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/option.test b/tests/option.test
index 7ddaa96..2cdd675 100644
--- a/tests/option.test
+++ b/tests/option.test
@@ -6,12 +6,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: option.test,v 1.5 2003/04/01 21:06:48 dgp Exp $
+# RCS: @(#) $Id: option.test,v 1.6 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
+testConstraint appNameIsTktest [expr {[winfo name .] eq "tktest"}]
+
catch {destroy .op1}
catch {destroy .op2}
set appName [winfo name .]
@@ -193,9 +195,7 @@ test option-15.1 {database files} {
} {1 {couldn't open "non-existent": no such file or directory}}
option read $option1
test option-15.2 {database files} {option get . x1 color} blue
-if {$appName == "tktest"} {
- test option-15.3 {database files} {option get . x2 color} green
-}
+test option-15.3 {database files} appNameIsTktest {option get . x2 color} green
test option-15.4 {database files} {option get . x3 color} purple
test option-15.5 {database files} {option get . {x 4} color} brown
test option-15.6 {database files} {option get . x6 color} {}
@@ -227,16 +227,3 @@ catch {destroy .op2}
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/panedwindow.test b/tests/panedwindow.test
index 9be6aae..f746719 100644
--- a/tests/panedwindow.test
+++ b/tests/panedwindow.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: panedwindow.test,v 1.13 2004/05/03 19:16:11 hobbs Exp $
+# RCS: @(#) $Id: panedwindow.test,v 1.14 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -40,7 +40,7 @@ foreach test {
list [lindex [.p configure $name] 4] [.p cget $name]
} [list [lindex $test 2] [lindex $test 2]]
incr i
- if {[lindex $test 3] != ""} {
+ if {[lindex $test 3] ne ""} {
test panedwindow-1.$i {configuration options} {
list [catch {.p configure $name [lindex $test 3]} msg] $msg
} [list 1 [lindex $test 4]]
@@ -66,7 +66,7 @@ foreach test {
list [lindex [.p paneconfigure .b $name] 4] [.p panecget .b $name]
} [list [lindex $test 2] [lindex $test 2]]
incr i
- if {[lindex $test 3] != ""} {
+ if {[lindex $test 3] ne ""} {
test panedwindow-1.$i {configuration options} {
list [catch {.p paneconfigure .b $name [lindex $test 3]} msg] $msg
} [list 1 [lindex $test 4]]
diff --git a/tests/raise.test b/tests/raise.test
index bcf3573..21650f2 100644
--- a/tests/raise.test
+++ b/tests/raise.test
@@ -8,7 +8,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: raise.test,v 1.8 2003/04/01 21:06:50 dgp Exp $
+# RCS: @(#) $Id: raise.test,v 1.9 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -289,16 +289,3 @@ deleteWindows
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/scale.test b/tests/scale.test
index 13c1d3a..ffc4101 100644
--- a/tests/scale.test
+++ b/tests/scale.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: scale.test,v 1.14 2003/08/13 10:28:21 patthoyts Exp $
+# RCS: @(#) $Id: scale.test,v 1.15 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -78,7 +78,7 @@ foreach test {
lindex [.s configure $name] 4
} [lindex $test 2]
incr i
- if {[lindex $test 3] != ""} {
+ if {[lindex $test 3] ne ""} {
test scale-1.$i {configuration options} {
list [catch {.s configure $name [lindex $test 3]} msg] $msg
} [list 1 [lindex $test 4]]
diff --git a/tests/scrollbar.test b/tests/scrollbar.test
index e511948..7c0b3a7 100644
--- a/tests/scrollbar.test
+++ b/tests/scrollbar.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: scrollbar.test,v 1.11 2004/03/17 18:15:49 das Exp $
+# RCS: @(#) $Id: scrollbar.test,v 1.12 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -96,7 +96,7 @@ foreach test {
lindex [.s configure $name] 4
} [lindex $test 2]
incr i
- if {[lindex $test 3] != ""} {
+ if {[lindex $test 3] ne ""} {
test scrollbar-1.2 {configuration options} {
list [catch {.s configure $name [lindex $test 3]} msg] $msg
} [list 1 [lindex $test 4]]
@@ -639,16 +639,3 @@ catch {destroy .t}
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/select.test b/tests/select.test
index 24bae6d..d8b67e3 100644
--- a/tests/select.test
+++ b/tests/select.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: select.test,v 1.12 2004/03/17 18:15:50 das Exp $
+# RCS: @(#) $Id: select.test,v 1.13 2004/05/23 17:34:49 dkf Exp $
#
# Note: Multiple display selection handling will only be tested if the
@@ -764,50 +764,50 @@ test select-6.39 {Tk_SelectionCmd procedure} {
##############################################################################
- # This test is non-portable because some old X11/News servers ignore
- # a selection request when the window doesn't exist, which causes a
- # different error message.
+# This test is non-portable because some old X11/News servers ignore
+# a selection request when the window doesn't exist, which causes a
+# different error message.
- test select-7.1 {TkSelDeadWindow procedure} {nonPortable} {
- setup
- selection handle .f1 { handler TEST }
- set result [selection own]
- destroy .f1
- lappend result [selection own] [catch { selection get } msg] $msg
- } {.f1 {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined}}
+test select-7.1 {TkSelDeadWindow procedure} nonPortable {
+ setup
+ selection handle .f1 { handler TEST }
+ set result [selection own]
+ destroy .f1
+ lappend result [selection own] [catch {selection get} msg] $msg
+} {.f1 {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined}}
##############################################################################
# Check reentrancy on losing selection
-test select-8.1 {TkSelEventProc procedure} {unixOnly} {
+test select-8.1 {TkSelEventProc procedure} -constraints unixOnly -setup {
setup
setupbg
- selection own -selection CLIPBOARD -command { destroy .f1 } .f1
+} -body {
+ selection own -selection CLIPBOARD -command {destroy .f1} .f1
update
- set result [dobg {selection own -selection CLIPBOARD .}]
+ dobg {selection own -selection CLIPBOARD .}
+} -cleanup {
cleanupbg
- set result
-} {}
+} -result {}
##############################################################################
-test select-9.1 {SelCvtToX and SelCvtFromX procedures} {unixOnly} {
- global selValue selInfo
+test select-9.1 {SelCvtToX and SelCvtFromX procedures} -setup {
setup
setupbg
+} -constraint unixOnly -body {
set selValue "1024"
set selInfo ""
selection handle -selection PRIMARY -format INTEGER -type TEST \
- .f1 {handler TEST}
+ .f1 {handler TEST}
update
set result ""
lappend result [dobg {selection get TEST}]
cleanupbg
lappend result $selInfo
-} {0x400 {TEST 0 4000}}
-test select-9.2 {SelCvtToX and SelCvtFromX procedures} {unixOnly} {
- global selValue selInfo
+} -result {0x400 {TEST 0 4000}}
+test select-9.2 {SelCvtToX and SelCvtFromX procedures} unixOnly {
setup
setupbg
set selValue "1024 0xffff 2048 -2 "
@@ -819,8 +819,7 @@ test select-9.2 {SelCvtToX and SelCvtFromX procedures} {unixOnly} {
cleanupbg
lappend result $selInfo
} {{0x400 0xffff 0x800 0xfffffffe} {TEST 0 4000}}
-test select-9.3 {SelCvtToX and SelCvtFromX procedures} {unixOnly} {
- global selValue selInfo
+test select-9.3 {SelCvtToX and SelCvtFromX procedures} unixOnly {
setup
setupbg
set selValue " "
@@ -832,8 +831,7 @@ test select-9.3 {SelCvtToX and SelCvtFromX procedures} {unixOnly} {
cleanupbg
lappend result $selInfo
} {{} {TEST 0 4000}}
-test select-9.4 {SelCvtToX and SelCvtFromX procedures} {unixOnly} {
- global selValue selInfo
+test select-9.4 {SelCvtToX and SelCvtFromX procedures} unixOnly {
setup
setupbg
set selValue "16 foobar 32"
@@ -1004,7 +1002,6 @@ test select-12.5 {DefaultSelection procedure} {unixOnly} {
set result
} {.f1 .f1}
test select-12.6 {DefaultSelection procedure} {
- global selValue selInfo
setup
selection handle .f1 {handler TARGETS.f1} TARGETS
set selValue "Targets value"
@@ -1045,16 +1042,3 @@ catch {rename weirdHandler {}}
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/textBTree.test b/tests/textBTree.test
index 85194dc..ed9762e 100644
--- a/tests/textBTree.test
+++ b/tests/textBTree.test
@@ -8,7 +8,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: textBTree.test,v 1.6 2003/04/01 21:06:53 dgp Exp $
+# RCS: @(#) $Id: textBTree.test,v 1.7 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -898,16 +898,3 @@ destroy .t
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/textDisp.test b/tests/textDisp.test
index 7707b8a..f2a7803 100644
--- a/tests/textDisp.test
+++ b/tests/textDisp.test
@@ -6,22 +6,16 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: textDisp.test,v 1.24 2004/04/21 15:16:45 dkf Exp $
+# RCS: @(#) $Id: textDisp.test,v 1.25 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
-if {[tcltest::testConstraint fonts]} {
- tcltest::testConstraint textfonts 1
-} else {
- if {$::tcl_platform(platform) eq "windows"} {
- tcltest::testConstraint textfonts 1
- } else {
- tcltest::testConstraint textfonts 0
- }
-}
+tcltest::testConstraint textfonts [expr {
+ [tcltest::testConstraint fonts] || $tcl_platform(platform) eq "windows"
+}]
# The procedure below is used as the scrolling command for the text;
# it just saves the scrolling information in a variable "scrollInfo".
diff --git a/tests/textImage.test b/tests/textImage.test
index 3436875..6b66a1a 100644
--- a/tests/textImage.test
+++ b/tests/textImage.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: textImage.test,v 1.8 2003/10/31 09:02:16 vincentdarley Exp $
+# RCS: @(#) $Id: textImage.test,v 1.9 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -352,16 +352,3 @@ font delete test_font
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/textIndex.test b/tests/textIndex.test
index 3186fe0..1dd486a 100644
--- a/tests/textIndex.test
+++ b/tests/textIndex.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: textIndex.test,v 1.11 2004/01/07 15:20:53 vincentdarley Exp $
+# RCS: @(#) $Id: textIndex.test,v 1.12 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -871,16 +871,3 @@ rename textimage {}
catch {destroy .t}
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/textMark.test b/tests/textMark.test
index 70886af..712c724 100644
--- a/tests/textMark.test
+++ b/tests/textMark.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: textMark.test,v 1.7 2003/05/19 13:04:24 vincentdarley Exp $
+# RCS: @(#) $Id: textMark.test,v 1.8 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -221,16 +221,3 @@ catch {destroy .t}
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/textTag.test b/tests/textTag.test
index 8f39142..21de629 100644
--- a/tests/textTag.test
+++ b/tests/textTag.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: textTag.test,v 1.9 2003/11/12 17:19:18 vincentdarley Exp $
+# RCS: @(#) $Id: textTag.test,v 1.10 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -802,16 +802,3 @@ catch {destroy .t}
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/textWind.test b/tests/textWind.test
index d0c245c..77e84dc 100644
--- a/tests/textWind.test
+++ b/tests/textWind.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: textWind.test,v 1.15 2003/12/10 12:14:05 vincentdarley Exp $
+# RCS: @(#) $Id: textWind.test,v 1.16 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -27,11 +27,7 @@ if {[tcltest::testConstraint fonts]} {
option add *Text.borderWidth 2
option add *Text.highlightThickness 2
-if {$tcl_platform(platform) == "windows"} {
- option add *Text.font {Courier -12}
-} else {
- option add *Text.font {Courier -12}
-}
+option add *Text.font {Courier -12}
set fixedFont {Courier -12}
# 15 on XP, 13 on Solaris 8
@@ -51,11 +47,7 @@ pack append . .t {top expand fill}
update
.t debug on
wm geometry . {}
-if {[winfo depth .t] > 1} {
- set color green
-} else {
- set color black
-}
+set color [expr {[winfo depth .t] > 1 ? "green" : "black"}]
# The statements below reset the main window; it's needed if the window
# manager is mwm to make mwm forget about a previous minimum size setting.
@@ -885,16 +877,3 @@ option clear
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test
index 1f0538d..214df36 100644
--- a/tests/unixEmbed.test
+++ b/tests/unixEmbed.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: unixEmbed.test,v 1.12 2003/04/01 21:06:55 dgp Exp $
+# RCS: @(#) $Id: unixEmbed.test,v 1.13 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -559,16 +559,3 @@ deleteWindows
cleanupbg
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/unixFont.test b/tests/unixFont.test
index 68f8395..c1244c3 100644
--- a/tests/unixFont.test
+++ b/tests/unixFont.test
@@ -12,7 +12,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: unixFont.test,v 1.8 2003/04/01 21:06:56 dgp Exp $
+# RCS: @(#) $Id: unixFont.test,v 1.9 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -314,16 +314,3 @@ test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} unix {
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/util.test b/tests/util.test
index 35e8f39..212ea8a 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: util.test,v 1.6 2003/04/01 21:06:58 dgp Exp $
+# RCS: @(#) $Id: util.test,v 1.7 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -66,16 +66,3 @@ test util-1.12 {Tk_GetScrollInfo procedure} {
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/visual.test b/tests/visual.test
index 77dd665..1eb06bc 100644
--- a/tests/visual.test
+++ b/tests/visual.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: visual.test,v 1.7 2003/04/01 21:06:58 dgp Exp $
+# RCS: @(#) $Id: visual.test,v 1.8 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -69,43 +69,46 @@ if {[llength $avail] > 1} {
}
}
}
+tcltest::testConstraint haveOtherVisual [expr {$other ne ""}]
+tcltest::testConstraint havePseudocolorVisual [string match *pseudocolor* $avail]
+tcltest::testConstraint haveMultipleVisuals [expr {[llength $avail] > 1}]
+tktest::testConstraint defaultPseudocolor8 [expr {
+ ([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)
+}]
test visual-1.1 {Tk_GetVisual, copying from other window} {
list [catch {toplevel .t -visual .foo.bar} msg] $msg
} {1 {bad window path name ".foo.bar"}}
-if {$other != ""} {
- test visual-1.2 {Tk_GetVisual, copying from other window} {nonPortable} {
- catch {destroy .t1}
- catch {destroy .t2}
- toplevel .t1 -width 250 -height 100 -visual $other
- wm geom .t1 +0+0
- toplevel .t2 -width 200 -height 80 -visual .t1
- wm geom .t2 +5+5
- concat "[winfo visual .t2] [winfo depth .t2]"
- } $other
- test visual-1.3 {Tk_GetVisual, copying from other window} {
- catch {destroy .t1}
- catch {destroy .t2}
- toplevel .t1 -width 250 -height 100 -visual $other
- wm geom .t1 +0+0
- toplevel .t2 -width 200 -height 80 -visual .
- wm geom .t2 +5+5
- concat "[winfo visual .t2] [winfo depth .t2]"
- } $default
-
- # Make sure reference count is incremented when copying visual (the
- # following test will cause the colormap to be freed prematurely if
- # the reference count isn't incremented).
- test visual-1.4 {Tk_GetVisual, colormap reference count} {
- catch {destroy .t1}
- catch {destroy .t2}
- toplevel .t1 -width 250 -height 100 -visual $other
- wm geom .t1 +0+0
- set result [list [catch {toplevel .t2 -gorp 80 -visual .t1} msg] $msg]
- update
- set result
- } {1 {unknown option "-gorp"}}
-}
+test visual-1.2 {Tk_GetVisual, copying from other window} {haveOtherVisual nonPortable} {
+ catch {destroy .t1}
+ catch {destroy .t2}
+ toplevel .t1 -width 250 -height 100 -visual $other
+ wm geom .t1 +0+0
+ toplevel .t2 -width 200 -height 80 -visual .t1
+ wm geom .t2 +5+5
+ concat "[winfo visual .t2] [winfo depth .t2]"
+} $other
+test visual-1.3 {Tk_GetVisual, copying from other window} haveOtherVisual {
+ catch {destroy .t1}
+ catch {destroy .t2}
+ toplevel .t1 -width 250 -height 100 -visual $other
+ wm geom .t1 +0+0
+ toplevel .t2 -width 200 -height 80 -visual .
+ wm geom .t2 +5+5
+ concat "[winfo visual .t2] [winfo depth .t2]"
+} $default
+# Make sure reference count is incremented when copying visual (the
+# following test will cause the colormap to be freed prematurely if
+# the reference count isn't incremented).
+test visual-1.4 {Tk_GetVisual, colormap reference count} haveOtherVisual {
+ catch {destroy .t1}
+ catch {destroy .t2}
+ toplevel .t1 -width 250 -height 100 -visual $other
+ wm geom .t1 +0+0
+ set result [list [catch {toplevel .t2 -gorp 80 -visual .t1} msg] $msg]
+ update
+ set result
+} {1 {unknown option "-gorp"}}
test visual-1.5 {Tk_GetVisual, default colormap} {
catch {destroy .t1}
toplevel .t1 -width 250 -height 100 -visual default
@@ -163,7 +166,7 @@ test visual-3.5 {Tk_GetVisual, parsing visual string} {
} msg] $msg
} {1 {expected integer but got "48x"}}
-if {$other != ""} {
+test visual-4.1 {Tk_GetVisual, numerical visual id} -setup {
catch {destroy .t1}
catch {destroy .t2}
catch {destroy .t3}
@@ -173,95 +176,93 @@ if {$other != ""} {
wm geom .t2 +5+5
toplevel .t3 -width 150 -height 250 -visual [winfo visual .t1]
wm geom .t3 +10+10
- test visual-4.1 {Tk_GetVisual, numerical visual id} nonPortable {
- list [winfo visualid .t2] [winfo visualid .t3]
- } [list [winfo visualid .] [winfo visualid .t1]]
+} -constraints {haveOtherVisual nonPortable} -body {
+ set v1 [list [winfo visualid .t2] [winfo visualid .t3]]
+ set v2 [list [winfo visualid .] [winfo visualid .t1]]
+ expr {$v1 eq $v2 ? "OK" : "[list $v1] ne [list $v2]"}
+} -result OK -cleanup {
destroy .t1 .t2 .t3
}
test visual-4.2 {Tk_GetVisual, numerical visual id} {
catch {destroy .t1}
list [catch {toplevel .t1 -visual 12xyz} msg] $msg
-} {1 {bad X identifier for visual: 12xyz"}}
+} {1 {bad X identifier for visual: "12xyz"}}
test visual-4.3 {Tk_GetVisual, numerical visual id} {
catch {destroy .t1}
list [catch {toplevel .t1 -visual 1291673} msg] $msg
} {1 {couldn't find an appropriate visual}}
-if ![string match *pseudocolor* $avail] {
- test visual-5.1 {Tk_GetVisual, no matching visual} {
- catch {destroy .t1}
- list [catch {
- toplevel .t1 -width 250 -height 100 -visual "pseudocolor 8"
- wm geometry .t1 +0+0
- } msg] $msg
- } {1 {couldn't find an appropriate visual}}
-}
-
-if {[string match *pseudocolor* $avail] && ([llength $avail] > 1)} {
- test visual-6.1 {Tk_GetVisual, no matching visual} {nonPortable} {
- catch {destroy .t1}
- toplevel .t1 -width 250 -height 100 -visual "best"
+test visual-5.1 {Tk_GetVisual, no matching visual} !havePseudocolorVisual {
+ catch {destroy .t1}
+ list [catch {
+ toplevel .t1 -width 250 -height 100 -visual "pseudocolor 8"
wm geometry .t1 +0+0
- update
- winfo visual .t1
- } {pseudocolor}
-}
+ } msg] $msg
+} {1 {couldn't find an appropriate visual}}
+
+test visual-6.1 {Tk_GetVisual, no matching visual} {havePseudocolorVisual haveMultipleVisuals nonPortable} {
+ catch {destroy .t1}
+ toplevel .t1 -width 250 -height 100 -visual "best"
+ wm geometry .t1 +0+0
+ update
+ winfo visual .t1
+} {pseudocolor}
# These tests are non-portable due to variations in how many colors
# are already in use on the screen.
-if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} {
+if {[tktest::testConstraint defaultPseudocolor8]} {
eatColors .t1
- test visual-7.1 {Tk_GetColormap, "new"} {nonPortable} {
- toplevel .t2 -width 30 -height 20
- wm geom .t2 +0+0
- update
- colorsFree .t2
- } {0}
- test visual-7.2 {Tk_GetColormap, "new"} {nonPortable} {
- catch {destroy .t2}
- toplevel .t2 -width 30 -height 20 -colormap new
- wm geom .t2 +0+0
- update
- colorsFree .t2
- } {1}
- test visual-7.3 {Tk_GetColormap, copy from other window} {nonPortable} {
- catch {destroy .t2}
- toplevel .t3 -width 400 -height 50 -colormap new
- wm geom .t3 +0+0
- catch {destroy .t2}
- toplevel .t2 -width 30 -height 20 -colormap .t3
- wm geom .t2 +0+0
- update
- destroy .t3
- colorsFree .t2
- } {1}
- test visual-7.4 {Tk_GetColormap, copy from other window} {nonPortable} {
- catch {destroy .t2}
- toplevel .t3 -width 400 -height 50 -colormap new
- wm geom .t3 +0+0
- catch {destroy .t2}
- toplevel .t2 -width 30 -height 20 -colormap .
- wm geom .t2 +0+0
- update
- destroy .t3
- colorsFree .t2
- } {0}
- test visual-7.5 {Tk_GetColormap, copy from other window} {nonPortable} {
- catch {destroy .t1}
- list [catch {toplevel .t1 -width 400 -height 50 \
- -colormap .choke.lots} msg] $msg
- } {1 {bad window path name ".choke.lots"}}
- if {$other != {}} {
- test visual-7.6 {Tk_GetColormap, copy from other window} {nonPortable} {
- catch {destroy .t1}
- catch {destroy .t2}
- toplevel .t1 -width 300 -height 150 -visual $other
- wm geometry .t1 +0+0
- list [catch {toplevel .t2 -width 400 -height 50 \
- -colormap .t1} msg] $msg
- } {1 {can't use colormap for .t1: incompatible visuals}}
- }
+}
+test visual-7.1 {Tk_GetColormap, "new"} {defaultPseudocolor8 nonPortable} {
+ toplevel .t2 -width 30 -height 20
+ wm geom .t2 +0+0
+ update
+ colorsFree .t2
+} {0}
+test visual-7.2 {Tk_GetColormap, "new"} {defaultPseudocolor8 nonPortable} {
+ catch {destroy .t2}
+ toplevel .t2 -width 30 -height 20 -colormap new
+ wm geom .t2 +0+0
+ update
+ colorsFree .t2
+} {1}
+test visual-7.3 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 nonPortable} {
+ catch {destroy .t2}
+ toplevel .t3 -width 400 -height 50 -colormap new
+ wm geom .t3 +0+0
+ catch {destroy .t2}
+ toplevel .t2 -width 30 -height 20 -colormap .t3
+ wm geom .t2 +0+0
+ update
+ destroy .t3
+ colorsFree .t2
+} {1}
+test visual-7.4 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 nonPortable} {
+ catch {destroy .t2}
+ toplevel .t3 -width 400 -height 50 -colormap new
+ wm geom .t3 +0+0
+ catch {destroy .t2}
+ toplevel .t2 -width 30 -height 20 -colormap .
+ wm geom .t2 +0+0
+ update
+ destroy .t3
+ colorsFree .t2
+} {0}
+test visual-7.5 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 nonPortable} {
+ catch {destroy .t1}
+ list [catch {
+ toplevel .t1 -width 400 -height 50 -colormap .choke.lots
+ } msg] $msg
+} {1 {bad window path name ".choke.lots"}}
+test visual-7.6 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 haveOtherVisual nonPortable} {
+ catch {destroy .t1}
+ catch {destroy .t2}
+ toplevel .t1 -width 300 -height 150 -visual $other
+ wm geometry .t1 +0+0
+ list [catch {toplevel .t2 -width 400 -height 50 -colormap .t1} msg] $msg
+} {1 {can't use colormap for .t1: incompatible visuals}}
+if {[tktest::testConstraint defaultPseudocolor8]} {
catch {destroy .t1}
catch {destroy .t2}
}
@@ -279,21 +280,19 @@ test visual-8.1 {Tk_FreeColormap procedure} {
destroy .t4
update
} {}
-if {$other != {}} {
- test visual-8.2 {Tk_FreeColormap procedure} {
- deleteWindows
- toplevel .t1 -width 300 -height 180 -visual $other
- wm geometry .t1 +0+0
- foreach i {.t2 .t3 .t4} {
- toplevel $i -width 250 -height 150 -visual $other
- wm geometry $i +0+0
- }
- destroy .t2
- destroy .t3
- destroy .t4
- update
- } {}
-}
+test visual-8.2 {Tk_FreeColormap procedure} haveOtherVisual {
+ deleteWindows
+ toplevel .t1 -width 300 -height 180 -visual $other
+ wm geometry .t1 +0+0
+ foreach i {.t2 .t3 .t4} {
+ toplevel $i -width 250 -height 150 -visual $other
+ wm geometry $i +0+0
+ }
+ destroy .t2
+ destroy .t3
+ destroy .t4
+ update
+} {}
deleteWindows
rename eatColors {}
@@ -302,16 +301,3 @@ rename colorsFree {}
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/winMenu.test b/tests/winMenu.test
index 5e76440..0c56507 100644
--- a/tests/winMenu.test
+++ b/tests/winMenu.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: winMenu.test,v 1.7 2003/04/01 21:07:01 dgp Exp $
+# RCS: @(#) $Id: winMenu.test,v 1.8 2004/05/23 17:34:49 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -1034,15 +1034,3 @@ test winMenu-34.1 {TkpMenuInit called at boot time} {emptyTest pcOnly} {} {}
deleteWindows
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/winSend.test b/tests/winSend.test
index d95e102..089ea85 100644
--- a/tests/winSend.test
+++ b/tests/winSend.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: winSend.test,v 1.5 2003/04/01 21:07:02 dgp Exp $
+# RCS: @(#) $Id: winSend.test,v 1.6 2004/05/23 17:34:50 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -36,27 +36,32 @@ proc newApp {name {safe {}}} {
}
set currentInterps [winfo interps]
-if {[testConstraint win] && [llength [info commands send]]} {
+if {
+ [testConstraint win] &&
+ [llength [info commands send]] &&
+ [catch {exec [interpreter] &}] == 0
+} then {
+ # Wait until the child application has launched.
+ while {[llength [winfo interps]] == [llength $currentInterps]} {}
- if {[catch {exec [interpreter] &}] == 0} {
-
- # Wait until the child application has launched.
- while {[llength [winfo interps]] == [llength $currentInterps]} {}
-
- # Now find an interp to send to
- set newInterps [winfo interps]
- foreach interp $newInterps {
- if {[lsearch -exact $currentInterps $interp] < 0} {
- break
- }
+ # Now find an interp to send to
+ set newInterps [winfo interps]
+ foreach interp $newInterps {
+ if {[lsearch -exact $currentInterps $interp] < 0} {
+ break
}
-
- # Now we have found our interpreter we are going to send to.
- # Make sure that it works first.
- testConstraint winSend [expr {[catch {
- send $interp {console hide; update}
- }] == 0}]
}
+
+ # Now we have found our interpreter we are going to send to.
+ # Make sure that it works first.
+ testConstraint winSend [expr {![catch {
+ send $interp {
+ console hide
+ update
+ }
+ }]}]
+} else {
+ testConstraint winSend 0
}
# setting up dde server is done when the first interp is created and
@@ -65,9 +70,7 @@ test winSend-1.1 {Tk_SetAppName - changing name of interp} winSend {
newApp testApp
list [testApp eval tk appname testApp2] [interp delete testApp]
} {testApp2 {}}
-test winSend-1.2 {Tk_SetAppName - changing name - not front of linked list} {
- winSend
-} {
+test winSend-1.2 {Tk_SetAppName - changing name - not front of linked list} winSend {
newApp testApp
newApp testApp2
list [testApp eval tk appname testApp3] [interp delete testApp] [interp delete testApp2]
@@ -404,4 +407,3 @@ while {[llength $newInterps] != [llength $currentInterps]} {
# cleanup
cleanupTests
return
-
diff --git a/tests/window.test b/tests/window.test
index db80f97..1bdcd6f 100644
--- a/tests/window.test
+++ b/tests/window.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: window.test,v 1.9 2003/11/18 01:47:51 dgp Exp $
+# RCS: @(#) $Id: window.test,v 1.10 2004/05/23 17:34:50 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -304,15 +304,3 @@ test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \
# cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/wm.test b/tests/wm.test
index 255efc4..24a8ee2 100644
--- a/tests/wm.test
+++ b/tests/wm.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: wm.test,v 1.24 2004/03/17 18:15:50 das Exp $
+# RCS: @(#) $Id: wm.test,v 1.25 2004/05/23 17:34:50 dkf Exp $
# This file tests window manager interactions that work across
# platforms. Window manager tests that only work on a specific
@@ -1786,6 +1786,3 @@ test wm-deletion-epoch-1.1 {Deletion epoch on multiple displays} {altDisplay} {
deleteWindows
cleanupTests
return
-
-
-
diff --git a/tests/xmfbox.test b/tests/xmfbox.test
index ca3858a..c2f3edd 100644
--- a/tests/xmfbox.test
+++ b/tests/xmfbox.test
@@ -10,7 +10,7 @@
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
#
-# RCS: @(#) $Id: xmfbox.test,v 1.8 2003/04/01 21:07:05 dgp Exp $
+# RCS: @(#) $Id: xmfbox.test,v 1.9 2004/05/23 17:34:50 dkf Exp $
package require tcltest 2.1
eval tcltest::configure $argv
@@ -141,15 +141,3 @@ test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} {unixOnly} {
cleanup
cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-