diff options
| author | dkf <donal.k.fellows@manchester.ac.uk> | 2004-05-23 17:34:48 (GMT) |
|---|---|---|
| committer | dkf <donal.k.fellows@manchester.ac.uk> | 2004-05-23 17:34:48 (GMT) |
| commit | 7c820a9ae19502e7f5d59f4310c33bfeb64bf9ba (patch) | |
| tree | c1834b8cace8654026ee20f8fd75ea3f340a902c | |
| parent | fc07382fecf576d43fc28117ca52416170fb0f4f (diff) | |
| download | tk-7c820a9ae19502e7f5d59f4310c33bfeb64bf9ba.zip tk-7c820a9ae19502e7f5d59f4310c33bfeb64bf9ba.tar.gz tk-7c820a9ae19502e7f5d59f4310c33bfeb64bf9ba.tar.bz2 | |
First step towards improving test style. Also start using Tcl 8.5 features.
59 files changed, 1150 insertions, 1657 deletions
@@ -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 - - - - - - - - - - - - |